From 24030c621fd48d990978998c9f99c0073d52a796 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 21 Apr 2022 00:42:09 -0700 Subject: [PATCH 001/123] (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/123] (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/123] (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/123] (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/123] (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/123] (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/123] (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/123] (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/123] (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/123] (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/123] 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/123] 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 09e337c1b2d566cdadef5abb93104e5ce1cf9996 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Fri, 17 Mar 2023 15:12:19 +1100 Subject: [PATCH 013/123] 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 014/123] [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 015/123] [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 016/123] [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 017/123] 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 018/123] 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 21de775ee08b384a7d5b232da3bdd489d06da4cb Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 4 Apr 2023 15:31:29 +1000 Subject: [PATCH 019/123] 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 60fe91545b77827121f5830a5b7171d014dbe894 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Fri, 7 Apr 2023 15:13:47 +1000 Subject: [PATCH 020/123] 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 e39125567109fbbc55da5c87452970fb34116ee0 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 18 Apr 2023 16:33:59 +1000 Subject: [PATCH 021/123] 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 022/123] 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 023/123] 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 024/123] (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 025/123] (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 026/123] 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 027/123] 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 028/123] [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 029/123] [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 030/123] [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 031/123] [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 032/123] [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 033/123] [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 034/123] [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 035/123] 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 036/123] 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 bf717dc13c0291e2872845493d4dc2affd26b20e Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Mon, 29 May 2023 15:55:22 +1000 Subject: [PATCH 037/123] 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 038/123] 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 039/123] 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 040/123] 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 6b196f9a8b3f0d10ebd27b1615a0cfbf94ac98d9 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 17 Jul 2023 18:10:35 +0200 Subject: [PATCH 041/123] (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 042/123] (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 e7d21dc033eca770b41fb4356e0a0cc7234f2439 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Fri, 28 Jul 2023 12:25:17 +0200 Subject: [PATCH 043/123] 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 044/123] (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 ad57a52a9ac5952ff05885ebe1a010f59efeccc7 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Tue, 29 Aug 2023 12:00:11 +1000 Subject: [PATCH 045/123] 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 e5efd4d466170072f4332e52dad79bca748df282 Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Wed, 30 Aug 2023 11:35:47 +1000 Subject: [PATCH 046/123] 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 047/123] 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 7d22e0e2089a0840022bacaccfe6ae2d8eb2c40e Mon Sep 17 00:00:00 2001 From: Spencer Magnall Date: Wed, 20 Sep 2023 11:55:01 +1000 Subject: [PATCH 048/123] 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 dbc5a7495dd369988d301eeb859ed001815bba90 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 23 Oct 2023 16:29:00 +1100 Subject: [PATCH 049/123] (#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 050/123] (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 051/123] (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 052/123] (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 053/123] (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 054/123] (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 055/123] 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 056/123] 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 057/123] 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 058/123] 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 059/123] 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 3fc2bccd4d92fb4d9eeeeeee1c0f90a2f7d6a997 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 2 Nov 2023 10:01:26 +0100 Subject: [PATCH 060/123] (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 2747924e8436b3ce83d9aa56bf60b45f63207f55 Mon Sep 17 00:00:00 2001 From: Miguel Gonzalez-Bolivar Date: Thu, 16 Nov 2023 17:25:52 +1100 Subject: [PATCH 061/123] 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 b17a283876eaa93f87e2450ab83c25c9159dbe88 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 20 Nov 2023 10:09:08 +0100 Subject: [PATCH 062/123] (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 063/123] 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 f80b5ec543c3014b2530db14dabe1d3ff6f10eb9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 27 Nov 2023 10:09:12 +1100 Subject: [PATCH 064/123] (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 065/123] (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 066/123] (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 067/123] (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 068/123] (#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 069/123] (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 070/123] [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 071/123] [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 072/123] [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 073/123] [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 074/123] [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 075/123] (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 076/123] (#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 077/123] 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 078/123] [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 079/123] [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 080/123] 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 081/123] (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 082/123] (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 083/123] (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 084/123] (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 085/123] (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 086/123] (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 087/123] (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 088/123] (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 089/123] (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 090/123] (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 091/123] (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 da865fe17f18393dcbc25ebfbbc9839fc9bd0126 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Sun, 3 Dec 2023 14:54:51 +0100 Subject: [PATCH 092/123] 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 3beb7770679213d26f9e032327bf4000121f4249 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 4 Dec 2023 21:29:10 +0100 Subject: [PATCH 093/123] (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 094/123] 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 095/123] 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 096/123] 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 097/123] 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 098/123] [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 099/123] [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 100/123] [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 101/123] [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 102/123] 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 103/123] 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 104/123] (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 105/123] 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 106/123] 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 107/123] 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 108/123] 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 109/123] 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 110/123] 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 111/123] (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 112/123] (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 113/123] (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 114/123] (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 115/123] (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 b23ef5acabf9862868af52777abfb1de0f58a881 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 29 Jan 2024 17:17:05 +1100 Subject: [PATCH 116/123] (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 117/123] 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 118/123] [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 119/123] [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 120/123] [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 121/123] 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 122/123] (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 123/123] 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 ~~~~~