From fb7cd32ed0e513a01c9fc780cc698d379ede0061 Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Thu, 30 Mar 2023 17:07:57 +0200 Subject: [PATCH 01/39] [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 02/39] [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 03/39] [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 04/39] 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 0855dd6df43402213c1bad9688873eb7df0ecb3c Mon Sep 17 00:00:00 2001 From: MatsEsseldeurs Date: Wed, 26 Apr 2023 06:30:52 +0100 Subject: [PATCH 05/39] (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 06/39] (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 6b196f9a8b3f0d10ebd27b1615a0cfbf94ac98d9 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 17 Jul 2023 18:10:35 +0200 Subject: [PATCH 07/39] (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 08/39] (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 09/39] 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 10/39] (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 5227b267e44f1627e7eedcf8839bcd5e7b7de55d Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Thu, 26 Oct 2023 16:36:12 +0200 Subject: [PATCH 11/39] 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 12/39] 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 13/39] 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 14/39] 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 e1bd640d90730f2f00de878ce6ddaa511d0499be Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Mon, 20 Nov 2023 12:05:25 +0100 Subject: [PATCH 15/39] 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 da865fe17f18393dcbc25ebfbbc9839fc9bd0126 Mon Sep 17 00:00:00 2001 From: Lionel Siess Date: Sun, 3 Dec 2023 14:54:51 +0100 Subject: [PATCH 16/39] 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 17/39] (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 18/39] 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 19/39] 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 20/39] 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 21/39] 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 22/39] [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 23/39] [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 24/39] [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 25/39] [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 26/39] 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 27/39] 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 28/39] (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 29/39] 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 30/39] 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 31/39] 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 32/39] 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 33/39] 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 34/39] 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 35/39] (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 36/39] (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 37/39] (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 38/39] (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 39/39] (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 !