../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/adaptive_loop.f90 subroutine adaptive_loop use amr_commons use hydro_commons use pm_commons use poisson_commons use cooling_module #ifdef RT use rt_hydro_commons #endif implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer(kind=8)::n_step integer::ilevel,idim,ivar,info,tot_pt real(kind=8)::tt1,tt2,muspt,muspt_this_step real(kind=4)::real_mem,real_mem_tot #ifndef WITHOUTMPI tt1=MPI_WTIME() #endif call init_amr ! Initialize AMR variables call init_time ! Initialize time variables if(hydro)call init_hydro ! Initialize hydro variables #ifdef RT if(rt.or.neq_chem) & & call rt_init_hydro ! Initialize radiation variables #endif if(poisson)call init_poisson ! Initialize poisson variables #ifdef ATON if(aton)call init_radiation ! Initialize radiation variables #endif ! RESTART patch ! ADDED BY TTG MAY 2017 ! if(nrestart==0)call init_refine ! Build initial AMR grid if(nrestart<=0)call init_refine ! Build initial AMR grid #ifdef grackle if(use_grackle==0)then if(cooling.and..not.neq_chem) & call set_table(dble(aexp)) ! Initialize cooling look up table endif #else if(cooling.and..not.neq_chem) & call set_table(dble(aexp)) ! Initialize cooling look up table #endif if(pic)call init_part ! Initialize particle variables if(pic)call init_tree ! Initialize particle tree ! RESTART patch ! ADDED BY TTG MAY 2017 ! if(nrestart==0)call init_refine_2 ! Build initial AMR grid again if(nrestart<=0)call init_refine_2 ! Build initial AMR grid again #ifndef WITHOUTMPI muspt=0. tot_pt=-1 tt2=MPI_WTIME() if(myid==1)write(*,*)'Time elapsed since startup:',tt2-tt1 #endif if(myid==1)then write(*,*)'Initial mesh structure' do ilevel=1,nlevelmax if(numbtot(1,ilevel)>0)write(*,999)ilevel,numbtot(1:4,ilevel) end do end if nstep_coarse_old=nstep_coarse if(myid==1)write(*,*)'Starting time integration' do ! Main time loop call timer('coarse levels','start') #ifndef WITHOUTMPI tt1=MPI_WTIME() #endif if(verbose)write(*,*)'Entering amr_step_coarse' epot_tot=0.0D0 ! Reset total potential energy ekin_tot=0.0D0 ! Reset total kinetic energy mass_tot=0.0D0 ! Reset total mass eint_tot=0.0D0 ! Reset total internal energy #ifdef SOLVERmhd emag_tot=0.0D0 ! Reset total magnetic energy #endif ! Make new refinements if(levelmin.lt.nlevelmax.and.(.not.static.or.(nstep_coarse_old.eq.nstep_coarse.and.restart_remap)))then call refine_coarse do ilevel=1,levelmin call build_comm(ilevel) call make_virtual_fine_int(cpu_map(1),ilevel) if(hydro)then #ifdef SOLVERmhd do ivar=1,nvar+3 #else do ivar=1,nvar #endif call make_virtual_fine_dp(uold(1,ivar),ilevel) #ifdef SOLVERmhd end do #else end do #endif if(simple_boundary)call make_boundary_hydro(ilevel) endif #ifdef RT if(rt)then do ivar=1,nrtvar call make_virtual_fine_dp(rtuold(1,ivar),ilevel) end do if(simple_boundary)call rt_make_boundary_hydro(ilevel) endif #endif if(poisson)then call make_virtual_fine_dp(phi(1),ilevel) do idim=1,ndim call make_virtual_fine_dp(f(1,idim),ilevel) end do end if if(ilevel0)then ! Add particle at the tail of its linked list nextp(tailp(list2(j)))=ind_part(j) prevp(ind_part(j))=tailp(list2(j)) nextp(ind_part(j))=0 tailp(list2(j))=ind_part(j) numbp(list2(j))=numbp(list2(j))+1 else ! Initialise linked list headp(list2(j))=ind_part(j) tailp(list2(j))=ind_part(j) prevp(ind_part(j))=0 nextp(ind_part(j))=0 numbp(list2(j))=1 end if end if end do end subroutine add_list !################################################################ !################################################################ !################################################################ !################################################################ subroutine add_free(ind_part,np) use amr_commons use pm_commons use dice_commons implicit none integer::np integer,dimension(1:nvector)::ind_part ! ! Add particles to the free memory linked list ! and reset all particle variables ! integer::j,idim do idim=1,ndim do j=1,np xp(ind_part(j),idim)=0.0 vp(ind_part(j),idim)=0.0 end do end do do j=1,np mp(ind_part(j))=0.0 idp(ind_part(j))=0 levelp(ind_part(j))=0 end do if(star.or.sink)then do j=1,np tp(ind_part(j))=0.0 end do if(metal)then do j=1,np zp(ind_part(j))=0.0 end do end if end if ! DICE / RESTART patch if(dice_init) then do j=1,np up(ind_part(j))=0.0 end do endif do j=1,np if(numbp_free>0)then ! Add particle at the tail of its linked list nextp(tailp_free)=ind_part(j) prevp(ind_part(j))=tailp_free nextp(ind_part(j))=0 tailp_free=ind_part(j) numbp_free=numbp_free+1 else ! Initialise linked list headp_free=ind_part(j) tailp_free=ind_part(j) prevp(ind_part(j))=0 nextp(ind_part(j))=0 numbp_free=1 end if end do npart=npartmax-numbp_free end subroutine add_free !################################################################ !################################################################ !################################################################ !################################################################ subroutine add_free_cond(ind_part,ok,np) use amr_commons use pm_commons use dice_commons implicit none integer::np integer,dimension(1:nvector)::ind_part logical,dimension(1:nvector)::ok ! ! Add particles to the free memory linked list ! and reset all particle variables ! integer::j,idim do idim=1,ndim do j=1,np if(ok(j))then xp(ind_part(j),idim)=0.0 vp(ind_part(j),idim)=0.0 endif end do end do do j=1,np if(ok(j))then mp(ind_part(j))=0.0 idp(ind_part(j))=0 levelp(ind_part(j))=0 endif end do if(star.or.sink)then do j=1,np if(ok(j))then tp(ind_part(j))=0.0 endif end do if(metal)then do j=1,np if(ok(j))then zp(ind_part(j))=0.0 endif end do end if end if ! DICE / RESTART patch if(dice_init) then do j=1,np if(ok(j))then up(ind_part(j))=0.0 endif end do endif do j=1,np if(ok(j))then if(numbp_free>0)then ! Add particle at the tail of its linked list nextp(tailp_free)=ind_part(j) prevp(ind_part(j))=tailp_free nextp(ind_part(j))=0 tailp_free=ind_part(j) numbp_free=numbp_free+1 else ! Initialise linked list headp_free=ind_part(j) tailp_free=ind_part(j) prevp(ind_part(j))=0 nextp(ind_part(j))=0 numbp_free=1 end if endif end do npart=npartmax-numbp_free end subroutine add_free_cond ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/amr_commons.f90 module amr_commons use amr_parameters logical::output_done=.false. ! Output just performed logical::init=.false. ! Set up or run logical::balance=.false. ! Load balance or run logical::shrink=.false. ! Shrink mesh or run integer::nstep=0 ! Time step integer::nstep_coarse=0 ! Coarse step integer::nstep_coarse_old=0 ! Old coarse step integer::nflag,ncreate,nkill ! Refinements integer::ncoarse ! nx.ny.nz integer::ngrid_current ! Actual number of octs real(dp)::emag_tot=0.0D0 ! Total magnetic energy real(dp)::ekin_tot=0.0D0 ! Total kinetic energy real(dp)::eint_tot=0.0D0 ! Total internal energy real(dp)::epot_tot=0.0D0 ! Total potential energy real(dp)::epot_tot_old=0.0D0 ! Old potential energy real(dp)::epot_tot_int=0.0D0 ! Time integrated potential real(dp)::einit=0.0D0 ! Initial total energy real(dp)::aexp_old=1.0D0 ! Old expansion factor real(dp)::rho_tot=0.0D0 ! Mean density in the box real(dp)::t=0.0D0 ! Time variable ! executable identification CHARACTER(LEN=80)::builddate,patchdir CHARACTER(LEN=80)::gitrepo,gitbranch,githash ! Save namelist filename ! CHANGED BY TTG (FEB 2017) ! CHARACTER(LEN=80)::namelist_file CHARACTER(LEN=256)::namelist_file ! MPI variables integer::ncpu,ndomain,myid,overload=1 ! Friedman model variables integer::n_frw real(dp),allocatable,dimension(:)::aexp_frw,hexp_frw,tau_frw,t_frw ! Initial conditions parameters from grafic integer ::nlevelmax_part real(dp) ::aexp_ini=10. real(dp),dimension(1:MAXLEVEL)::dfact=1.0d0,astart real(dp),dimension(1:MAXLEVEL)::vfact real(dp),dimension(1:MAXLEVEL)::xoff1,xoff2,xoff3,dxini integer ,dimension(1:MAXLEVEL)::n1,n2,n3 ! Level related arrays real(dp),dimension(1:MAXLEVEL)::dtold,dtnew ! Time step at each level real(dp),dimension(1:MAXLEVEL)::rho_max ! Maximum density at each level integer ,dimension(1:MAXLEVEL)::nsubcycle=2 ! Subcycling at each level ! Pointers for each level linked list integer,allocatable,dimension(:,:)::headl integer,allocatable,dimension(:,:)::taill integer,allocatable,dimension(:,:)::numbl integer(i8b),allocatable,dimension(:,:)::numbtot ! Pointers for each level boundary linked list integer,allocatable,dimension(:,:)::headb integer,allocatable,dimension(:,:)::tailb integer,allocatable,dimension(:,:)::numbb ! Pointers for free memory grid linked list integer::headf,tailf,numbf,used_mem,used_mem_tot ! Tree arrays real(dp),allocatable,dimension(:,:)::xg ! grids position integer ,allocatable,dimension(:,:)::nbor ! neighboring father cells integer ,allocatable,dimension(:) ::father ! father cell integer ,allocatable,dimension(:) ::next ! next grid in list integer ,allocatable,dimension(:) ::prev ! previous grid in list integer ,allocatable,dimension(:) ::son ! sons grids integer ,allocatable,dimension(:) ::flag1 ! flag for refine integer ,allocatable,dimension(:) ::flag2 ! flag for expansion ! Global indexing integer ,allocatable,dimension(:) ::cpu_map ! domain decomposition integer ,allocatable,dimension(:) ::cpu_map2 ! new domain decomposition ! Hilbert key real(qdp),allocatable,dimension(:)::hilbert_key real(qdp),allocatable,dimension(:)::bound_key,bound_key2 real(qdp) ::order_all_min,order_all_max ! Recursive bisection real(dp),allocatable,dimension(:) ::bisec_wall ! bisection wall positions integer ,allocatable,dimension(:,:) ::bisec_next ! next 2 child cells in bisection integer::bisec_root ! root of bisection tree integer,allocatable,dimension(:) ::bisec_indx ! map from leaf cell id to cpu id real(dp),allocatable,dimension(:,:) ::bisec_cpubox_min ! cpu domains boxes real(dp),allocatable,dimension(:,:) ::bisec_cpubox_max real(dp),allocatable,dimension(:,:) ::bisec_cpubox_min2 ! cpu domains boxes for new decomp real(dp),allocatable,dimension(:,:) ::bisec_cpubox_max2 integer,allocatable,dimension(:) ::bisec_cpu_load ! CPU loads (for stats) integer,allocatable,dimension(:,:) ::bisec_hist ! histograms for load computation integer,allocatable,dimension(:) ::bisec_hist_bounds ! histogram splitting boundaries integer,allocatable,dimension(:) ::new_hist_bounds integer,allocatable,dimension(:) ::bisec_ind_cell ! histo swap id -> cell id map (big) integer,allocatable,dimension(:) ::cell_level ! store the level of the cells (big) real(dp)::bisec_res ! resolution parameters integer ::bisec_nres ! Communication structure type communicator integer ::ngrid integer ::npart integer ,dimension(:) ,pointer::igrid integer ,dimension(:,:),pointer::f real(kind=8),dimension(:,:),pointer::u integer(i8b),dimension(:,:),pointer::fp real(kind=8),dimension(:,:),pointer::up #ifdef ATON real(kind=8),dimension(:,:),pointer::u_radiation #endif end type communicator ! Active grid, emission and reception communicators type(communicator),allocatable,dimension(:) ::active type(communicator),allocatable,dimension(:,:)::boundary type(communicator),allocatable,dimension(:,:)::emission type(communicator),allocatable,dimension(:,:)::reception ! Types for physical boundary conditions CHARACTER(LEN=20)::type_hydro ='hydro' CHARACTER(LEN=20)::type_accel ='accel' CHARACTER(LEN=20)::type_flag ='flag' ! Units specified by the user in the UNITS_PARAMS namelist for non-cosmo runs. ! These values shouldn't be used directly. Instead call units() in amr/units.f90. real(dp)::units_density=1.0 ! [g/cm^3] real(dp)::units_time=1.0 ! [seconds] real(dp)::units_length=1.0 ! [cm] end module amr_commons ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/amr_parameters.f90 module amr_parameters ! Define real types integer,parameter::sp=kind(1.0E0) #ifndef NPRE integer,parameter::dp=kind(1.0E0) ! default #else #if NPRE==4 integer,parameter::dp=kind(1.0E0) ! real*4 #else integer,parameter::dp=kind(1.0D0) ! real*8 #endif #endif #ifdef QUADHILBERT integer,parameter::qdp=kind(1.0_16) ! real*16 #else integer,parameter::qdp=kind(1.0_8) ! real*8 #endif integer,parameter::MAXOUT=1000 integer,parameter::MAXLEVEL=100 ! Define integer types (for particle IDs mostly) integer,parameter::i4b=4 #ifndef LONGINT integer,parameter::i8b=4 ! default long int are short int #else integer,parameter::i8b=8 ! long int are long int #endif ! Number of dimensions #ifndef NDIM integer,parameter::ndim=1 #else integer,parameter::ndim=NDIM #endif integer,parameter::twotondim=2**ndim integer,parameter::threetondim=3**ndim integer,parameter::twondim=2*ndim ! Vectorization parameter #ifndef NVECTOR integer,parameter::nvector=500 ! Size of vector sweeps #else integer,parameter::nvector=NVECTOR #endif integer, parameter :: nstride = 65536 ! Run control logical::verbose =.false. ! Write everything logical::hydro =.false. ! Hydro activated logical::pic =.false. ! Particle In Cell activated logical::poisson =.false. ! Poisson solver activated logical::cosmo =.false. ! Cosmology activated logical::star =.false. ! Star formation activated logical::sink =.false. ! Sink particles activated logical::rt =.false. ! Radiative transfer activated logical::debug =.false. ! Debug mode activated logical::static =.false. ! Static mode activated logical::static_dm=.false. ! Static mode for dm only activated logical::static_gas=.false. ! Static mode for gas only activated logical::static_stars=.false.! Static mode for stars only activated logical::tracer =.false. ! Tracer particles activated logical::lightcone=.false. ! Enable lightcone generation logical::clumpfind=.false. ! Enable clump finder logical::aton=.false. ! Enable ATON coarse grid radiation transfer ! Mesh parameters integer::geom=1 ! 1: cartesian, 2: cylindrical, 3: spherical integer::nx=1,ny=1,nz=1 ! Number of coarse cells in each dimension integer::levelmin=1 ! Full refinement up to levelmin integer::nlevelmax=1 ! Maximum number of level integer::ngridmax=0 ! Maximum number of grids integer,dimension(1:MAXLEVEL)::nexpand=1 ! Number of mesh expansion integer::nexpand_bound=1 ! Number of mesh expansion for virtual boundaries real(dp)::boxlen=1.0D0 ! Box length along x direction character(len=128)::ordering='hilbert' logical::cost_weighting=.true. ! Activate load balancing according to cpu time ! Recursive bisection tree parameters integer::nbilevelmax=1 ! Max steps of bisection partitioning integer::nbinodes=3 ! Max number of internal nodes integer::nbileafnodes=2 ! Max number of leaf (terminal) nodes real(dp)::bisec_tol=0.05d0 ! Tolerance for bisection load balancing ! Step parameters integer::nrestart=0 ! New run or backup file number integer::nrestart_quad=0 ! Restart with double precision Hilbert keys real(dp)::trestart=0.0 ! Restart time logical::restart_remap=.false. ! Force load balance on restart integer::nstepmax=1000000 ! Maximum number of time steps integer::ncontrol=1 ! Write control variables integer::fbackup=1000000 ! Backup data to disk integer::nremap=0 ! Load balancing frequency (0: never) ! Output parameters integer::iout=1 ! Increment for output times integer::ifout=1 ! Increment for output files integer::iback=1 ! Increment for backup files integer::noutput=1 ! Total number of outputs integer::foutput=1000000 ! Frequency of outputs integer::output_mode=0 ! Output mode (for hires runs) logical::gadget_output=.false. ! Output in gadget format logical::output_now=.false. ! write output next step character(LEN=256)::output_dir='./' ! Output directory; ADDED BY TTG (FEB 2017) ! Lightcone parameters real(dp)::thetay_cone=12.5 real(dp)::thetaz_cone=12.5 real(dp)::zmax_cone=2.0 ! Cosmology and physical parameters real(dp)::boxlen_ini ! Box size in h-1 Mpc real(dp)::omega_b=0.045 ! Omega Baryon real(dp)::omega_m=1.0D0 ! Omega Matter real(dp)::omega_l=0.0D0 ! Omega Lambda real(dp)::omega_k=0.0D0 ! Omega Curvature real(dp)::h0 =1.0D0 ! Hubble constant in km/s/Mpc real(dp)::aexp =1.0D0 ! Current expansion factor real(dp)::hexp =0.0D0 ! Current Hubble parameter real(dp)::texp =0.0D0 ! Current proper time real(dp)::n_sink = -1.d0 ! Sink particle density threshold in H/cc real(dp)::rho_sink = -1.D0 ! Sink particle density threshold in g/cc real(dp)::d_sink = -1.D0 ! Sink particle density threshold in user units real(dp)::m_star =-1.0 ! Star particle mass in units of mass_sph real(dp)::n_star =0.1D0 ! Star formation density threshold in H/cc real(dp)::t_star =0.0D0 ! Star formation time scale in Gyr real(dp)::eps_star=0.0D0 ! Star formation efficiency (0.02 at n_star=0.1 gives t_star=8 Gyr) real(dp)::T2_star=0.0D0 ! Typical ISM polytropic temperature real(dp)::g_star =1.6D0 ! Typical ISM polytropic index real(dp)::jeans_ncells=-1 ! Jeans polytropic EOS real(dp)::del_star=2.D2 ! Minimum overdensity to define ISM real(dp)::eta_sn =0.0D0 ! Supernova mass fraction real(dp)::eta_ssn=0.95 ! Single supernova ejected mass fraction (sf_imf=.true. only) real(dp)::yield =0.0D0 ! Supernova yield real(dp)::f_ek =1.0D0 ! Supernovae kinetic energy fraction (only between 0 and 1) real(dp)::rbubble=0.0D0 ! Supernovae superbubble radius in pc real(dp)::f_w =0.0D0 ! Supernovae mass loading factor integer ::ndebris=1 ! Supernovae debris particle number real(dp)::mass_gmc=-1.0 ! Stochastic exploding GMC mass real(dp)::z_ave =0.0D0 ! Average metal abundance real(dp)::B_ave =0.0D0 ! Average magnetic field real(dp)::z_reion=8.5D0 ! Reionization redshift real(dp)::T2_start ! Starting gas temperature real(dp)::T2max= 1d50 ! Temperature ceiling for cooling_fine real(dp)::t_delay=1.0D1 ! Feedback time delay in Myr real(dp)::t_diss =20.0D0 ! Dissipation timescale for feedback real(dp)::t_sne =10.0D0 ! Supernova blast time real(dp)::J21 =0.0D0 ! UV flux at threshold in 10^21 units real(dp)::a_spec =1.0D0 ! Slope of the UV spectrum real(dp)::beta_fix=0.0D0 ! Pressure fix parameter real(dp)::kappa_IR=0d0 ! IR dust opacity real(dp)::ind_rsink=4.0d0 ! Number of cells defining the radius of the sphere where AGN feedback is active real(dp)::ir_eff=0.75 ! efficiency of the IR feedback (only when ir_feedback=.true.) real(dp)::sf_trelax=0.0D0 ! Relaxation time for star formation (cosmo=.false. only) real(dp)::sf_tdiss=0.0D0 ! Dissipation timescale for subgrid turbulence in units of turbulent crossing time integer::sf_model=3 ! Virial star formation model integer::nlevel_collapse=3 ! Number of levels to follow initial dark matter collapse (cosmo=.true. only) real(dp)::mass_star_max=120.0D0 ! Maximum mass of a star in solar mass real(dp)::mass_sne_min=10.0D0 ! Minimum mass of a single supernova in solar mass logical ::self_shielding=.false. logical ::pressure_fix=.false. logical ::nordlund_fix=.true. logical ::cooling=.false. logical ::neq_chem=.false. ! Non-equilbrium chemistry activated logical ::isothermal=.false. logical ::metal=.false. logical ::haardt_madau=.false. logical ::delayed_cooling=.false. logical ::smbh=.false. logical ::agn=.false. logical ::use_proper_time=.false. logical ::convert_birth_times=.false. ! Convert stellar birthtimes: conformal -> proper logical ::ir_feedback=.false. ! Activate ir feedback from accreting sinks logical ::sf_virial=.false. ! Activate SF Virial criterion logical ::sf_log_properties=.false. ! Log in ascii files birth properties of stars and supernovae logical ::sf_imf=.false. ! Activate IMF sampling for SN feedback when resolution allows it logical ::sf_compressive=.false. ! Advect compressive and solenoidal turbulence terms separately ! Output times real(dp),dimension(1:MAXOUT)::aout=1.1 ! Output expansion factors real(dp),dimension(1:MAXOUT)::tout=0.0 ! Output times ! Movie integer::imovout=0 ! Increment for output times integer::imov=1 ! Initialize real(kind=8)::tstartmov=0.,astartmov=0. real(kind=8)::tendmov=0.,aendmov=0. real(kind=8),allocatable,dimension(:)::amovout,tmovout logical::movie=.false. integer::nw_frame=512 ! prev: nx_frame, width of frame in pixels integer::nh_frame=512 ! prev: ny_frame, height of frame in pixels integer::levelmax_frame=0 real(kind=8),dimension(1:20)::xcentre_frame=0d0 real(kind=8),dimension(1:20)::ycentre_frame=0d0 real(kind=8),dimension(1:20)::zcentre_frame=0d0 real(kind=8),dimension(1:10)::deltax_frame=0d0 real(kind=8),dimension(1:10)::deltay_frame=0d0 real(kind=8),dimension(1:10)::deltaz_frame=0d0 real(kind=8),dimension(1:5)::dtheta_camera=0d0 real(kind=8),dimension(1:5)::dphi_camera=0d0 real(kind=8),dimension(1:5)::theta_camera=0d0 real(kind=8),dimension(1:5)::phi_camera=0d0 real(kind=8),dimension(1:5)::tstart_theta_camera=0d0 real(kind=8),dimension(1:5)::tstart_phi_camera=0d0 real(kind=8),dimension(1:5)::tend_theta_camera=0d0 real(kind=8),dimension(1:5)::tend_phi_camera=0d0 real(kind=8),dimension(1:5)::focal_camera=0d0 real(kind=8),dimension(1:5)::dist_camera=0d0 real(kind=8),dimension(1:5)::ddist_camera=0d0 real(kind=8),dimension(1:5)::smooth_frame=1d0 real(kind=8),dimension(1:5)::varmin_frame=0d0 real(kind=8),dimension(1:5)::varmax_frame=1d60 integer,dimension(1:5)::ivar_frame=0 logical,dimension(1:5)::perspective_camera=.false. logical,dimension(1:5)::zoom_only_frame=.false. character(LEN=5)::proj_axis='z' ! x->x, y->y, projection along z character(LEN=6),dimension(1:5)::shader_frame='square' character(LEN=10),dimension(1:5)::method_frame='mean_mass' #ifdef SOLVERmhd integer,dimension(0:NVAR+6)::movie_vars=0 character(len=5),dimension(0:NVAR+6)::movie_vars_txt='' #else integer,dimension(0:NVAR+2)::movie_vars=0 character(len=5),dimension(0:NVAR+2)::movie_vars_txt='' #endif ! Refinement parameters for each level real(dp),dimension(1:MAXLEVEL)::m_refine =-1.0 ! Lagrangian threshold real(dp),dimension(1:MAXLEVEL)::r_refine =-1.0 ! Radius of refinement region real(dp),dimension(1:MAXLEVEL)::x_refine = 0.0 ! Center of refinement region real(dp),dimension(1:MAXLEVEL)::y_refine = 0.0 ! Center of refinement region real(dp),dimension(1:MAXLEVEL)::z_refine = 0.0 ! Center of refinement region real(dp),dimension(1:MAXLEVEL)::exp_refine = 2.0 ! Exponent for distance real(dp),dimension(1:MAXLEVEL)::a_refine = 1.0 ! Ellipticity (Y/X) real(dp),dimension(1:MAXLEVEL)::b_refine = 1.0 ! Ellipticity (Z/X) real(dp)::var_cut_refine=-1.0 ! Threshold for variable-based refinement real(dp)::mass_cut_refine=-1.0 ! Mass threshold for particle-based refinement integer::ivar_refine=-1 ! Variable index for refinement logical::sink_refine=.false. ! Fully refine on sink particles ! Initial condition files for each level logical::multiple=.false. ! CHANGED BY TTG (FEB 2017) ! character(LEN=80),dimension(1:MAXLEVEL)::initfile=' ' character(LEN=256),dimension(1:MAXLEVEL)::initfile=' ' character(LEN=20)::filetype='ascii' ! Initial condition regions parameters integer,parameter::MAXREGION=100 integer ::nregion=0 character(LEN=10),dimension(1:MAXREGION)::region_type='square' real(dp),dimension(1:MAXREGION) ::x_center=0. real(dp),dimension(1:MAXREGION) ::y_center=0. real(dp),dimension(1:MAXREGION) ::z_center=0. real(dp),dimension(1:MAXREGION) ::length_x=1.E10 real(dp),dimension(1:MAXREGION) ::length_y=1.E10 real(dp),dimension(1:MAXREGION) ::length_z=1.E10 real(dp),dimension(1:MAXREGION) ::exp_region=2.0 ! Boundary conditions parameters integer,parameter::MAXBOUND=100 logical ::simple_boundary=.false. integer ::nboundary=0 integer ::icoarse_min=0 integer ::icoarse_max=0 integer ::jcoarse_min=0 integer ::jcoarse_max=0 integer ::kcoarse_min=0 integer ::kcoarse_max=0 integer ,dimension(1:MAXBOUND) ::boundary_type=0 integer ,dimension(1:MAXBOUND) ::ibound_min=0 integer ,dimension(1:MAXBOUND) ::ibound_max=0 integer ,dimension(1:MAXBOUND) ::jbound_min=0 integer ,dimension(1:MAXBOUND) ::jbound_max=0 integer ,dimension(1:MAXBOUND) ::kbound_min=0 integer ,dimension(1:MAXBOUND) ::kbound_max=0 logical ::no_inflow=.false. !Number of processes sharing one token !Only one process can write at a time in an I/O group integer::IOGROUPSIZE=0 ! Main snapshot integer::IOGROUPSIZECONE=0 ! Lightcone integer::IOGROUPSIZEREP=0 ! Subfolder size logical::withoutmkdir=.false. !If true mkdir should be done before the run logical::print_when_io=.false. !If true print when IO logical::synchro_when_io=.false. !If true synchronize when IO end module amr_parameters ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/cooling_fine.f90 subroutine cooling_fine(ilevel) use amr_commons use hydro_commons use cooling_module #ifdef grackle use grackle_parameters #endif implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel !------------------------------------------------------------------- ! Compute cooling for fine levels !------------------------------------------------------------------- integer::ncache,i,igrid,ngrid,info integer,dimension(1:nvector),save::ind_grid real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v if(numbtot(1,ilevel)==0)return ! CHANGED BY TTG (FEB 2017) ! if(verbose)write(*,111)ilevel if(myid==1)write(*,111)ilevel ! Operator splitting step for cooling source term ! by vector sweeps ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do call coolfine1(ind_grid,ngrid,ilevel) end do if((cooling.and..not.neq_chem).and.ilevel==levelmin.and.cosmo)then #ifdef grackle if(use_grackle==0)then if(myid==1)write(*,*)'Computing new cooling table' call set_table(dble(aexp)) endif #else if(myid==1)write(*,*)'Computing new cooling table' call set_table(dble(aexp)) #endif endif 111 format(' Entering cooling_fine for level',i2) end subroutine cooling_fine !########################################################### !########################################################### !########################################################### !########################################################### subroutine coolfine1(ind_grid,ngrid,ilevel) use amr_commons use hydro_commons use cooling_module #ifdef grackle use grackle_parameters #endif #ifdef ATON use radiation_commons, ONLY: Erad #endif #ifdef RT use rt_parameters, only: nGroups, iGroups use rt_hydro_commons use rt_cooling_module, only: rt_solve_cooling,iIR,rt_isIRtrap & ,rt_pressBoost,iIRtrapVar,kappaSc,a_r,is_kIR_T,rt_vc #endif implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel,ngrid integer,dimension(1:nvector)::ind_grid !------------------------------------------------------------------- !------------------------------------------------------------------- integer::i,ind,iskip,idim,nleaf,nx_loc,ix,iy,iz,info real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v real(kind=8)::dtcool,nISM,nCOM,damp_factor,cooling_switch,t_blast real(dp)::polytropic_constant integer,dimension(1:nvector),save::ind_cell,ind_leaf real(kind=8),dimension(1:nvector),save::nH,T2,T2_new,delta_T2,ekk,err,emag real(kind=8),dimension(1:nvector),save::T2min,Zsolar,boost real(dp),dimension(1:3)::skip_loc real(kind=8)::dx,dx_loc,scale,vol_loc integer::irad #ifdef RT integer::ii,ig,iNp,il real(kind=8),dimension(1:nvector),save:: ekk_new logical,dimension(1:nvector),save::cooling_on=.true. real(dp)::scale_Np,scale_Fp,work,Npc,fred,Npnew, kScIR, EIR, TR real(dp),dimension(1:ndim)::Fpnew real(dp),dimension(nIons, 1:nvector),save:: xion real(dp),dimension(nGroups, 1:nvector),save:: Np, Np_boost=0d0, dNpdt=0d0 real(dp),dimension(ndim, nGroups, 1:nvector),save:: Fp, Fp_boost, dFpdt real(dp),dimension(ndim, 1:nvector),save:: p_gas, u_gas real(kind=8)::f_trap, NIRtot, EIR_trapped, unit_tau, tau, Np2Ep, aexp_loc real(dp),dimension(nDim, nDim):: tEdd ! Eddington tensor real(dp),dimension(nDim):: flux #endif ! ADDED BY TTG (FEB 2017) logical::first_call=.true. ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) #ifdef RT call rt_units(scale_Np, scale_Fp) #endif ! Typical ISM density in H/cc nISM = n_star; nCOM=0d0 if(cosmo)then nCOM = del_star*omega_b*rhoc*(h0/100.)**2/aexp**3*X/mH endif nISM = MAX(nCOM,nISM) ! Polytropic constant for Jeans length related polytropic EOS if(jeans_ncells>0)then polytropic_constant=2d0*(boxlen*jeans_ncells*0.5d0**dble(nlevelmax)*scale_l/aexp)**2/ & & (twopi)*6.67e-8*scale_d*(scale_t/scale_l)**2 ! ADDED BY TTG (FEB 2017) if((myid==1).and.first_call)then first_call = .false. write(*,'(a32,1pe10.2,i5)')'Temperature floor at 1/cm^3 [K], level : ', polytropic_constant*scale_T2, nlevelmax endif endif #ifdef RT #if NGROUPS>0 if(rt_isIRtrap) then ! For conversion from photon number density to photon energy density: Np2Ep = scale_Np * group_egy(iIR) * ev_to_erg & * rt_pressBoost / scale_d / scale_v**2 endif #endif aexp_loc=aexp ! Allow for high-z UV background in noncosmo sims: if(.not. cosmo .and. haardt_madau .and. aexp_ini .le. 1.) & aexp_loc = aexp_ini #endif ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do ! Gather leaf cells nleaf=0 do i=1,ngrid if(son(ind_cell(i))==0)then nleaf=nleaf+1 ind_leaf(nleaf)=ind_cell(i) end if end do if(nleaf.eq.0)cycle ! Compute rho ! TTG 2017: nH is a misnomer; as it is not hydrogen, but rather total, mass density do i=1,nleaf nH(i)=MAX(uold(ind_leaf(i),1),smallr) end do ! Compute metallicity in solar units ! IMPORTANT: uold(:,imetal) corresponds to metal mass density (i.e density * Z; Z = metal mass fraction) if(metal)then do i=1,nleaf Zsolar(i)=uold(ind_leaf(i),imetal)/nH(i)/0.02 ! TTG 2017: convert total metal mass density to Z in solar units end do else do i=1,nleaf Zsolar(i)=z_ave ! TTG (MAR 2017): recall that z_ave = 0 (default value) end do endif #ifdef RT ! Floor density (prone to go negative with strong rad. pressure): do i=1,nleaf uold(ind_leaf(i),1) = max(uold(ind_leaf(i),1),smallr) end do ! Initialise gas momentum and velocity for photon momentum abs.: do i=1,nleaf p_gas(:,i) = uold(ind_leaf(i),2:ndim+1) * scale_d * scale_v u_gas(:,i) = uold(ind_leaf(i),2:ndim+1) & /uold(ind_leaf(i),1) * scale_v end do #if NGROUPS>0 if(rt_isIRtrap) then ! Gather also trapped photons for solve_cooling iNp=iGroups(iIR) do i=1,nleaf il=ind_leaf(i) rtuold(il,iNp) = rtuold(il,iNp) + uold(il,iIRtrapVar)/Np2Ep if(rt_smooth) & rtunew(il,iNp)= rtunew(il,iNp) + uold(il,iIRtrapVar)/Np2Ep end do endif if(rt_vc) then ! Add/remove radiation work on gas. Eq A6 in RT15 iNp=iGroups(iIR) do i=1,nleaf il=ind_leaf(i) NIRtot = rtuold(il,iNp) kScIR = kappaSc(iIR) if(is_kIR_T) then ! k_IR depends on T EIR = group_egy(iIR) * ev_to_erg * NIRtot *scale_Np TR = max(T2_min_fix,(EIR*rt_c_cgs/c_cgs/a_r)**0.25) kScIR = kappaSc(iIR) * (TR/10d0)**2 endif kScIR = kScIR*scale_d*scale_l flux = rtuold(il,iNp+1:iNp+ndim) work = scale_v/c_cgs * kScIR * sum(uold(il,2:ndim+1)*flux) & * Zsolar(i) * dtnew(ilevel) ! Eq A6 uold(il,ndim+2) = uold(il,ndim+2) & ! Add work to gas energy + work * group_egy(iIR) & * ev_to_erg / scale_d / scale_v**2 / scale_l**3 rtuold(il,iNp) = rtuold(il,iNp) - work !Remove from rad density rtuold(il,iNp) = max(rtuold(il,iNp),smallnp) call reduce_flux(rtuold(il,iNp+1:iNp+ndim),rtuold(il,iNp)*rt_c) enddo endif #endif #endif ! Compute thermal pressure do i=1,nleaf T2(i)=uold(ind_leaf(i),ndim+2) end do do i=1,nleaf ekk(i)=0.0d0 end do do idim=1,ndim do i=1,nleaf ekk(i)=ekk(i)+0.5*uold(ind_leaf(i),idim+1)**2/nH(i) end do end do do i=1,nleaf err(i)=0.0d0 end do #if NENER>0 do irad=0,nener-1 do i=1,nleaf err(i)=err(i)+uold(ind_leaf(i),inener+irad) end do end do #endif do i=1,nleaf emag(i)=0.0d0 end do #ifdef SOLVERmhd do idim=1,ndim do i=1,nleaf emag(i)=emag(i)+0.125d0*(uold(ind_leaf(i),idim+ndim+2)+uold(ind_leaf(i),idim+nvar))**2 end do end do #endif do i=1,nleaf T2(i)=(gamma-1.0)*(T2(i)-ekk(i)-err(i)-emag(i)) end do ! Compute T2=T/mu in Kelvin do i=1,nleaf T2(i)=T2(i)/nH(i)*scale_T2 end do ! Compute nH in H/cc do i=1,nleaf nH(i)=nH(i)*scale_nH end do ! Compute radiation boost factor if(self_shielding)then do i=1,nleaf boost(i)=MAX(exp(-nH(i)/0.01),1.0D-20) end do #ifdef ATON else if (aton) then do i=1,nleaf boost(i)=MAX(Erad(ind_leaf(i))/J0simple(aexp), & & J0min/J0simple(aexp) ) end do #endif else do i=1,nleaf boost(i)=1.0 end do endif !========================================== ! Compute temperature from polytrope EOS !========================================== if(jeans_ncells>0)then do i=1,nleaf T2min(i) = nH(i)*polytropic_constant*scale_T2 end do else do i=1,nleaf T2min(i) = T2_star*(nH(i)/nISM)**(g_star-1.0) end do endif !========================================== ! You can put your own polytrope EOS here !========================================== if(cooling)then ! Compute thermal temperature by subtracting polytrope do i=1,nleaf T2(i) = min(max(T2(i)-T2min(i),T2_min_fix),T2max) end do endif ! Compute cooling time step in second dtcool = dtnew(ilevel)*scale_t #ifdef RT if(neq_chem) then ! Get the ionization fractions do ii=0,nIons-1 do i=1,nleaf xion(1+ii,i) = uold(ind_leaf(i),iIons+ii)/uold(ind_leaf(i),1) end do end do ! Get photon densities and flux magnitudes do ig=1,nGroups iNp=iGroups(ig) do i=1,nleaf il=ind_leaf(i) Np(ig,i) = scale_Np * rtuold(il,iNp) Fp(1:ndim, ig, i) = scale_Fp * rtuold(il,iNp+1:iNp+ndim) enddo if(rt_smooth) then ! Smooth RT update do i=1,nleaf !Calc addition per sec to Np, Fp for current dt il=ind_leaf(i) Npnew = scale_Np * rtunew(il,iNp) Fpnew = scale_Fp * rtunew(il,iNp+1:iNp+ndim) dNpdt(ig,i) = (Npnew - Np(ig,i)) / dtcool dFpdt(:,ig,i) = (Fpnew - Fp(:,ig,i)) / dtcool end do end if end do if(cooling .and. delayed_cooling) then cooling_on(1:nleaf)=.true. do i=1,nleaf if(uold(ind_leaf(i),idelay)/uold(ind_leaf(i),1) .gt. 1d-3) & cooling_on(i)=.false. end do end if if(isothermal)cooling_on(1:nleaf)=.false. endif if(rt_vc) then ! Do the Lorentz boost. Eqs A4 and A5. in RT15 do i=1,nleaf do ig=1,nGroups Npc=Np(ig,i)*rt_c_cgs call cmp_Eddington_tensor(Npc,Fp(:,ig,i),tEdd) Np_boost(ig,i) = - 2d0/c_cgs/rt_c_cgs * sum(u_gas(:,i)*Fp(:,ig,i)) do idim=1,ndim Fp_boost(idim,ig,i) = & -u_gas(idim,i)*Np(ig,i) * rt_c_cgs/c_cgs & -sum(u_gas(:,i)*tEdd(idim,:))*Np(ig,i)*rt_c_cgs/c_cgs end do end do Np(:,i) = Np(:,i) + Np_boost(:,i) Fp(:,:,i) = Fp(:,:,i) + Fp_boost(:,:,i) end do endif #endif ! grackle tabular cooling #ifdef grackle if(use_grackle==1)then gr_rank = 3 do i = 1, gr_rank gr_dimension(i) = 1 gr_start(i) = 0 gr_end(i) = 0 enddo gr_dimension(1) = nvector gr_end(1) = nleaf - 1 if(cosmo)then my_grackle_units%a_value = MAX(aexp,0.0625) my_grackle_units%density_units = scale_d my_grackle_units%length_units = scale_l my_grackle_units%time_units = scale_t my_grackle_units%velocity_units = scale_v endif do i = 1, nleaf gr_density(i) = uold(ind_leaf(i),1) if(metal)then gr_metal_density(i) = uold(ind_leaf(i),imetal) else gr_metal_density(i) = uold(ind_leaf(i),1)*0.02*z_ave endif gr_energy(i) = T2(i)/(scale_T2*(gamma-1.0)) gr_HI_density(i) = X*gr_density(i) gr_HeI_density(i) = (1.0-X)*gr_density(i) gr_DI_density(i) = 2.0*3.4e-5*gr_density(i) enddo ! Update grid properties my_grackle_fields%grid_rank = gr_rank my_grackle_fields%grid_dx = dx_loc iresult = solve_chemistry(my_grackle_units, my_grackle_fields, dtnew(ilevel)) if(iresult.eq.0)then write(*,*) 'Grackle: error in solve_chemistry' #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif do i = 1, nleaf T2_new(i) = gr_energy(i)*scale_T2*(gamma-1.0) end do delta_T2(1:nleaf) = T2_new(1:nleaf) - T2(1:nleaf) else ! Compute net cooling at constant nH if(cooling.and..not.neq_chem)then call solve_cooling(nH,T2,Zsolar,boost,dtcool,delta_T2,nleaf) endif endif #else ! Compute net cooling at constant nH if(cooling.and..not.neq_chem)then call solve_cooling(nH,T2,Zsolar,boost,dtcool,delta_T2,nleaf) endif #endif #ifdef RT if(neq_chem) then T2_new(1:nleaf) = T2(1:nleaf) call rt_solve_cooling(T2_new, xion, Np, Fp, p_gas, dNpdt, dFpdt & , nH, cooling_on, Zsolar, dtcool, aexp_loc,nleaf) delta_T2(1:nleaf) = T2_new(1:nleaf) - T2(1:nleaf) endif #endif #ifdef RT if(.not. static) then ! Update gas momentum and kinetic energy: do i=1,nleaf uold(ind_leaf(i),2:1+ndim) = p_gas(:,i) /scale_d /scale_v end do ! Energy update ================================================== ! Calculate NEW pressure from updated momentum ekk_new(1:nleaf) = 0d0 do i=1,nleaf do idim=1,ndim ekk_new(i) = ekk_new(i) & + 0.5*uold(ind_leaf(i),idim+1)**2 / uold(ind_leaf(i),1) end do end do do i=1,nleaf ! Update the pressure variable with the new kinetic energy: uold(ind_leaf(i),ndim+2) = uold(ind_leaf(i),ndim+2) & - ekk(i) + ekk_new(i) end do do i=1,nleaf ekk(i)=ekk_new(i) end do #if NGROUPS>0 if(rt_vc) then ! Photon work: subtract from the IR ONLY radiation do i=1,nleaf Np(iIR,i) = Np(iIR,i) + (ekk(i) - ekk_new(i)) & /scale_d/scale_v**2 / group_egy(iIR) / ev_to_erg end do endif #endif ! End energy update ============================================== endif ! if(.not. static) #endif ! Compute rho do i=1,nleaf nH(i) = nH(i)/scale_nH end do ! Deal with cooling if(cooling.or.neq_chem)then ! Compute net energy sink do i=1,nleaf delta_T2(i) = delta_T2(i)*nH(i)/scale_T2/(gamma-1.0) end do ! Compute initial fluid internal energy do i=1,nleaf T2(i) = T2(i)*nH(i)/scale_T2/(gamma-1.0) end do ! Turn off cooling in blast wave regions if(delayed_cooling)then do i=1,nleaf cooling_switch = uold(ind_leaf(i),idelay)/max(uold(ind_leaf(i),1),smallr) if(cooling_switch > 1d-3)then delta_T2(i) = MAX(delta_T2(i),real(0,kind=dp)) endif end do endif endif ! Compute polytrope internal energy do i=1,nleaf T2min(i) = T2min(i)*nH(i)/scale_T2/(gamma-1.0) end do ! Update fluid internal energy if(cooling.or.neq_chem)then do i=1,nleaf ! CHANGED BY TTG MAR 2017: limit maximum temperature to 10^7 K to keep dt reasonable at > ~10^-4 ! See e.g. Perret et al. (2014; their Section 2.1) ! NOT USED FOR NOW ! T2(i) = MIN(1.0d7*nH(i)/scale_T2/(gamma-1.0), T2(i) + delta_T2(i)) T2(i) = T2(i) + delta_T2(i) end do endif ! Update total fluid energy if(isothermal)then do i=1,nleaf uold(ind_leaf(i),ndim+2) = T2min(i) + ekk(i) + err(i) + emag(i) end do else if(cooling .or. neq_chem)then do i=1,nleaf uold(ind_leaf(i),ndim+2) = T2(i) + T2min(i) + ekk(i) + err(i) + emag(i) end do endif ! Update delayed cooling switch if(delayed_cooling)then t_blast=t_diss*1d6*(365.*24.*3600.) damp_factor=exp(-dtcool/t_blast) do i=1,nleaf uold(ind_leaf(i),idelay)=uold(ind_leaf(i),idelay)*damp_factor end do endif #ifdef RT if(neq_chem) then ! Update ionization fraction do ii=0,nIons-1 do i=1,nleaf uold(ind_leaf(i),iIons+ii) = xion(1+ii,i)*nH(i) end do end do endif #if NGROUPS>0 if(rt) then ! Update photon densities and flux magnitudes do ig=1,nGroups do i=1,nleaf rtuold(ind_leaf(i),iGroups(ig)) = (Np(ig,i)-Np_boost(ig,i)) /scale_Np rtuold(ind_leaf(i),iGroups(ig)) = & max(rtuold(ind_leaf(i),iGroups(ig)),smallNp) rtuold(ind_leaf(i),iGroups(ig)+1:iGroups(ig)+ndim) & = (Fp(1:ndim,ig,i)-Fp_boost(1:ndim,ig,i)) /scale_Fp enddo end do endif ! Split IR photons into trapped and freeflowing if(rt_isIRtrap) then if(nener .le. 0) then print*,'Trying to store E_trapped pressure, but NERAD too small!!' STOP endif iNp=iGroups(iIR) unit_tau = 1.5d0 * dx_loc * scale_d * scale_l do i=1,nleaf il=ind_leaf(i) NIRtot =max(rtuold(il,iNp),smallNp) ! Total photon density kScIR = kappaSc(iIR) if(is_kIR_T) then ! k_IR depends on T EIR = group_egy(iIR) * ev_to_erg * NIRtot *scale_Np TR = max(T2_min_fix,(EIR*rt_c_cgs/c_cgs/a_r)**0.25) kScIR = kappaSc(iIR) * (TR/10d0)**2 endif tau = nH(i) * Zsolar(i) * unit_tau * kScIR f_trap = 0d0 ! Fraction IR photons that are trapped if(tau .gt. 0d0) f_trap = min(max(exp(-1d0/tau), 0d0), 1d0) ! Update streaming photons, trapped photons, and tot energy: rtuold(il,iNp) = max(smallnp,(1d0-f_trap) * NIRtot) ! Streaming rtuold(il,iNp+1:iNp+ndim) = & ! Limit streaming flux rtuold(il,iNp+1:iNp+ndim) * (1d0-f_trap) EIR_trapped = max(0d0, NIRtot-rtuold(il,iNp)) * Np2Ep ! Trapped ! Update tot energy due to change in trapped radiation energy: uold(il,ndim+2)=uold(il,ndim+2)-uold(il,iIRtrapVar)+EIR_trapped ! Update the trapped photon energy: uold(il,iIRtrapVar) = EIR_trapped call reduce_flux(rtuold(il,iNp+1:iNp+ndim),rtuold(il,iNp)*rt_c) end do ! i=1,nleaf endif !rt_isIRtrap #endif #endif end do ! End loop over cells end subroutine coolfine1 #ifdef RT !************************************************************************ subroutine cmp_Eddington_tensor(Npc,Fp,T_Edd) ! Compute Eddington tensor for given radiation variables ! Npc => Photon number density times light speed ! Fp => Photon number flux ! T_Edd <= Returned Eddington tensor !------------------------------------------------------------------------ use amr_commons implicit none real(dp)::Npc real(dp),dimension(1:ndim)::Fp ,u real(dp),dimension(1:ndim,1:ndim)::T_Edd real(dp)::iterm,oterm,Np_c_sq,Fp_sq,fred_sq,chi integer::p,q !------------------------------------------------------------------------ if(Npc .le. 0.d0) then write(*,*)'negative photon density in cmp_Eddington_tensor. -EXITING-' call clean_stop endif T_Edd(:,:) = 0.d0 Np_c_sq = Npc**2 Fp_sq = sum(Fp**2) ! Sq. photon flux magnitude u(:) = 0.d0 ! Flux unit vector if(Fp_sq .gt. 0.d0) u(:) = Fp/sqrt(Fp_sq) fred_sq = Fp_sq/Np_c_sq ! Reduced flux, squared chi = max(4.d0-3.d0*fred_sq, 0.d0) ! Eddington factor chi = (3.d0+ 4.d0*fred_sq)/(5.d0 + 2.d0*sqrt(chi)) iterm = (1.d0-chi)/2.d0 ! Identity term in tensor oterm = (3.d0*chi-1.d0)/2.d0 ! Outer product term do p = 1, ndim do q = 1, ndim T_Edd(p,q) = oterm * u(p) * u(q) enddo T_Edd(p,p) = T_Edd(p,p) + iterm enddo end subroutine cmp_Eddington_tensor #endif ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/cooling_module.f90 !============================================================================= ! SUPERMEGAGIGAMODULECOOLINGQUIDEPOTE !============================================================================= ! Les subroutines et fonctions d'interet general sont : ! ! ROUTINES A APPELER PAR LE CODE HYDRO ! ! subroutine set_model(...) : ! pour choisir le modele de cooling et ses parametres ! ! subroutine set_table(aexp) : ! pour creer la table avec les parametres par defaut ! Plus pratique a appeler que ! cmp_table(nH_min,nH_max,T2_min,T2_max,nbin_n,nbin_T,aexp) ! ! subroutine solve_cooling(...) : ! pour calculer le cooling ! ! ROUTINE A MODIFIER SI NECESSAIRE ! ! function J0simple(aexp) : ! donne le J0 en fonction du redshift dans les modeles Teyssier ! ou Theuns ! !============================================================================= module cooling_module use amr_parameters implicit none logical :: verbose_cooling=.false. real(kind=8),parameter ::smallnum_cooling= 1d-30 real(kind=8),parameter ::twopi = 6.2831853d0 real(kind=8),parameter ::hplanck = 6.6262000d-27 real(kind=8),parameter ::eV = 1.6022000d-12 real(kind=8),parameter ::kB = 1.3806200d-16 real(kind=8),parameter ::clight = 2.9979250d+10 real(kind=8),parameter ::Gyr = 3.1536000d+16 real(kind=8) ::X = 0.76 real(kind=8) ::Y = 0.24 real(kind=8),parameter ::rhoc = 1.8800000d-29 real(kind=8),parameter ::mH = 1.6600000d-24 real(kind=8),parameter ::mu_mol = 1.2195D0 integer,parameter::HI = 1 integer,parameter::HEI = 2 integer,parameter::HEII = 3 ! Les parametres de la table par defaut integer,parameter :: nbin_T_fix=101 integer,parameter :: nbin_n_fix=161 real(kind=8),parameter:: nH_min_fix=1.d-10 real(kind=8),parameter:: nH_max_fix=1.d+6 real(kind=8),parameter:: T2_min_fix=1.d-2 real(kind=8),parameter:: T2_max_fix=1.d+9 type cooling_table integer::n1 integer::n2 real(kind=8),dimension(:) ,pointer::nH real(kind=8),dimension(:) ,pointer::T2 real(kind=8),dimension(:,:) ,pointer::cool real(kind=8),dimension(:,:) ,pointer::heat real(kind=8),dimension(:,:) ,pointer::cool_com real(kind=8),dimension(:,:) ,pointer::heat_com real(kind=8),dimension(:,:) ,pointer::metal real(kind=8),dimension(:,:) ,pointer::cool_prime real(kind=8),dimension(:,:) ,pointer::heat_prime real(kind=8),dimension(:,:) ,pointer::cool_com_prime real(kind=8),dimension(:,:) ,pointer::heat_com_prime real(kind=8),dimension(:,:) ,pointer::metal_prime real(kind=8),dimension(:,:) ,pointer::mu real(kind=8),dimension(:,:,:),pointer::n_spec end type cooling_table type(cooling_table)::table,table2 ! Utilisation de table%n_spec si necessaire logical, parameter :: if_species_abundances=.true. ! Facteur correctif de Theuns et al. real(kind=8),parameter :: dumfac_ion_theuns=2.d0 real(kind=8),parameter :: dumfac_rec_theuns=0.75D0 ! idem real(kind=8) :: dumfac_ion=dumfac_ion_theuns real(kind=8) :: dumfac_rec=dumfac_rec_theuns ! On DOIT AVOIR OU teyssier OU theuns OU madau ! OU weinbergint OU courty avec un OU exclusif logical :: teyssier=.false. logical :: theuns=.false. logical :: madau=.false. logical :: weinberg=.false. logical :: weinbergint=.false. logical :: courty=.true. ! Default model (TTG 2017: not really, actually theuns [Nmodel=2] is default; see amr/init_time.f90) ! Si teyssier ou theuns : real(kind=8) :: J0in=1.d-22 ! J0 default (TTG 2017: Theuns+98 actually used 5.0d-22 ...) real(kind=8) :: J0min=1.d-29 ! Valeur minimale du J0 logical :: force_j0_one=.false. ! Force constant UV bkg ! (saturation a grand redshift) real(kind=8) :: aexp_ref=0.0001 real(kind=8) :: J0min_ref=2.77168510365299962D-25 ! J0min_ref precalcule pour ! H0=70, omegab=0.04, omega0=0.3, omegaL=0.7 logical :: high_z_realistic_ne=.true. ! Calcul du J0min de telle sorte ! que le n_e soit realiste a grand z. J0min=J0min_ref/(aexp/aexp_ref)^2 real(kind=8) :: alpha=1.d0 ! J(nu) \propto nu^{-alpha} ! Si madau ou weinbergint : real(kind=8) :: normfacJ0=0.74627 ! Facteur de normalisation pour J0 ! pour un J(nu,z) de type haardt et Madau ! Ce facteur la est celui utilise par Dave et al. pour LCDM ! Sauvegarde des termes de cooling/heating dans les logical, parameter :: if_cooling_functions=.true. ! variables en dessous real(kind=8)::cb1s,cb2s,cb3s,ci1s,ci2s,ci3s,cr1s,cr2s,cr3s,cds real(kind=8)::ce1s,ce3s,ch1s,ch2s,ch3s,cocs,cohs real(kind=8)::cool_out, heat_out ! Les heating et photoionization rates de Dave et al. ! pour le J0 derniere version de HM (weinberg ou weinbergint si ! if_read_weinberg=.true. (voir plus bas) dans ce dernier cas) real(kind=8),allocatable, dimension(:,:)::table_weinberg ! Table d'interpolation en input character(len=128), parameter :: table_weinberg_name='TREECOOL' ! Nom du fichier avec les donnees integer,parameter :: luweinberg=21 ! unit pour lire le fichier integer :: Nweinberg ! Nombre de bins en redshift ! Les coefficients d'interpolation des heating rates de Dave et al. ! (weinbergint) logical,parameter :: if_read_weinberg=.false. ! .true. pour lire le fichier table_weinberg_name ! puis interpoler par un polynome ! .false. pour utiliser les valeurs des coefficients ! precalcules listes plus bas integer,parameter :: Norderweinberg=7 ! Ordre+1 du polynome d'interpolation (NE PAS CHANGER) real(kind=8) :: coefweinberg(Norderweinberg,6)= reshape( & & (/ -0.31086729929951613D+002, 0.34803667059463761D+001,-0.15145716066316397D+001, & & 0.54649951450632972D+000,-0.16395924120387340D+000, 0.25197466148524143D-001, & & -0.15352763785487806D-002, & & -0.31887274113252204D+002, 0.44178493140927095D+001,-0.20158132553082293D+001, & & 0.64080497292269134D+000,-0.15981267091909040D+000, 0.22056900050237707D-001, & & -0.12837570029562849D-002, & & -0.35693331167978656D+002, 0.20207245722165794D+001,-0.76856976101363744D-001, & & -0.75691470654320359D-001,-0.54502220282734729D-001, 0.20633345104660583D-001, & & -0.18410307456285177D-002, & & -0.56967559787460921D+002, 0.38601174525546353D+001,-0.18318926655684415D+001, & & 0.67360594266440688D+000,-0.18983466813215341D+000, 0.27768907786915147D-001, & & -0.16330066969315893D-002, & & -0.56977907250821026D+002, 0.38686249565302266D+001,-0.13330942368518774D+001, & & 0.33988839029092172D+000,-0.98997915675929332D-001, 0.16781612113050747D-001, & & -0.11514328893746039D-002, & & -0.59825233828609278D+002, 0.21898162706563347D+001,-0.42982055888598525D+000, & & 0.50312144291614215D-001,-0.61550639239553132D-001, 0.18017109270959387D-001, & & -0.15438891584271634D-002 /), (/Norderweinberg,6/) ) real(kind=8) :: zreioniz=8.5d0 integer,parameter :: Nordercourty=7 ! Ordre+1 du polynome d'interpolation (NE PAS CHANGER) real(kind=8) :: coefcourty(0:Nordercourty,6)= reshape( & (/ -13.5857, 1.24475, 0.187739, & -0.430409, 0.152544, -0.0246448, & 0.00192622, -5.89772e-05, & -14.0242, 1.99211, -0.490766, & -0.122646, 0.0776501, -0.0146310, & 0.00123335, -3.96066e-05, & -15.6627, 0.128240, 1.65633, & -1.23799, 0.372157, -0.0561687, & 0.00422696, -0.000126344, & -24.8422, 1.50750, -0.0699428, & -0.308682, 0.122196, -0.0205179, & 0.00163695, -5.08050e-05, & -25.0252, 1.79577, -0.159054, & -0.300924, 0.125343, -0.0214598, & 0.00173377, -5.43576e-05, & -26.4168, 0.0479454, 1.70948, & -1.26395, 0.378922, -0.0570957, & 0.00428897, -0.000127909 /),(/Nordercourty+1,6/) ) real(kind=8),dimension(6) :: coef_fit= (/ 20., 20., 20., 20., 20., 20. /) integer,dimension(6) :: beta_fit= (/ 6, 6, 8, 6, 6, 8 /) contains !======================================================================= subroutine set_model(Nmodel,J0in_in,J0min_in,alpha_in,normfacJ0_in,zreioniz_in, & & correct_cooling,realistic_ne, & & h,omegab,omega0,omegaL,astart_sim,T2_sim) !======================================================================= ! Nmodel(integer) =1 : Teyssier : ancien choix de l'evolution et de la forme du J(nu,z) ! 2 : Theuns : pareil mais avec les fonctions interpolees de Theuns (+ rapide) ! 3 : Madau : J(nu,z) de Theuns et al. 1998 avec les anciennes mesures de ! Haardt et Madau (HM) ! 4 : Weinberg : J(nu,z) de Dave et al. 1999 avec les nouvelles mesure de HM ! lues dans le fichier table_weinberg_name (inactive) ! 5 : idem 4 mais interpole interpole de maniere polynomiale : RECOMMANDE ! 6 : Courty ! -1 : defaut defini dans le module ! J0in_in (dble) : valeur du J0 utilisee pour Teyssier et Theuns ! Exemple : J0in_in=1.d-22 ! J0in_in <= 0 utilise le defaut defini dans le module ! J0min_in (dble) : valeur du J0min ou J0min_ref (voir option realistic_ne) ! utilisee dans tous les modeles a grand redshift ! Exemple : J0min_in=1.d-29 ! J0min_in <= 0 utilise le defaut defini dans le module ! alpha_in (dble) : valeur de l'indice spectral du J(nu) \propto nu^{-alpha} ! Exemple : alpha=1. ! alpha_in < 0 utilise le defaut defini dans le module ! zreioniz_in (dble) : valeur du redshift de reionisation ! Exemple : zerion=10. ! zreioniz_in < 0 utilise le defaut defini dans le module ! normfacJ0_in (dble) : valeur du facteur de normalisation dans le cas des ! spectres de Haardt et Madau. C'est un nombre de l'ordre de ! l'unite en general plus petit que 1. ! Exemple : normfacJ0_in=0.74627 ! normfacJ0_in prend le defaut defini dans le module ! correct_cooling (integer) : 0 : pas de correction ! 1 : correction de Theuns et al 98 ! -1 : defaut defini dans le module ! realistic_ne (integer) : 0 : pas de n_e realiste a grand redshift : ! Le J0min reste le meme quel que soit le redshift ! (J0min=J0min_in si celui-ci est > 0) ! 1 : n_e realiste a grand redshift : J0min proportionnel a 1/a^2 ! egal initialement a J0min_ref pour a=aexp_ref=0.0001 ! (J0min_ref=J0min_in si celui-ci est > 0) ! 2 : RECOMMANDE : pareil que 1, mais J0min_ref est calcule de ! maniere iterative pour avoir le bon n_e a z=19. ! Le J0min_in n'est pas relevant dans ce cas la. ! h (dble) : H0/100 ! omegab (dble) : omega baryons ! omega0 (dble) : omega matiere total ! omegaL (dble) : omega Lambda ! astart_sim (dble) : redshift auquel on veut commencer la simulation ! T2_sim (dble) : ce sera en output, le T/mu en K a ce redshift pour des regions de contraste ! de densite nul. ! ! NOTE : ! Dans les cas madau, ou weinberg ou weinbergint, le J0 a grand redshift est calcule comme ! dans l'option theuns : ! madau : pour z >= 15 ou quand le taux trouve est plus petit que celui donne par ! l'option theuns=.true. ! weinberg : quand on sort de la table des taux ! weinbergint : pour z >= 8.5 ou quand le taux trouve est plus petit que celui donne ! par l'option theuns=.true. ! courty : !======================================================================= implicit none real(kind=8) :: J0in_in,zreioniz_in,J0min_in,alpha_in,normfacJ0_in,astart_sim,T2_sim real(kind=8) :: J0min_ref_calc,h,omegab,omega0,omegaL integer :: Nmodel,correct_cooling,realistic_ne real(kind=8) :: astart,aend,dasura,T2end,mu,ne,minus1 if (Nmodel /= -1) then teyssier=.false. theuns=.false. madau=.false. weinberg=.false. weinbergint=.false. courty=.false. if (Nmodel==1) then teyssier=.true. elseif (Nmodel==2) then theuns=.true. elseif (Nmodel==3) then madau=.true. elseif (Nmodel==4) then weinberg=.true. elseif (Nmodel==5) then weinbergint=.true. elseif (Nmodel==6) then courty=.true. else write(*,*) 'ERROR in set_model : wrong value of Nmodel' write(*,*) 'Nmodel =',Nmodel STOP endif endif if (J0in_in >= 0.0) J0in=J0in_in if (zreioniz_in >= 0.0) zreioniz=zreioniz_in if (alpha_in > 0.0) alpha=alpha_in if (normfacJ0_in > 0.0) normfacJ0=normfacJ0_in if (correct_cooling == 0) then dumfac_ion=1.d0 dumfac_rec=1.d0 elseif (correct_cooling == 1) then dumfac_ion=dumfac_ion_theuns dumfac_rec=dumfac_rec_theuns elseif (correct_cooling /= -1) then write(*,*) 'ERROR in set_model : wrong value of correct_cooling' write(*,*) 'correct_cooling =',correct_cooling STOP endif if (realistic_ne == 0) then astart=5.d-4 high_z_realistic_ne=.false. if (J0min_in > 0.d0) J0min=J0min_in elseif (realistic_ne == 1) then astart=aexp_ref high_z_realistic_ne=.true. if (J0min_in > 0.d0) J0min_ref=J0min_in elseif (realistic_ne == 2) then astart=aexp_ref high_z_realistic_ne=.true. call compute_J0min(h,omegab,omega0,omegaL,J0min_ref_calc) J0min_ref=J0min_ref_calc else write(*,*) 'ERROR in set_model : wrong value of realistic_ne' write(*,*) 'realistic_ne =',realistic_ne STOP endif if (astart_sim < astart) then write(*,*) 'ERROR in set_model : astart_sim is too small.' write(*,*) 'astart =',astart write(*,*) 'astart_sim =',astart_sim STOP endif ! Calcul de la temperature initiale aend=astart_sim dasura=0.02d0 minus1=-1.0 call evol_single_cell(astart,aend,dasura,h,omegab,omega0,omegaL,minus1,T2end,mu,ne,.false.) if (verbose_cooling) write(*,*) 'Starting temperature in K :',T2end*mu T2_sim=T2end end subroutine set_model !======================================================================= subroutine set_table(aexp) !======================================================================= implicit none real(kind=8) :: aexp integer :: nbin_n,nbin_T real(kind=8) :: nH_min,nH_max,T2_min,T2_max nH_min=nH_min_fix nH_max=nH_max_fix T2_min=T2_min_fix T2_max=T2_max_fix nbin_n=nbin_n_fix nbin_T=nbin_T_fix call cmp_table(nH_min,nH_max,T2_min,T2_max,nbin_n,nbin_T,aexp) end subroutine set_table !======================================================================= subroutine output_cool(filename) !======================================================================= implicit none ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename open(unit=10,file=filename,form='unformatted') write(10)table%n1,table%n2 write(10)table%nH write(10)table%T2 write(10)table%cool write(10)table%heat write(10)table%cool_com write(10)table%heat_com write(10)table%metal write(10)table%cool_prime write(10)table%heat_prime write(10)table%cool_com_prime write(10)table%heat_com_prime write(10)table%metal_prime write(10)table%mu if (if_species_abundances) write(10)table%n_spec close(10) end subroutine output_cool !======================================================================= subroutine evol_single_cell(astart,aend,dasura,h,omegab,omega0,omegaL, & & J0min_in,T2end,mu,ne,if_write_result) !======================================================================= ! astart : valeur du facteur d'expansion au debut du calcul ! aend : valeur du facteur d'expansion a la fin du calcul ! dasura : la valeur de da/a entre 2 pas de temps ! h : la valeur de H0/100 ! omegab : la valeur de Omega baryons ! omega0 : la valeur de Omega matiere (total) ! omegaL : la valeur de Omega Lambda ! J0min_in : la valeur du J0min a injecter : ! Si high_z_realistic_ne alors c'est J0min a a=astart qui ! est considere ! Sinon, c'est le J0min habituel. ! Si J0min_in <=0, les parametres par defaut ou predefinis ! auparavant sont pris pour le J0min. ! T2end : Le T/mu en output ! mu : le poids moleculaire en output ! ne : le ne en output ! if_write_result : .true. pour ecrire l'evolution de la temperature ! et de n_e sur l'ecran. !======================================================================= implicit none real(kind=8)::astart,aend,T2end,h,omegab,omega0,omegaL,J0min_in,ne,dasura logical :: if_write_result real(kind=8)::aexp,daexp,dt_cool,coeff,coeff2 real(kind=8)::T2_com,T2_old,T2,T2_left,T2_right,err_T2 real(kind=8)::nH_com,nH real(kind=8),dimension(1:3)::t_rad_spec,h_rad_spec real(kind=8) ::mu real(kind=8) ::cool_tot,heat_tot,cool_com,heat_com real(kind=8) ::diff integer::niter real(kind=8) :: n_spec(1:6) if (J0min_in > 0.0) then if (high_z_realistic_ne) then J0min_ref = J0min_in aexp_ref = astart else J0min = J0min_in endif endif aexp = astart T2_com = 2.726d0 / aexp * aexp**2 / mu_mol nH_com = omegab*rhoc*h**2*X/mH do while (aexp < aend) daexp = dasura*aexp dt_cool=daexp/(aexp*100.*h*3.2408608e-20*HsurH0(1.0/aexp-1.,omega0,omegaL,1.-omega0-omegaL)) nH = nH_com/aexp**3 T2_old = T2_com/aexp**2 ! Compute radiative ionization and heating rates call set_rates(t_rad_spec,h_rad_spec,aexp) ! Iteration to find new T2 err_T2=1. T2_left=1.d-2 T2_right=1.d8 niter=0 coeff = 2.*nH*X/3./kB coeff2 = 2.*X/3./kB do while (err_T2 > 1.d-10.and.niter <= 100) T2=0.5*(T2_left+T2_right) call cmp_cooling(T2,nH,t_rad_spec,h_rad_spec,cool_tot,heat_tot,cool_com,heat_com,mu,aexp,n_spec) diff = coeff*(heat_tot-cool_tot) + coeff2*(heat_com-cool_com) + (T2_old-T2)/dt_cool if(diff>0.)then T2_left =0.5*(T2_left+T2_right) T2_right=T2_right else T2_left =T2_left T2_right=0.5*(T2_left+T2_right) end if err_T2=abs(T2_right-T2_left)/T2_left niter=niter+1 end do if (niter > 100) then write(*,*) 'ERROR in evol_single_cell : too many iterations' STOP endif T2_com=T2*aexp**2 aexp = aexp + daexp if (if_write_result) write(*,'(4(1pe10.3))')aexp,nH,T2_com*mu/aexp**2,n_spec(1)/nH end do T2end=T2 ne=n_spec(1)/nH end subroutine evol_single_cell !======================================================================= subroutine compute_J0min(h,omegab,omega0,omegaL,J0min_in) !======================================================================= implicit none real(kind=8) :: omega0,omegaL,h,omegab,ne_to_find,mu real(kind=8) :: h0,astart,aend,J0min_in,T2end,ne real(kind=8) :: J0min_left,J0min_right,err_J0min,diff,xval,dasura integer :: niter logical :: if_write_result=.false. xval=sqrt(omega0)/(h*omegab) ne_to_find=1.2d-5*xval ! From the book of Peebles p. 173 astart=aexp_ref aend=MIN(0.05d0,0.5d0/(1d0+zreioniz)) ! Always end before reionization dasura=0.05 err_J0min=1. J0min_left=1d-20 J0min_right=1d-30 niter=0 do while (err_J0min > 1.d-3 .and. niter <= 100) J0min_in=0.5*(J0min_left+J0min_right) call evol_single_cell(astart,aend,dasura,h,omegab,omega0,omegaL,J0min_in,T2end,mu,ne,if_write_result) diff=ne-ne_to_find if (diff>0.d0) then J0min_left=0.5*(J0min_left+J0min_right) J0min_right=J0min_right else J0min_left=J0min_left J0min_right=0.5*(J0min_left+J0min_right) endif err_J0min=abs(J0min_right-J0min_left)/J0min_left niter=niter+1 enddo if (niter > 100) then write(*,*) 'ERROR in compute_J0min : too many iterations' STOP endif if (verbose_cooling) write(*,*) 'J0min found ',J0min_in end subroutine compute_J0min !======================================================================= subroutine solve_cooling(nH,T2,zsolar,boost,dt,deltaT2,ncell) !======================================================================= implicit none integer::ncell real(kind=8)::dt real(kind=8),dimension(1:ncell)::nH,T2,deltaT2,zsolar,boost real(kind=8)::facT,dlog_nH,dlog_T2,coeff,precoeff,h,h2,h3 real(kind=8)::metal,cool,heat,cool_com,heat_com,w1T,w2T,w11,w12,w21,w22,err,yy,yy2,yy3 real(kind=8)::metal_prime,cool_prime,heat_prime,cool_com_prime,heat_com_prime,wcool real(kind=8)::lambda,lambda_prime,logT2max real(kind=8)::fa,fb,fprimea,fprimeb,alpha,beta,gamma real(kind=8),dimension(1:ncell)::rgt,lft,tau,tau_old real(kind=8),dimension(1:ncell)::time,time_old,facH,zzz,tau_ini real(kind=8),dimension(1:ncell)::w1H,w2H,wmax,time_max real(kind=8)::varmax=4d0 integer::i,i_T2,iter,n,n_active integer,dimension(1:ncell)::ind,iii,i_nH logical::tau_negative ! Initializations logT2max=log10(T2_max_fix) dlog_nH=dble(table%n1-1)/(table%nH(table%n1)-table%nH(1)) dlog_T2=dble(table%n2-1)/(table%T2(table%n2)-table%T2(1)) h=1d0/dlog_T2 h2=h*h h3=h2*h precoeff=2d0*X/(3d0*kB) do i=1,ncell zzz(i)=zsolar(i) facH(i)=MIN(MAX(log10(nH(i)/boost(i)),table%nH(1)),table%nH(table%n1)) i_nH(i)=MIN(MAX(int((facH(i)-table%nH(1))*dlog_nH)+1,1),table%n1-1) w1H(i)=(table%nH(i_nH(i)+1)-facH(i))*dlog_nH w2H(i)=(facH(i)-table%nH(i_nH(i) ))*dlog_nH tau(i)=T2(i) tau_ini(i)=T2(i) time_max(i)=dt*precoeff*nH(i) time(i)=0d0 wmax(i)=1d0/time_max(i) ind(i)=i end do ! Check positivity tau_negative=.false. do i=1,ncell if(tau(i)<=0.)tau_negative=.true. end do if (tau_negative) then write(*,*)'ERROR in solve_cooling :' write(*,*)'Initial temperature is negative' STOP endif ! Loop over active cells iter=0 n=ncell do while(n>0) iter=iter+1 if (iter > 500) then write(*,*) 'Too many iterations in solve_cooling',iter,n do i=1,n write(*,*)i,tau(ind(i)),T2(ind(i)),nH(ind(i)),i_nH(ind(i)) end do STOP endif n_active=0 do i=1,n facT=log10(tau(ind(i))) if(facT.le.logT2max)then i_T2=MIN(MAX(int((facT-table%T2(1))*dlog_T2)+1,1),table%n2-1) yy=facT-table%T2(i_T2) yy2=yy*yy yy3=yy2*yy ! Cooling fa=table%cool(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%cool(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fb=table%cool(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%cool(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) fprimea=table%cool_prime(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%cool_prime(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fprimeb=table%cool_prime(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%cool_prime(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) alpha=fprimea beta=3d0*(fb-fa)/h2-(2d0*fprimea+fprimeb)/h gamma=(fprimea+fprimeb)/h2-2d0*(fb-fa)/h3 cool=10d0**(fa+alpha*yy+beta*yy2+gamma*yy3) cool_prime=cool/tau(ind(i))*(alpha+2d0*beta*yy+3d0*gamma*yy2) ! Heating fa=table%heat(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%heat(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fb=table%heat(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%heat(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) fprimea=table%heat_prime(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%heat_prime(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fprimeb=table%heat_prime(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%heat_prime(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) alpha=fprimea beta=3d0*(fb-fa)/h2-(2d0*fprimea+fprimeb)/h gamma=(fprimea+fprimeb)/h2-2d0*(fb-fa)/h3 heat=10d0**(fa+alpha*yy+beta*yy2+gamma*yy3) heat_prime=heat/tau(ind(i))*(alpha+2d0*beta*yy+3d0*gamma*yy2) ! Compton cooling fa=table%cool_com(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%cool_com(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fb=table%cool_com(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%cool_com(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) fprimea=table%cool_com_prime(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%cool_com_prime(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fprimeb=table%cool_com_prime(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%cool_com_prime(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) alpha=fprimea beta=3d0*(fb-fa)/h2-(2d0*fprimea+fprimeb)/h gamma=(fprimea+fprimeb)/h2-2d0*(fb-fa)/h3 cool_com=10d0**(fa+alpha*yy+beta*yy2+gamma*yy3) cool_com_prime=cool_com/tau(ind(i))*(alpha+2d0*beta*yy+3d0*gamma*yy2) ! Compton heating fa=table%heat_com(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%heat_com(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fb=table%heat_com(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%heat_com(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) fprimea=table%heat_com_prime(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%heat_com_prime(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fprimeb=table%heat_com_prime(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%heat_com_prime(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) alpha=fprimea beta=3d0*(fb-fa)/h2-(2d0*fprimea+fprimeb)/h gamma=(fprimea+fprimeb)/h2-2d0*(fb-fa)/h3 heat_com=10d0**(fa+alpha*yy+beta*yy2+gamma*yy3) heat_com_prime=heat_com/tau(ind(i))*(alpha+2d0*beta*yy+3d0*gamma*yy2) ! Metal cooling fa=table%metal(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%metal(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fb=table%metal(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%metal(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) fprimea=table%metal_prime(i_nH(ind(i)),i_T2 )*w1H(ind(i))+table%metal_prime(i_nH(ind(i))+1,i_T2 )*w2H(ind(i)) fprimeb=table%metal_prime(i_nH(ind(i)),i_T2+1)*w1H(ind(i))+table%metal_prime(i_nH(ind(i))+1,i_T2+1)*w2H(ind(i)) alpha=fprimea beta=3d0*(fb-fa)/h2-(2d0*fprimea+fprimeb)/h gamma=(fprimea+fprimeb)/h2-2d0*(fb-fa)/h3 metal=10d0**(fa+alpha*yy+beta*yy2+gamma*yy3) metal_prime=metal/tau(ind(i))*(alpha+2d0*beta*yy+3d0*gamma*yy2) ! Total net cooling lambda=cool+zzz(ind(i))*metal-heat+(cool_com-heat_com)/nH(ind(i)) lambda_prime=cool_prime+zzz(ind(i))*metal_prime-heat_prime+(cool_com_prime-heat_com_prime)/nH(ind(i)) else lambda=1.42*1d-27*sqrt(tau(ind(i)))*1.1 lambda_prime=lambda/2./tau(ind(i)) endif wcool=MAX(abs(lambda)/tau(ind(i))*varmax,wmax(ind(i)),-lambda_prime*varmax) tau_old(ind(i))=tau(ind(i)) tau(ind(i))=tau(ind(i))*(1d0+lambda_prime/wcool-lambda/tau(ind(i))/wcool)/(1d0+lambda_prime/wcool) time_old(ind(i))=time(ind(i)) time(ind(i))=time(ind(i))+1d0/wcool !! if(i==1)then !! write(10,'(I5,10(1PE10.3,1X))')iter,tau_old(ind(i)),cool+zzz(ind(i))*metal,heat,lambda !! endif if(time(ind(i)) 1.d-4 .and. niter <= 50) mu_old=0.5*(mu_left+mu_right) T = T2*mu_old call cmp_chem_eq(T,nH,t_rad_spec,n_spec,n_TOT,mu) err_mu = (mu-mu_old)/mu_old if(err_mu>0.)then mu_left =0.5*(mu_left+mu_right) mu_right=mu_right else mu_left =mu_left mu_right=0.5*(mu_left+mu_right) end if err_mu=ABS(err_mu) niter=niter+1 end do if (niter > 50) then write(*,*) 'ERROR in cmp_cooling : too many iterations.' STOP endif ! Get equilibrium abundances n_E = n_spec(1) ! electrons n_HI = n_spec(2) ! H n_HII = n_spec(3) ! H+ n_HEI = n_spec(4) ! He n_HEII = n_spec(5) ! He+ n_HEIII = n_spec(6) ! He++ ! Bremstrahlung cb1 = cool_bre(HI ,T)*n_E*n_HII /nH**2 cb2 = cool_bre(HEI ,T)*n_E*n_HEII /nH**2 cb3 = cool_bre(HEII,T)*n_E*n_HEIII/nH**2 ! Ionization cooling ci1 = cool_ion(HI ,T)*n_E*n_HI /nH**2 ci2 = cool_ion(HEI ,T)*n_E*n_HEI /nH**2 ci3 = cool_ion(HEII,T)*n_E*n_HEII /nH**2 ! Recombination cooling cr1 = cool_rec(HI ,T)*n_E*n_HII /nH**2 cr2 = cool_rec(HEI ,T)*n_E*n_HEII /nH**2 cr3 = cool_rec(HEII,T)*n_E*n_HEIII/nH**2 ! Dielectric recombination cooling cd = cool_die(T )*n_E*n_HEII /nH**2 ! Line cooling ce1 = cool_exc(HI ,T)*n_E*n_HI /nH**2 ce2 = cool_exc(HEI, T)*n_E*n_HEI /nH**2 ce3 = cool_exc(HEII,T)*n_E*n_HEII /nH**2 ! Radiative heating ch1 = h_rad_spec(HI ) *n_HI /nH**2 ch2 = h_rad_spec(HEI ) *n_HEI /nH**2 ch3 = h_rad_spec(HEII) *n_HEII /nH**2 ! Total cooling and heating rates heat_tot = ch1+ch2+ch3 cool_tot = cb1+cb2+cb3+ci1+ci2+ci3+cr1+cr2+cr3+cd+ce1+ce2+ce3 ! Compton cooling coc = cool_compton(T,aexp)*n_E/nH cool_com = coc ! Compton heating coh = heat_compton(T,aexp)*n_E/nH heat_com = coh ! Mean molecular weight mu_out = mu if (if_cooling_functions) then cool_out=max(cool_tot,smallnum_cooling) heat_out=max(heat_tot,smallnum_cooling) cool_com=max(cool_com,smallnum_cooling) heat_com=max(heat_com,smallnum_cooling) cb1s=max(cb1,smallnum_cooling) cb2s=max(cb2,smallnum_cooling) cb3s=max(cb3,smallnum_cooling) ci1s=max(ci1,smallnum_cooling) ci2s=max(ci2,smallnum_cooling) ci3s=max(ci3,smallnum_cooling) cr1s=max(cr1,smallnum_cooling) cr2s=max(cr2,smallnum_cooling) cr3s=max(cr3,smallnum_cooling) cds =max(cd ,smallnum_cooling) ce1s=max(ce1,smallnum_cooling) ce3s=max(ce3,smallnum_cooling) cocs=max(coc,smallnum_cooling) cohs=max(coh,smallnum_cooling) ch1s=max(ch1,smallnum_cooling) ch2s=max(ch2,smallnum_cooling) ch3s=max(ch3,smallnum_cooling) cohs=max(coh,smallnum_cooling) endif end subroutine cmp_cooling !======================================================================= subroutine cmp_chem_eq(T,n_H,t_rad_spec,n_spec,n_TOT,mu) !======================================================================= implicit none real(kind=8)::T,n_H,n_TOT,mu real(kind=8),dimension(1:3)::t_rad_spec real(kind=8),dimension(1:6)::n_spec real(kind=8)::xx,yy real(kind=8)::n_HI,n_HII,n_HEI,n_HEII,n_HEIII,n_E real(kind=8)::t_rad_HI,t_rad_HEI,t_rad_HEII real(kind=8)::t_rec_HI,t_rec_HEI,t_rec_HEII real(kind=8)::t_ion_HI,t_ion_HEI,t_ion_HEII real(kind=8)::t_ion2_HI,t_ion2_HEI,t_ion2_HEII real(kind=8)::x1,err_nE xx=(1.-Y) yy=Y/(1.-Y)/4. t_rad_HI = t_rad_spec(HI) t_rec_HI = taux_rec (HI,T) t_ion_HI = taux_ion (HI,T) t_rad_HEI = t_rad_spec(HEI) t_rec_HEI = taux_rec (HEI,T) t_ion_HEI = taux_ion (HEI,T) t_rad_HEII = t_rad_spec(HEII) t_rec_HEII = taux_rec (HEII,T) t_ion_HEII = taux_ion (HEII,T) n_E = n_H err_nE = 1. do while(err_nE > 1.d-8) t_ion2_HI = t_ion_HI + t_rad_HI /MAX(n_E,1e-15*n_H) t_ion2_HEI = t_ion_HEI + t_rad_HEI /MAX(n_E,1e-15*n_H) t_ion2_HEII = t_ion_HEII + t_rad_HEII/MAX(n_E,1e-15*n_H) n_HI = t_rec_HI/(t_ion2_HI+t_rec_HI)*n_H n_HII = t_ion2_HI/(t_ion2_HI+t_rec_HI)*n_H x1 = (t_rec_HEII*t_rec_HEI+t_ion2_HEI*t_rec_HEII+t_ion2_HEII*t_ion2_HEI) n_HEIII = yy*t_ion2_HEII*t_ion2_HEI/x1*n_H n_HEII = yy*t_ion2_HEI *t_rec_HEII/x1*n_H n_HEI = yy*t_rec_HEII *t_rec_HEI /x1*n_H err_nE = ABS((n_E - (n_HII + n_HEII + 2.*n_HEIII))/n_H) n_E = 0.5*n_E+0.5*(n_HII + n_HEII + 2.*n_HEIII) end do n_TOT =n_E+n_HI+n_HII+n_HEI+n_HEII+n_HEIII mu =n_H/xx/n_TOT n_spec(1)=n_E n_spec(2)=n_HI n_spec(3)=n_HII n_spec(4)=n_HEI n_spec(5)=n_HEII n_spec(6)=n_HEIII end subroutine cmp_chem_eq !======================================================================= function cool_bre(ispec,T) !======================================================================= ! TTG 2017: Brehmsstrahlung cooling rate (erg cm^3 / s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B1 implicit none integer::ispec real(kind=8) ::T,cool_bre if(ispec==HI )cool_bre = 1.42D-27*sqrt(T)*(1.1D0+0.34D0*exp(-(5.5D0-log10(T))**2 /3.D0)) if(ispec==HEI )cool_bre = 1.42D-27*sqrt(T)*(1.1D0+0.34D0*exp(-(5.5D0-log10(T))**2 /3.D0)) if(ispec==HEII)cool_bre = 5.68D-27*sqrt(T)*(1.1D0+0.34D0*exp(-(5.5D0-log10(T))**2 /3.D0)) return end function cool_bre !======================================================================= function cool_exc(ispec,T) !======================================================================= ! TTG 2017: Collisional excitation cooling rate (erg cm^3 / s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B1. Note: HEI not given there. implicit none integer::ispec real(kind=8) ::T,cool_exc,T5 T5=1.d-5*T if(ispec==HI )cool_exc = 7.50D-19/(1.+sqrt(T5)) *exp(-118348.D0/T) if(ispec==HEI )cool_exc = 9.10D-27/(1.+sqrt(T5))/(T**0.1687D0)*exp(-13179.D0/T) if(ispec==HEII)cool_exc = 5.54D-17/(1.+sqrt(T5))/(T**0.397D0 )*exp(-473638.D0/T) return end function cool_exc !======================================================================= function cool_rec(ispec,T) !======================================================================= ! TTG 2017: Recombination cooling rate (erg cm^3 / s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B1 implicit none integer::ispec real(kind=8) ::T,cool_rec real(kind=8) ::T3, T6 T3 = 1.d-03*T T6 = 1.d-06*T if(ispec==HI )cool_rec = 8.70D-27*SQRT(T)/T3**(0.2D0)/(1.D0+T6**0.7D0) if(ispec==HEI )cool_rec = 1.55D-26*T**0.3647D0 if(ispec==HEII)cool_rec = 3.48D-26*SQRT(T)/T3**(0.2D0)/(1.D0+T6**0.7D0) return end function cool_rec !======================================================================= function cool_die(T) !======================================================================= ! TTG 2017: Dielectric recombination cooling rate (erg cm^3 / s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B1 implicit none real(kind=8) :: T,cool_die cool_die=1.24D-13*T**(-1.5D0)*exp(-470000.D0/T)*(1.D0+0.3D0*exp(-94000.D0/T)) return end function cool_die !======================================================================= function taux_rec(ispec,T) !======================================================================= ! TTG 2017: Recombination rate (1/s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B2. Note: dumfac_rec = 0.75 in theuns' model implicit none integer::ispec real(kind=8) ::T,taux_rec real(kind=8) ::T3, T6 T3 = 1.d-03*T T6 = 1.d-06*T if(ispec==HI )taux_rec = dumfac_rec*8.40e-11/SQRT(T)/T3**(0.2)/(1.+T6**0.7) if(ispec==HEI )taux_rec = 1.50e-10/T**0.6353+taux_die(T) if(ispec==HEII)taux_rec = 3.36e-10/SQRT(T)/T3**(0.2)/(1.+T6**0.7) return end function taux_rec !======================================================================= function taux_die(T) !======================================================================= ! TTG 2017: Dielectric recombination rate (1/s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B2 implicit none real(kind=8) :: T,taux_die taux_die=1.9D-3*T**(-1.5D0)*exp(-470000.D0/T)*(1.D0+0.3D0*exp(-94000.D0/T)) return end function taux_die !======================================================================= function cool_ion(ispec,T) !======================================================================= ! TTG 2017: Collisional ionisation cooling rate (erg cm^3 / s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B1. Note: dumfac_ion = 2 in theuns' model implicit none integer::ispec real(kind=8) ::T,cool_ion real(kind=8) ::T5 T5 = 1.d-05*T if(ispec==HI )cool_ion = dumfac_ion*1.27D-21*SQRT(T)/(1.+SQRT(T5))*EXP(-157809.1D0/T) if(ispec==HEI )cool_ion = dumfac_ion*9.38D-22*SQRT(T)/(1.+SQRT(T5))*EXP(-285335.4D0/T) if(ispec==HEII)cool_ion = dumfac_ion*4.95D-22*SQRT(T)/(1.+SQRT(T5))*EXP(-631515.0D0/T) return end function cool_ion !======================================================================= function cool_compton(T,aexp) !======================================================================= ! TTG 2017: Inverse Compton cooling rate (erg cm^3 / s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B1 implicit none real(kind=8) ::T,aexp,cool_compton cool_compton=5.406D-36*T/aexp**4 return end function cool_compton !======================================================================= function heat_compton(T,aexp) !======================================================================= ! TTG 2017: Compton heating rate (erg cm^3 / s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B1 implicit none real(kind=8) ::T,aexp,heat_compton heat_compton=5.406D-36*2.726D0/aexp**5 return end function heat_compton !======================================================================= function taux_ion(ispec,T) !======================================================================= ! TTG 2017: Collisional ionisation rate (1/s) ! See e.g. Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B2. Note: dumfac_ion = 2 in theuns' model ! See also Katz et al., ApJS, 105, 1996, Table 2 implicit none integer::ispec real(kind=8) :: T,taux_ion real(kind=8) :: T5 T5 = 1.d-05*T if(ispec==HI )taux_ion = dumfac_ion*5.85D-11*SQRT(T)/(1.+SQRT(T5))*EXP(-157809.1D0/T) if(ispec==HEI )taux_ion = dumfac_ion*2.38D-11*SQRT(T)/(1.+SQRT(T5))*EXP(-285335.4D0/T) if(ispec==HEII)taux_ion = dumfac_ion*5.68D-12*SQRT(T)/(1.+SQRT(T5))*EXP(-631515.0D0/T) return end function taux_ion !======================================================================= function J_nu(e,J0) !======================================================================= implicit none real(kind=8) :: e,J_nu,e_L,J0,Jloc Jloc = max(J0,J0min) e_L = 13.598*eV J_nu = Jloc*(e_L/e) return end function J_nu !======================================================================= function sigma_rad(e,ispec) !======================================================================= implicit none integer::ispec real(kind=8) ::sigma_rad,e,e_i,xxx,alph if(ispec==HI )e_i = 13.598D0*eV if(ispec==HEI )e_i = 24.587D0*eV if(ispec==HEII)e_i = 54.416D0*eV xxx = e/e_i alph = sqrt(xxx-1.0d0) if(ispec==HI )sigma_rad = 6.30D-18/xxx**4*exp(4.D0-4.D0*atan(alph)/alph) & & /(1.D0-exp(-twopi/alph)) if(ispec==HEI )sigma_rad = 7.42D-18*(1.66D0/xxx**2.05D0-0.66D0/xxx**3.05D0) if(ispec==HEII)sigma_rad = 1.58D-18/xxx**4*exp(4.D0-4.D0*atan(alph)/alph) & & /(1.D0-exp(-twopi/alph)) return end function sigma_rad !======================================================================= function taux_rad(ispec,J0) !======================================================================= ! TTG 2017: H / He photoionisation rate implicit none integer::ispec real(kind=8) :: J0,taux_rad,e_i,e,de,error,integ if(ispec==HI )e_i = 13.598D0*eV if(ispec==HEI )e_i = 24.587D0*eV if(ispec==HEII)e_i = 54.416D0*eV integ = 0.0d0 e = e_i de = e/100.D0 error = 1.D0 do while(error>1.d-6) e = e + de de = e/100.D0 error = 2.0d0*twopi*J_nu(e,J0)*sigma_rad(e,ispec)*de/e integ = integ + error error = error/abs(integ) end do taux_rad = integ/hplanck return end function taux_rad !======================================================================= function taux_rad_madau(ispec,z) !======================================================================= implicit none integer :: ispec real(kind=8) :: z,taux_rad_madau,tt if (z < 15.d0) then if (ispec==HI ) taux_rad_madau=normfacJ0*exp(-31.04D0+2.795D0*z-0.5589D0*z**2) if (ispec==HEI ) taux_rad_madau=normfacJ0*exp(-31.08D0+2.822D0*z-0.5664D0*z**2) if (ispec==HEII) taux_rad_madau=normfacJ0*exp(-34.30D0+1.826D0*z-0.3899D0*z**2) else taux_rad_madau=0.d0 endif tt=taux_rad_theuns(ispec,J0min) if (taux_rad_madau < tt) taux_rad_madau=tt return end function taux_rad_madau !======================================================================= function taux_rad_weinbergint(ispec,z) !======================================================================= implicit none integer :: ispec,i,iweinb real(kind=8) :: z,zz,taux_rad_weinbergint,hh,tt if (z < 8.5d0) then if (ispec==HI ) iweinb=1 if (ispec==HEI ) iweinb=2 if (ispec==HEII) iweinb=3 hh=0.d0 zz=max(z,1.0d-15) do i=1,Norderweinberg hh=hh+coefweinberg(i,iweinb)*zz**(i-1) enddo taux_rad_weinbergint=normfacJ0*exp(hh) else taux_rad_weinbergint=0.d0 endif tt=taux_rad_theuns(ispec,J0min) if (taux_rad_weinbergint < tt) taux_rad_weinbergint=tt return end function taux_rad_weinbergint !======================================================================= function taux_rad_theuns(ispec,J0) !======================================================================= ! ADDED BY TTG: This rates are taken from Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B4 implicit none integer :: ispec real(kind=8) :: J0,taux_rad_theuns if (ispec==HI ) taux_rad_theuns=1.26D10*J0/(3.D0+alpha) if (ispec==HEI ) taux_rad_theuns=1.48D10*J0*0.553D0**alpha & & *(1.66D0/(alpha+2.05D0)-0.66D0/(alpha+3.05D0)) if (ispec==HEII) taux_rad_theuns=3.34D9*J0*0.249D0**alpha/(3.D0+alpha) return end function taux_rad_theuns !======================================================================= function taux_rad_courty(ispec,z) !======================================================================= implicit none integer :: ispec,i,iweinb real(kind=8) :: z,zz,taux_rad_courty,hh,tt,hhreion if (z < zreioniz) then if (ispec==HI ) iweinb=1 if (ispec==HEI ) iweinb=2 if (ispec==HEII) iweinb=3 hh=0.d0 zz=max(z,1.0d-15) do i=0,Nordercourty hh=hh+coefcourty(i,iweinb)*zz**i enddo hhreion=coef_fit(iweinb)*(zz/zreioniz)**beta_fit(iweinb) taux_rad_courty=10.**(hh-hhreion) else taux_rad_courty=0.d0 endif tt=taux_rad_theuns(ispec,J0min) if (taux_rad_courty < tt) taux_rad_courty=tt return end function taux_rad_courty !======================================================================= function heat_rad(ispec,J0) !======================================================================= implicit none integer::ispec real(kind=8) :: J0,heat_rad,e_i,e,de,error,integ if(ispec==HI )e_i = 13.598D0*eV if(ispec==HEI )e_i = 24.587D0*eV if(ispec==HEII)e_i = 54.416D0*eV integ = 0.0d0 e = e_i de = e/100.D0 error = 1.D0 do while(error>1.d-6) e = e + de de = e/100.D0 error = 2.0d0*twopi*J_nu(e,J0)*sigma_rad(e,ispec)*(e/e_i-1.D0)*de/e integ = integ + error error=error/abs(integ) end do heat_rad = integ/hplanck*e_i return end function heat_rad !======================================================================= function heat_rad_madau(ispec,z) !======================================================================= implicit none integer :: ispec real(kind=8) :: z,heat_rad_madau,tt if (z < 15.d0) then if (ispec==HI ) heat_rad_madau=normfacJ0*exp(-56.62D0+2.788D0*z-0.5594D0*z**2) if (ispec==HEI ) heat_rad_madau=normfacJ0*exp(-56.06D0+2.800D0*z-0.5532D0*z**2) if (ispec==HEII) heat_rad_madau=normfacJ0*exp(-58.67D0+1.888D0*z-0.3947D0*z**2) else heat_rad_madau=0.d0 endif tt=heat_rad_theuns(ispec,J0min) if (heat_rad_madau < tt) heat_rad_madau=tt return end function heat_rad_madau !======================================================================= function heat_rad_weinbergint(ispec,z) !======================================================================= implicit none integer :: ispec,i,iweinb real(kind=8) :: z,zz,heat_rad_weinbergint,hh,tt if (z < 8.5d0) then if (ispec==HI ) iweinb=4 if (ispec==HEI ) iweinb=5 if (ispec==HEII) iweinb=6 hh=0.d0 zz=max(z,1.0d-15) do i=1,Norderweinberg hh=hh+coefweinberg(i,iweinb)*zz**(i-1) enddo heat_rad_weinbergint=normfacJ0*exp(hh) else heat_rad_weinbergint=0.d0 endif tt=heat_rad_theuns(ispec,J0min) if (heat_rad_weinbergint < tt) heat_rad_weinbergint=tt return end function heat_rad_weinbergint !======================================================================= function heat_rad_theuns(ispec,J0) !======================================================================= ! ADDED BY TTG: This rates are taken from Theuns et al., MNRAS, 301, 1998 ! their Appendix B, Table B4 implicit none integer :: ispec real(kind=8) :: J0,heat_rad_theuns if (ispec==HI ) heat_rad_theuns=(2.91D-1*J0/(2.D0+alpha))/(3.D0+alpha) if (ispec==HEI ) heat_rad_theuns=5.84D-1*J0*0.553D0**alpha* & & (1.66D0/(alpha+1.05D0)-2.32D0/(alpha+2.05D0)+0.66D0/(alpha+3.05D0)) if (ispec==HEII) heat_rad_theuns=(2.92D-1*J0*0.249D0**alpha/(2.D0+alpha))/(3.D0+alpha) return end function heat_rad_theuns !======================================================================= function heat_rad_courty(ispec,z) !======================================================================= implicit none integer :: ispec,i,iweinb real(kind=8) :: z,zz,heat_rad_courty,hh,tt,hhreion if (z < zreioniz) then if (ispec==HI ) iweinb=4 if (ispec==HEI ) iweinb=5 if (ispec==HEII) iweinb=6 hh=0.d0 zz=max(z,1.0d-15) do i=0,Nordercourty hh=hh+coefcourty(i,iweinb)*zz**i enddo hhreion=coef_fit(iweinb)*(zz/zreioniz)**beta_fit(iweinb) heat_rad_courty=10.**(hh-hhreion) else heat_rad_courty=0.d0 endif tt=heat_rad_theuns(ispec,J0min) if (heat_rad_courty < tt) heat_rad_courty=tt return end function heat_rad_courty !======================================================================= function HsurH0(z,omega0,omegaL,OmegaR) !======================================================================= implicit none real(kind=8) :: HsurH0,z,omega0,omegaL,omegaR HsurH0=sqrt(Omega0*(1.d0+z)**3+OmegaR*(1.d0+z)**2+OmegaL) end function HsurH0 end module cooling_module ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/flag_utils.f90 !################################################################ !################################################################ !################################################################ !################################################################ subroutine flag use amr_commons implicit none integer::ilevel if(verbose)write(*,*)'Entering flag' do ilevel=nlevelmax-1,1,-1 call flag_fine(ilevel,2) end do call flag_coarse if(verbose)write(*,*)'Complete flag' end subroutine flag !################################################################ !################################################################ !################################################################ !################################################################ subroutine flag_coarse use amr_commons implicit none !-------------------------------------------------------------- ! This routine compute the refinement map at the coarse level. !-------------------------------------------------------------- integer::ind,nxny,ix,iy,iz if(verbose)write(*,*)' Entering flag_coarse' ! Constants nxny=nx*ny ! Reset flag1 array at coarse level flag1(0:ncoarse)=0 ! Set flag1 to 1 at coarse level for inner cells only nflag=0 do iz=kcoarse_min,kcoarse_max do iy=jcoarse_min,jcoarse_max do ix=icoarse_min,icoarse_max ind=1+ix+iy*nx+iz*nxny flag1(ind)=1 nflag=nflag+1 end do end do end do if(verbose)write(*,112)nflag call make_virtual_coarse_int(flag1(1)) if(simple_boundary)call make_boundary_coarse 112 format(' ==> Flag ',i6,' cells') end subroutine flag_coarse !################################################################ !################################################################ !################################################################ !################################################################ subroutine flag_fine(ilevel,icount) use amr_commons implicit none integer::ilevel,icount !-------------------------------------------------------- ! This routine builds the refinement map at level ilevel. !-------------------------------------------------------- integer::iexpand if(ilevel==nlevelmax)return if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Step 1: initialize refinement map to minimal refinement rules call init_flag(ilevel) if(verbose)write(*,*) ' ==> end step 1',nflag ! If ilevel < levelmin, exit routine if(ilevel end step 2',nflag ! Step 3: if cell satisfies user-defined physical citeria, ! then flag cell for refinement. call userflag_fine(ilevel) if(verbose)write(*,*) ' ==> end step 3',nflag ! Step 4: make nexpand cubic buffers around flagged cells. do iexpand=1,nexpand(ilevel) call smooth_fine(ilevel) end do if(verbose)write(*,*) ' ==> end step 4',nflag if(verbose)write(*,112)nflag ! In case of adaptive time step ONLY, check for refinement rules. if(ilevel>levelmin)then if(icount Flag ',i6,' cells') end subroutine flag_fine !################################################################ !################################################################ !################################################################ !################################################################ subroutine init_flag(ilevel) use amr_commons implicit none integer::ilevel !------------------------------------------- ! This routine initialize the refinement map ! to a minimal state in order to satisfy the ! refinement rules. !------------------------------------------- integer::i,ind,iskip ! Initialize flag1 to 0 nflag=0 do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid flag1(active(ilevel)%igrid(i)+iskip)=0 end do end do ! If load balancing operations, flag only refined cells if(balance)then do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid if(son(active(ilevel)%igrid(i)+iskip)>0)then flag1(active(ilevel)%igrid(i)+iskip)=1 nflag=nflag+1 end if end do end do else ! If cell is refined and contains a flagged son ! or a refined son, then flag cell for refinement. if(ilevel>=levelmin)then call test_flag(ilevel) else ! If ilevel < levelmin, set flag to 1 for all cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid flag1(active(ilevel)%igrid(i)+iskip)=1 end do nflag=nflag+active(ilevel)%ngrid end do end if end if ! Update boundaries call make_virtual_fine_int(flag1(1),ilevel) if(simple_boundary)call make_boundary_flag(ilevel) end subroutine init_flag !################################################################ !################################################################ !################################################################ !################################################################ subroutine test_flag(ilevel) use amr_commons implicit none integer::ilevel !--------------------------------------------------------- ! This routine sets flag1 to 1 if cell is refined and ! contains a flagged son or a refined son. ! This ensures that refinement rules are satisfied. !--------------------------------------------------------- integer::i,ind_son,ind,iskip integer::iskip_son,ind_grid_son,ind_cell_son logical::ok ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax ! Test all refined cells do i=1,active(ilevel)%ngrid ! Gather child grid number ind_grid_son=son(active(ilevel)%igrid(i)+iskip) ! Test child if it exists ok=.false. if(ind_grid_son>0)then ! Loop over children cells do ind_son=1,twotondim iskip_son=ncoarse+(ind_son-1)*ngridmax ind_cell_son=iskip_son+ind_grid_son ok=(ok.or.(son (ind_cell_son)> 0)) ok=(ok.or.(flag1(ind_cell_son)==1)) end do end if ! If ok, then flag1 cells. if(ok)then flag1(active(ilevel)%igrid(i)+iskip)=1 nflag=nflag+1 end if end do end do ! End loop over cells end subroutine test_flag !################################################################ !################################################################ !################################################################ !################################################################ subroutine ensure_ref_rules(ilevel) use amr_commons implicit none integer::ilevel !----------------------------------------------------------------- ! This routine determines if all grids at level ilevel are ! surrounded by 26 neighboring grids, in order to enforce the ! strict refinement rule. ! Used in case of adaptive time steps only. !----------------------------------------------------------------- integer::i,ind,iskip,igrid,ngrid,ncache integer,dimension(1:nvector),save::ind_cell,ind_grid integer,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer,dimension(1:nvector,1:twotondim),save::nbors_father_grids logical,dimension(1:nvector),save::ok ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ! Gather nvector grids ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do ! Gather neighboring father cells (should be present anytime !) do i=1,ngrid ind_cell(i)=father(ind_grid(i)) end do call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids & & ,ngrid,ilevel) do i=1,ngrid ok(i)=.true. end do do ind=1,threetondim do i=1,ngrid ind_cell(i)=nbors_father_cells(i,ind) if(ind_cell(i)==0)ok(i)=.false. end do do i=1,ngrid if(ind_cell(i)>0)then if(son(ind_cell(i))==0)ok(i)=.false. endif end do end do do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do do i=1,ngrid if(.not.ok(i))flag1(ind_cell(i))=0 end do end do end do ! Update boundaries call make_virtual_fine_int(flag1(1),ilevel) if(simple_boundary)call make_boundary_flag(ilevel) end subroutine ensure_ref_rules !############################################################### !############################################################### !############################################################### !############################################################### subroutine userflag_fine(ilevel) use amr_commons use hydro_commons use cooling_module implicit none integer::ilevel ! ------------------------------------------------------------------- ! This routine flag for refinement cells that satisfies ! some user-defined physical criteria at the level ilevel. ! ------------------------------------------------------------------- integer::i,j,ncache,nok,ix,iy,iz,iskip integer::igrid,ind,idim,ngrid,ivar integer::nx_loc integer,dimension(1:nvector),save::ind_grid,ind_cell integer,dimension(1:nvector,0:twondim),save::igridn integer,dimension(1:nvector,1:twondim),save::indn logical,dimension(1:nvector),save::ok real(dp)::dx,dx_loc,scale real(dp)::d0,dx_min,vol_min,mstar,msnk,nISM,nCOM real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:twotondim,1:3)::xc real(dp),dimension(1:nvector,1:ndim),save::xx logical::prevent_refine if(ilevel==nlevelmax)return if(numbtot(1,ilevel)==0)return ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! Mesh size at level ilevel dx=0.5D0**ilevel ! Rescaling factors nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale ! Do we prevent the whole level from refining ? prevent_refine=.false. ! Prevent over refinement due to gas cooling ! This translates into : ! - a constant physical resolution at low redshift (ilevel<=nlevelmax_part+nlevel_collapse) ! - a constant comobile resolution at high redshift (ilevel>nlevelmax_part+nlevel_collapse) if(cosmo.and.cooling)then ! Finest cell size dx_min=(0.5D0**nlevelmax)*scale ! Test is designed so that nlevelmax is activated at aexp~0.8 if(ilevel.gt.nlevelmax_part+nlevel_collapse)then if(dx_loc<(4d0**(1d0/ndim))*(dx_min/aexp)) prevent_refine=.true. endif endif if(prevent_refine)return ! Set position of cell centers relative to grid center do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do ! Loop over active grids ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ! Gather nvector grids ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do ! Initialize refinement to false do i=1,ngrid ok(i)=.false. end do ! Apply purely local Lagrangian refinement criteria if(m_refine(ilevel)>-1.0d0)then call poisson_refine(ind_cell,ok,ngrid,ilevel) ! Apply geometry-based refinement criteria if(r_refine(ilevel)>-1.0)then ! Compute cell center in code units do idim=1,ndim do i=1,ngrid xx(i,idim)=xg(ind_grid(i),idim)+xc(ind,idim) end do end do ! Rescale position from code units to user units do idim=1,ndim do i=1,ngrid xx(i,idim)=(xx(i,idim)-skip_loc(idim))*scale end do end do call geometry_refine(xx,ind_cell,ok,ngrid,ilevel) end if end if ! Count newly flagged cells nok=0 do i=1,ngrid if(flag1(ind_cell(i))==0.and.ok(i))then nok=nok+1 end if end do do i=1,ngrid if(ok(i))flag1(ind_cell(i))=1 end do nflag=nflag+nok end do ! End loop over cells end do ! End loop over grids ! Do the same for hydro solver if(hydro)call hydro_flag(ilevel) #ifdef RT ! Do the same for RT solver if(rt)call rt_hydro_flag(ilevel) #endif ! Update boundaries call make_virtual_fine_int(flag1(1),ilevel) if(simple_boundary)call make_boundary_flag(ilevel) end subroutine userflag_fine !##################################################################### !##################################################################### !##################################################################### !##################################################################### subroutine poisson_refine(ind_cell,ok,ncell,ilevel) use amr_commons use pm_commons use hydro_commons use poisson_commons implicit none integer::ncell,ilevel integer,dimension(1:nvector)::ind_cell logical,dimension(1:nvector)::ok !------------------------------------------------- ! This routine sets flag1 to 1 if cell statisfy ! user-defined physical criterion for refinement. !------------------------------------------------- integer::i,nx_loc real(dp)::d_scale,scale,dx,dx_loc,vol_loc nx_loc=(icoarse_max-icoarse_min+1) scale=boxlen/dble(nx_loc) dx=0.5d0**ilevel dx_loc=dx*scale vol_loc=dx_loc**3 if(poisson)then if(.not. init) then do i=1,ncell ok(i)=ok(i).or.(cpu_map2(ind_cell(i))==1) end do else if(ivar_refine==0)then do i=1,ncell ok(i)=ok(i).or.(cpu_map2(ind_cell(i))==1) end do else if(ivar_refine>0)then do i=1,ncell ok(i)=ok(i).or. & & (uold(ind_cell(i),ivar_refine)/uold(ind_cell(i),1) & & > var_cut_refine) end do else if(m_refine(ilevel)==0.0)then do i=1,ncell ok(i)=.true. end do endif endif else if(hydro)then d_scale=mass_sph/vol_loc do i=1,ncell ok(i)=ok(i).or.(uold(ind_cell(i),1)>=m_refine(ilevel)*d_scale) end do endif end if end subroutine poisson_refine !##################################################################### !##################################################################### !##################################################################### !##################################################################### subroutine geometry_refine(xx,ind_cell,ok,ncell,ilevel) use amr_commons use pm_commons use hydro_commons use poisson_commons implicit none integer::ncell,ilevel integer,dimension(1:nvector)::ind_cell real(dp),dimension(1:nvector,1:ndim)::xx logical ,dimension(1:nvector)::ok !------------------------------------------------- ! This routine sets flag1 to 1 if cell statisfy ! user-defined physical criterion for refinement. !------------------------------------------------- real(dp)::er,xr,yr,zr,rr,xn,yn,zn,r,aa,bb integer ::i ! Authorize refinement if cell lies within region, ! otherwise unmark cell (no refinement outside region) if(r_refine(ilevel)>-1.0)then er=exp_refine(ilevel) ! Exponent defining norm xr=x_refine (ilevel) ! Region centre yr=y_refine (ilevel) zr=z_refine (ilevel) rr=r_refine (ilevel) ! Region DIAMETER (beware !) aa=a_refine (ilevel) ! Ellipticity (Y/X) bb=b_refine (ilevel) ! Ellipticity (Z/X) do i=1,ncell xn=0.0d0; yn=0.0d0; zn=0.0d0 xn=abs(xx(i,1)-xr) if(cosmo .and. xn>0.5) then xn=1.0-xn endif xn=2.0d0*xn/rr #if NDIM > 1 yn=abs(xx(i,2)-yr) if(cosmo .and. yn>0.5) then yn=1.0-yn endif yn=2.0d0*yn/(aa*rr) #endif #if NDIM >2 zn=abs(xx(i,3)-zr) if(cosmo .and. zn>0.5) then zn=1.0-zn endif zn=2.0d0*zn/(bb*rr) #endif if(er<10)then r=(xn**er+yn**er+zn**er)**(1.0/er) else r=max(xn,yn,zn) end if ! CHANGED BY TTG (2018): geometry-based refinement is not exclusive! ! ok(i)=ok(i).and.(r < 1.0) ok(i)=ok(i).or.(r < 1.0) end do endif end subroutine geometry_refine !############################################################ !############################################################ !############################################################ !############################################################ subroutine smooth_fine(ilevel) use amr_commons implicit none integer::ilevel ! ------------------------------------------------------------------- ! Dilatation operator. ! This routine makes one cell width cubic buffer around flag1 cells ! at level ilevel by following these 3 steps: ! step 1: flag1 cells with at least 1 flag1 neighbors (if ndim > 0) ! step 2: flag1 cells with at least 2 flag1 neighbors (if ndim > 1) ! step 3: flag1 cells with at least 2 flag1 neighbors (if ndim > 2) ! Array flag2 is used as temporary workspace. ! ------------------------------------------------------------------- integer::ismooth integer::i,ncache,iskip,ngrid integer::igrid,ind integer,dimension(1:3)::n_nbor integer,dimension(1:nvector),save::ind_grid,ind_cell integer,dimension(1:nvector,0:twondim),save::igridn if(ilevel==nlevelmax)return if(numbtot(1,ilevel)==0)return n_nbor(1:3)=(/1,2,2/) flag1(0)=0 ncache=active(ilevel)%ngrid ! Loop over steps do ismooth=1,ndim ! Initialize flag2 to 0 do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do do i=1,ngrid flag2(ind_cell(i))=0 end do end do end do ! Count neighbors and set flag2 accordingly do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do call getnborgrids(ind_grid,igridn,ngrid) do ind=1,twotondim call count_nbors(igridn,ind,n_nbor(ismooth),ngrid) end do end do ! Set flag1=1 for cells with flag2=1 do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do do i=1,ngrid if(flag1(ind_cell(i))==1)flag2(ind_cell(i))=0 end do do i=1,ngrid if(flag2(ind_cell(i))==1)then flag1(ind_cell(i))=1 nflag=nflag+1 end if end do end do end do ! Update boundaries call make_virtual_fine_int(flag1(1),ilevel) if(simple_boundary)call make_boundary_flag(ilevel) end do ! End loop over steps end subroutine smooth_fine !############################################################ !############################################################ !############################################################ !############################################################ subroutine count_nbors(igridn,ind,n_nbor,nn) use amr_commons implicit none integer::ind,nn,n_nbor integer,dimension(1:nvector,0:twondim)::igridn !---------------------------------------------------- ! This routine computes the number of neighbors ! for cell ind in grid igridn(:,0) for which flag1=1. ! The user must provide the neighboring grids index ! stored in igridn(:,:) and the threshold n_nbor ! If the number of flag1 neighbors exceeds n_nbor, ! then cell is marked with flag2=1 !---------------------------------------------------- integer::i,in,iskip integer,dimension(1:nvector),save::ind_cell,i_nbor integer,dimension(1:nvector,1:twondim),save::indn ! Compute cell number iskip=ncoarse+(ind-1)*ngridmax do i=1,nn ind_cell(i)=iskip+igridn(i,0) end do ! Gather neighbors call getnborcells(igridn,ind,indn,nn) ! Check if neighboring cell exists and count it as a flagged neighbor i_nbor(1:nn)=0 do in=1,twondim do i=1,nn i_nbor(i)=i_nbor(i)+flag1(indn(i,in)) end do end do ! flag2 cell if necessary do i=1,nn if(i_nbor(i)>=n_nbor)flag2(ind_cell(i))=1 end do end subroutine count_nbors !############################################################ !############################################################ !############################################################ !############################################################ subroutine count_nbors2(igridn,ind,n_nbor,nn) use amr_commons implicit none integer::ind,nn,n_nbor integer,dimension(1:nvector,0:twondim)::igridn !---------------------------------------------------- ! This routine computes the number of neighbors ! for cell ind in grid igridn(:,0) for which flag2=1. ! The user must provide the neighboring grids index ! stored in igridn(:,:) and the threshold n_nbor ! If the number of flag2 neighbors exceeds n_nbor, ! then cell is marked with flag1=1 !---------------------------------------------------- integer::i,in,iskip integer,dimension(1:nvector),save::ind_cell,i_nbor integer,dimension(1:nvector,1:twondim),save::indn ! Compute cell number iskip=ncoarse+(ind-1)*ngridmax do i=1,nn ind_cell(i)=iskip+igridn(i,0) end do ! Gather neighbors call getnborcells(igridn,ind,indn,nn) ! Check if neighboring cell exists and count it as a flagged neighbor i_nbor(1:nn)=0 do in=1,twondim do i=1,nn i_nbor(i)=i_nbor(i)+flag2(indn(i,in)) end do end do ! flag2 cell if necessary do i=1,nn if(i_nbor(i)>=n_nbor)flag1(ind_cell(i))=1 end do end subroutine count_nbors2 !############################################################ !############################################################ !############################################################ subroutine init_refmap use amr_commons implicit none integer::ilevel,ivar if(verbose)write(*,*)'Entering init_refmap' do ilevel=nlevelmax,1,-1 if(ilevel>=levelmin)call init_refmap_fine(ilevel) call make_virtual_fine_int(cpu_map2(1),ilevel) end do if(verbose)write(*,*)'Complete init_refmap' end subroutine init_refmap !############################################################ !############################################################ !############################################################ !############################################################ subroutine init_refmap_fine(ilevel) use amr_commons use hydro_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel integer::i,icell,igrid,ncache,iskip,ngrid,ilun integer::ind,idim,ivar,ix,iy,iz,nx_loc integer::i1,i2,i3,i1_min,i1_max,i2_min,i2_max,i3_min,i3_max integer::buf_count,info,nvar_in integer ,dimension(1:nvector),save::ind_grid,ind_cell real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v real(dp)::dx,rr,vx,vy,vz,ek,ei,pp,xx1,xx2,xx3,dx_loc,scale real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:twotondim,1:3)::xc real(dp),dimension(1:nvector) ,save::vv real(dp),dimension(1:nvector,1:ndim),save::xx real(dp),dimension(1:nvector,1:nvar),save::uu real(dp),allocatable,dimension(:,:,:)::init_array real(kind=4),allocatable,dimension(:,:) ::init_plane logical::error,ok_file1,ok_file2,ok_file character(LEN=80)::filename character(LEN=5)::nchar,ncharvar integer,parameter::tag=1103 integer::dummy_io,info2 if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Mesh size at level ilevel in coarse cell units dx=0.5D0**ilevel ! Set position of cell centers relative to grid center do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do ! Local constants nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale ncache=active(ilevel)%ngrid !-------------------------------------- ! Compute initial conditions from files !-------------------------------------- if(multiple)then filename=TRIM(initfile(ilevel))//'/dir_refmap/ic_refmap.00001' INQUIRE(file=filename,exist=ok_file2) else filename=TRIM(initfile(ilevel))//'/ic_refmap' INQUIRE(file=filename,exist=ok_file2) endif if (.not. ok_file2)then if(myid==1)write(*,*)'File '//TRIM(filename)//' not found' call clean_stop endif !------------------------------------------------------------------------- ! First step: compute level boundaries in terms of initial condition array !------------------------------------------------------------------------- if(ncache>0)then i1_min=n1(ilevel)+1; i1_max=0 i2_min=n2(ilevel)+1; i2_max=0 i3_min=n3(ilevel)+1; i3_max=0 do ind=1,twotondim do i=1,ncache igrid=active(ilevel)%igrid(i) xx1=xg(igrid,1)+xc(ind,1)-skip_loc(1) xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel) xx2=xg(igrid,2)+xc(ind,2)-skip_loc(2) xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel) xx3=xg(igrid,3)+xc(ind,3)-skip_loc(3) xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel) i1_min=MIN(i1_min,int(xx1)+1) i1_max=MAX(i1_max,int(xx1)+1) i2_min=MIN(i2_min,int(xx2)+1) i2_max=MAX(i2_max,int(xx2)+1) i3_min=MIN(i3_min,int(xx3)+1) i3_max=MAX(i3_max,int(xx3)+1) end do end do error=.false. if(i1_min<1.or.i1_max>n1(ilevel))error=.true. if(i2_min<1.or.i2_max>n2(ilevel))error=.true. if(i3_min<1.or.i3_max>n3(ilevel))error=.true. if(error) then write(*,*)'Some grid are outside initial conditions sub-volume' write(*,*)'for ilevel=',ilevel write(*,*)i1_min,i1_max write(*,*)i2_min,i2_max write(*,*)i3_min,i3_max write(*,*)n1(ilevel),n2(ilevel),n3(ilevel) call clean_stop end if endif !----------------------------------------- ! Second step: read initial condition file !----------------------------------------- ! Allocate initial conditions array if(ncache>0)allocate(init_array(i1_min:i1_max,i2_min:i2_max,i3_min:i3_max)) allocate(init_plane(1:n1(ilevel),1:n2(ilevel))) if(myid==1)write(*,*)'Reading file '//TRIM(filename) if(multiple)then ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif ilun=ncpu+myid+10 open(ilun,file=filename,form='unformatted') rewind ilun read(ilun) ! skip first line do i3=1,n3(ilevel) read(ilun) ((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel)) if(i3.ge.i3_min.and.i3.le.i3_max)then init_array(i1_min:i1_max,i2_min:i2_max,i3) = & & init_plane(i1_min:i1_max,i2_min:i2_max) end if end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif else if(myid==1)then open(10,file=filename,form='unformatted') rewind 10 read(10) ! skip first line endif do i3=1,n3(ilevel) if(myid==1)then read(10) ((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel)) else init_plane=0.0 endif buf_count=n1(ilevel)*n2(ilevel) #ifndef WITHOUTMPI call MPI_BCAST(init_plane,buf_count,MPI_REAL,0,MPI_COMM_WORLD,info) #endif if(ncache>0)then if(i3.ge.i3_min.and.i3.le.i3_max)then init_array(i1_min:i1_max,i2_min:i2_max,i3) = & & init_plane(i1_min:i1_max,i2_min:i2_max) end if endif end do if(myid==1)close(10) endif if(ncache>0)then ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ncache igrid=active(ilevel)%igrid(i) icell=igrid+iskip xx1=xg(igrid,1)+xc(ind,1)-skip_loc(1) xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel) xx2=xg(igrid,2)+xc(ind,2)-skip_loc(2) xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel) xx3=xg(igrid,3)+xc(ind,3)-skip_loc(3) xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel) i1=int(xx1)+1 i1=int(xx1)+1 i2=int(xx2)+1 i2=int(xx2)+1 i3=int(xx3)+1 i3=int(xx3)+1 ! Scatter to corresponding primitive variable cpu_map2(icell)=int(init_array(i1,i2,i3)) end do end do ! End loop over cells endif ! Deallocate initial conditions array if(ncache>0)deallocate(init_array) deallocate(init_plane) 111 format(' Entering init_refmap_fine ',I2) end subroutine init_refmap_fine ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/gadgetreadfile.f90 MODULE gadgetreadfilemod ! ! Routines to read L-Gadget2 particle data files in Fortran ! Adapted from http://astro.dur.ac.uk/~jch/password_pages/index.html ! ! CHARACTER(LEN=*) :: basefile - the base snapshot name. It may get a file id added ! ! ! ! ! Data type corresponding to gadget file header TYPE gadgetheadertype INTEGER*4, DIMENSION(6) :: npart REAL*8, DIMENSION(6) :: mass REAL*8 :: time REAL*8 :: redshift INTEGER*4 :: flag_sfr INTEGER*4 :: flag_feedback INTEGER*4, DIMENSION(6) :: nparttotal INTEGER*4 :: flag_cooling INTEGER*4 :: numfiles REAL*8 :: boxsize REAL*8 :: omega0 REAL*8 :: omegalambda REAL*8 :: hubbleparam INTEGER*4 :: flag_stellarage INTEGER*4 :: flag_metals INTEGER*4, DIMENSION(6) :: totalhighword INTEGER*4 :: flag_entropy_instead_u INTEGER*4 :: flag_doubleprecision INTEGER*4 :: flag_ic_info REAL*4 :: lpt_scalingfactor CHARACTER, DIMENSION(48) :: unused END TYPE gadgetheadertype CONTAINS ! --------------------------------------------------------------------------- SUBROUTINE gadgetreadheader(basename,ifile, header, ok) ! ! Read and return the gadget file header for the specified file ! IMPLICIT NONE ! Input parameters CHARACTER(LEN=*), INTENT(IN) :: basename INTEGER, INTENT(IN):: ifile ! Header to return TYPE (gadgetheadertype), INTENT(OUT) :: header logical, INTENT(OUT)::ok ! Internal variables CHARACTER(LEN=256) :: filename CHARACTER(LEN=6) :: fileno integer::dummy_int,blck_size,head_blck character(LEN=4)::blck_name filename = TRIM(basename) INQUIRE(file=filename, exist=ok) if (.not.ok) then ! Generate the number to go on the end of the filename IF(ifile.LT.10)THEN WRITE(fileno,'('.',1i1.1)')ifile ELSE IF (ifile.LT.100)THEN WRITE(fileno,'('.',1i2.2)')ifile ELSE IF (ifile.LT.1000)THEN WRITE(fileno,'('.',1i3.3)')ifile ELSE IF (ifile.LT.10000)THEN WRITE(fileno,'('.',1i4.4)')ifile ELSE WRITE(fileno,'('.',1i5.5)')ifile END IF filename = TRIM(basename) // fileno INQUIRE(file=filename, exist=ok) if(.not.ok) then write(*,*) 'No file '//basename//' or '//filename RETURN end if end if !OPEN(unit=1,file=filename,status='old',action='read',form='unformatted') OPEN(unit=1,file=filename,status='old',action='read',form='unformatted',access='stream') read(1,POS=1) dummy_int read(1,POS=1+sizeof(dummy_int)) blck_name read(1,POS=1+sizeof(dummy_int)+sizeof(blck_name)) dummy_int read(1,POS=1+2*sizeof(dummy_int)+sizeof(blck_name)) dummy_int read(1,POS=1+3*sizeof(dummy_int)+sizeof(blck_name)) blck_size head_blck = 1+sizeof(blck_name)+4*sizeof(dummy_int) ! Byte swapping doesn't work if you just do READ(1)header !READ(1)header%npart,header%mass,header%time,header%redshift, & ! header%flag_sfr,header%flag_feedback,header%nparttotal, & ! header%flag_cooling,header%numfiles,header%boxsize, & ! header%omega0,header%omegalambda,header%hubbleparam, & ! header%flag_stellarage,header%flag_metals,header%totalhighword, & ! header%flag_entropy_instead_u, header%flag_doubleprecision, & ! header%flag_ic_info, header%lpt_scalingfactor READ(1,POS=head_blck) header%npart,header%mass,header%time,header%redshift, & header%flag_sfr,header%flag_feedback,header%nparttotal, & header%flag_cooling,header%numfiles,header%boxsize, & header%omega0,header%omegalambda,header%hubbleparam, & header%flag_stellarage,header%flag_metals,header%totalhighword, & header%flag_entropy_instead_u, header%flag_doubleprecision, & header%flag_ic_info, header%lpt_scalingfactor CLOSE(1) END SUBROUTINE gadgetreadheader ! --------------------------------------------------------------------------- SUBROUTINE gadgetreadfile(basename,ifile,header,pos,vel,id) ! ! Read and return all data from the specified file. Output arrays must ! already be allocated. Use readheader to get particle numbers to do this. ! IMPLICIT NONE ! Input parameters CHARACTER(LEN=*), INTENT(IN) :: basename INTEGER, INTENT(IN) :: ifile ! Header and hash table to return TYPE (gadgetheadertype) :: header ! Particle data REAL, DIMENSION(3,*) :: pos,vel #ifndef LONGINT INTEGER*4, DIMENSION(*) :: id #else INTEGER*8, DIMENSION(*) :: id #endif ! Internal variables CHARACTER(LEN=256) :: filename CHARACTER(LEN=6) :: fileno INTEGER :: np logical::ok ! Generate the number to go on the end of the filename IF(ifile.LT.10)THEN WRITE(fileno,'('.',1i1.1)')ifile ELSE IF (ifile.LT.100)THEN WRITE(fileno,'('.',1i2.2)')ifile ELSE IF (ifile.LT.1000)THEN WRITE(fileno,'('.',1i3.3)')ifile ELSE IF (ifile.LT.10000)THEN WRITE(fileno,'('.',1i4.4)')ifile ELSE WRITE(fileno,'('.',1i5.5)')ifile END IF filename = TRIM(basename) // fileno INQUIRE(file=filename, exist=ok) if(.not.ok) then write(*,*) 'No file '//filename RETURN end if OPEN(unit=1,file=filename,status='old',action='read',form='unformatted') ! Byte swapping doesn't appear to work if you just do READ(1)header READ(1)header%npart,header%mass,header%time,header%redshift, & header%flag_sfr,header%flag_feedback,header%nparttotal, & header%flag_cooling,header%numfiles,header%boxsize, & header%omega0,header%omegalambda,header%hubbleparam, & header%flag_stellarage,header%flag_metals,header%totalhighword, & header%flag_entropy_instead_u, header%flag_doubleprecision, & header%flag_ic_info, header%lpt_scalingfactor np=header%npart(2) READ(1)pos(1:3,1:np) READ(1)vel(1:3,1:np) READ(1)id(1:np) CLOSE(1) END SUBROUTINE gadgetreadfile ! --------------------------------------------------------------------------- SUBROUTINE gadgetwritefile(basename,ifile,header,pos,vel,id) ! ! Read and return all data from the specified file. Output arrays must ! already be allocated. Use readheader to get particle numbers to do this. ! IMPLICIT NONE ! Input parameters CHARACTER(LEN=*), INTENT(IN) :: basename INTEGER, INTENT(IN) :: ifile ! Header and hash table to return TYPE (gadgetheadertype) :: header ! Particle data REAL, DIMENSION(3,*) :: pos,vel #ifndef LONGINT INTEGER*4, DIMENSION(*) :: id #else INTEGER*8, DIMENSION(*) :: id #endif ! Internal variables CHARACTER(LEN=256) :: filename CHARACTER(LEN=6) :: fileno INTEGER :: np logical::ok ! Generate the number to go on the end of the filename IF(ifile.LT.10)THEN WRITE(fileno,'('.',1i1.1)')ifile ELSE IF (ifile.LT.100)THEN WRITE(fileno,'('.',1i2.2)')ifile ELSE IF (ifile.LT.1000)THEN WRITE(fileno,'('.',1i3.3)')ifile ELSE IF (ifile.LT.10000)THEN WRITE(fileno,'('.',1i4.4)')ifile ELSE WRITE(fileno,'('.',1i5.5)')ifile END IF filename = TRIM(basename) // fileno OPEN(unit=1,file=filename,status='unknown',action='write',form='unformatted') WRITE(1)header%npart,header%mass,header%time,header%redshift, & header%flag_sfr,header%flag_feedback,header%nparttotal, & header%flag_cooling,header%numfiles,header%boxsize, & header%omega0,header%omegalambda,header%hubbleparam, & header%flag_stellarage,header%flag_metals,header%totalhighword, & header%flag_entropy_instead_u, header%flag_doubleprecision, & header%flag_ic_info, header%lpt_scalingfactor, header%unused np=header%npart(2) WRITE(1)pos(1:3,1:np) WRITE(1)vel(1:3,1:np) WRITE(1)id(1:np) CLOSE(1) END SUBROUTINE gadgetwritefile END MODULE gadgetreadfilemod ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/hydro_parameters.f90 module hydro_parameters #ifdef grackle use grackle_parameters #endif use amr_parameters ! Number of independant variables #ifndef NENER integer,parameter::nener=0 #else integer,parameter::nener=NENER #endif #ifndef NVAR integer,parameter::nvar=ndim+2+nener #else integer,parameter::nvar=NVAR #endif ! Size of hydro kernel integer,parameter::iu1=-1 integer,parameter::iu2=+4 integer,parameter::ju1=(1-ndim/2)-1*(ndim/2) integer,parameter::ju2=(1-ndim/2)+4*(ndim/2) integer,parameter::ku1=(1-ndim/3)-1*(ndim/3) integer,parameter::ku2=(1-ndim/3)+4*(ndim/3) integer,parameter::if1=1 integer,parameter::if2=3 integer,parameter::jf1=1 integer,parameter::jf2=(1-ndim/2)+3*(ndim/2) integer,parameter::kf1=1 integer,parameter::kf2=(1-ndim/3)+3*(ndim/3) ! Imposed boundary condition variables real(dp),dimension(1:MAXBOUND,1:nvar)::boundary_var real(dp),dimension(1:MAXBOUND)::d_bound=0.0d0 real(dp),dimension(1:MAXBOUND)::p_bound=0.0d0 real(dp),dimension(1:MAXBOUND)::u_bound=0.0d0 real(dp),dimension(1:MAXBOUND)::v_bound=0.0d0 real(dp),dimension(1:MAXBOUND)::w_bound=0.0d0 #if NENER>0 real(dp),dimension(1:MAXBOUND,1:NENER)::prad_bound=0.0 #endif #if NVAR>NDIM+2+NENER real(dp),dimension(1:MAXBOUND,1:NVAR-NDIM-2-NENER)::var_bound=0.0 #endif ! Refinement parameters for hydro real(dp)::err_grad_d=-1.0 ! Density gradient real(dp)::err_grad_u=-1.0 ! Velocity gradient real(dp)::err_grad_p=-1.0 ! Pressure gradient real(dp)::floor_d=1.d-10 ! Density floor real(dp)::floor_u=1.d-10 ! Velocity floor real(dp)::floor_p=1.d-10 ! Pressure floor real(dp)::mass_sph=0.0D0 ! mass_sph #if NENER>0 real(dp),dimension(1:NENER)::err_grad_prad=-1.0 #endif #if NVAR>NDIM+2+NENER real(dp),dimension(1:NVAR-NDIM-2)::err_grad_var=-1.0 #endif real(dp),dimension(1:MAXLEVEL)::jeans_refine=-1.0 ! Initial conditions hydro variables real(dp),dimension(1:MAXREGION)::d_region=0. real(dp),dimension(1:MAXREGION)::u_region=0. real(dp),dimension(1:MAXREGION)::v_region=0. real(dp),dimension(1:MAXREGION)::w_region=0. real(dp),dimension(1:MAXREGION)::p_region=0. #if NENER>0 real(dp),dimension(1:MAXREGION,1:NENER)::prad_region=0.0 #endif #if NVAR>NDIM+2+NENER real(dp),dimension(1:MAXREGION,1:NVAR-NDIM-2-NENER)::var_region=0.0 #endif ! Hydro solver parameters integer ::niter_riemann=10 integer ::slope_type=1 real(dp)::slope_theta=1.5d0 real(dp)::gamma=1.4d0 real(dp),dimension(1:512)::gamma_rad=1.33333333334d0 real(dp)::courant_factor=0.5d0 real(dp)::difmag=0.0d0 real(dp)::smallc=1.d-10 real(dp)::smallr=1.d-10 character(LEN=10)::scheme='muscl' character(LEN=10)::riemann='llf' ! Interpolation parameters integer ::interpol_var=0 integer ::interpol_type=1 ! Passive variables index ! ADDED BY TTG APR 2017: include a passive scalar with index 6 integer::itracer=6 ! CHANGED BY TTG APR 2017: to allow for a passive scalar with index 6 ! integer::imetal=6 integer::imetal=7 ! TTG APR 2017: not sure whether to shift the following by +1, ! given that, originally, they were equal to imetal... integer::idelay=6 integer::ixion=6 integer::ichem=6 integer::ivirial1=6 integer::ivirial2=6 integer::inener=6 end module hydro_parameters ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/init_amr.f90 subroutine init_amr use amr_commons use hydro_commons use pm_commons use poisson_commons use bisection implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::i,idim,ncell,iskip,ind,ncache,ilevel,ibound,nboundary2 integer::ncpu2,ndim2,nx2,ny2,nz2,ngridmax2,nlevelmax2 integer::noutput2,iout2,ifout2,ilun,info integer::ix,iy,iz,ix_max,iy_max,iz_max,nxny,nx_loc real(dp)::mass_sph2 integer,dimension(:),allocatable::ind_grid,iig,pos,grid real(dp),dimension(1:MAXOUT)::aout2=1.1d0 real(dp),dimension(1:MAXOUT)::tout2=0.0d0 real(dp),dimension(:),allocatable::xxg integer ,dimension(1:nvector)::c real(dp),dimension(1:nvector,1:ndim)::x real(qdp),dimension(1:nvector)::order_min,order_max logical::ok real(dp)::dx_loc,scale character(LEN=128)::ordering2 ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar,ncharcpu real(dp),allocatable,dimension(:)::bxmin,bxmax integer,parameter::tag=1100 integer::dummy_io,info2 real(kind=8),allocatable,dimension(:)::bound_key_restart if(verbose.and.myid==1)write(*,*)'Entering init_amr' ! Constants ncoarse=nx*ny*nz ncell=ncoarse+twotondim*ngridmax nxny=nx*ny ix_max=0; iy_max=0; iz_max=0 if(ndim>0)ix_max=1 if(ndim>1)iy_max=1 if(ndim>2)iz_max=1 nx_loc=icoarse_max-icoarse_min+1 scale=boxlen/dble(nx_loc) ! Initial time step for each level dtold=0.0D0 dtnew=0.0D0 ! Allocate AMR cell-based arrays allocate(flag1(0:ncell)) ! Note: starting from 0 allocate(flag2(0:ncell)) ! Note: starting from 0 allocate(son (1:ncell)) ! Son index flag1=0; flag2=0; son=0 ! Allocate MPI cell-based arrays allocate(cpu_map (1:ncell)) ! Cpu map allocate(cpu_map2 (1:ncell)) ! New cpu map for load balance allocate(hilbert_key(1:ncell)) ! Ordering key cpu_map=0; cpu_map2=0; hilbert_key=0.0d0 ! Bisection ordering: compute array boundaries and ! allocate arrays if needed nbilevelmax=ceiling(log(dble(ncpu))/log(2.0)) nbinodes=2**(nbilevelmax+1)-1 nbileafnodes=2**nbilevelmax bisec_nres=2**(nlevelmax+1) bisec_res=scale/dble(bisec_nres) if(ordering=='bisection') then ! allocate bisection tree structure allocate(bisec_wall(1:nbinodes)) allocate(bisec_next(1:nbinodes,1:2)) allocate(bisec_indx(1:nbinodes)) bisec_wall=0.0d0; bisec_next=0; bisec_indx=0; bisec_root=0 ! allocate some other bisection stuff allocate(bisec_cpubox_min (1:ncpu,1:ndim)) allocate(bisec_cpubox_max (1:ncpu,1:ndim)) allocate(bisec_cpubox_min2(1:ncpu,1:ndim)) allocate(bisec_cpubox_max2(1:ncpu,1:ndim)) allocate(bisec_cpu_load(1:ncpu)) bisec_cpubox_min=0; bisec_cpubox_max=0; bisec_cpubox_min2=0; bisec_cpubox_max2=0; bisec_cpu_load=0; ! allocate histograms allocate(bisec_hist(1:nbileafnodes,1:bisec_nres)) allocate(bisec_hist_bounds(1:(nbileafnodes+1))) allocate(new_hist_bounds (1:(nbileafnodes+1))) allocate(bisec_ind_cell(1:ncell)) ! big array allocate(cell_level (1:ncell)) ! big array bisec_hist=0 bisec_hist_bounds=0; new_hist_bounds=0 bisec_ind_cell=0; cell_level=0 end if bisection_or_ordering:if(ordering /= 'bisection') then ! use usual ordering machinery ! Cpu boundaries in chosen ordering ndomain=ncpu*overload allocate(bound_key (0:ndomain)) allocate(bound_key2(0:ndomain)) ! Compute minimum and maximum ordering key dx_loc=scale x(1,1)=0.5*scale #if NDIM>1 x(1,2)=0.5*scale #endif #if NDIM>2 x(1,3)=0.5*scale #endif call cmp_minmaxorder(x,order_min,order_max,dx_loc,1) order_all_min=order_min(1) order_all_max=order_max(1) do iz=kcoarse_min,kcoarse_max do iy=jcoarse_min,jcoarse_max do ix=icoarse_min,icoarse_max ind=1+ix+iy*nx+iz*nxny x(1,1)=(dble(ix)+0.5d0-dble(icoarse_min))*scale #if NDIM>1 x(1,2)=(dble(iy)+0.5d0-dble(jcoarse_min))*scale #endif #if NDIM>2 x(1,3)=(dble(iz)+0.5d0-dble(kcoarse_min))*scale #endif call cmp_minmaxorder(x,order_min,order_max,dx_loc,1) order_all_min=min(order_all_min,order_min(1)) order_all_max=max(order_all_max,order_max(1)) end do end do end do ! Set initial cpu boundaries do i=0,ndomain-1 #ifdef QUADHILBERT bound_key(i)=order_all_min+real(i,16)/real(ndomain,16)* & & (order_all_max-order_all_min) #else bound_key(i)=order_all_min+real(i,8)/real(ndomain,8)* & & (order_all_max-order_all_min) #endif end do bound_key(ndomain)=order_all_max else ! Init bisection balancing call build_bisection(update=.false.) end if bisection_or_ordering ! Compute coarse cpu map do iz=kcoarse_min,kcoarse_max do iy=jcoarse_min,jcoarse_max do ix=icoarse_min,icoarse_max ind=1+ix+iy*nx+iz*nxny x(1,1)=(dble(ix)+0.5d0-dble(icoarse_min))*scale #if NDIM>1 x(1,2)=(dble(iy)+0.5d0-dble(jcoarse_min))*scale #endif #if NDIM>2 x(1,3)=(dble(iz)+0.5d0-dble(kcoarse_min))*scale #endif call cmp_cpumap(x,c,1) cpu_map(ind)=c(1) end do end do end do ! Allocate linked list for each level allocate(headl(1:ncpu,1:nlevelmax)) allocate(taill(1:ncpu,1:nlevelmax)) allocate(numbl(1:ncpu,1:nlevelmax)) allocate(numbtot(1:10,1:nlevelmax)) headl=0 ! Head grid in the level taill=0 ! Tail grid in the level numbl=0 ! Number of grids in the level numbtot=0 ! Total number of grids in the level ! Allocate communicators allocate(active(1:nlevelmax)) allocate(emission(1:ncpu,1:nlevelmax)) allocate(reception(1:ncpu,1:nlevelmax)) do ilevel=1,nlevelmax active(ilevel)%ngrid=0 do i=1,ncpu emission (i,ilevel)%ngrid=0 emission (i,ilevel)%npart=0 reception(i,ilevel)%ngrid=0 reception(i,ilevel)%npart=0 end do end do ! Allocate lookup array for multigrid fine if(poisson)then allocate(lookup_mg(1:ngridmax)) lookup_mg=0 endif ! Allocate physical boundary for each level allocate(headb (1:MAXBOUND,1:nlevelmax)) allocate(tailb (1:MAXBOUND,1:nlevelmax)) allocate(numbb (1:MAXBOUND,1:nlevelmax)) allocate(boundary(1:MAXBOUND,1:nlevelmax)) do i=1,MAXBOUND do ilevel=1,nlevelmax headb (i,ilevel)=0 ! Head grid in boundary tailb (i,ilevel)=0 ! Tail grid in boundary numbb (i,ilevel)=0 ! Number of grids in boundary boundary(i,ilevel)%ngrid=0 ! Communicators end do end do ! Allocate grid center coordinates allocate(xg(1:ngridmax,1:ndim)) xg=0.0D0 ! Allocate tree arrays allocate(father(1:ngridmax)) allocate(nbor (1:ngridmax,1:twondim)) allocate(next (1:ngridmax)) allocate(prev (1:ngridmax)) father=0; nbor=0; next=0; prev=0 ! Allocate pointer to particles linked lists if(pic)then allocate(headp(1:ngridmax)) allocate(tailp(1:ngridmax)) allocate(numbp(1:ngridmax)) headp=0; tailp=0; numbp=0 endif ! Initialize AMR grid linked list do i=1,ngridmax-1 next(i)=i+1 end do do i=2,ngridmax prev(i)=i-1 end do headf=1 ! Pointer to first grid in free memory tailf=ngridmax ! Pointer to last grid in free memory prev(headf)=0; next(tailf)=0 numbf=ngridmax ! Number of grids in free memory used_mem=ngridmax-numbf !---------------------------- ! Read amr file for a restart !---------------------------- if(nrestart>0)then ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif #ifdef QUADHILBERT if(nrestart_quad.eq.nrestart) allocate(bound_key_restart(0:ndomain)) #endif ilun=myid+10 call title(nrestart,nchar) if(IOGROUPSIZEREP>0)then call title(((myid-1)/IOGROUPSIZEREP)+1,ncharcpu) ! CHANGED BY TTG (FEB 2017) ! fileloc='output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/amr_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/amr_'//TRIM(nchar)//'.out' else ! CHANGED BY TTG (FEB 2017) ! fileloc='output_'//TRIM(nchar)//'/amr_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/amr_'//TRIM(nchar)//'.out' endif call title(myid,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) inquire(file=fileloc, exist=ok) if(.not. ok)then write(*,*)'Restart failed:' write(*,*)'File '//TRIM(fileloc)//' not found' call clean_stop end if if(debug)write(*,*)'amr.tmp opened for processor ',myid open(unit=ilun,file=fileloc,form='unformatted') ! Read grid variables read(ilun)ncpu2 read(ilun)ndim2 read(ilun)nx2,ny2,nz2 read(ilun)nlevelmax2 read(ilun)ngridmax2 read(ilun)nboundary2 read(ilun)ngrid_current read(ilun)boxlen if(ncpu2.ne.ncpu)then if(myid==1)then write(*,*)'Number of processes not compatible' write(*,*)'ncpu should be set equal to',ncpu2 endif call clean_stop end if ! Read time variables read(ilun)noutput2,iout2,ifout2 if(noutput2>MAXOUT)then write(*,*) 'Error: noutput>MAXOUT' call clean_stop end if read(ilun)tout2(1:noutput2) read(ilun)aout2(1:noutput2) ! Check compatibility with current parameters if((ndim2.ne.ndim).or.(nx2.ne.nx).or.(ny2.ne.ny).or.(nz2.ne.nz).or.& & (nboundary2.ne.nboundary).or.(nlevelmax2>nlevelmax).or.& & (ngrid_current>ngridmax).or.(noutput2>noutput) )then write(*,*)'File amr.tmp is not compatible with namelist' write(*,*)' ndim nx ny nz nlevelmax noutput ngridmax nboundary' write(*,'('amr.tmp =',4(I4,1x),5x,I4,4x,I4,3x,I8)')& & ndim2,nx2,ny2,nz2,nlevelmax2,noutput2,ngrid_current,nboundary2 write(*,'('namelist =',4(I4,1x),5x,I4,4x,I4,3x,I8)')& & ndim ,nx ,ny ,nz ,nlevelmax ,noutput, ngridmax ,nboundary if(myid==1)write(*,*)'Restart failed' call clean_stop end if ! Old output times tout(1:noutput2)=tout2(1:noutput2) aout(1:noutput2)=aout2(1:noutput2) iout=iout2 ifout=ifout2 if(ifout.gt.nrestart+1) ifout=nrestart+1 read(ilun)t read(ilun)dtold(1:nlevelmax2) read(ilun)dtnew(1:nlevelmax2) read(ilun)nstep,nstep_coarse nstep_coarse_old=nstep_coarse read(ilun)einit,mass_tot_0,rho_tot read(ilun)omega_m,omega_l,omega_k,omega_b,h0,aexp_ini,boxlen_ini read(ilun)aexp,hexp,aexp_old,epot_tot_int,epot_tot_old if(cosmo)then read(ilun)mass_sph else read(ilun)mass_sph2 endif if(myid==1)write(*,*)'Restarting at t=',t,' nstep_coarse=',nstep_coarse trestart = t ! Compute movie frame number if applicable if(imovout>0) then do i=2,imovout if(aendmov>0)then if(aexp>amovout(i-1).and.aexptmovout(i-1).and.t0)then if(myid==1)write(*,*) 'Frame number, aexp ',imov, amovout(imov) else if(myid==1)write(*,*) 'Frame number, t ',imov, tmovout(imov) endif endif ! Read levels variables read(ilun)headl(1:ncpu,1:nlevelmax2) read(ilun)taill(1:ncpu,1:nlevelmax2) read(ilun)numbl(1:ncpu,1:nlevelmax2) read(ilun)numbtot(1:10,1:nlevelmax2) ! Read boundary linked list if(simple_boundary)then read(ilun)headb(1:nboundary,1:nlevelmax2) read(ilun)tailb(1:nboundary,1:nlevelmax2) read(ilun)numbb(1:nboundary,1:nlevelmax2) end if ! Read free memory read(ilun)headf,tailf,numbf,used_mem,used_mem_tot headf=ngrid_current+1 tailf=ngridmax numbf=ngridmax-ngrid_current prev(headf)=0 next(tailf)=0 ! Read cpu boundaries read(ilun)ordering2 if(ordering2.ne.ordering)then if(myid==1)write(*,*)'Ordering is uncompatible' call clean_stop endif if(ordering=='bisection') then read(ilun)bisec_wall(1:nbinodes) read(ilun)bisec_next(1:nbinodes,1:2) read(ilun)bisec_indx(1:nbinodes) read(ilun)bisec_cpubox_min(1:ncpu,1:ndim) read(ilun)bisec_cpubox_max(1:ncpu,1:ndim) else #ifdef QUADHILBERT if(nrestart_quad.eq.nrestart) then read(ilun)bound_key_restart(0:ndomain) bound_key(0:ndomain)=bound_key_restart(0:ndomain) else read(ilun)bound_key(0:ndomain) endif #else read(ilun)bound_key(0:ndomain) #endif endif ! Read coarse level read(ilun)son(1:ncoarse) read(ilun)flag1(1:ncoarse) read(ilun)cpu_map(1:ncoarse) ! Read fine levels do ilevel=1,nlevelmax2 do ibound=1,nboundary+ncpu if(ibound<=ncpu)then ncache=numbl(ibound,ilevel) else ncache=numbb(ibound-ncpu,ilevel) end if if(ncache>0)then allocate(ind_grid(1:ncache)) allocate(xxg(1:ncache)) allocate(iig(1:ncache)) allocate(pos(1:ncache)) allocate(grid(1:ncache)) ! Read grid index read(ilun)ind_grid ! Read next index read(ilun)iig do i=1,ncache next(ind_grid(i))=iig(i) end do ! Read prev index read(ilun)iig do i=1,ncache prev(ind_grid(i))=iig(i) end do ! Read grid center do idim=1,ndim read(ilun)xxg do i=1,ncache xg(ind_grid(i),idim)=xxg(i) end do end do ! Read father index read(ilun)iig if(ngridmax.ne.ngridmax2.and.ilevel>1)then do i=1,ncache pos(i)=(iig(i)-ncoarse-1)/ngridmax2 end do do i=1,ncache grid(i)=iig(i)-ncoarse-pos(i)*ngridmax2 end do do i=1,ncache iig(i)=ncoarse+pos(i)*ngridmax+grid(i) end do end if do i=1,ncache father(ind_grid(i))=iig(i) end do ! Read nbor index do ind=1,twondim read(ilun)iig if(ngridmax.ne.ngridmax2.and.ilevel>1)then do i=1,ncache pos(i)=(iig(i)-ncoarse-1)/ngridmax2 end do do i=1,ncache grid(i)=iig(i)-ncoarse-pos(i)*ngridmax2 end do do i=1,ncache iig(i)=ncoarse+pos(i)*ngridmax+grid(i) end do end if do i=1,ncache nbor(ind_grid(i),ind)=iig(i) end do end do ! Read son index do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax read(ilun)iig do i=1,ncache son(ind_grid(i)+iskip)=iig(i) end do end do ! Read cpu map do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax read(ilun)iig do i=1,ncache cpu_map(ind_grid(i)+iskip)=iig(i) end do end do ! Read refinement map do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax read(ilun)iig do i=1,ncache flag1(ind_grid(i)+iskip)=iig(i) end do end do deallocate(xxg,iig,pos,grid,ind_grid) end if end do end do close(ilun) #ifdef QUADHILBERT if(nrestart_quad.eq.nrestart) deallocate(bound_key_restart) #endif ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif #ifndef WITHOUTMPI if(debug)write(*,*)'amr.tmp read for processor ',myid call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(verbose)write(*,*)'AMR backup files read completed' ! Build communicators do ilevel=1,nlevelmax call build_comm(ilevel) end do end if end subroutine init_amr ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/init_flow_fine.f90 !################################################################ !################################################################ !################################################################ !################################################################ subroutine init_flow use amr_commons use hydro_commons, ONLY: nvar, uold use dice_commons implicit none integer::ilevel,ivar,i if(verbose)write(*,*)'Entering init_flow' do ilevel=nlevelmax,1,-1 if(ilevel>=levelmin)call init_flow_fine(ilevel) call upload_fine(ilevel) do ivar=1,nvar call make_virtual_fine_dp(uold(1,ivar),ilevel) end do if(simple_boundary)call make_boundary_hydro(ilevel) end do if(verbose)write(*,*)'Complete init_flow' #ifdef SOLVERmhd ! magnetic field parameters if(myid==1) write(*,'(A50)')'__________________________________________________' if(myid==1) write(*,*) 'Background magnetic field' if(myid==1) write(*,'(A50)')'__________________________________________________' if(myid==1) write(*,'(A,E15.7)') 'Bx:',ic_mag_const(1) if(myid==1) write(*,'(A,E15.7)') 'By:',ic_mag_const(2) if(myid==1) write(*,'(A,E15.7)') 'Bz:',ic_mag_const(3) do i=1,MAXGAL if (ic_mag_scale_B(i) .EQ. 0.0) cycle if(myid==1) write(*,'(A50)')'__________________________________________________' if(myid==1) write(*,'(A,I3)') ' Foreground magnetic field',i if(myid==1) write(*,'(A50)')'__________________________________________________' if(myid==1) write(*,'(A,E15.7)') 'pos x:', ic_mag_center_x(i) if(myid==1) write(*,'(A,E15.7)') 'pos y:', ic_mag_center_y(i) if(myid==1) write(*,'(A,E15.7)') 'pos z:', ic_mag_center_z(i) enddo if(myid==1) write(*,'(A50)')'__________________________________________________' #endif end subroutine init_flow !################################################################ !################################################################ !################################################################ !################################################################ subroutine init_flow_fine(ilevel) use amr_commons use hydro_commons use cooling_module use dice_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel integer::i,icell,igrid,ncache,iskip,ngrid,ilun integer::ind,idim,ivar,ix,iy,iz,nx_loc integer::i1,i2,i3,i1_min,i1_max,i2_min,i2_max,i3_min,i3_max integer::buf_count,info,nvar_in integer ,dimension(1:nvector),save::ind_grid,ind_cell real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v real(dp)::dx,rr,vx,vy,vz,ek,ei,pp,xx1,xx2,xx3,dx_loc,scale,xval real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:twotondim,1:3)::xc real(dp),dimension(1:nvector) ,save::vv real(dp),dimension(1:nvector,1:ndim),save::xx real(dp),dimension(1:nvector,1:nvar),save::uu real(dp)::axlen real(dp),allocatable,dimension(:,:,:)::init_array real(kind=4),allocatable,dimension(:,:) ::init_plane logical::error,ok_file1,ok_file2,ok_file3,ok_file ! CHANGED BY TTG MAY 2017 ! character(LEN=80)::filename character(LEN=256)::filename character(LEN=5)::nchar,ncharvar integer,parameter::tag=1107 integer::dummy_io,info2 if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! Mesh size at level ilevel in coarse cell units dx=0.5D0**ilevel ! Set position of cell centers relative to grid center do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do ! Local constants nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale ncache=active(ilevel)%ngrid !-------------------------------------- ! Compute initial conditions from files !-------------------------------------- filename=TRIM(initfile(ilevel))//'/ic_d' INQUIRE(file=filename,exist=ok_file1) if(multiple)then filename=TRIM(initfile(ilevel))//'/dir_deltab/ic_deltab.00001' INQUIRE(file=filename,exist=ok_file2) else filename=TRIM(initfile(ilevel))//'/ic_deltab' INQUIRE(file=filename,exist=ok_file2) endif ok_file = ok_file1 .or. ok_file2 if(ok_file)then !------------------------------------------------------------------------- ! First step: compute level boundaries in terms of initial condition array !------------------------------------------------------------------------- if(ncache>0)then i1_min=n1(ilevel)+1; i1_max=0 i2_min=n2(ilevel)+1; i2_max=0 i3_min=n3(ilevel)+1; i3_max=0 do ind=1,twotondim do i=1,ncache igrid=active(ilevel)%igrid(i) xx1=xg(igrid,1)+xc(ind,1)-skip_loc(1) xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel) xx2=xg(igrid,2)+xc(ind,2)-skip_loc(2) xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel) xx3=xg(igrid,3)+xc(ind,3)-skip_loc(3) xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel) i1_min=MIN(i1_min,int(xx1)+1) i1_max=MAX(i1_max,int(xx1)+1) i2_min=MIN(i2_min,int(xx2)+1) i2_max=MAX(i2_max,int(xx2)+1) i3_min=MIN(i3_min,int(xx3)+1) i3_max=MAX(i3_max,int(xx3)+1) end do end do error=.false. if(i1_min<1.or.i1_max>n1(ilevel))error=.true. if(i2_min<1.or.i2_max>n2(ilevel))error=.true. if(i3_min<1.or.i3_max>n3(ilevel))error=.true. if(error) then write(*,*)'Some grid are outside initial conditions sub-volume' write(*,*)'for ilevel=',ilevel write(*,*)i1_min,i1_max write(*,*)i2_min,i2_max write(*,*)i3_min,i3_max write(*,*)n1(ilevel),n2(ilevel),n3(ilevel) call clean_stop end if endif !----------------------------------------- ! Second step: read initial condition file !----------------------------------------- ! Allocate initial conditions array if(ncache>0)allocate(init_array(i1_min:i1_max,i2_min:i2_max,i3_min:i3_max)) allocate(init_plane(1:n1(ilevel),1:n2(ilevel))) ! Loop over input variables do ivar=1,nvar if(cosmo)then ! Read baryons initial overdensity and displacement at a=aexp if(multiple)then call title(myid,nchar) if(ivar==1)filename=TRIM(initfile(ilevel))//'/dir_deltab/ic_deltab.'//TRIM(nchar) if(ivar==2)filename=TRIM(initfile(ilevel))//'/dir_velcx/ic_velcx.'//TRIM(nchar) if(ivar==3)filename=TRIM(initfile(ilevel))//'/dir_velcy/ic_velcy.'//TRIM(nchar) if(ivar==4)filename=TRIM(initfile(ilevel))//'/dir_velcz/ic_velcz.'//TRIM(nchar) if(ivar==5)filename=TRIM(initfile(ilevel))//'/dir_tempb/ic_tempb.'//TRIM(nchar) else if(ivar==1)filename=TRIM(initfile(ilevel))//'/ic_deltab' if(ivar==2)filename=TRIM(initfile(ilevel))//'/ic_velcx' if(ivar==3)filename=TRIM(initfile(ilevel))//'/ic_velcy' if(ivar==4)filename=TRIM(initfile(ilevel))//'/ic_velcz' if(ivar==5)filename=TRIM(initfile(ilevel))//'/ic_tempb' endif else ! Read primitive variables if(ivar==1)filename=TRIM(initfile(ilevel))//'/ic_d' if(ivar==2)filename=TRIM(initfile(ilevel))//'/ic_u' if(ivar==3)filename=TRIM(initfile(ilevel))//'/ic_v' if(ivar==4)filename=TRIM(initfile(ilevel))//'/ic_w' if(ivar==5)filename=TRIM(initfile(ilevel))//'/ic_p' endif call title(ivar,ncharvar) if(ivar>5)then call title(ivar-5,ncharvar) filename=TRIM(initfile(ilevel))//'/ic_pvar_'//TRIM(ncharvar) endif INQUIRE(file=filename,exist=ok_file3) if(ok_file3)then ! Reading the existing file if(myid==1)write(*,*)'Reading file '//TRIM(filename) if(multiple)then ilun=ncpu+myid+10 ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(ilun,file=filename,form='unformatted') rewind ilun read(ilun) ! skip first line do i3=1,n3(ilevel) read(ilun) ((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel)) if(ncache>0)then if(i3.ge.i3_min.and.i3.le.i3_max)then init_array(i1_min:i1_max,i2_min:i2_max,i3) = & & init_plane(i1_min:i1_max,i2_min:i2_max) end if endif end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif else if(myid==1)then open(10,file=filename,form='unformatted') rewind 10 read(10) ! skip first line endif do i3=1,n3(ilevel) if(myid==1)then read(10) ((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel)) else init_plane=0.0 endif buf_count=n1(ilevel)*n2(ilevel) #ifndef WITHOUTMPI call MPI_BCAST(init_plane,buf_count,MPI_REAL,0,MPI_COMM_WORLD,info) #endif if(ncache>0)then if(i3.ge.i3_min.and.i3.le.i3_max)then init_array(i1_min:i1_max,i2_min:i2_max,i3) = & & init_plane(i1_min:i1_max,i2_min:i2_max) end if endif end do if(myid==1)close(10) endif else ! If file doesn't exist, initialize variable to default value ! In most cases, this is zero (you can change that if necessary) if(myid==1)write(*,*)'File '//TRIM(filename)//' not found' if(myid==1)write(*,*)'Initialize corresponding variable to default value' if(ncache>0)then init_array=0d0 ! Default value for metals if(cosmo.and.ivar==imetal.and.metal)init_array=z_ave*0.02 ! from solar units ! Default value for ionization fraction if(cosmo)xval=sqrt(omega_m)/(h0/100.*omega_b) ! From the book of Peebles p. 173 if(cosmo.and.ivar==ixion.and.aton)init_array=1.2d-5*xval endif endif if(ncache>0)then ! For cosmo runs, rescale initial conditions to code units if(cosmo)then ! Compute approximate average temperature in K if(.not. cooling)T2_start=1.356d-2/aexp**2 if(ivar==1)init_array=(1.0+dfact(ilevel)*init_array)*omega_b/omega_m if(ivar==2)init_array=dfact(ilevel)*vfact(1)*dx_loc/dxini(ilevel)*init_array/vfact(ilevel) if(ivar==3)init_array=dfact(ilevel)*vfact(1)*dx_loc/dxini(ilevel)*init_array/vfact(ilevel) if(ivar==4)init_array=dfact(ilevel)*vfact(1)*dx_loc/dxini(ilevel)*init_array/vfact(ilevel) if(ivar==ndim+2)init_array=(1.0+init_array)*T2_start/scale_T2 endif ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ncache igrid=active(ilevel)%igrid(i) icell=igrid+iskip xx1=xg(igrid,1)+xc(ind,1)-skip_loc(1) xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel) xx2=xg(igrid,2)+xc(ind,2)-skip_loc(2) xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel) xx3=xg(igrid,3)+xc(ind,3)-skip_loc(3) xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel) i1=int(xx1)+1 i1=int(xx1)+1 i2=int(xx2)+1 i2=int(xx2)+1 i3=int(xx3)+1 i3=int(xx3)+1 ! Scatter to corresponding primitive variable uold(icell,ivar)=init_array(i1,i2,i3) end do end do ! End loop over cells endif end do ! End loop over input variables ! Deallocate initial conditions array if(ncache>0)deallocate(init_array) deallocate(init_plane) !---------------------------------------------------------------- ! For cosmology runs: compute pressure, prevent negative density !---------------------------------------------------------------- if(cosmo)then ! Loop over grids by vector sweeps do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do ! Loop over cells do ind=1,twotondim ! Gather cell indices iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do ! Prevent negative density do i=1,ngrid rr=max(uold(ind_cell(i),1),0.1*omega_b/omega_m) uold(ind_cell(i),1)=rr end do ! Compute pressure from temperature and density do i=1,ngrid uold(ind_cell(i),ndim+2)=uold(ind_cell(i),1)*uold(ind_cell(i),ndim+2) end do end do ! End loop over cells end do ! End loop over grids end if !--------------------------------------------------- ! Third step: compute initial conservative variables !--------------------------------------------------- ! Loop over grids by vector sweeps do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do vy=0.0 vz=0.0 ! Loop over cells do ind=1,twotondim ! Gather cell indices iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do ! Compute total energy density do i=1,ngrid rr=uold(ind_cell(i),1) vx=uold(ind_cell(i),2) #if NDIM>1 vy=uold(ind_cell(i),3) #endif #if NDIM>2 vz=uold(ind_cell(i),4) #endif pp=uold(ind_cell(i),ndim+2) ek=0.5d0*(vx**2+vy**2+vz**2) ei=pp/(gamma-1.0) vv(i)=ei+rr*ek end do ! Scatter to corresponding conservative variable do i=1,ngrid uold(ind_cell(i),ndim+2)=vv(i) end do ! Compute momentum density do ivar=1,ndim do i=1,ngrid rr=uold(ind_cell(i),1) vx=uold(ind_cell(i),ivar+1) vv(i)=rr*vx end do ! Scatter to corresponding conservative variable do i=1,ngrid uold(ind_cell(i),ivar+1)=vv(i) end do end do #if NVAR > NDIM + 2 ! Compute passive variable density do ivar=ndim+3,nvar do i=1,ngrid rr=uold(ind_cell(i),1) uold(ind_cell(i),ivar)=rr*uold(ind_cell(i),ivar) end do enddo #endif end do ! End loop over cells end do ! End loop over grids !------------------------------------------------------- ! Compute initial conditions from subroutine condinit !------------------------------------------------------- else do i=1,MAXGAL if (ic_mag_scale_B(i) .EQ. 0.0) cycle ! renormalise axes axlen = SQRT(ic_mag_axis_x(i)**2 + ic_mag_axis_y(i)**2 + ic_mag_axis_z(i)**2) ic_mag_axis_x(i) = ic_mag_axis_x(i) / axlen ic_mag_axis_y(i) = ic_mag_axis_y(i) / axlen ic_mag_axis_z(i) = ic_mag_axis_z(i) / axlen enddo call reset_uold(ilevel) ! Update the grid using the gas particles read from the Gadget1 file ! NGP scheme is used call condinit_loc(ilevel) ! Reverse update boundaries do ivar=1,nvar call make_virtual_reverse_dp(uold(1,ivar),ilevel) end do ! CHANGED BY TTG (FEB 2017); comment was previously preceding the call to reset_uold ! Initialise uold with values from the DICE_PARAMS namelist call init_uold(ilevel) do ivar=1,nvar call make_virtual_fine_dp(uold(1,ivar),ilevel) end do end if 111 format(' Entering init_flow_fine for level ',I2) end subroutine init_flow_fine !################################################################ !################################################################ !################################################################ !################################################################ subroutine region_condinit(x,q,dx,nn) use amr_parameters use hydro_parameters implicit none integer ::nn real(dp)::dx real(dp),dimension(1:nvector,1:nvar)::q real(dp),dimension(1:nvector,1:ndim)::x integer::i,ivar,k real(dp)::vol,r,xn,yn,zn,en ! Set some (tiny) default values in case n_region=0 q(1:nn,1)=smallr q(1:nn,2)=0.0d0 #if NDIM>1 q(1:nn,3)=0.0d0 #endif #if NDIM>2 q(1:nn,4)=0.0d0 #endif q(1:nn,ndim+2)=smallr*smallc**2/gamma #if NVAR > NDIM + 2 do ivar=ndim+3,nvar q(1:nn,ivar)=0.0d0 end do #endif ! Loop over initial conditions regions do k=1,nregion ! For 'square' regions only: if(region_type(k) .eq. 'square')then ! Exponent of choosen norm en=exp_region(k) do i=1,nn ! Compute position in normalized coordinates xn=0.0d0; yn=0.0d0; zn=0.0d0 xn=2.0d0*abs(x(i,1)-x_center(k))/length_x(k) #if NDIM>1 yn=2.0d0*abs(x(i,2)-y_center(k))/length_y(k) #endif #if NDIM>2 zn=2.0d0*abs(x(i,3)-z_center(k))/length_z(k) #endif ! Compute cell 'radius' relative to region center if(exp_region(k)<10)then r=(xn**en+yn**en+zn**en)**(1.0/en) else r=max(xn,yn,zn) end if ! If cell lies within region, ! REPLACE primitive variables by region values if(r<1.0)then q(i,1)=d_region(k) q(i,2)=u_region(k) #if NDIM>1 q(i,3)=v_region(k) #endif #if NDIM>2 q(i,4)=w_region(k) #endif q(i,ndim+2)=p_region(k) #if NENER>0 do ivar=1,nener q(i,ndim+2+ivar)=prad_region(k,ivar) enddo #endif #if NVAR>NDIM+2+NENER do ivar=ndim+3+nener,nvar q(i,ivar)=var_region(k,ivar-ndim-2-nener) end do #endif end if end do end if ! For 'point' regions only: if(region_type(k) .eq. 'point')then ! Volume elements vol=dx**ndim ! Compute CIC weights relative to region center do i=1,nn xn=1.0; yn=1.0; zn=1.0 xn=max(1.0-abs(x(i,1)-x_center(k))/dx,0.0_dp) #if NDIM>1 yn=max(1.0-abs(x(i,2)-y_center(k))/dx,0.0_dp) #endif #if NDIM>2 zn=max(1.0-abs(x(i,3)-z_center(k))/dx,0.0_dp) #endif r=xn*yn*zn ! If cell lies within CIC cloud, ! ADD to primitive variables the region values q(i,1)=q(i,1)+d_region(k)*r/vol q(i,2)=q(i,2)+u_region(k)*r #if NDIM>1 q(i,3)=q(i,3)+v_region(k)*r #endif #if NDIM>2 q(i,4)=q(i,4)+w_region(k)*r #endif q(i,ndim+2)=q(i,ndim+2)+p_region(k)*r/vol #if NENER>0 do ivar=1,nener q(i,ndim+2+ivar)=q(i,ndim+2+ivar)+prad_region(k,ivar)*r/vol enddo #endif #if NVAR>NDIM+2+NENER do ivar=ndim+3+nener,nvar q(i,ivar)=var_region(k,ivar-ndim-2-nener) end do #endif end do end if end do return end subroutine region_condinit subroutine reset_uold(ilevel) use amr_commons use hydro_commons use dice_commons implicit none integer::ilevel !-------------------------------------------------------------------------- ! This routine sets array uold to zero before calling ! the hydro scheme. uold is set to zero in virtual boundaries as well. !-------------------------------------------------------------------------- integer::i,ivar,irad,ind,icpu,iskip if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Set uold to uold for myid cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do ivar=1,nvar do i=1,active(ilevel)%ngrid uold(active(ilevel)%igrid(i)+iskip,ivar)=0D0 end do end do end do ! Set uold to 0 for virtual boundary cells do icpu=1,ncpu do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do ivar=1,nvar do i=1,reception(icpu,ilevel)%ngrid uold(reception(icpu,ilevel)%igrid(i)+iskip,ivar)=0D0 end do end do end do end do ! CHANGED BY TTG (FEB 2017) ! 111 format(' Entering init_uold for level ',i2) 111 format(' Entering reset_uold for level ',i2) end subroutine reset_uold subroutine init_uold(ilevel) use amr_commons use hydro_commons use dice_commons ! RESTART patch use restart_commons ! RESTART patch implicit none integer::ilevel,info !-------------------------------------------------------------------------- ! This routine sets array unew to its initial value uold before calling ! the hydro scheme. unew is set to zero in virtual boundaries. !-------------------------------------------------------------------------- integer::i,ivar,irad,ind,icpu,iskip,idim real(dp)::d,u,v,w,e real(dp)::scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2 call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Set uold to namelist values for myid cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do ivar=nvar,1,-1 do i=1,active(ilevel)%ngrid if(uold(active(ilevel)%igrid(i)+iskip,1).lt.IG_rho/scale_nH) then uold(active(ilevel)%igrid(i)+iskip,ivar) = 0D0 if(ivar.eq.1) uold(active(ilevel)%igrid(i)+iskip,ivar) = max(IG_rho/scale_nH,smallr) if(ivar.eq.ndim+2)then uold(active(ilevel)%igrid(i)+iskip,ivar) = IG_T2/scale_T2/(gamma-1)*max(IG_rho/scale_nH,smallr) endif !IMPORTANT (TTG 2017): uold(:,imetal) corresponds to total metal mass density (i.e density * Z; Z = metal mass fraction) if(metal) then if(ivar.eq.imetal) uold(active(ilevel)%igrid(i)+iskip,ivar) = max(IG_rho/scale_nH,smallr)*IG_metal endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) if(ivar.eq.itracer) uold(active(ilevel)%igrid(i)+iskip,ivar) = 0.d0 endif end do end do end do ! Set cell averaged kinetic energy do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid e = 0d0 do idim=1,ndim e = e+0.5*uold(active(ilevel)%igrid(i)+iskip,idim+1)**2/uold(active(ilevel)%igrid(i)+iskip,1) enddo uold(active(ilevel)%igrid(i)+iskip,ndim+2) = uold(active(ilevel)%igrid(i)+iskip,ndim+2)+e end do end do #ifdef SOLVERmhd ! set constant magnetic field CALL mag_constant(ilevel) ! toroidal field CALL mag_compute(ilevel) #endif ! Set uold to 0 for virtual boundary cells do icpu=1,ncpu do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do ivar=1,nvar do i=1,reception(icpu,ilevel)%ngrid uold(reception(icpu,ilevel)%igrid(i)+iskip,ivar)=0.0 end do end do end do end do 111 format(' Entering init_uold for level ',i2) end subroutine init_uold subroutine condinit_loc(ilevel) use amr_commons use pm_commons use hydro_commons use poisson_commons use dice_commons implicit none integer::ilevel !------------------------------------------------------------------ ! This routine computes the initial density field at level ilevel using ! the CIC scheme from particles that are not entirely in ! level ilevel (boundary particles). ! Arrays flag1 and flag2 are used as temporary work space. !------------------------------------------------------------------ integer::igrid,jgrid,ipart,jpart,idim,icpu,next_part integer::i,ig,ip,npart1,npart2 real(dp)::dx integer,dimension(1:nvector),save::ind_grid,ind_cell integer,dimension(1:nvector),save::ind_part,ind_grid_part real(dp),dimension(1:nvector,1:ndim),save::x0 if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Mesh spacing in that level dx=0.5D0**ilevel ! Loop over cpus do icpu=1,ncpu ! Loop over grids igrid=headl(icpu,ilevel) ig=0 ip=0 do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid npart2=0 ! Count gas particles if(npart1>0)then ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ! if(idp(ipart).eq.1)then !TTG (FEB 2017): select gas particles (defined by init_part.f90 to have ID = 1) if(MOD(idp(ipart),2).eq.0)then !TTG (MAR 2017): select gas particles (defined by DICE / RESTART to have even ID) npart2=npart2+1 endif ipart=next_part ! Go to next particle end do endif ! Gather gas particles if(npart2>0)then ig=ig+1 ind_grid(ig)=igrid ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ! if(idp(ipart).eq.1)then !TTG (FEB 2017): select gas particles (defined by init_part.f90 to have ID = 1) if(MOD(idp(ipart),2).eq.0)then !TTG (MAR 2017): select gas particles (defined by DICE/ RESTART to have even ID) if(ig==0)then ig=1 ind_grid(ig)=igrid end if ip=ip+1 ind_part(ip)=ipart ind_grid_part(ip)=ig endif if(ip==nvector)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ig x0(i,idim)=xg(ind_grid(i),idim)-3.0D0*dx end do end do do i=1,ig ind_cell(i)=father(ind_grid(i)) end do if(amr_struct) then call init_gas_ngp(ind_grid,ind_part,ind_grid_part,ig,ip,ilevel) else call init_gas_cic(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) endif ip=0 ig=0 end if ipart=next_part ! Go to next particle end do ! End loop over particles end if igrid=next(igrid) ! Go to next grid end do ! End loop over grids if(ip>0)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ig x0(i,idim)=xg(ind_grid(i),idim)-3.0D0*dx end do end do do i=1,ig ind_cell(i)=father(ind_grid(i)) end do if(amr_struct) then call init_gas_ngp(ind_grid,ind_part,ind_grid_part,ig,ip,ilevel) else call init_gas_cic(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) endif end if end do 111 format(' Entering condinit_loc for level ',I2) end subroutine condinit_loc !================================================================================== !================================================================================== !================================================================================== subroutine init_gas_cic(ind_cell,ind_part,ind_grid_part,x0,ng,np,ilevel) use amr_commons use pm_commons use hydro_commons use dice_commons use cooling_module implicit none integer::ng,np,ilevel integer ,dimension(1:nvector)::ind_cell,ind_grid_part,ind_part real(dp),dimension(1:nvector,1:ndim)::x0 !------------------------------------------------------------------ ! This routine computes the initial density field at level ilevel using ! the CIC scheme. Only cells that are in level ilevel ! are updated by the input particle list. !------------------------------------------------------------------ logical::error integer::j,ind,idim,nx_loc real(dp)::dx,dx_loc,scale ! Grid-based arrays integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids ! Particle-based arrays logical ,dimension(1:nvector),save::ok real(dp),dimension(1:nvector,1:ndim),save::xx,dd,dg integer ,dimension(1:nvector,1:ndim),save::ig,id,igg,igd,icg,icd real(dp),dimension(1:nvector,1:twotondim),save::vol integer ,dimension(1:nvector,1:twotondim),save::igrid,icell,indp,kg real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:nvector),save::ethermal real(dp),dimension(1:nvector),save::vol_loc real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v,scale_m ! ADDED BY TTG (FEB 2017) if(verbose)write(*,111)ilevel call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc(1:nvector)=dx_loc**ndim ! Gather neighboring father cells (should be present anytime !) call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ng,ilevel) ! Rescale particle position at level ilevel do idim=1,ndim do j=1,np xx(j,idim)=xp(ind_part(j),idim)/scale+skip_loc(idim) end do end do do idim=1,ndim do j=1,np xx(j,idim)=xx(j,idim)-x0(ind_grid_part(j),idim) end do end do do idim=1,ndim do j=1,np xx(j,idim)=xx(j,idim)/dx end do end do ! Check for illegal moves error=.false. do idim=1,ndim do j=1,np if(xx(j,idim)<0.5D0.or.xx(j,idim)>5.5D0)error=.true. end do end do if(error)then write(*,*)'problem in cic' do idim=1,ndim do j=1,np if(xx(j,idim)<0.5D0.or.xx(j,idim)>5.5D0)then write(*,*)xx(j,1:ndim) endif end do end do stop end if ! CIC at level ilevel (dd: right cloud boundary; dg: left cloud boundary) do idim=1,ndim do j=1,np dd(j,idim)=xx(j,idim)+0.5D0 id(j,idim)=dd(j,idim) dd(j,idim)=dd(j,idim)-id(j,idim) dg(j,idim)=1.0D0-dd(j,idim) ig(j,idim)=id(j,idim)-1 end do end do ! Compute cloud volumes #if NDIM==1 do j=1,np vol(j,1)=dg(j,1) vol(j,2)=dd(j,1) end do #endif #if NDIM==2 do j=1,np vol(j,1)=dg(j,1)*dg(j,2) vol(j,2)=dd(j,1)*dg(j,2) vol(j,3)=dg(j,1)*dd(j,2) vol(j,4)=dd(j,1)*dd(j,2) end do #endif #if NDIM==3 do j=1,np vol(j,1)=dg(j,1)*dg(j,2)*dg(j,3) vol(j,2)=dd(j,1)*dg(j,2)*dg(j,3) vol(j,3)=dg(j,1)*dd(j,2)*dg(j,3) vol(j,4)=dd(j,1)*dd(j,2)*dg(j,3) vol(j,5)=dg(j,1)*dg(j,2)*dd(j,3) vol(j,6)=dd(j,1)*dg(j,2)*dd(j,3) vol(j,7)=dg(j,1)*dd(j,2)*dd(j,3) vol(j,8)=dd(j,1)*dd(j,2)*dd(j,3) end do #endif ! Compute parent grids do idim=1,ndim do j=1,np igg(j,idim)=ig(j,idim)/2 igd(j,idim)=id(j,idim)/2 end do end do #if NDIM==1 do j=1,np kg(j,1)=1+igg(j,1) kg(j,2)=1+igd(j,1) end do #endif #if NDIM==2 do j=1,np kg(j,1)=1+igg(j,1)+3*igg(j,2) kg(j,2)=1+igd(j,1)+3*igg(j,2) kg(j,3)=1+igg(j,1)+3*igd(j,2) kg(j,4)=1+igd(j,1)+3*igd(j,2) end do #endif #if NDIM==3 do j=1,np kg(j,1)=1+igg(j,1)+3*igg(j,2)+9*igg(j,3) kg(j,2)=1+igd(j,1)+3*igg(j,2)+9*igg(j,3) kg(j,3)=1+igg(j,1)+3*igd(j,2)+9*igg(j,3) kg(j,4)=1+igd(j,1)+3*igd(j,2)+9*igg(j,3) kg(j,5)=1+igg(j,1)+3*igg(j,2)+9*igd(j,3) kg(j,6)=1+igd(j,1)+3*igg(j,2)+9*igd(j,3) kg(j,7)=1+igg(j,1)+3*igd(j,2)+9*igd(j,3) kg(j,8)=1+igd(j,1)+3*igd(j,2)+9*igd(j,3) end do #endif do ind=1,twotondim do j=1,np if(nbors_father_cells(ind_grid_part(j),kg(j,ind)).gt.0) then igrid(j,ind)=son(nbors_father_cells(ind_grid_part(j),kg(j,ind))) else igrid(j,ind)=0 endif end do end do ! Compute parent cell position do idim=1,ndim do j=1,np icg(j,idim)=ig(j,idim)-2*igg(j,idim) icd(j,idim)=id(j,idim)-2*igd(j,idim) end do end do #if NDIM==1 do j=1,np icell(j,1)=1+icg(j,1) icell(j,2)=1+icd(j,1) end do #endif #if NDIM==2 do j=1,np icell(j,1)=1+icg(j,1)+2*icg(j,2) icell(j,2)=1+icd(j,1)+2*icg(j,2) icell(j,3)=1+icg(j,1)+2*icd(j,2) icell(j,4)=1+icd(j,1)+2*icd(j,2) end do #endif #if NDIM==3 do j=1,np icell(j,1)=1+icg(j,1)+2*icg(j,2)+4*icg(j,3) icell(j,2)=1+icd(j,1)+2*icg(j,2)+4*icg(j,3) icell(j,3)=1+icg(j,1)+2*icd(j,2)+4*icg(j,3) icell(j,4)=1+icd(j,1)+2*icd(j,2)+4*icg(j,3) icell(j,5)=1+icg(j,1)+2*icg(j,2)+4*icd(j,3) icell(j,6)=1+icd(j,1)+2*icg(j,2)+4*icd(j,3) icell(j,7)=1+icg(j,1)+2*icd(j,2)+4*icd(j,3) icell(j,8)=1+icd(j,1)+2*icd(j,2)+4*icd(j,3) end do #endif ! Update mass density and number density fields do ind=1,twotondim ! Check if particles are entirely in level ilevel do j=1,np ok(j)=igrid(j,ind)>0 end do ! Compute parent cell adress do j=1,np if(ok(j))then indp(j,ind)=ncoarse+(icell(j,ind)-1)*ngridmax+igrid(j,ind) end if end do ! Update hydro variables do j=1,np if(ok(j)) then ! Specific kinetic energy of the gas particle ! TTG (MAR 2017): specific INTERNAL energy, actually ethermal(j)=up(ind_part(j)) ! Update hydro variable in CIC cells uold(indp(j,ind),1)=uold(indp(j,ind),1)+mp(ind_part(j))*vol(j,ind)/vol_loc(j) do idim=1,ndim uold(indp(j,ind),idim+1)=uold(indp(j,ind),idim+1)+mp(ind_part(j))*vol(j,ind)/vol_loc(j)*vp(ind_part(j),idim) end do uold(indp(j,ind),ndim+2)=uold(indp(j,ind),ndim+2)+mp(ind_part(j))*vol(j,ind)/vol_loc(j)*ethermal(j) !TTG (FEB 2017): should check for star or sink here as well to avoid segmentation fault !since zp is only allocated if(star.or.sink).and.(metal) = true !NOTE: I have patched init_part.f90 and output_part.f90 to allow the use !of metal=.true. w/o star or sink=.true. !DICE / RESTART specific !IMPORTANT: uold(:,imetal) corresponds to metal mass density (i.e density * Z; Z = metal mass fraction) if(metal) then uold(indp(j,ind),imetal)=uold(indp(j,ind),imetal)+mp(ind_part(j))*vol(j,ind)/vol_loc(j)*zp(ind_part(j)) endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) uold(indp(j,ind),itracer)=uold(indp(j,ind),itracer)+mp(ind_part(j))*vol(j,ind)/vol_loc(j)*trcp(ind_part(j)) if(cosmo) then if(ivar_refine.gt.0) then uold(indp(j,ind),ivar_refine)=uold(indp(j,ind),ivar_refine)+mp(ind_part(j))*vol(j,ind)/vol_loc(j)*maskp(ind_part(j)) endif endif endif end do end do ! ADDED BY TTG (FEB 2017) 111 format(' Entering init_gas_cic for level ',I2) end subroutine init_gas_cic subroutine init_gas_ngp(ind_grid,ind_part,ind_grid_part,ng,np,ilevel) use amr_commons use pm_commons use hydro_commons use random use dice_commons implicit none integer::ng,np,ilevel integer,dimension(1:nvector)::ind_grid integer,dimension(1:nvector)::ind_grid_part,ind_part !------------------------------------------------------------------ ! This routine computes the initial density field at level ilevel using ! the NGP scheme. Only cells that are in level ilevel ! are updated by the input particle list. !------------------------------------------------------------------ integer::i,j,idim,nx_loc,ivar real(dp)::dx,dx_loc,scale ! Grid based arrays real(dp),dimension(1:nvector,1:ndim),save::x0 integer ,dimension(1:nvector),save::ind_cell integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids real(dp),dimension(1:nvector),save::ethermal ! Particle based arrays logical ,dimension(1:nvector),save::ok real(dp),dimension(1:nvector),save::vol_loc real(dp),dimension(1:nvector,1:ndim),save::x integer ,dimension(1:nvector,1:ndim),save::id,igd,icd integer ,dimension(1:nvector),save::igrid,icell,indp,kg real(dp),dimension(1:3)::skip_loc ! ADDED BY TTG (FEB 2017) if(verbose)write(*,111)ilevel ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc(1:nvector)=dx_loc**ndim ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ng x0(i,idim)=xg(ind_grid(i),idim)-3.0D0*dx end do end do ! Gather 27 neighboring father cells (should be present anytime !) do i=1,ng ind_cell(i)=father(ind_grid(i)) end do call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ng,ilevel) ! Rescale position at level ilevel do idim=1,ndim do j=1,np x(j,idim)=xp(ind_part(j),idim)/scale+skip_loc(idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)-x0(ind_grid_part(j),idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/dx end do end do ! NGP at level ilevel do idim=1,ndim do j=1,np id(j,idim)=x(j,idim) end do end do ! Compute parent grids do idim=1,ndim do j=1,np igd(j,idim)=id(j,idim)/2 end do end do do j=1,np kg(j)=1+igd(j,1)+3*igd(j,2)+9*igd(j,3) end do do j=1,np if(nbors_father_cells(ind_grid_part(j),kg(j)).gt.0) then igrid(j)=son(nbors_father_cells(ind_grid_part(j),kg(j))) else igrid(j)=0 endif end do ! Compute parent cell position do idim=1,ndim do j=1,np icd(j,idim)=id(j,idim)-2*igd(j,idim) end do end do do j=1,np icell(j)=1+icd(j,1)+2*icd(j,2)+4*icd(j,3) end do ! Check if particles are entirely in level ilevel do j=1,np ok(j)=igrid(j)>0 end do ! Compute parent cell adresses do j=1,np if(ok(j))then indp(j)=ncoarse+(icell(j)-1)*ngridmax+igrid(j) endif end do ! Update hydro variables do j=1,np if(ok(j))then ethermal(j)=up(ind_part(j)) ! Update density in NGP cell uold(indp(j),1)=uold(indp(j),1)+mp(ind_part(j))/vol_loc(j) ! Update velocity in NGP cell do idim=1,ndim uold(indp(j),idim+1)=uold(indp(j),idim+1)+mp(ind_part(j))/vol_loc(j)*vp(ind_part(j),idim) end do ! Update temperature in NGP cell uold(indp(j),ndim+2)=uold(indp(j),ndim+2)+mp(ind_part(j))/vol_loc(j)*ethermal(j) ! Update passive hydro variables in NGP cell !TTG (FEB 2017): should check for star or sink here as well to avoid segmentation fault !since zp is only allocated if(star.or.sink).and.(metal) = true !NOTE: I have patched init_part.f90 and output_part.f90 to allow the use !of metal=.true. w/o star or sink=.true. !DICE / RESTART specific !IMPORTANT: uold(:,imetal) corresponds to metal mass density (i.e density * Z; Z = metal mass fraction) if(metal) then uold(indp(j),imetal)=uold(indp(j),imetal)+mp(ind_part(j))/vol_loc(j)*zp(ind_part(j)) endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) uold(indp(j),itracer)=uold(indp(j),itracer)+mp(ind_part(j))/vol_loc(j)*trcp(ind_part(j)) if(ivar_refine.gt.0) then uold(indp(j),ivar_refine)=uold(indp(j),ivar_refine)+mp(ind_part(j))/vol_loc(j)*maskp(ind_part(j)) endif endif end do ! ADDED BY TTG (FEB 2017) 111 format(' Entering init_gas_ngp for level ',I2) end subroutine init_gas_ngp #ifdef SOLVERmhd subroutine mag_constant(ilevel) ! constant background magnetic field use amr_commons use hydro_commons use dice_commons implicit none integer::i,ind,iskip,ilevel do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid uold(active(ilevel)%igrid(i)+iskip,6:8) = ic_mag_const uold(active(ilevel)%igrid(i)+iskip,nvar+1:nvar+3) = ic_mag_const enddo enddo end subroutine mag_constant subroutine mag_compute(ilevel) use amr_commons !use pm_commons use hydro_commons use dice_commons !use random implicit none integer::i,j,ilevel,icell logical::nogal real(dp)::Axdl,Axdr,Axul,Axur real(dp)::Aydl,Aydr,Ayul,Ayur real(dp)::Azdl,Azdr,Azul,Azur real(dp)::Bxl,Bxr,Byl,Byr,Bzl,Bzr real(dp),dimension(1:3)::pos,cell_center real(dp)::dx,dxhalf,dxmin,dxminhalf,scale,dx_loc,vol_loc integer::nx_loc,ind,ix,iy,iz,iskip,nfine real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:twotondim,1:3)::xc nogal=.true. do i=1,MAXGAL ! check if galaxy has a magnetic field if (ic_mag_scale_B(i) .NE. 0.0) nogal=.false. enddo if (nogal) return ! Mesh spacing in that level dx=0.5D0**ilevel dxhalf = 0.5D0*dx dxmin = 0.5D0**nlevelmax dxminhalf = 0.5D0*dxmin nfine = 2**(nlevelmax-ilevel) nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do ! compute field do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do j=1,active(ilevel)%ngrid icell=active(ilevel)%igrid(j) cell_center = xg(icell,:)+xc(ind,:)-skip_loc(:) ! edge coordinates ! Ax pos = cell_center pos(1) = pos(1) - dxhalf + dxminhalf pos(2) = pos(2) - dxhalf pos(3) = pos(3) - dxhalf Axdl=0.0;Axdr=0.0;Axul=0.0;Axur=0.0 do i=1,nfine CALL mag_toroidal(pos,1,Axdl) pos(1) = pos(1) + dxmin enddo pos(2) = pos(2) + dx do i=1,nfine pos(1) = pos(1) - dxmin CALL mag_toroidal(pos,1,Axdr) enddo pos(3) = pos(3) + dx do i=1,nfine CALL mag_toroidal(pos,1,Axur) pos(1) = pos(1) + dxmin enddo pos(2) = pos(2) - dx do i=1,nfine pos(1) = pos(1) - dxmin CALL mag_toroidal(pos,1,Axul) enddo ! Ay pos = cell_center pos(1) = pos(1) - dxhalf pos(2) = pos(2) - dxhalf + dxminhalf pos(3) = pos(3) - dxhalf Aydl=0.0;Aydr=0.0;Ayul=0.0;Ayur=0.0 do i=1,nfine CALL mag_toroidal(pos,2,Aydl) pos(2) = pos(2) + dxmin enddo pos(1) = pos(1) + dx do i=1,nfine pos(2) = pos(2) - dxmin CALL mag_toroidal(pos,2,Aydr) enddo pos(3) = pos(3) + dx do i=1,nfine CALL mag_toroidal(pos,2,Ayur) pos(2) = pos(2) + dxmin enddo pos(1) = pos(1) - dx do i=1,nfine pos(2) = pos(2) - dxmin CALL mag_toroidal(pos,2,Ayul) enddo ! Az pos = cell_center pos(1) = pos(1) - dxhalf pos(2) = pos(2) - dxhalf pos(3) = pos(3) - dxhalf + dxminhalf Azdl=0.0;Azdr=0.0;Azul=0.0;Azur=0.0 do i=1,nfine CALL mag_toroidal(pos,3,Azdl) pos(3) = pos(3) + dxmin enddo pos(1) = pos(1) + dx do i=1,nfine pos(3) = pos(3) - dxmin CALL mag_toroidal(pos,3,Azdr) enddo pos(2) = pos(2) + dx do i=1,nfine CALL mag_toroidal(pos,3,Azur) pos(3) = pos(3) + dxmin enddo pos(1) = pos(1) - dx do i=1,nfine pos(3) = pos(3) - dxmin CALL mag_toroidal(pos,3,Azul) enddo ! Bx left Bxl = ((Azul - Azdl) - (Ayul - Aydl))/dx / nfine uold(icell+iskip,6) = uold(icell+iskip,6) + Bxl ! By left Byl = ((Axul - Axdl) - (Azdr - Azdl))/dx / nfine uold(icell+iskip,7) = uold(icell+iskip,7) + Byl ! Bz left Bzl = ((Aydr - Aydl) - (Axdr - Axdl))/dx / nfine uold(icell+iskip,8) = uold(icell+iskip,8) + Bzl ! Bx right Bxr = ((Azur - Azdr) - (Ayur - Aydr))/dx / nfine uold(icell+iskip,nvar+1) = uold(icell+iskip,nvar+1) + Bxr ! By right Byr = ((Axur - Axdr) - (Azur - Azul))/dx / nfine uold(icell+iskip,nvar+2) = uold(icell+iskip,nvar+2) + Byr ! Bz right Bzr = ((Ayur - Ayul) - (Axur - Axul))/dx / nfine uold(icell+iskip,nvar+3) = uold(icell+iskip,nvar+3) + Bzr end do end do end subroutine mag_compute subroutine mag_toroidal(pos,dir,A) use dice_commons use amr_parameters, ONLY: boxlen implicit none real(dp)::r,h real(dp)::Ah,A integer::i,dir real(dp),dimension(1:3)::pos,gcenter,gaxis,xrel,grad real(dp)::sB,sR,sH do i=1,MAXGAL ! check if galaxy has a magnetic field if (ic_mag_scale_B(i) .EQ. 0.0) cycle gcenter(1) = 0.5d0 + ic_mag_center_x(i)/boxlen gcenter(2) = 0.5d0 + ic_mag_center_y(i)/boxlen gcenter(3) = 0.5d0 + ic_mag_center_z(i)/boxlen gaxis(1) = ic_mag_axis_x(i) gaxis(2) = ic_mag_axis_y(i) gaxis(3) = ic_mag_axis_z(i) sR = ic_mag_scale_R(i) / boxlen sH = ic_mag_scale_H(i) / boxlen sB = ic_mag_scale_B(i) ! coordinates in galaxy frame xrel = pos - gcenter h = DOT_PRODUCT(xrel,gaxis) grad = xrel - h*gaxis r = NORM2(grad) Ah = sB * sR * exp(-r/sR) * exp(-ABS(h)/sH) ! vector in cartesian frame A = A + Ah*gaxis(dir) end do end subroutine #endif ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/init_hydro.f90 subroutine init_hydro use amr_commons use hydro_commons #ifdef RT use rt_parameters,only: convert_birth_times #endif implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ncell,ncache,iskip,igrid,i,ilevel,ind,ivar,irad integer::nvar2,ilevel2,numbl2,ilun,ibound,istart,info integer::ncpu2,ndim2,nlevelmax2,nboundary2 integer ,dimension(:),allocatable::ind_grid real(dp),dimension(:),allocatable::xx real(dp)::gamma2 ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar,ncharcpu integer,parameter::tag=1108 integer::dummy_io,info2 if(verbose)write(*,*)'Entering init_hydro' !------------------------------------------------------ ! Allocate conservative, cell-centered variables arrays !------------------------------------------------------ ncell=ncoarse+twotondim*ngridmax allocate(uold(1:ncell,1:nvar)) allocate(unew(1:ncell,1:nvar)) uold=0.0d0; unew=0.0d0 if(pressure_fix)then allocate(divu(1:ncell)) allocate(enew(1:ncell)) divu=0.0d0; enew=0.0d0 end if !-------------------------------- ! For a restart, read hydro file !-------------------------------- if(nrestart>0)then ilun=ncpu+myid+10 call title(nrestart,nchar) if(IOGROUPSIZEREP>0)then call title(((myid-1)/IOGROUPSIZEREP)+1,ncharcpu) ! CHANGED BY TTG (FEB 2017) ! fileloc='output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/hydro_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/hydro_'//TRIM(nchar)//'.out' else ! CHANGED BY TTG (FEB 2017) ! fileloc='output_'//TRIM(nchar)//'/hydro_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/hydro_'//TRIM(nchar)//'.out' endif call title(myid,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(unit=ilun,file=fileloc,form='unformatted') read(ilun)ncpu2 read(ilun)nvar2 read(ilun)ndim2 read(ilun)nlevelmax2 read(ilun)nboundary2 read(ilun)gamma2 if(.not.(neq_chem.or.rt) .and. nvar2.ne.nvar)then write(*,*)'File hydro.tmp is not compatible' write(*,*)'Found =',nvar2 write(*,*)'Expected=',nvar call clean_stop end if #ifdef RT if((neq_chem.or.rt).and.nvar2.lt.nvar)then ! OK to add ionization fraction vars ! Convert birth times for RT postprocessing: if(rt.and.static) convert_birth_times=.true. if(myid==1) write(*,*)'File hydro.tmp is not compatible' if(myid==1) write(*,*)'Found nvar2 =',nvar2 if(myid==1) write(*,*)'Expected=',nvar if(myid==1) write(*,*)'..so only reading first ',nvar2, & 'variables and setting the rest to zero' end if if((neq_chem.or.rt).and.nvar2.gt.nvar)then ! Not OK to drop variables if(myid==1) write(*,*)'File hydro.tmp is not compatible' if(myid==1) write(*,*)'Found =',nvar2 if(myid==1) write(*,*)'Expected=',nvar call clean_stop end if #endif do ilevel=1,nlevelmax2 do ibound=1,nboundary+ncpu if(ibound<=ncpu)then ncache=numbl(ibound,ilevel) istart=headl(ibound,ilevel) else ncache=numbb(ibound-ncpu,ilevel) istart=headb(ibound-ncpu,ilevel) end if read(ilun)ilevel2 read(ilun)numbl2 if(numbl2.ne.ncache)then write(*,*)'File hydro.tmp is not compatible' write(*,*)'Found =',numbl2,' for level ',ilevel2 write(*,*)'Expected=',ncache,' for level ',ilevel end if if(ncache>0)then allocate(ind_grid(1:ncache)) allocate(xx(1:ncache)) ! Loop over level grids igrid=istart do i=1,ncache ind_grid(i)=igrid igrid=next(igrid) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax ! Read density and velocities --> density and momenta do ivar=1,ndim+1 read(ilun)xx if(ivar==1)then do i=1,ncache uold(ind_grid(i)+iskip,1)=xx(i) end do else if(ivar>=2.and.ivar<=ndim+1)then do i=1,ncache uold(ind_grid(i)+iskip,ivar)=xx(i)*max(uold(ind_grid(i)+iskip,1),smallr) end do endif end do #if NENER>0 ! Read non-thermal pressures --> non-thermal energies do ivar=ndim+3,ndim+2+nener read(ilun)xx do i=1,ncache uold(ind_grid(i)+iskip,ivar)=xx(i)/(gamma_rad(ivar-ndim-2)-1d0) end do end do #endif ! Read thermal pressure --> total fluid energy read(ilun)xx do i=1,ncache xx(i)=xx(i)/(gamma-1d0) if (uold(ind_grid(i)+iskip,1)>0.)then xx(i)=xx(i)+0.5d0*uold(ind_grid(i)+iskip,2)**2/max(uold(ind_grid(i)+iskip,1),smallr) #if NDIM>1 xx(i)=xx(i)+0.5d0*uold(ind_grid(i)+iskip,3)**2/max(uold(ind_grid(i)+iskip,1),smallr) #endif #if NDIM>2 xx(i)=xx(i)+0.5d0*uold(ind_grid(i)+iskip,4)**2/max(uold(ind_grid(i)+iskip,1),smallr) #endif #if NENER>0 do irad=1,nener xx(i)=xx(i)+uold(ind_grid(i)+iskip,ndim+2+irad) end do #endif else xx(i)=0. end if uold(ind_grid(i)+iskip,ndim+2)=xx(i) end do #if NVAR>NDIM+2+NENER ! Read passive scalars do ivar=ndim+3+nener,min(nvar,nvar2) read(ilun)xx do i=1,ncache uold(ind_grid(i)+iskip,ivar)=xx(i)*max(uold(ind_grid(i)+iskip,1),smallr) end do end do #endif end do deallocate(ind_grid,xx) end if end do end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif #ifndef WITHOUTMPI if(debug)write(*,*)'hydro.tmp read for processor ',myid call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(verbose)write(*,*)'HYDRO backup files read completed' end if end subroutine init_hydro ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/init_part.f90 subroutine init_part use amr_commons use pm_commons use clfind_commons ! DICE patch use dice_commons use cooling_module use gadgetreadfilemod ! DICE patch ! RESTART patch use restart_commons use hydro_parameters, only: imetal,itracer use hydro_commons, only: mass_tot_0 ! RESTART patch #ifdef RT use rt_parameters,only: convert_birth_times #endif implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif !------------------------------------------------------------ ! Allocate particle-based arrays. ! Read particles positions and velocities from grafic files !------------------------------------------------------------ integer::npart2,ndim2,ncpu2 integer::ipart,jpart,ipart_old,ilevel,idim integer::i,igrid,ncache,ngrid,iskip,isink integer::ind,ix,iy,iz,ilun,info,icpu,nx_loc integer::i1,i2,i3,i1_min,i1_max,i2_min,i2_max,i3_min,i3_max integer::buf_count,indglob,npart_new real(dp)::dx,xx1,xx2,xx3,vv1,vv2,vv3,mm1,ll1,ll2,ll3 real(dp)::scale,dx_loc,rr,rmax,dx_min,min_mdm_cpu,min_mdm_all integer::ncode,bit_length,temp real(kind=8)::bscale real(dp),dimension(1:twotondim,1:3)::xc integer ,dimension(1:nvector)::ind_grid,ind_cell,cc,ii integer(i8b),dimension(1:ncpu)::npart_cpu,npart_all real(dp),allocatable,dimension(:)::xdp integer,allocatable,dimension(:)::isp integer(i8b),allocatable,dimension(:)::isp8 logical,allocatable,dimension(:)::nb real(kind=4),allocatable,dimension(:,:)::init_plane,init_plane_x real(dp),allocatable,dimension(:,:,:)::init_array,init_array_x real(kind=8),dimension(1:nvector,1:3)::xx,vv,xs real(dp),dimension(1:nvector,1:3)::xx_dp integer,dimension(1:nvector)::ixx,iyy,izz real(qdp),dimension(1:nvector)::order real(kind=8),dimension(1:nvector)::mm real(kind=8)::dispmax=0.0,dispall real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:3)::centerofmass integer::ibuf,tag=101,tagf=102,tagu=102 integer::countsend,countrecv #ifndef WITHOUTMPI integer,dimension(MPI_STATUS_SIZE,2*ncpu)::statuses integer,dimension(2*ncpu)::reqsend,reqrecv integer,dimension(ncpu)::sendbuf,recvbuf #endif logical::error,keep_part,eof,jumped,ic_sink=.false.,read_pos=.false.,ok ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename,filename_x ! character(LEN=80)::fileloc character(LEN=256)::filename,filename_x character(LEN=256)::fileloc character(LEN=20)::filetype_loc character(LEN=5)::nchar,ncharcpu integer,parameter::tagg=1109,tagg2=1110,tagg3=1111 integer::dummy_io,info2 ! ADDED BY TTG MAY 2017 real(dp)::msol=1.989d33!,kpc=3.086d21,myr=3.154d13 ! g, cm, s ! DICE patch integer::j,type_index integer::dummy_int,blck_size,jump_blck,blck_cnt,stat,ifile integer::head_blck,pos_blck,vel_blck,id_blck,mass_blck,u_blck,metal_blck,age_blck ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) integer::trc_blck integer::head_size,pos_size,vel_size,id_size,mass_size,u_size,metal_size,age_size ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) integer::trc_size integer::kpart,lpart,mpart,opart,gpart,ngas,nhalo integer, dimension(nvector)::ids real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v,scale_m real(dp),dimension(1:nvector)::tt,zz,uu ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) real(dp),dimension(1:nvector)::trc real,dimension(1:nvector,1:3)::xx_sp,vv_sp real,dimension(1:nvector)::mm_sp,tt_sp,zz_sp,uu_sp ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) real,dimension(1:nvector)::trc_sp real(dp)::mgas_tot real::dummy_real,ipbar character(LEN=12)::ifile_str character(LEN=4)::blck_name logical::eob,file_exists,skip TYPE(gadgetheadertype)::header ! DICE patch ! RESTART patch ! ADDED BY TTG APR 2018: specific for Magellanic Clouds simulations real(dp)::theta_1, cos_theta_1, sin_theta_1, pi real(dp)::theta_2, cos_theta_2, sin_theta_2 real(dp)::theta_3, cos_theta_3, sin_theta_3 real(dp)::theta_4, cos_theta_4, sin_theta_4 real(dp)::x_1_save, x_2_save, x_3_save real(dp)::v_1_save, v_2_save, v_3_save real(dp),dimension(1:3)::lmc_com = (/-52.5, 9.5, 0.5/) ! Position of the LMC CoM (kpc) real(dp),dimension(1:3)::lmc_cov = (/-15.6766d5, -5.665d5 , -0.2266d5/) ! Position of the LMC CoV (cm/s) real(dp),dimension(1:3)::r_shift = (/48., 198., -85./) ! kpc real(dp),dimension(1:3)::v_shift = (/-17.0d5, -160.0d5, -29.0d5/) ! cm/s ! ADDED BY TTG MAY 2017 integer::son1 integer::ilun1,ilun2,ilun3,ilun4 integer::ibound,ivar ! integer::dummy_int integer::id_blck_restart,mass_blck_restart,metal_blck_restart,age_blck_restart,level_blck_restart integer::sink_index_blck_restart,sink_mass_blck_restart,sink_birth_blck_restart,sink_dm_blck_restart,& &sink_ar_blck_restart,sink_newb_blck_restart integer,dimension(1:3)::pos_blck_restart,vel_blck_restart,sink_pos_blck_restart,sink_vel_blck_restart,& &sink_am_blck_restart integer,allocatable,dimension(:,:,:)::amr_pos_blck_restart integer,allocatable,dimension(:,:,:)::amr_son_blck_restart integer,allocatable,dimension(:,:,:,:)::hydro_var_blck_restart integer::kpart_restart,lpart_restart integer::nhalo_tot,nsink_tot integer::nstar_loc,nhalo_loc,ngas_loc,nsink_loc !TTG: The following are declared in the DICE patch block: ! real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v ! real(kind=8),dimension(1:nvector)::tt,zz,aa,dd ! real(kind=8),dimension(1:nvector)::aa,dd ! real(kind=8),dimension(1:nvector,1:3)::ll ! real(kind=8),allocatable,dimension(:,:)::pasvar ! real(kind=8),dimension(1:3)::xxg real(dp),dimension(1:nvector)::aa,dd real(dp),dimension(1:nvector,1:3)::ll real(dp),allocatable,dimension(:,:)::pasvar real(dp),dimension(1:3)::xxg real(dp)::dummy_real_restart real(dp)::vol_loc,mgas_tot_restart,mhalo_tot,msink_tot logical::eob_restart,eocpu,read_center,dummy_logical logical,dimension(1:nvector)::nn integer::mypos,size_blck_restart integer::ilevel2,numbl2 TYPE ramses_part_headertype integer::ncpu integer::ndim integer::npart integer,dimension(IRandNumSize)::localseed integer::nstar_tot real(dp)::mstar_tot real(dp)::mstar_lost integer::nsink END TYPE ramses_part_headertype TYPE ramses_hydro_headertype integer::ncpu integer::nvar integer::ndim integer::nlevelmax integer::nboundary real(dp)::gamma END TYPE ramses_hydro_headertype TYPE ramses_amr_headertype integer::ncpu integer::ndim integer::nx,ny,nz integer::nlevelmax integer::ngridmax integer::nboundary integer::ngrid_current real(dp)::boxlen integer::noutput,iout,ifout real(dp),dimension(1:MAXOUT)::tout real(dp),dimension(1:MAXOUT)::aout real(dp)::t real(dp),dimension(1:MAXLEVEL)::dtold real(dp),dimension(1:MAXLEVEL)::dtnew integer::nstep,nstep_coarse real(dp)::einit,mass_tot_0,rho_tot real(dp)::omega_m,omega_l,omega_k,omega_b,h0,aexp_ini,boxlen_ini real(dp)::aexp,hexp,aexp_old,epot_tot_int,epot_tot_old real(dp)::mass_sph integer,allocatable,dimension(:,:)::headl integer,allocatable,dimension(:,:)::taill integer,allocatable,dimension(:,:)::numbl character(len=128)::ordering type(communicator),allocatable,dimension(:,:)::boundary integer(i8b),allocatable,dimension(:,:)::numbtot integer,allocatable,dimension(:,:)::headb integer,allocatable,dimension(:,:)::tailb integer,allocatable,dimension(:,:)::numbb integer::headf,tailf,numbf,used_mem,used_mem_tot real(dp),allocatable,dimension(:) ::bisec_wall integer ,allocatable,dimension(:,:) ::bisec_next integer,allocatable,dimension(:) ::bisec_indx real(dp),allocatable,dimension(:,:) ::bisec_cpubox_min real(dp),allocatable,dimension(:,:) ::bisec_cpubox_max real(qdp),allocatable,dimension(:) ::bound_key integer::ibound_min,jbound_min,kbound_min integer::ibound_max,jbound_max,kbound_max integer::twotondim integer::twondim integer::nbilevelmax integer::nbinodes integer::ndomain END TYPE ramses_amr_headertype TYPE ramses_sink_headertype integer::nsink integer::nindsink END TYPE ramses_sink_headertype type(ramses_part_headertype) :: header_part type(ramses_hydro_headertype) :: header_hydro type(ramses_amr_headertype) :: header_amr type(ramses_sink_headertype) :: header_sink ! RESTART patch if(verbose)write(*,*)'Entering init_part' if(allocated(xp))then if(verbose)write(*,*)'Initial conditions already set' return end if ! Allocate particle variables allocate(xp (npartmax,ndim)) allocate(vp (npartmax,ndim)) allocate(mp (npartmax)) allocate(nextp (npartmax)) allocate(prevp (npartmax)) allocate(levelp(npartmax)) allocate(idp (npartmax)) #ifdef OUTPUT_PARTICLE_POTENTIAL allocate(ptcl_phi(npartmax)) #endif ! patch DICE allocate(up (npartmax)) if(cosmo) allocate(maskp (npartmax)) ! patch DICE xp=0.0; vp=0.0; mp=0.0; levelp=0; idp=0 if(star.or.sink)then allocate(tp(npartmax)) tp=0.0 ! CHANGED BY TTG (FEB 2017) ! if(metal)then ! allocate(zp(npartmax)) ! zp=0.0 ! end if end if ! ADDED BY TTG (FEB 2017) ! to allow the use of metallicity for gas components if(metal)then allocate(zp(npartmax)) zp=0.0 end if ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) allocate(trcp (npartmax)) trcp=0.0 !-------------------- ! Read part.tmp file !-------------------- if(nrestart>0)then ilun=2*ncpu+myid+10 call title(nrestart,nchar) if(IOGROUPSIZEREP>0)then call title(((myid-1)/IOGROUPSIZEREP)+1,ncharcpu) ! CHANGED BY TTG (FEB 2017) ! fileloc='output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/part_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/part_'//TRIM(nchar)//'.out' else ! fileloc='output_'//TRIM(nchar)//'/part_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/part_'//TRIM(nchar)//'.out' endif call title(myid,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tagg,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(unit=ilun,file=fileloc,form='unformatted') rewind(ilun) read(ilun)ncpu2 read(ilun)ndim2 read(ilun)npart2 read(ilun)localseed read(ilun)nstar_tot read(ilun)mstar_tot read(ilun)mstar_lost read(ilun)nsink if(ncpu2.ne.ncpu.or.ndim2.ne.ndim.or.npart2.gt.npartmax)then write(*,*)'File part.tmp not compatible' write(*,*)'Found =',ncpu2,ndim2,npart2 write(*,*)'Expected=',ncpu,ndim,npartmax call clean_stop end if ! Read position allocate(xdp(1:npart2)) do idim=1,ndim read(ilun)xdp xp(1:npart2,idim)=xdp end do ! Read velocity do idim=1,ndim read(ilun)xdp vp(1:npart2,idim)=xdp end do ! Read mass read(ilun)xdp mp(1:npart2)=xdp deallocate(xdp) ! Read identity allocate(isp8(1:npart2)) read(ilun)isp8 idp(1:npart2)=isp8 deallocate(isp8) ! Read level allocate(isp(1:npart2)) read(ilun)isp levelp(1:npart2)=isp deallocate(isp) if(star.or.sink)then ! Read birth epoch allocate(xdp(1:npart2)) read(ilun)xdp tp(1:npart2)=xdp if(convert_birth_times) then do i = 1, npart2 ! Convert birth time to proper for RT postpr. call getProperTime(tp(i),tp(i)) enddo endif ! CHANGED BY TTG (FEB 2017) ! if(metal)then ! ! Read metallicity ! read(ilun)xdp ! zp(1:npart2)=xdp ! end if deallocate(xdp) end if ! ADDED BY TTG (FEB 2017) ! to allow the use of metallicity for gas components if(metal)then allocate(xdp(1:npart2)) ! Read metallicity read(ilun)xdp zp(1:npart2)=xdp deallocate(xdp) end if close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tagg, & & MPI_COMM_WORLD,info2) end if endif #endif ! Get nlevelmax_part from cosmological inital conditions if(cosmo)then min_mdm_cpu = 1.0 do ipart=1,npart2 if(star)then if(tp(ipart).eq.0d0)then if(mp(ipart).lt.min_mdm_cpu) min_mdm_cpu = mp(ipart) endif else if(mp(ipart).lt.min_mdm_cpu) min_mdm_cpu = mp(ipart) endif enddo if(myid==1) write(*,*) 'nlevelmax_part=',nlevelmax_part endif if(debug)write(*,*)'part.tmp read for processor ',myid npart=npart2 else filetype_loc=filetype !if(.not. cosmo)filetype_loc='ascii' select case (filetype_loc) case ('grafic') !---------------------------------------------------- ! Reading initial conditions GRAFIC2 multigrid arrays !---------------------------------------------------- ipart=0 ! Loop over initial condition levels do ilevel=levelmin,nlevelmax if(initfile(ilevel)==' ')cycle ! Mesh size at level ilevel in coarse cell units dx=0.5D0**ilevel ! Set position of cell centers relative to grid center do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do !-------------------------------------------------------------- ! First step: compute level boundaries and particle positions !-------------------------------------------------------------- i1_min=n1(ilevel)+1; i1_max=0 i2_min=n2(ilevel)+1; i2_max=0 i3_min=n3(ilevel)+1; i3_max=0 ipart_old=ipart ! Loop over grids by vector sweeps ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do do i=1,ngrid xx1=xg(ind_grid(i),1)+xc(ind,1) xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel) xx2=xg(ind_grid(i),2)+xc(ind,2) xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel) xx3=xg(ind_grid(i),3)+xc(ind,3) xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel) i1_min=MIN(i1_min,int(xx1)+1) i1_max=MAX(i1_max,int(xx1)+1) i2_min=MIN(i2_min,int(xx2)+1) i2_max=MAX(i2_max,int(xx2)+1) i3_min=MIN(i3_min,int(xx3)+1) i3_max=MAX(i3_max,int(xx3)+1) keep_part=son(ind_cell(i))==0 if(keep_part)then ipart=ipart+1 if(ipart>npartmax)then write(*,*)'Maximum number of particles incorrect' write(*,*)'npartmax should be greater than',ipart call clean_stop endif if(ndim>0)xp(ipart,1)=xg(ind_grid(i),1)+xc(ind,1) if(ndim>1)xp(ipart,2)=xg(ind_grid(i),2)+xc(ind,2) if(ndim>2)xp(ipart,3)=xg(ind_grid(i),3)+xc(ind,3) mp(ipart)=0.5d0**(3*ilevel)*(1.0d0-omega_b/omega_m) end if end do end do ! End loop over cells end do ! End loop over grids ! Check that all grids are within initial condition region error=.false. if(active(ilevel)%ngrid>0)then if(i1_min<1.or.i1_max>n1(ilevel))error=.true. if(i2_min<1.or.i2_max>n2(ilevel))error=.true. if(i3_min<1.or.i3_max>n3(ilevel))error=.true. end if if(error) then write(*,*)'Some grid are outside initial conditions sub-volume' write(*,*)'for ilevel=',ilevel write(*,*)i1_min,i1_max write(*,*)i2_min,i2_max write(*,*)i3_min,i3_max write(*,*)n1(ilevel),n2(ilevel),n3(ilevel) call clean_stop end if if(debug)then write(*,*)myid,i1_min,i1_max,i2_min,i2_max,i3_min,i3_max endif !--------------------------------------------------------------------- ! Second step: read initial condition file and set particle velocities !--------------------------------------------------------------------- ! Allocate initial conditions array if(active(ilevel)%ngrid>0)then allocate(init_array(i1_min:i1_max,i2_min:i2_max,i3_min:i3_max)) allocate(init_array_x(i1_min:i1_max,i2_min:i2_max,i3_min:i3_max)) init_array=0d0 init_array_x=0d0 end if allocate(init_plane(1:n1(ilevel),1:n2(ilevel))) allocate(init_plane_x(1:n1(ilevel),1:n2(ilevel))) ! Loop over input variables do idim=1,ndim ! Read dark matter initial displacement field if(multiple)then call title(myid,nchar) if(idim==1)filename=TRIM(initfile(ilevel))//'/dir_velcx/ic_velcx.'//TRIM(nchar) if(idim==2)filename=TRIM(initfile(ilevel))//'/dir_velcy/ic_velcy.'//TRIM(nchar) if(idim==3)filename=TRIM(initfile(ilevel))//'/dir_velcz/ic_velcz.'//TRIM(nchar) else if(idim==1)filename=TRIM(initfile(ilevel))//'/ic_velcx' if(idim==2)filename=TRIM(initfile(ilevel))//'/ic_velcy' if(idim==3)filename=TRIM(initfile(ilevel))//'/ic_velcz' if(idim==1)filename_x=TRIM(initfile(ilevel))//'/ic_poscx' if(idim==2)filename_x=TRIM(initfile(ilevel))//'/ic_poscy' if(idim==3)filename_x=TRIM(initfile(ilevel))//'/ic_poscz' INQUIRE(file=filename_x,exist=ok) if(.not.ok)then read_pos = .false. else read_pos = .true. if(myid==1)write(*,*)'Reading file '//TRIM(filename_x) end if endif if(myid==1)write(*,*)'Reading file '//TRIM(filename) if(multiple)then ilun=myid+10 ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tagg2,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(ilun,file=filename,form='unformatted') rewind ilun read(ilun) ! skip first line do i3=1,n3(ilevel) read(ilun)((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel)) if(active(ilevel)%ngrid>0)then if(i3.ge.i3_min.and.i3.le.i3_max)then init_array(i1_min:i1_max,i2_min:i2_max,i3) = & & init_plane(i1_min:i1_max,i2_min:i2_max) end if endif end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tagg2, & & MPI_COMM_WORLD,info2) end if endif #endif else if(myid==1)then open(10,file=filename,form='unformatted') rewind 10 read(10) ! skip first line end if do i3=1,n3(ilevel) if(myid==1)then if(debug.and.mod(i3,10)==0)write(*,*)'Reading plane ',i3 read(10)((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel)) else init_plane=0.0 endif buf_count=n1(ilevel)*n2(ilevel) #ifndef WITHOUTMPI call MPI_BCAST(init_plane,buf_count,MPI_REAL,0,MPI_COMM_WORLD,info) #endif if(active(ilevel)%ngrid>0)then if(i3.ge.i3_min.and.i3.le.i3_max)then init_array(i1_min:i1_max,i2_min:i2_max,i3) = & & init_plane(i1_min:i1_max,i2_min:i2_max) end if endif end do if(myid==1)close(10) if(read_pos) then if(myid==1)then open(10,file=filename_x,form='unformatted') rewind 10 read(10) ! skip first line end if do i3=1,n3(ilevel) if(myid==1)then if(debug.and.mod(i3,10)==0)write(*,*)'Reading plane ',i3 read(10)((init_plane_x(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel)) else init_plane_x=0.0 endif buf_count=n1(ilevel)*n2(ilevel) #ifndef WITHOUTMPI call MPI_BCAST(init_plane_x,buf_count,MPI_REAL,0,MPI_COMM_WORLD,info) #endif if(active(ilevel)%ngrid>0)then if(i3.ge.i3_min.and.i3.le.i3_max)then init_array_x(i1_min:i1_max,i2_min:i2_max,i3) = & & init_plane_x(i1_min:i1_max,i2_min:i2_max) end if endif end do if(myid==1)close(10) end if endif if(active(ilevel)%ngrid>0)then ! Rescale initial displacement field to code units init_array=dfact(ilevel)*dx/dxini(ilevel)*init_array/vfact(ilevel) if(read_pos)then init_array_x = init_array_x/boxlen_ini endif ! Loop over grids by vector sweeps ipart=ipart_old ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do do i=1,ngrid xx1=xg(ind_grid(i),1)+xc(ind,1) xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel) xx2=xg(ind_grid(i),2)+xc(ind,2) xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel) xx3=xg(ind_grid(i),3)+xc(ind,3) xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel) i1=int(xx1)+1 i1=int(xx1)+1 i2=int(xx2)+1 i2=int(xx2)+1 i3=int(xx3)+1 i3=int(xx3)+1 keep_part=son(ind_cell(i))==0 if(keep_part)then ipart=ipart+1 vp(ipart,idim)=init_array(i1,i2,i3) if(.not. read_pos)then dispmax=max(dispmax,abs(init_array(i1,i2,i3)/dx)) else xp(ipart,idim)=xg(ind_grid(i),idim)+xc(ind,idim)+init_array_x(i1,i2,i3) dispmax=max(dispmax,abs(init_array_x(i1,i2,i3)/dx)) endif end if end do end do ! End loop over cells end do ! End loop over grids endif end do ! End loop over input variables ! Deallocate initial conditions array if(active(ilevel)%ngrid>0)then deallocate(init_array,init_array_x) end if deallocate(init_plane,init_plane_x) if(debug)write(*,*)'npart=',ipart,'/',npartmax,' for PE=',myid end do ! End loop over levels ! Initial particle number npart=ipart ! Move particle according to Zeldovich approximation if(.not. read_pos)then xp(1:npart,1:ndim)=xp(1:npart,1:ndim)+vp(1:npart,1:ndim) endif ! Scale displacement to velocity vp(1:npart,1:ndim)=vfact(1)*vp(1:npart,1:ndim) ! Periodic box do ipart=1,npart #if NDIM>0 if(xp(ipart,1)< 0.0d0 )xp(ipart,1)=xp(ipart,1)+dble(nx) if(xp(ipart,1)>=dble(nx))xp(ipart,1)=xp(ipart,1)-dble(nx) #endif #if NDIM>1 if(xp(ipart,2)< 0.0d0 )xp(ipart,2)=xp(ipart,2)+dble(ny) if(xp(ipart,2)>=dble(ny))xp(ipart,2)=xp(ipart,2)-dble(ny) #endif #if NDIM>2 if(xp(ipart,3)< 0.0d0 )xp(ipart,3)=xp(ipart,3)+dble(nz) if(xp(ipart,3)>=dble(nz))xp(ipart,3)=xp(ipart,3)-dble(nz) #endif end do #ifndef WITHOUTMPI ! Compute particle Hilbert ordering sendbuf=0 do ipart=1,npart xx(1,1:3)=xp(ipart,1:3) xx_dp(1,1:3)=xx(1,1:3) call cmp_cpumap(xx_dp,cc,1) if(cc(1).ne.myid)sendbuf(cc(1))=sendbuf(cc(1))+1 end do ! Allocate communication buffer in emission do icpu=1,ncpu ncache=sendbuf(icpu) if(ncache>0)then allocate(emission(icpu,1)%up(1:ncache,1:twondim+1)) end if end do ! Fill communicators jpart=0 sendbuf=0 do ipart=1,npart xx(1,1:3)=xp(ipart,1:3) xx_dp(1,1:3)=xx(1,1:3) call cmp_cpumap(xx_dp,cc,1) if(cc(1).ne.myid)then icpu=cc(1) sendbuf(icpu)=sendbuf(icpu)+1 ibuf=sendbuf(icpu) emission(icpu,1)%up(ibuf,1)=xp(ipart,1) emission(icpu,1)%up(ibuf,2)=xp(ipart,2) emission(icpu,1)%up(ibuf,3)=xp(ipart,3) emission(icpu,1)%up(ibuf,4)=vp(ipart,1) emission(icpu,1)%up(ibuf,5)=vp(ipart,2) emission(icpu,1)%up(ibuf,6)=vp(ipart,3) emission(icpu,1)%up(ibuf,7)=mp(ipart) else jpart=jpart+1 xp(jpart,1:3)=xp(ipart,1:3) vp(jpart,1:3)=vp(ipart,1:3) mp(jpart) =mp(ipart) endif end do ! Communicate virtual particle number to parent cpu call MPI_ALLTOALL(sendbuf,1,MPI_INTEGER,recvbuf,1,MPI_INTEGER,MPI_COMM_WORLD,info) ! Compute total number of newly created particles npart_new=0 do icpu=1,ncpu npart_new=npart_new+recvbuf(icpu) end do if(jpart+npart_new.gt.npartmax)then write(*,*)'No more free memory for particles' write(*,*)'Increase npartmax' write(*,*)myid write(*,*)jpart,npart_new write(*,*)bound_key call MPI_ABORT(MPI_COMM_WORLD,1,info) end if ! Allocate communication buffer in reception do icpu=1,ncpu ncache=recvbuf(icpu) if(ncache>0)then allocate(reception(icpu,1)%up(1:ncache,1:twondim+1)) end if end do ! Receive particles countrecv=0 do icpu=1,ncpu ncache=recvbuf(icpu) if(ncache>0)then buf_count=ncache*(twondim+1) countrecv=countrecv+1 call MPI_IRECV(reception(icpu,1)%up,buf_count, & & MPI_DOUBLE_PRECISION,icpu-1,& & tagu,MPI_COMM_WORLD,reqrecv(countrecv),info) end if end do ! Send particles countsend=0 do icpu=1,ncpu ncache=sendbuf(icpu) if(ncache>0)then buf_count=ncache*(twondim+1) countsend=countsend+1 call MPI_ISEND(emission(icpu,1)%up,buf_count, & & MPI_DOUBLE_PRECISION,icpu-1,& & tagu,MPI_COMM_WORLD,reqsend(countsend),info) end if end do ! Wait for full completion of receives call MPI_WAITALL(countrecv,reqrecv,statuses,info) ! Wait for full completion of sends call MPI_WAITALL(countsend,reqsend,statuses,info) ! Create new particles do icpu=1,ncpu do ibuf=1,recvbuf(icpu) jpart=jpart+1 xp(jpart,1)=reception(icpu,1)%up(ibuf,1) xp(jpart,2)=reception(icpu,1)%up(ibuf,2) xp(jpart,3)=reception(icpu,1)%up(ibuf,3) vp(jpart,1)=reception(icpu,1)%up(ibuf,4) vp(jpart,2)=reception(icpu,1)%up(ibuf,5) vp(jpart,3)=reception(icpu,1)%up(ibuf,6) mp(jpart) =reception(icpu,1)%up(ibuf,7) end do end do ! Erase old particles do ipart=jpart+1,npart xp(ipart,1)=0d0 xp(ipart,2)=0d0 xp(ipart,3)=0d0 vp(ipart,1)=0d0 vp(ipart,2)=0d0 vp(ipart,3)=0d0 mp(ipart) =0d0 end do npart=jpart ! Deallocate communicators do icpu=1,ncpu if(sendbuf(icpu)>0)deallocate(emission(icpu,1)%up) if(recvbuf(icpu)>0)deallocate(reception(icpu,1)%up) end do write(*,*)'npart=',ipart,'/',npartmax,' for PE=',myid #endif ! Compute particle initial level do ipart=1,npart levelp(ipart)=levelmin end do ! Compute particle initial age and metallicity if(star.or.sink)then do ipart=1,npart tp(ipart)=0d0 if(metal)then zp(ipart)=0d0 end if end do end if ! Compute particle initial identity npart_cpu=0; npart_all=0 npart_cpu(myid)=npart #ifndef WITHOUTMPI #ifndef LONGINT call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) #else call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,info) #endif npart_cpu(1)=npart_all(1) #endif do icpu=2,ncpu npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu) end do if(myid==1)then do ipart=1,npart idp(ipart)=ipart end do else do ipart=1,npart idp(ipart)=npart_cpu(myid-1)+ipart end do end if case ('ascii') ! Local particle count ipart=0 if(TRIM(initfile(levelmin)).NE.' ')then filename=TRIM(initfile(levelmin))//'/ic_part' if(myid==1)then open(10,file=filename,form='formatted') indglob=0 end if eof=.false. do while (.not.eof) xx=0.0 if(myid==1)then jpart=0 do i=1,nvector read(10,*,end=100)xx1,xx2,xx3,vv1,vv2,vv3,mm1 jpart=jpart+1 indglob=indglob+1 xx(i,1)=xx1+boxlen/2.0 xx(i,2)=xx2+boxlen/2.0 xx(i,3)=xx3+boxlen/2.0 vv(i,1)=vv1 vv(i,2)=vv2 vv(i,3)=vv3 mm(i )=mm1 ii(i )=indglob end do 100 continue if(jpartnpartmax)then write(*,*)'Maximum number of particles incorrect' write(*,*)'npartmax should be greater than',ipart call clean_stop endif xp(ipart,1:3)=xx(i,1:3) vp(ipart,1:3)=vv(i,1:3) mp(ipart) =mm(i) levelp(ipart)=levelmin idp(ipart) =ii(i) #ifndef WITHOUTMPI endif #endif enddo end do if(myid==1)close(10) end if npart=ipart ! Compute total number of particle npart_cpu=0; npart_all=0 npart_cpu(myid)=npart #ifndef WITHOUTMPI #ifndef LONGINT call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) #else call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,info) #endif npart_cpu(1)=npart_all(1) #endif do icpu=2,ncpu npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu) end do if(debug)write(*,*)'npart=',npart,'/',npart_cpu(ncpu) !---------------------------------------------------------------------- ! DICE patch case ('dice') dice_init=.true. ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) scale_m = scale_d*scale_l**3 ! Reading header of the Gadget file error=.false. ipart = 0 do ifile=1,ic_nfile write(ifile_str,*) ifile if(ic_nfile.eq.1) then filename=TRIM(initfile(levelmin))//'/'//TRIM(ic_file) else filename=TRIM(initfile(levelmin))//'/'//TRIM(ic_file)//'.'//ADJUSTL(ifile_str) endif INQUIRE(FILE=filename,EXIST=file_exists) if(.not.file_exists) then if(myid==1) write(*,*) TRIM(filename),' not found' call clean_stop endif if(myid==1)then write(*,'(A12,A)') ' Loading -> ',filename ! TTG 2018: Added new file format Gadget X, corresponding to a slightly modified version of Gadget2 ! Gadget2 file format currently not supported ! Requires modifications to init_part.f90, init_flow_fine.f90, ... if((ic_format.ne.'Gadget1').and.(ic_format.ne.'GadgetX')) then if(myid==1) write(*,*) 'Specify a valid IC file format [ic_format=Gadget1/GadgetX]' if(myid==1) write(*,*) 'Gadget2 file format currently not supported!' error=.true. endif OPEN(unit=1,file=filename,status='old',action='read',form='unformatted',access='stream') ! Init block address head_blck = -1 pos_blck = -1 vel_blck = -1 id_blck = -1 mass_blck = -1 u_blck = -1 metal_blck = -1 age_blck = -1 ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trc_blck = -1 if(ic_format .eq. 'Gadget1') then ! Init block counter jump_blck = 1 blck_cnt = 1 do while(.true.) ! Reading data block header read(1,POS=jump_blck,iostat=stat) blck_size if(stat /= 0) exit ! Saving data block positions if(blck_cnt .eq. 1) then head_blck = jump_blck+sizeof(blck_size) head_size = blck_size endif if(blck_cnt .eq. 2) then pos_blck = jump_blck+sizeof(blck_size) pos_size = blck_size/(3*sizeof(dummy_real)) endif if(blck_cnt .eq. 3) then vel_blck = jump_blck+sizeof(blck_size) vel_size = blck_size/(3*sizeof(dummy_real)) endif if(blck_cnt .eq. 4) then id_blck = jump_blck+sizeof(blck_size) id_size = blck_size/sizeof(dummy_int) endif if(blck_cnt .eq. 5) then mass_blck = jump_blck+sizeof(blck_size) mass_size = blck_size/sizeof(dummy_real) endif if(blck_cnt .eq. 6) then u_blck = jump_blck+sizeof(blck_size) u_size = blck_size/sizeof(dummy_real) endif if(blck_cnt .eq. 7) then metal_blck = jump_blck+sizeof(blck_size) metal_size = blck_size/sizeof(dummy_real) endif if(blck_cnt .eq. 8) then age_blck = jump_blck+sizeof(blck_size) age_size = blck_size/sizeof(dummy_real) endif jump_blck = jump_blck+blck_size+2*sizeof(dummy_int) blck_cnt = blck_cnt+1 enddo endif if(ic_format .eq. 'GadgetX') then ! Init block counter jump_blck = 1 write(*,'(A50)')'__________________________________________________' do while(.true.) ! Reading data block header read(1,POS=jump_blck,iostat=stat) dummy_int if(stat /= 0) exit read(1,POS=jump_blck+sizeof(dummy_int),iostat=stat) blck_name if(stat /= 0) exit read(1,POS=jump_blck+sizeof(dummy_int)+sizeof(blck_name),iostat=stat) dummy_int if(stat /= 0) exit read(1,POS=jump_blck+2*sizeof(dummy_int)+sizeof(blck_name),iostat=stat) dummy_int if(stat /= 0) exit read(1,POS=jump_blck+3*sizeof(dummy_int)+sizeof(blck_name),iostat=stat) blck_size if(stat /= 0) exit ! Saving data block positions if(blck_name .eq. ic_head_name) then head_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) head_size = blck_size write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_pos_name) then pos_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) pos_size = blck_size/(3*sizeof(dummy_real)) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_vel_name) then vel_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) vel_size = blck_size/(3*sizeof(dummy_real)) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_id_name) then id_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) id_size = blck_size/sizeof(dummy_int) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_mass_name) then mass_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) mass_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_u_name) then u_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) u_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) if(blck_name .eq. 'TRC ') then trc_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) trc_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_metal_name) then metal_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) metal_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_age_name) then age_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) age_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif jump_blck = jump_blck+blck_size+sizeof(blck_name)+5*sizeof(dummy_int) enddo endif if((head_blck.eq.-1).or.(pos_blck.eq.-1).or.(vel_blck.eq.-1).or.(mass_blck.eq.-1)) then write(*,*) 'Gadget file does not contain handful data' error=.true. endif if(head_size.ne.256) then write(*,*) 'Gadget header is not 256 bytes' error=.true. endif ! Byte swapping doesn't appear to work if you just do READ(1)header READ(1,POS=head_blck) header%npart,header%mass,header%time,header%redshift, & header%flag_sfr,header%flag_feedback,header%nparttotal, & header%flag_cooling,header%numfiles,header%boxsize, & header%omega0,header%omegalambda,header%hubbleparam, & header%flag_stellarage,header%flag_metals,header%totalhighword, & header%flag_entropy_instead_u, header%flag_doubleprecision, & header%flag_ic_info, header%lpt_scalingfactor nstar_tot = sum(header%npart(3:5)) npart = sum(header%npart) ngas = header%npart(1) nhalo = header%npart(2) if(cosmo) T2_start = 1.356d-2/aexp**2 write(*,'(A50)')'__________________________________________________' write(*,*)'Found ',npart,' particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.0) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(1),' type 0 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.1) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(2),' type 1 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.2) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(3),' type 2 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.3) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(4),' type 3 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.4) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(5),' type 4 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.5) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(6),' type 5 particles' write(*,'(A50)')'_____________________progress_____________________' if((pos_size.ne.npart).or.(vel_size.ne.npart).or.((metal_size.ne.npart).and.(metal_size.ne.ngas+nstar_tot))) then write(*,*) 'POS =',pos_size write(*,*) 'Z =',metal_size write(*,*) 'VEL =',vel_size write(*,*) 'Number of particles does not correspond to block sizes' error=.true. endif endif if(error) call clean_stop #ifndef WITHOUTMPI call MPI_BCAST(nstar_tot,1,MPI_INTEGER,0,MPI_COMM_WORLD,info) #endif eob = .false. kpart = 0 lpart = 0 mpart = 0 gpart = 0 opart = 0 mgas_tot = 0. ipbar = 0. ! TTG 2018: Loop to read particles do while(.not.eob) xx=0. vv=0. ii=0 mm=0. tt=0. zz=0. uu=0. ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trc=0. if(myid==1)then jpart=0 do i=1,nvector jpart=jpart+1 ! All particles counter kpart=kpart+1 !TTG 2017: gas particles if(kpart.le.header%npart(1)) type_index = 1 !TTG 2017: other particles do j=1,5 if(kpart.gt.sum(header%npart(1:j)).and.kpart.le.sum(header%npart(1:j+1))) type_index = j+1 enddo if((sum(header%npart(3:5)).gt.0).and.(kpart.gt.(header%npart(1)+header%npart(2)))) mpart=mpart+1 if(type_index.ne.2) gpart=gpart+1 ! Reading GadgetX file line-by-line ! Mandatory data read(1,POS=pos_blck+3*sizeof(dummy_real)*(kpart-1)) xx_sp(i,1:3) read(1,POS=vel_blck+3*sizeof(dummy_real)*(kpart-1)) vv_sp(i,1:3) if(header%mass(type_index).gt.0) then mm_sp(i) = header%mass(type_index) else opart=opart+1 read(1,POS=mass_blck+sizeof(dummy_real)*(opart-1)) mm_sp(i) endif ! Optional data if(id_blck.ne.-1) then read(1,POS=id_blck+sizeof(dummy_int)*(kpart-1)) ii(i) else ii(i) = kpart endif if(kpart.le.header%npart(1)) then if((u_blck.ne.-1).and.(u_size.eq.header%npart(1))) then read(1,POS=u_blck+sizeof(dummy_real)*(kpart-1)) uu_sp(i) endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) if((trc_blck.ne.-1).and.(trc_size.eq.header%npart(1))) then read(1,POS=trc_blck+sizeof(dummy_real)*(kpart-1)) trc_sp(i) endif endif if(metal) then if((metal_blck.ne.-1).and.(metal_size.eq.npart)) then read(1,POS=metal_blck+sizeof(dummy_real)*(kpart-1)) zz_sp(i) endif if((metal_blck.ne.-1).and.(metal_size.eq.ngas+nstar_tot)) then read(1,POS=metal_blck+sizeof(dummy_real)*(gpart-1)) zz_sp(i) endif endif if(star) then if((age_blck.ne.-1).and.(age_size.eq.sum(header%npart(3:5)))) then if((sum(header%npart(3:5)).gt.0).and.(kpart.gt.(header%npart(1)+header%npart(2)))) then read(1,POS=age_blck+sizeof(dummy_real)*(mpart-1)) tt_sp(i) endif endif endif ! Scaling to ramses code units if(cosmo) then gadget_scale_l = scale_l/header%boxsize gadget_scale_v = 1e3*SQRT(aexp)/header%boxsize*aexp/100. endif xx(i,:) = xx_sp(i,:)*(gadget_scale_l/scale_l)*ic_scale_pos vv(i,:) = vv_sp(i,:)*(gadget_scale_v/scale_v)*ic_scale_vel mm(i) = mm_sp(i)*(gadget_scale_m/scale_m)*ic_scale_mass if(cosmo) then if(type_index .eq. 1) mass_sph = mm(i) if(xx(i,1)< 0.0d0 )xx(i,1)=xx(i,1)+dble(nx) if(xx(i,1)>=dble(nx))xx(i,1)=xx(i,1)-dble(nx) if(xx(i,2)< 0.0d0 )xx(i,2)=xx(i,2)+dble(ny) if(xx(i,2)>=dble(ny))xx(i,2)=xx(i,2)-dble(ny) if(xx(i,3)< 0.0d0 )xx(i,3)=xx(i,3)+dble(nz) if(xx(i,3)>=dble(nz))xx(i,3)=xx(i,3)-dble(nz) endif if(metal) then if(metal_blck.ne.-1) then zz(i) = zz_sp(i)*ic_scale_metal !TTG 2017: DICE adopts solar units for the metallicity; !RAMSES (cooling_fine.f90) assumes absolute units! -> set ic_scale_metal = 0.02 endif endif if(kpart.gt.header%npart(1)+header%npart(2)) then if(age_blck.ne.-1) then if(cosmo) then tt(i) = tt_sp(i) else tt(i) = tt_sp(i)*(gadget_scale_t/(scale_t/aexp**2))*ic_scale_age endif endif endif if(kpart.le.header%npart(1)) then if(cosmo) then uu(i) = T2_start/scale_T2 else ! Temperature stored in units of K/mu uu(i) = uu_sp(i)*mu_mol*(gadget_scale_v/scale_v)**2*ic_scale_u endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trc(i) = trc_sp(i) endif if(kpart.le.header%npart(1)) mgas_tot = mgas_tot+mm(i) ! Check the End Of Block if(kpart.ge.ipbar*(npart/49.0))then write(*,'(A1)',advance='no') '_' ipbar = ipbar+1.0 endif if(kpart.ge.npart) then write(*,'(A1)') ' ' write(*,'(A,A7,A)') ' ',TRIM(ic_format),' file successfully loaded' write(*,'(A50)')'__________________________________________________' eob=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BCAST(eob,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ii,nvector ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(zz,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(tt,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) call MPI_BCAST(trc,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(header%npart,6,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif ! Determine current particle type if((lpart+i).le.header%npart(1)) type_index = 1 !TTG (MAR 2017): identify gas particles do j=1,5 if((lpart+i).gt.sum(header%npart(1:j)).and.(lpart+i).le.sum(header%npart(1:j+1))) type_index = j+1 enddo skip = .false. do j=1,6 if(ic_skip_type(j).eq.type_index-1) skip=.true. enddo if(.not.skip) then if(abs(xx(i,1)-ic_center(1)).ge.boxlen/2d0) cycle if(abs(xx(i,2)-ic_center(2)).ge.boxlen/2d0) cycle if(abs(xx(i,3)-ic_center(3)).ge.boxlen/2d0) cycle ipart = ipart+1 if(ipart.gt.npartmax) then write(*,*) 'Increase npartmax' #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif xp(ipart,1:3) = xx(i,1:3)+boxlen/2.0D0-ic_center(1:3) vp(ipart,1:3) = vv(i,1:3) !! CHANGED BY TTG (FEB 2017): identify particles by their Gadget type number (0 = gas; 1 = DM halo; 2 = disc; 3 = bulge) ! ! Flag gas particles with idp=1 ! if(type_index.gt.1)then !! idp(ipart) = ii(i)+1 !this is the original line ! idp(ipart) = type_index !TTG (FEB 2017): this is the Gadget type shifted by +1; init_refine does -1 ! else ! idp(ipart) = 1 ! endif ! CHANGED BY TTG (MAR 2017): identify particles by their myDICE component number ! NOTE: need to modify init_flow_fine.f90/condinit_loc accordingly! idp(ipart) = ii(i) !TTG (MAR 2017): this is the myDICE component number (even = gas; odd = DM/stars) mp(ipart) = mm(i) levelp(ipart) = levelmin if(star) then tp(ipart) = tt(i) ! CHANGED BY TTG (FEB 2017) ! Particle metallicity ! if(metal) then ! zp(ipart) = zz(i) ! endif endif ! ADDED BY TTG (FEB 2017) ! to allow the use of metallicity for gas components ! Particle metallicity if(metal) then zp(ipart) = zz(i) endif up(ipart) = uu(i) ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trcp(ipart) = trc(i) ! Add a gas particle outside the zoom region if(cosmo) then maskp(ipart) = 1.0 do j=1,6 if(type_index.eq.cosmo_add_gas_index(j)) then ! Add a gas particle xp(ipart+1,1:3) = xp(ipart,1:3) vp(ipart+1,1:3) = vp(ipart,1:3) ! CHANGED BY TTG (MAY 2017): identify particles by their myDICE component number (even = gas; odd = DM/stars) ! idp(ipart+1) = -1 idp(ipart+1) = -2 mp(ipart+1) = mp(ipart)*(omega_b/omega_m) levelp(ipart+1) = levelmin up(ipart+1) = T2_start/scale_T2 maskp(ipart+1) = 0.0 if(metal) then zp(ipart+1) = z_ave*0.02 endif ! Remove mass from the DM particle mp(ipart) = mp(ipart)-mp(ipart+1) ! Update index ipart = ipart+1 endif end do endif endif #ifndef WITHOUTMPI endif #endif enddo lpart = lpart+jpart enddo if(myid==1)then write(*,'(A,E10.3)') ' Gas mass in AMR grid [Msun]-> ',mgas_tot*scale_m/msol write(*,'(A50)')'__________________________________________________' close(1) endif enddo npart = ipart ! Compute total number of particles npart_cpu = 0 npart_all = 0 npart_cpu(myid) = npart #ifndef WITHOUTMPI call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) npart_cpu(1) = npart_all(1) #else npart_all = npart #endif if(myid==1)then write(*,*) ' npart_tot -> ',sum(npart_all) write(*,'(A50)')'__________________________________________________' close(1) endif do icpu=2,ncpu npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu) end do !! if(debug)write(*,*)'npart=',npart,'/',npart_cpu(ncpu) ! if(debug)write(*,*)'DICE file: npart(myid)=',npart,'(',myid,') / ',npart_cpu(ncpu) ifout = ic_ifout t = ic_t_restart ! DICE patch !---------------------------------------------------------------------- !---------------------------------------------------------------------- ! RESTART patch ! ! ADDED BY TTG MAY 2017 ! ! This is a *modified* version of the analogue snippet provided ! by the current RAMSES distribution in patch/init/restart/init_part.f90 ! written by Valentin Perret. ! This restart patch makes use of V.Perret's DICE patch (see ! patch/init/dice) ! Essentially, this patch transforms a Ramses output file into a DICE ! Initial Conditions (input) file. ! The idea is to remap the AMR fluid variables and particles onto ! a set of particles following the DICE structure, and re-map these onto ! RAMSES at *levelmin* using the DICE framework. ! ! IMPORTANT: This restart differs from the usual restart procedure in that ! 1) it allows to change the number of processors; ! 2) it allows to shift the system's position (does not yet take care of ! particles at boundary) ! 3) it allows to shift the system's velocities (need to implement and test this!) ! ! TO DO: ! - Additional paramters to the RESTART_PARAMS namelist to e.g. shift ! the velocity of AMR pseudo particles, reset their metallicity or gas ! tracer, etc. ! case ('ramses') ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) scale_m = scale_d*scale_l**3 !LMC / SMC transformation angles (in radian) pi = DACOS(-1.0d0) theta_1 = pi*(66./180.) cos_theta_1 = DCOS(theta_1) sin_theta_1 = DSIN(theta_1) theta_2 = pi*(231.2/180.) cos_theta_2 = DCOS(theta_2) sin_theta_2 = DSIN(theta_2) theta_3 = pi*(31.9/180.) cos_theta_3 = DCOS(theta_3) sin_theta_3 = DSIN(theta_3) theta_4 = pi*(18.5/180.) cos_theta_4 = DCOS(theta_4) sin_theta_4 = DSIN(theta_4) ! Initialisation restart_init = .true. dice_init = .true. !-> VERY IMPORTANT: switch on DICE patch ! amr_struct = .false. !-> does not conserve mass but works better; do NOT hardcode, though eocpu = .false. error = .false. icpu = 1 lpart_restart = 0 ipart = 0 mhalo_tot = 0. mstar_tot = 0. mgas_tot_restart = 0. nhalo_tot = 0 nstar_tot = 0 if(myid==1) then write(*,'(A50)')'__________________________________________________' write(*,*)' RAMSES restart' write(*,'(A50)')'__________________________________________________' endif do while(.not.eocpu) nstar_loc = 0 nhalo_loc = 0 ngas_loc = 0 nsink_loc = 0 if(myid==1)then call title(abs(nrestart),nchar) if(icpu==1) write(*,'(a)') ' Loading -> '//TRIM(output_dir)//'output_'//TRIM(nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/part_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(.not.ok)then write(*,*) TRIM(fileloc),' not found' call clean_stop endif ilun1 = 1 OPEN(unit=ilun1,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos = 1 read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%ncpu; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%ndim; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%npart; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%localseed; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%nstar_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%mstar_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%mstar_lost; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%nsink; mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Init block address read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) pos_blck_restart(1) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) pos_blck_restart(2) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) pos_blck_restart(3) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) vel_blck_restart(1) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) vel_blck_restart(2) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) vel_blck_restart(3) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) mass_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) id_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) level_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) if(star.or.sink)then read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) age_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) if(metal) then read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) metal_blck_restart = mypos endif endif endif ! TTG 2018: Loop to read particles eob_restart = .false. kpart_restart = 0 do while(.not.eob_restart) xx=0. vv=0. ii=0. mm=0. tt=0. zz=0. !ADDED BY TTG MAY 2017 uu = 0. if(myid==1)then jpart=0 do i=1,nvector jpart=jpart+1 ! All particles counter kpart_restart=kpart_restart+1 ! Reading ramses part file line-by-line do idim=1,ndim read(ilun1,pos=pos_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) xx(jpart,idim) end do do idim=1,ndim read(ilun1,pos=vel_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) vv(jpart,idim) end do read(ilun1,pos=mass_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) mm(jpart) read(ilun1,pos=id_blck_restart+sizeof(dummy_int)*(kpart_restart-1)) ii(jpart) if(star.or.sink) then read(ilun1,pos=age_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) tt(jpart) if(metal) then read(ilun1,pos=metal_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) zz(jpart) endif endif ! Updating total masses if(tt(jpart)==0d0) then mhalo_tot = mhalo_tot+mm(jpart) nhalo_tot = nhalo_tot+1 nhalo_loc = nhalo_loc+1 else mstar_tot = mstar_tot+mm(jpart) nstar_tot = nstar_tot+1 nstar_loc = nstar_loc+1 endif ! Check the End Of Block if(kpart_restart.ge.header_part%npart) then eob_restart=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BCAST(eob_restart,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ii,nvector ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(zz,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(tt,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BARRIER(MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif !HERE: transform particle positions and velocities ! xx(i,1:3) = xx(i,1:3)-restart_ic_center(1:3) xx(i,1:3) = xx(i,1:3) - 0.5*5.0d2 ! shift positions by half the original box size xx(i,1:3) = xx(i,1:3) - lmc_com ! shift positions to the LMC CoM vv(i,1:3) = vv(i,1:3) - lmc_cov/scale_v ! shift vel to the LMC CoV !Rotate all vectors counter-clockwise around x axis by 66 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_1*x_2_save - sin_theta_1*x_3_save xx(i,3) = sin_theta_1*x_2_save + cos_theta_1*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_1*v_2_save - sin_theta_1*v_3_save vv(i,3) = sin_theta_1*v_2_save + cos_theta_1*v_3_save !Rotate all vectors counter-clockwise around z axis by 231.2 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_2*x_1_save - sin_theta_2*x_2_save xx(i,2) = sin_theta_2*x_1_save + cos_theta_2*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_2*v_1_save - sin_theta_2*v_2_save vv(i,2) = sin_theta_2*v_1_save + cos_theta_2*v_2_save !Translate positons xx(i,1:3) = xx(i,1:3) + r_shift !Translate velocities vv(i,1:3) = vv(i,1:3) + v_shift/scale_v !Rotate all vectors counter-clockwise around x axis by 31.9 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_3*x_2_save - sin_theta_3*x_3_save xx(i,3) = sin_theta_3*x_2_save + cos_theta_3*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_3*v_2_save - sin_theta_3*v_3_save vv(i,3) = sin_theta_3*v_2_save + cos_theta_3*v_3_save !Rotate all vectors counter-clockwise around z axis by 18.5 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_4*x_1_save - sin_theta_4*x_2_save xx(i,2) = sin_theta_4*x_1_save + cos_theta_4*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_4*v_1_save - sin_theta_4*v_2_save vv(i,2) = sin_theta_4*v_1_save + cos_theta_4*v_2_save !Shift positions by half the new box size xx(i,1:3) = xx(i,1:3) + 0.5*boxlen if(xx(i,1).ge.0d0.and.xx(i,1).le.boxlen.and. & & xx(i,2).ge.0d0.and.xx(i,2).le.boxlen.and. & & xx(i,3).ge.0d0.and.xx(i,3).le.boxlen) then ipart = ipart+1 if(ipart.gt.npartmax) then write(*,*) 'Increase npartmax' error=.true. #ifndef WITHOUTMPI call MPI_BCAST(error,1,MPI_LOGICAL,0,MPI_COMM_WORLD,info) #endif endif xp(ipart,1:3) = xx(i,1:3) vp(ipart,1:3) = vv(i,1:3) !CHANGED BY TTG MAY 2017 ! idp(ipart) = ii(i)+1 idp(ipart) = ii(i) mp(ipart) = mm(i) !ADDED BY TTG MAY 2017 up(ipart) = uu(i) levelp(ipart) = levelmin if(star) then tp(ipart) = tt(i) if(metal) then zp(ipart) = zz(i) endif endif endif #ifndef WITOUTMPI endif #endif enddo #ifndef WITOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(error) call clean_stop enddo if(myid==1)then ! Conversion factor from user units to cgs units ! call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! scale_m = scale_d*scale_l**3 call title(abs(nrestart),nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/amr_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(.not.ok)then write(*,*) TRIM(fileloc),' not found' call clean_stop endif ilun2 = 2 OPEN(unit=ilun2,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos=1 read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ncpu; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ndim; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nx,header_amr%ny,header_amr%nz; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nlevelmax; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ngridmax; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nboundary; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ngrid_current; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%boxlen; mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Read time variables read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%noutput,header_amr%iout,header_amr%ifout; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%tout(1:header_amr%noutput); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%aout(1:header_amr%noutput); mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Old output times read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%t; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%dtold(1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%dtnew(1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nstep,header_amr%nstep_coarse; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%einit,header_amr%mass_tot_0,header_amr%rho_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%omega_m,header_amr%omega_l,header_amr%omega_k, & & header_amr%omega_b,header_amr%h0,header_amr%aexp_ini,header_amr%boxlen_ini; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%aexp,header_amr%hexp,header_amr%aexp_old,header_amr%epot_tot_int,header_amr%epot_tot_old; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%mass_sph; mypos=mypos+sizeof(dummy_int)+size_blck_restart header_amr%twotondim=2**header_amr%ndim header_amr%twondim=2*header_amr%ndim ! Read levels variables if(icpu==1) then allocate(header_amr%headl(1:header_amr%ncpu,1:header_amr%nlevelmax)) allocate(header_amr%taill(1:header_amr%ncpu,1:header_amr%nlevelmax)) allocate(header_amr%numbl(1:header_amr%ncpu,1:header_amr%nlevelmax)) allocate(header_amr%numbtot(1:10,1:header_amr%nlevelmax)) endif read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%headl(1:header_amr%ncpu,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%taill(1:header_amr%ncpu,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%numbl(1:header_amr%ncpu,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%numbtot(1:10,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Read boundary linked list if(icpu==1) then allocate(header_amr%headb (1:MAXBOUND,1:header_amr%nlevelmax)) allocate(header_amr%tailb (1:MAXBOUND,1:header_amr%nlevelmax)) allocate(header_amr%numbb (1:MAXBOUND,1:header_amr%nlevelmax)) allocate(header_amr%boundary(1:MAXBOUND,1:header_amr%nlevelmax)) endif if(simple_boundary)then read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%headb(1:header_amr%nboundary,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%tailb(1:header_amr%nboundary,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%numbb(1:header_amr%nboundary,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart end if ! Read free memory read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%headf,header_amr%tailf,header_amr%numbf,header_amr%used_mem,header_amr%used_mem_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Read cpu boundaries read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ordering; mypos=mypos+sizeof(dummy_int)+size_blck_restart header_amr%nbilevelmax=ceiling(log(dble(header_amr%ncpu))/log(2.0)) header_amr%nbinodes=2**(nbilevelmax+1)-1 header_amr%ndomain=header_amr%ncpu*overload if(icpu==1) allocate(header_amr%bound_key (0:header_amr%ndomain)) if(header_amr%ordering=='bisection') then read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_wall(1:header_amr%nbinodes); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_next(1:header_amr%nbinodes,1:2); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_indx(1:header_amr%nbinodes); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_cpubox_min(1:header_amr%ncpu,1:header_amr%ndim); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_cpubox_max(1:header_amr%ncpu,1:header_amr%ndim); mypos=mypos+sizeof(dummy_int)+size_blck_restart else read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bound_key(0:header_amr%ndomain); mypos=mypos+sizeof(dummy_int)+size_blck_restart endif ! Read coarse level ! Son array read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Flag array read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! cpu_map array read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart if(icpu==1) then allocate(amr_pos_blck_restart(1:header_amr%ndim,1:header_amr%nlevelmax,1:header_amr%nboundary+header_amr%ncpu)) allocate(amr_son_blck_restart(1:header_amr%nlevelmax,1:header_amr%nboundary+header_amr%ncpu,1:header_amr%twotondim)) endif ! Read fine levels do ilevel=1,header_amr%nlevelmax do ibound=1,header_amr%nboundary+header_amr%ncpu if(ibound<=header_amr%ncpu)then ncache=header_amr%numbl(ibound,ilevel) else ncache=header_amr%numbb(ibound-header_amr%ncpu,ilevel) end if if(ncache>0)then ! Read grid index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read next index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read prev index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read grid center do idim=1,header_amr%ndim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) amr_pos_blck_restart(idim,ilevel,ibound) = mypos; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(size_blck_restart.ne.ncache*sizeof(dummy_real_restart)) then write(*,*) 'AMR -> Grid center block size does not correspond to ncache' call clean_stop endif end do ! Read father index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read nbor index do ind=1,header_amr%twondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart end do ! Read son index do ind=1,header_amr%twotondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) amr_son_blck_restart(ilevel,ibound,ind) = mypos; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(size_blck_restart.ne.ncache*sizeof(dummy_int)) then write(*,*) 'AMR -> Son index block size does not correspond to ncache' call clean_stop endif end do ! Read cpu map do ind=1,header_amr%twotondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart end do ! Read refinement map do ind=1,header_amr%twotondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart end do endif end do end do call title(abs(nrestart),nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/hydro_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(.not.ok)then write(*,*) TRIM(fileloc),' not found' call clean_stop endif ilun3 = 3 OPEN(unit=ilun3,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos=1 read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%ncpu; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%nvar; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%ndim; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%nlevelmax; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%nboundary; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%gamma; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(icpu==1) & &allocate(hydro_var_blck_restart(1:header_amr%nlevelmax,1:header_amr%nboundary+header_amr%ncpu,1:header_amr%twotondim,1:header_hydro%nvar)) do ilevel=1,header_hydro%nlevelmax do ibound=1,header_hydro%nboundary+header_hydro%ncpu if(ibound<=header_hydro%ncpu)then ncache=header_amr%numbl(ibound,ilevel) else ncache=header_amr%numbb(ibound-header_hydro%ncpu,ilevel) end if read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)ilevel2; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)numbl2; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(numbl2.ne.ncache)then write(*,*)'File hydro.tmp is not compatible' write(*,*)'Found =',numbl2,' for level ',ilevel2 write(*,*)'Expected=',ncache,' for level ',ilevel end if if(ncache>0)then ! Loop over cells do ind=1,header_amr%twotondim ! Read all hydro var do ivar=1,header_hydro%nvar read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) hydro_var_blck_restart(ilevel,ibound,ind,ivar)=mypos mypos=mypos+sizeof(dummy_int)+size_blck_restart if(size_blck_restart.ne.ncache*sizeof(dummy_real_restart)) then write(*,*) 'HYDRO -> Var block size does not correspond to ncache' call clean_stop endif end do end do end if end do end do if(nvector/header_amr%twotondim==0) then write(*,*) 'Recompile with a greater value for NVECTOR' call clean_stop endif endif if(icpu==1) then #ifndef WITHOUTMPI call MPI_BCAST(header_amr%nlevelmax,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%ndim,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%twotondim,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%ncpu,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%nboundary,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%ifout,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%t,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(header_amr%iout,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(header_amr%tout,MAXOUT ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(header_amr%aout,MAXOUT ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(header_amr%noutput,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%nstep_coarse,1,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%nstep,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%boxlen,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(header_amr%einit,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%mass_tot_0,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%rho_tot,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_hydro%nvar,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_hydro%ndim,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) if(cosmo) then call MPI_BCAST(header_amr%omega_m,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%omega_l,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%h0,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%boxlen_ini,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%aexp,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) endif call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1) write(*,'(A50)')'__________________________________________________' ! Number of passive scalars to load (does NOT include internal energy) nvar_min = min(header_hydro%nvar-header_hydro%ndim-1,nvar-ndim-1)-1 if(myid==1) write(*,*) '[Info] Number of passive variables [restart_passive_var]: ', nvar_min ! restart_boxlen = header_amr%boxlen if(cosmo) then omega_m = header_amr%omega_m omega_l = header_amr%omega_l h0 = header_amr%h0 boxlen_ini = header_amr%boxlen_ini aexp = header_amr%aexp aexp_ini = aexp endif allocate(pasvar(1:nvector,1:nvar_min)) ! Check passive hydro variables indices ! if(myid==1) write(*,'(A50)')'__________________________________________________' do ivar=1,nvar_min if(myid==1) write(*,'(A,I2,A,I2)') ' [Info] Passive variable ',restart_passive_vars(ivar),' loaded in var',ndim+2+ivar if(restart_passive_vars(ivar).gt.header_hydro%nvar) then if(myid==1) write(*,*) '[Error] ivar=',restart_passive_vars(ivar),' is empty in the restart output' call clean_stop endif ! if(restart_passive_vars(ivar).lt.header_amr%ndim+2) then if(restart_passive_vars(ivar).le.header_amr%ndim+2) then ! include internal energy / pressure if(myid==1) write(*,*) '[Error] ivar=',restart_passive_vars(ivar),' is an active variable' if(myid==1) write(*,*) '[Info] Additional variables have indices from ', ndim+2+nvar_min-1, 'to', header_hydro%nvar call clean_stop endif enddo if(myid==1) write(*,'(A50)')'__________________________________________________' ! (Re-)setting simulation time if(.not.reset_time) then t = header_amr%t ifout = header_amr%ifout !ADDED BY TTG MAY 2017 ! noutput = header_amr%noutput iout = header_amr%iout ! tout(1:noutput)= header_amr%tout(1:header_amr%noutput) ! aout(1:noutput)= header_amr%aout(1:header_amr%noutput) ! if(ifout.gt.abs(nrestart)+1) ifout=abs(nrestart)+1 nstep_coarse = header_amr%nstep_coarse nstep = header_amr%nstep endif ! (Re-)setting mass / energy / density conservation !ADDED BY TTG MAY 2017 if(.not.reset_cvars) then einit = header_amr%einit mass_tot_0= header_amr%mass_tot_0 rho_tot = header_amr%rho_tot endif ! Compute movie frame number if applicable if(imovout>0) then do i=2,imovout if(aendmov>0)then if(aexp>amovout(i-1).and.aexptmovout(i-1).and.t0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=header_amr%boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**header_amr%ndim do ind=1,header_amr%twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do do ibound=1,header_amr%nboundary+header_amr%ncpu if(myid==1) then if(ibound<=header_amr%ncpu)then ncache=header_amr%numbl(ibound,ilevel) else ncache=header_amr%numbb(ibound-header_amr%ncpu,ilevel) end if endif #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) call MPI_BCAST(ncache,1,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(ncache>0.and.ibound.eq.icpu) then kpart_restart = 0 eob_restart = .false. do while(.not.eob_restart) xx = 0. xxg = 0. vv = 0. mm = 0. tt = 0. pasvar = 0. uu = 0. jpart = 0 if(myid==1) then do i=1,nvector/header_amr%twotondim ! All particles counter kpart_restart=kpart_restart+1 ! Read the grid center one time per twotondim cells read_center=.true. ! Loop over cells do ind=1,header_amr%twotondim read(ilun2,pos=amr_son_blck_restart(ilevel,ibound,ind)+sizeof(dummy_int)*(kpart_restart-1)) son1 ! Consider leaf cells only if(son1==0) then jpart = jpart+1 lpart_restart = lpart_restart+1 ! Reading grid center ! TTG 2017: Converting to physical units is this taken care of when reading velocities below; ! This needs to be done this way since reading will be executed only once per oct! if(read_center) then do idim=1,ndim read(ilun2,pos=amr_pos_blck_restart(idim,ilevel,ibound)+sizeof(dummy_real_restart)*(kpart_restart-1)) xxg(idim) end do read_center=.false. endif ! Reading cell density read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,1)+sizeof(dummy_real_restart)*(kpart_restart-1)) mm(jpart) if(mm(jpart).lt.restart_rho_min) restart_rho_min = mm(jpart) if(mm(jpart).gt.restart_rho_max) restart_rho_max = mm(jpart) ! Converting to mass mm(jpart)=mm(jpart)*vol_loc ! Updating total mass mgas_tot_restart=mgas_tot_restart+mm(jpart) ! Updating leaf cells counter ngas_loc = ngas_loc+1 ! Reading velocities AND convert grid centre to physical units do idim=1,ndim read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,idim+1)+sizeof(dummy_real_restart)*(kpart_restart-1)) vv(jpart,idim) xx(jpart,idim)=(xxg(idim)+xc(ind,idim)-skip_loc(idim))*scale end do ! TTG MAY 2017: reading gas thermal pressure read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,header_amr%ndim+2)+sizeof(dummy_real_restart)*(kpart_restart-1)) uu(jpart) ! TTG MAY 2017: transform to SPECIFIC internal energy uu(jpart)=uu(jpart)/(header_hydro%gamma-1.d0)/(mm(jpart)/vol_loc) ! Reading passive hydro variables do ivar=1,nvar_min if(restart_passive_vars(ivar).gt.header_amr%ndim+2.and.restart_passive_vars(ivar).le.header_hydro%nvar) then read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,restart_passive_vars(ivar))+sizeof(dummy_real_restart)*(kpart_restart-1))& &pasvar(jpart,ivar) if(metal.and.((ndim+2+ivar)==imetal)) zz(jpart) = pasvar(jpart,ivar) if((ndim+2+ivar)==itracer) trc(jpart) = pasvar(jpart,ivar) endif enddo endif enddo ! Check the End Of Block if(kpart_restart.ge.ncache) then eob_restart=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) call MPI_BCAST(eob_restart,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(kpart_restart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(pasvar,nvector*nvar_min ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(zz,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(trc,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif !HERE: transform pseudo particle positions and velocities ! xx(i,1:3) = xx(i,1:3)-restart_ic_center(1:3) xx(i,1:3) = xx(i,1:3) - 0.5*5.0d2 ! shift positions by half the original box size xx(i,1:3) = xx(i,1:3) - lmc_com ! shift positions by the LMC CoM vv(i,1:3) = vv(i,1:3) - lmc_cov/scale_v ! shift vel by the LMC CoV !Rotate all vectors counter-clockwise around x axis by 66 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_1*x_2_save - sin_theta_1*x_3_save xx(i,3) = sin_theta_1*x_2_save + cos_theta_1*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_1*v_2_save - sin_theta_1*v_3_save vv(i,3) = sin_theta_1*v_2_save + cos_theta_1*v_3_save !Rotate all vectors counter-clockwise around z axis by 231.2 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_2*x_1_save - sin_theta_2*x_2_save xx(i,2) = sin_theta_2*x_1_save + cos_theta_2*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_2*v_1_save - sin_theta_2*v_2_save vv(i,2) = sin_theta_2*v_1_save + cos_theta_2*v_2_save !Translate positons xx(i,1:3) = xx(i,1:3) + r_shift !Translate velocities vv(i,1:3) = vv(i,1:3) + v_shift/scale_v !Rotate all vectors counter-clockwise around x axis by 31.9 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_3*x_2_save - sin_theta_3*x_3_save xx(i,3) = sin_theta_3*x_2_save + cos_theta_3*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_3*v_2_save - sin_theta_3*v_3_save vv(i,3) = sin_theta_3*v_2_save + cos_theta_3*v_3_save !Rotate all vectors counter-clockwise around z axis by 18.5 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_4*x_1_save - sin_theta_4*x_2_save xx(i,2) = sin_theta_4*x_1_save + cos_theta_4*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_4*v_1_save - sin_theta_4*v_2_save vv(i,2) = sin_theta_4*v_1_save + cos_theta_4*v_2_save !Shift positions by half the new box size xx(i,1:3) = xx(i,1:3) + 0.5*boxlen if(xx(i,1).ge.0d0.and.xx(i,1).le.boxlen.and. & & xx(i,2).ge.0d0.and.xx(i,2).le.boxlen.and. & & xx(i,3).ge.0d0.and.xx(i,3).le.boxlen) then ipart = ipart+1 if(ipart.gt.npartmax) then write(*,*) 'Increase npartmax' error=.true. #ifndef WITHOUTMPI call MPI_BCAST(error,1,MPI_LOGICAL,0,MPI_COMM_WORLD,info) #endif endif xp(ipart,1:3) = xx(i,1:3) vp(ipart,1:3) = vv(i,1:3) mp(ipart) = mm(i) !ADDED BY TTG MAY 2017 up(ipart) = uu(i) ! Flagged as gas particles ! idp(ipart) = 1 !CHANGED BY TTG MAY 2017 ! Flagged as gas particles according to myDICE (gas -> even id; collisionless -> odd id) idp(ipart) = 2 !CHANGED BY TTG MAY 2017 ! levelp(ipart) = ilevel levelp(ipart) = levelmin ! do ivar=1,nvar_min ! if(metal.and.((ndim+2+ivar)==imetal)) zp(ipart) = pasvar(i,ivar) ! if((ndim+2+ivar)==itracer) trcp(ipart) = pasvar(i,ivar) ! end do zp(ipart) = zz(i) trcp(ipart) = trc(i) endif #ifndef WITOUTMPI endif #endif enddo #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(error) call clean_stop enddo endif enddo enddo if(myid==1) then call title(abs(nrestart),nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/sink_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(sink.and.ok)then ilun4 = 4 OPEN(unit=ilun4,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos=1 read(ilun4,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun4,pos=mypos)header_sink%nsink; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun4,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun4,pos=mypos)header_sink%nindsink; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(header_sink%nsink>0)then ! Sink mass read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_mass_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink birth epoch read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_birth_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink position do idim=1,ndim read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_pos_blck_restart(idim) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) end do ! Sink velocitiy do idim=1,ndim read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_vel_blck_restart(idim) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) end do ! Sink angular momentum do idim=1,ndim read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_am_blck_restart(idim) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) end do ! Sink accumulated rest mass energy read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_dm_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink accretion rate read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_ar_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink index read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_index_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink new born boolean read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_newb_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink int level read(ilun4,pos=mypos) sinkint_level; mypos=mypos+sizeof(dummy_int)+size_blck_restart endif eob_restart = .false. kpart_restart = 0 do while(.not.eob_restart) xx=0. vv=0. ii=0. mm=0. tt=0. zz=0. aa=0. dd=0. ll=0. !ADDED BY TTG MAY 2017 uu=0. nn=.false. if(myid==1)then jpart=0 do i=1,nvector jpart=jpart+1 ! All particles counter kpart_restart=kpart_restart+1 ! Reading ramses sink file line-by-line do idim=1,ndim read(ilun4,pos=sink_pos_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) xx(jpart,idim) read(ilun4,pos=sink_vel_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) vv(jpart,idim) read(ilun4,pos=sink_am_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) ll(jpart,idim) end do read(ilun4,pos=sink_mass_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) mm(jpart) read(ilun4,pos=sink_index_blck_restart+sizeof(dummy_int)*(kpart_restart-1)) ii(jpart) read(ilun4,pos=sink_dm_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) dd(jpart) read(ilun4,pos=sink_ar_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) aa(jpart) read(ilun4,pos=sink_newb_blck_restart+sizeof(dummy_logical)*(kpart_restart-1)) nn(jpart) ! Updating total masses if(tt(jpart)==0d0) then msink_tot = msink_tot+mm(jpart) nsink_tot = nsink_tot+1 nsink_loc = nsink_loc+1 endif ! Check the End Of Block if(kpart_restart.ge.header_part%npart) then eob_restart=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BCAST(eob_restart,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ll,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ii,nvector ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(nn,nvector ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(tt,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif !HERE: transform sink particle positions and velocities ! xx(i,1:3) = xx(i,1:3)-restart_ic_center(1:3) xx(i,1:3) = xx(i,1:3) - 0.5*5.0d2 ! shift positions by half the original box size xx(i,1:3) = xx(i,1:3) - lmc_com ! shift positions by the LMC CoM vv(i,1:3) = vv(i,1:3) - lmc_cov/scale_v ! shift vel by the LMC CoV !Rotate all vectors counter-clockwise around x axis by 66 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_1*x_2_save - sin_theta_1*x_3_save xx(i,3) = sin_theta_1*x_2_save + cos_theta_1*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_1*v_2_save - sin_theta_1*v_3_save vv(i,3) = sin_theta_1*v_2_save + cos_theta_1*v_3_save !Rotate all vectors counter-clockwise around z axis by 231.2 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_2*x_1_save - sin_theta_2*x_2_save xx(i,2) = sin_theta_2*x_1_save + cos_theta_2*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_2*v_1_save - sin_theta_2*v_2_save vv(i,2) = sin_theta_2*v_1_save + cos_theta_2*v_2_save !Translate positons xx(i,1:3) = xx(i,1:3) + r_shift !Translate velocities vv(i,1:3) = vv(i,1:3) + v_shift/scale_v !Rotate all vectors counter-clockwise around x axis by 31.9 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_3*x_2_save - sin_theta_3*x_3_save xx(i,3) = sin_theta_3*x_2_save + cos_theta_3*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_3*v_2_save - sin_theta_3*v_3_save vv(i,3) = sin_theta_3*v_2_save + cos_theta_3*v_3_save !Rotate all vectors counter-clockwise around z axis by 18.5 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_4*x_1_save - sin_theta_4*x_2_save xx(i,2) = sin_theta_4*x_1_save + cos_theta_4*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_4*v_1_save - sin_theta_4*v_2_save vv(i,2) = sin_theta_4*v_1_save + cos_theta_4*v_2_save !Shift positions by half the new box size xx(i,1:3) = xx(i,1:3) + 0.5*boxlen if(xx(i,1).ge.0d0.and.xx(i,1).le.boxlen.and. & & xx(i,2).ge.0d0.and.xx(i,2).le.boxlen.and. & & xx(i,3).ge.0d0.and.xx(i,3).le.boxlen) then ipart = ipart+1 if(ipart.gt.nsinkmax) then write(*,*) 'Increase nsinkmax' error=.true. #ifndef WITHOUTMPI call MPI_BCAST(error,1,MPI_LOGICAL,0,MPI_COMM_WORLD,info) #endif endif xsink(ipart,1:3) = xx(i,1:3) vsink(ipart,1:3) = vv(i,1:3) lsink(ipart,1:3) = ll(i,1:3) msink(ipart) = mm(i) tsink(ipart) = tt(i) delta_mass(ipart) = dd(i) acc_rate(ipart) = aa(i) idsink(ipart) = ii(i) new_born(ipart) = nn(i) endif #ifndef WITOUTMPI endif #endif enddo #ifndef WITOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) if(error) call clean_stop #endif enddo call compute_ncloud_sink if(ir_feedback)then do i=1,nsink acc_lum(i)=ir_eff*acc_rate(i)*msink(i)/(5*6.955d10/scale_l) end do end if endif endif if(myid==1) then close(ilun1) close(ilun2) close(ilun3) close(ilun4) write(*,*) 'CPU',icpu,' -> [',ngas_loc,'cells/',nstar_loc,'stars/',nhalo_loc,'dm]' icpu = icpu+1 if(icpu.gt.header_part%ncpu) eocpu=.true. endif #ifndef WITHOUTMPI call MPI_BCAST(eocpu,1 ,MPI_LOGICAL,0,MPI_COMM_WORLD,info) call MPI_BCAST(icpu,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(nstar_tot,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(mstar_tot,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(restart_rho_min,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(restart_rho_max,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) #endif enddo if(myid==1) then write(*,'(a50)')'__________________________________________________' write(*,*)' RAMSES restart summary' write(*,'(A50)')'__________________________________________________' write(*,'(a32,i10)') 'Restart snapshot [ifout]: ',ifout-1 write(*,'(a32,1pe10.4)') 'Restart time [t]: ',t write(*,'(a32,1pe10.4)') 'Next snapshot time [tout(iout)]: ',tout(iout) write(*,'(a32,i10)') 'Total snapshots [noutput]: ',noutput write(*,'(a32,i10)') 'Main step [nstep_coarse]: ',nstep_coarse write(*,'(a32,i10)') 'Fine step [nstep]: ',nstep write(*,'(a32,i10)') 'CPUs: ',header_amr%ncpu write(*,'(a32,i10)') 'DM particles: ',nhalo_tot write(*,'(a32,1pe10.2)') 'M_DM [Msun]: ',mhalo_tot*scale_m/msol write(*,'(a32,i10)') 'STAR particles: ',nstar_tot write(*,'(a32,1pe10.2)') 'M_stars [Msun]: ',mstar_tot*scale_m/msol if(hydro) write(*,'(a32,i10)') 'GAS particles [leaf cells]: ',lpart_restart if(hydro) write(*,'(a32,1pe10.2)') 'M_gas [Msun]: ',mgas_tot_restart*scale_m/msol if(hydro) write(*,'(a32,1pe10.2)') 'rho_min [cm^-3]: ',restart_rho_min if(hydro) write(*,'(a32,1pe10.2)') 'rho_max [cm^-3]: ',restart_rho_max if(sink) write(*,'(a32,i10)') 'SINK particles: ',nsink_tot if(sink) write(*,'(a32,1pe10.2)') 'M_sink [Msun]: ',msink_tot*scale_m/msol write(*,'(a50)')'__________________________________________________' endif npart = ipart ! Compute total number of particles npart_cpu = 0 npart_all = 0 npart_cpu(myid) = npart #ifndef WITHOUTMPI call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) npart_cpu(1) = npart_all(1) #endif if(myid==1)then write(*,*) ' npart_tot -> ',sum(npart_all) write(*,'(A50)')'__________________________________________________' close(1) endif do icpu=2,ncpu npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu) end do ! if(debug)write(*,*)'RAMSES file: npart(myid)=',npart,'(',myid,') / ',npart_cpu(ncpu) ! RESTART patch !---------------------------------------------------------------------- !---------------------------------------------------------------------- ! DICE_RESTART patch ! ! ADDED BY TTG MAY 2017 ! ! This is a merge of cases 'dice' and 'ramses' with some minor tweaks ! It allows to add DICE initial conditions at restart by simply appending ! the new particle list to the 'old' (i.e. the restart snapshot's) list. ! Essentially, this patch transforms a Ramses output file into a second ! DICE Initial Conditions (input) file. This and the actual DICE ICs input ! file are then effectively treated as one DICE IC input file. ! The remap of a Ramses output onto (pseudo) particles is based on the ! RESTART patch [see case('ramses')]. ! ! ! NOTE: As the RESTART patch, this patch: ! 1) allows to change the number of processors; ! 2) allows to shift the system's position (does not yet take care of ! particles at boundary) ! 3) it allows to shift the system's velocities (need to implement and test this!) ! ! ! IMPORTANT: It does not fully satisfactorily. The fluid variables ! of the new DICE ICs show a strange, regular grid structure ! at initialisation, especially when new grids are added. ! This is accompanied by a weird effect where the values of ! the 'old' RAMSES fluid variables and the new DICE variables ! are not properly interpolated in the new grid(s) ! I have NO idea why this happens and how to solve it... ! Note that assigning the 'old' RAMSES 'particles' to their ! original level via levelp and taking this into account ! at initialisation through init_flow_fine/init_gas_cic does ! not help. This change requires assigning the new DICE ! particles to nlevelmax, as otherwise they are ignored. ! In this case, however, the old RAMSES variables are fully ! overwritten by the new DICE gas components within the ! new grid(s). ! ! TO DO: ! - Additional paramters to the RESTART_PARAMS namelist to e.g. shift ! the velocity of AMR pseudo particles, reset their metallicity or gas ! tracer, etc. ! case ('dice_restart') !------------------ !This is the start of the modified DICE patch dice_init=.true. !-> VERY IMPORTANT: switch on DICE patch ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) scale_m = scale_d*scale_l**3 ! Reading header of the Gadget file error=.false. ipart = 0 do ifile=1,ic_nfile write(ifile_str,*) ifile if(ic_nfile.eq.1) then filename=TRIM(initfile(levelmin))//'/'//TRIM(ic_file) else filename=TRIM(initfile(levelmin))//'/'//TRIM(ic_file)//'.'//ADJUSTL(ifile_str) endif INQUIRE(FILE=filename,EXIST=file_exists) if(.not.file_exists) then if(myid==1) write(*,*) TRIM(filename),' not found' call clean_stop endif if(myid==1)then write(*,'(A12,A)') ' Loading -> ',filename ! TTG 2018: Added new file format Gadget X, corresponding to a slightly modified version of Gadget2 ! Gadget2 file format currently not supported ! Requires modifications to init_part.f90, init_flow_fine.f90, ... if((ic_format.ne.'Gadget1').and.(ic_format.ne.'GadgetX')) then if(myid==1) write(*,*) 'Specify a valid IC file format [ic_format=Gadget1/GadgetX]' if(myid==1) write(*,*) 'Gadget2 file format currently not supported!' error=.true. endif OPEN(unit=1,file=filename,status='old',action='read',form='unformatted',access='stream') ! Init block address head_blck = -1 pos_blck = -1 vel_blck = -1 id_blck = -1 mass_blck = -1 u_blck = -1 metal_blck = -1 age_blck = -1 ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trc_blck = -1 if(ic_format .eq. 'Gadget1') then ! Init block counter jump_blck = 1 blck_cnt = 1 do while(.true.) ! Reading data block header read(1,POS=jump_blck,iostat=stat) blck_size if(stat /= 0) exit ! Saving data block positions if(blck_cnt .eq. 1) then head_blck = jump_blck+sizeof(blck_size) head_size = blck_size endif if(blck_cnt .eq. 2) then pos_blck = jump_blck+sizeof(blck_size) pos_size = blck_size/(3*sizeof(dummy_real)) endif if(blck_cnt .eq. 3) then vel_blck = jump_blck+sizeof(blck_size) vel_size = blck_size/(3*sizeof(dummy_real)) endif if(blck_cnt .eq. 4) then id_blck = jump_blck+sizeof(blck_size) id_size = blck_size/sizeof(dummy_int) endif if(blck_cnt .eq. 5) then mass_blck = jump_blck+sizeof(blck_size) mass_size = blck_size/sizeof(dummy_real) endif if(blck_cnt .eq. 6) then u_blck = jump_blck+sizeof(blck_size) u_size = blck_size/sizeof(dummy_real) endif if(blck_cnt .eq. 7) then metal_blck = jump_blck+sizeof(blck_size) metal_size = blck_size/sizeof(dummy_real) endif if(blck_cnt .eq. 8) then age_blck = jump_blck+sizeof(blck_size) age_size = blck_size/sizeof(dummy_real) endif jump_blck = jump_blck+blck_size+2*sizeof(dummy_int) blck_cnt = blck_cnt+1 enddo endif if(ic_format .eq. 'GadgetX') then ! Init block counter jump_blck = 1 write(*,'(A50)')'__________________________________________________' do while(.true.) ! Reading data block header read(1,POS=jump_blck,iostat=stat) dummy_int if(stat /= 0) exit read(1,POS=jump_blck+sizeof(dummy_int),iostat=stat) blck_name if(stat /= 0) exit read(1,POS=jump_blck+sizeof(dummy_int)+sizeof(blck_name),iostat=stat) dummy_int if(stat /= 0) exit read(1,POS=jump_blck+2*sizeof(dummy_int)+sizeof(blck_name),iostat=stat) dummy_int if(stat /= 0) exit read(1,POS=jump_blck+3*sizeof(dummy_int)+sizeof(blck_name),iostat=stat) blck_size if(stat /= 0) exit ! Saving data block positions if(blck_name .eq. ic_head_name) then head_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) head_size = blck_size write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_pos_name) then pos_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) pos_size = blck_size/(3*sizeof(dummy_real)) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_vel_name) then vel_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) vel_size = blck_size/(3*sizeof(dummy_real)) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_id_name) then id_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) id_size = blck_size/sizeof(dummy_int) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_mass_name) then mass_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) mass_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_u_name) then u_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) u_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) if(blck_name .eq. 'TRC ') then trc_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) trc_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_metal_name) then metal_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) metal_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif if(blck_name .eq. ic_age_name) then age_blck = jump_blck+sizeof(blck_name)+4*sizeof(dummy_int) age_size = blck_size/sizeof(dummy_real) write(*,*) '-> Found ',blck_name,' block' endif jump_blck = jump_blck+blck_size+sizeof(blck_name)+5*sizeof(dummy_int) enddo endif if((head_blck.eq.-1).or.(pos_blck.eq.-1).or.(vel_blck.eq.-1).or.(mass_blck.eq.-1)) then write(*,*) 'Gadget file does not contain handful data' error=.true. endif if(head_size.ne.256) then write(*,*) 'Gadget header is not 256 bytes' error=.true. endif ! Byte swapping doesn't appear to work if you just do READ(1)header READ(1,POS=head_blck) header%npart,header%mass,header%time,header%redshift, & header%flag_sfr,header%flag_feedback,header%nparttotal, & header%flag_cooling,header%numfiles,header%boxsize, & header%omega0,header%omegalambda,header%hubbleparam, & header%flag_stellarage,header%flag_metals,header%totalhighword, & header%flag_entropy_instead_u, header%flag_doubleprecision, & header%flag_ic_info, header%lpt_scalingfactor nstar_tot = sum(header%npart(3:5)) npart = sum(header%npart) ngas = header%npart(1) nhalo = header%npart(2) if(cosmo) T2_start = 1.356d-2/aexp**2 write(*,'(A50)')'__________________________________________________' write(*,*)'Found ',npart,' particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.0) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(1),' type 0 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.1) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(2),' type 1 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.2) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(3),' type 2 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.3) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(4),' type 3 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.4) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(5),' type 4 particles' skip=.false. do j=1,6 if(ic_skip_type(j).eq.5) skip=.true. enddo if(.not.skip) write(*,*)'----> ',header%npart(6),' type 5 particles' write(*,'(A50)')'_____________________progress_____________________' if((pos_size.ne.npart).or.(vel_size.ne.npart).or.((metal_size.ne.npart).and.(metal_size.ne.ngas+nstar_tot))) then write(*,*) 'POS =',pos_size write(*,*) 'Z =',metal_size write(*,*) 'VEL =',vel_size write(*,*) 'Number of particles does not correspond to block sizes' error=.true. endif endif if(error) call clean_stop #ifndef WITHOUTMPI call MPI_BCAST(nstar_tot,1,MPI_INTEGER,0,MPI_COMM_WORLD,info) #endif eob = .false. kpart = 0 lpart = 0 mpart = 0 gpart = 0 opart = 0 mgas_tot = 0. ipbar = 0. ! TTG 2018: Loop to read particles do while(.not.eob) xx=0. vv=0. ii=0 mm=0. tt=0. zz=0. uu=0. ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trc=0. if(myid==1)then jpart=0 do i=1,nvector jpart=jpart+1 ! All particles counter kpart=kpart+1 !TTG 2017: gas particles if(kpart.le.header%npart(1)) type_index = 1 !TTG 2017: other particles do j=1,5 if(kpart.gt.sum(header%npart(1:j)).and.kpart.le.sum(header%npart(1:j+1))) type_index = j+1 enddo if((sum(header%npart(3:5)).gt.0).and.(kpart.gt.(header%npart(1)+header%npart(2)))) mpart=mpart+1 if(type_index.ne.2) gpart=gpart+1 ! Reading GadgetX file line-by-line ! Mandatory data read(1,POS=pos_blck+3*sizeof(dummy_real)*(kpart-1)) xx_sp(i,1:3) read(1,POS=vel_blck+3*sizeof(dummy_real)*(kpart-1)) vv_sp(i,1:3) if(header%mass(type_index).gt.0) then mm_sp(i) = header%mass(type_index) else opart=opart+1 read(1,POS=mass_blck+sizeof(dummy_real)*(opart-1)) mm_sp(i) endif ! Optional data if(id_blck.ne.-1) then read(1,POS=id_blck+sizeof(dummy_int)*(kpart-1)) ii(i) else ii(i) = kpart endif if(kpart.le.header%npart(1)) then if((u_blck.ne.-1).and.(u_size.eq.header%npart(1))) then read(1,POS=u_blck+sizeof(dummy_real)*(kpart-1)) uu_sp(i) endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) if((trc_blck.ne.-1).and.(trc_size.eq.header%npart(1))) then read(1,POS=trc_blck+sizeof(dummy_real)*(kpart-1)) trc_sp(i) endif endif if(metal) then if((metal_blck.ne.-1).and.(metal_size.eq.npart)) then read(1,POS=metal_blck+sizeof(dummy_real)*(kpart-1)) zz_sp(i) endif if((metal_blck.ne.-1).and.(metal_size.eq.ngas+nstar_tot)) then read(1,POS=metal_blck+sizeof(dummy_real)*(gpart-1)) zz_sp(i) endif endif if(star) then if((age_blck.ne.-1).and.(age_size.eq.sum(header%npart(3:5)))) then if((sum(header%npart(3:5)).gt.0).and.(kpart.gt.(header%npart(1)+header%npart(2)))) then read(1,POS=age_blck+sizeof(dummy_real)*(mpart-1)) tt_sp(i) endif endif endif ! Scaling to ramses code units if(cosmo) then gadget_scale_l = scale_l/header%boxsize gadget_scale_v = 1e3*SQRT(aexp)/header%boxsize*aexp/100. endif xx(i,:) = xx_sp(i,:)*(gadget_scale_l/scale_l)*ic_scale_pos vv(i,:) = vv_sp(i,:)*(gadget_scale_v/scale_v)*ic_scale_vel mm(i) = mm_sp(i)*(gadget_scale_m/scale_m)*ic_scale_mass if(cosmo) then if(type_index .eq. 1) mass_sph = mm(i) if(xx(i,1)< 0.0d0 )xx(i,1)=xx(i,1)+dble(nx) if(xx(i,1)>=dble(nx))xx(i,1)=xx(i,1)-dble(nx) if(xx(i,2)< 0.0d0 )xx(i,2)=xx(i,2)+dble(ny) if(xx(i,2)>=dble(ny))xx(i,2)=xx(i,2)-dble(ny) if(xx(i,3)< 0.0d0 )xx(i,3)=xx(i,3)+dble(nz) if(xx(i,3)>=dble(nz))xx(i,3)=xx(i,3)-dble(nz) endif if(metal) then if(metal_blck.ne.-1) then zz(i) = zz_sp(i)*ic_scale_metal !TTG 2017: DICE adopts solar units for the metallicity; !RAMSES (cooling_fine.f90) assumes absolute units! -> set ic_scale_metal = 0.02 endif endif if(kpart.gt.header%npart(1)+header%npart(2)) then if(age_blck.ne.-1) then if(cosmo) then tt(i) = tt_sp(i) else tt(i) = tt_sp(i)*(gadget_scale_t/(scale_t/aexp**2))*ic_scale_age endif endif endif if(kpart.le.header%npart(1)) then if(cosmo) then uu(i) = T2_start/scale_T2 else ! Temperature stored in units of K/mu uu(i) = uu_sp(i)*mu_mol*(gadget_scale_v/scale_v)**2*ic_scale_u endif ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trc(i) = trc_sp(i) endif if(kpart.le.header%npart(1)) mgas_tot = mgas_tot+mm(i) ! Check the End Of Block if(kpart.ge.ipbar*(npart/49.0))then write(*,'(A1)',advance='no') '_' ipbar = ipbar+1.0 endif if(kpart.ge.npart) then write(*,'(A1)') ' ' write(*,'(A,A7,A)') ' DICE (',TRIM(ic_format),') file successfully loaded' write(*,'(A50)')'__________________________________________________' eob=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BCAST(eob,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ii,nvector ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(zz,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(tt,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) call MPI_BCAST(trc,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(header%npart,6,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif ! Determine current particle type if((lpart+i).le.header%npart(1)) type_index = 1 !TTG (MAR 2017): identify gas particles do j=1,5 if((lpart+i).gt.sum(header%npart(1:j)).and.(lpart+i).le.sum(header%npart(1:j+1))) type_index = j+1 enddo skip = .false. do j=1,6 if(ic_skip_type(j).eq.type_index-1) skip=.true. enddo if(.not.skip) then if(abs(xx(i,1)-ic_center(1)).ge.boxlen/2d0) cycle if(abs(xx(i,2)-ic_center(2)).ge.boxlen/2d0) cycle if(abs(xx(i,3)-ic_center(3)).ge.boxlen/2d0) cycle ipart = ipart+1 if(ipart.gt.npartmax) then write(*,*) 'Increase npartmax' #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif xp(ipart,1:3) = xx(i,1:3)+boxlen/2.0D0-ic_center(1:3) ! CHANGED BY TTG (MAY 2017) ! vp(ipart,1:3) = vv(i,1:3) vp(ipart,1:3) = vv(i,1:3) + ic_velocity(1:3)*(gadget_scale_v/scale_v)*ic_scale_vel !! CHANGED BY TTG (FEB 2017): identify particles by their Gadget type number (0 = gas; 1 = DM halo; 2 = disc; 3 = bulge) ! ! Flag gas particles with idp=1 ! if(type_index.gt.1)then !! idp(ipart) = ii(i)+1 !this is the original line ! idp(ipart) = type_index !TTG (FEB 2017): this is the Gadget type shifted by +1; init_refine does -1 ! else ! idp(ipart) = 1 ! endif ! CHANGED BY TTG (MAR 2017): identify particles by their DICE component number ! NOTE: need to modify init_flow_fine.f90/condinit_loc accordingly! idp(ipart) = ii(i) !TTG (MAR 2017): this is the myDICE component number (even = gas; odd = DM/stars) mp(ipart) = mm(i) levelp(ipart) = levelmin if(star) then tp(ipart) = tt(i) ! CHANGED BY TTG (FEB 2017) ! Particle metallicity ! if(metal) then ! zp(ipart) = zz(i) ! endif endif ! ADDED BY TTG (FEB 2017) ! to allow the use of metallicity for gas components ! Particle metallicity if(metal) then zp(ipart) = zz(i) endif up(ipart) = uu(i) ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) trcp(ipart) = trc(i) ! Add a gas particle outside the zoom region if(cosmo) then maskp(ipart) = 1.0 do j=1,6 if(type_index.eq.cosmo_add_gas_index(j)) then ! Add a gas particle xp(ipart+1,1:3) = xp(ipart,1:3) ! CHANGED BY TTG (MAY 2017) ! vp(ipart+1,1:3) = vp(ipart,1:3) vp(ipart+1,1:3) = vp(ipart,1:3) + ic_velocity(1:3)*(gadget_scale_v/scale_v)*ic_scale_vel ! CHANGED BY TTG (MAY 2017): identify particles by their myDICE component number (even = gas; odd = DM/stars) ! idp(ipart+1) = -1 idp(ipart+1) = -2 mp(ipart+1) = mp(ipart)*(omega_b/omega_m) levelp(ipart+1) = levelmin up(ipart+1) = T2_start/scale_T2 maskp(ipart+1) = 0.0 if(metal) then zp(ipart+1) = z_ave*0.02 endif ! Remove mass from the DM particle mp(ipart) = mp(ipart)-mp(ipart+1) ! Update index ipart = ipart+1 endif end do endif endif #ifndef WITHOUTMPI endif #endif enddo lpart = lpart+jpart enddo if(myid==1)then write(*,'(A,E10.3)') ' Gas mass in AMR grid [Msun]-> ',mgas_tot*scale_m/msol write(*,'(A50)')'__________________________________________________' close(1) endif enddo !VERY IMPORTANT: the total number of particles MUST not be yet computed here! !This is the end of the modified DICE patch !------------------ !------------------ !This is the start of the modified RESTART patch ! ! ADDED BY TTG MAY 2017 [see case('ramses')] !LMC / SMC transformation angles (in radian) pi = DACOS(-1.0d0) theta_1 = pi*(66./180.) cos_theta_1 = DCOS(theta_1) sin_theta_1 = DSIN(theta_1) theta_2 = pi*(231.2/180.) cos_theta_2 = DCOS(theta_2) sin_theta_2 = DSIN(theta_2) theta_3 = pi*(31.9/180.) cos_theta_3 = DCOS(theta_3) sin_theta_3 = DSIN(theta_3) theta_4 = pi*(18.5/180.) cos_theta_4 = DCOS(theta_4) sin_theta_4 = DSIN(theta_4) ! Initialisation restart_init = .true. ! dice_init = .true. !-> not necessary as it has been done above ! amr_struct = .false. !-> does not conserve mass but works better; do NOT hardcode, though eocpu = .false. error = .false. icpu = 1 lpart_restart = 0 ! ipart = 0 !<- VERY IMPORTANT TO NOT RESET THE PARTICLE COUNT mhalo_tot = 0. mstar_tot = 0. mgas_tot_restart = 0. nhalo_tot = 0 nstar_tot = 0 if(myid==1) then write(*,'(A50)')'__________________________________________________' write(*,*)' RAMSES restart' write(*,'(A50)')'__________________________________________________' endif do while(.not.eocpu) nstar_loc = 0 nhalo_loc = 0 ngas_loc = 0 nsink_loc = 0 if(myid==1)then call title(abs(nrestart),nchar) if(icpu==1) write(*,'(a)') ' Loading -> '//TRIM(output_dir)//'output_'//TRIM(nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/part_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(.not.ok)then write(*,*) TRIM(fileloc),' not found' call clean_stop endif ilun1 = 1 OPEN(unit=ilun1,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos = 1 read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%ncpu; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%ndim; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%npart; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%localseed; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%nstar_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%mstar_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%mstar_lost; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun1,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun1,pos=mypos)header_part%nsink; mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Init block address read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) pos_blck_restart(1) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) pos_blck_restart(2) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) pos_blck_restart(3) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) vel_blck_restart(1) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) vel_blck_restart(2) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) vel_blck_restart(3) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) mass_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) id_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) level_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) if(star.or.sink)then read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) age_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) if(metal) then read(ilun1,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) metal_blck_restart = mypos endif endif endif ! TTG 2018: Loop to read particles eob_restart = .false. kpart_restart = 0 do while(.not.eob_restart) xx=0. vv=0. ii=0. mm=0. tt=0. zz=0. !ADDED BY TTG MAY 2017 uu = 0. if(myid==1)then jpart=0 do i=1,nvector jpart=jpart+1 ! All particles counter kpart_restart=kpart_restart+1 ! Reading ramses part file line-by-line do idim=1,ndim read(ilun1,pos=pos_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) xx(jpart,idim) end do do idim=1,ndim read(ilun1,pos=vel_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) vv(jpart,idim) end do read(ilun1,pos=mass_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) mm(jpart) read(ilun1,pos=id_blck_restart+sizeof(dummy_int)*(kpart_restart-1)) ii(jpart) if(star.or.sink) then read(ilun1,pos=age_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) tt(jpart) if(metal) then read(ilun1,pos=metal_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) zz(jpart) endif endif ! Updating total masses if(tt(jpart)==0d0) then mhalo_tot = mhalo_tot+mm(jpart) nhalo_tot = nhalo_tot+1 nhalo_loc = nhalo_loc+1 else mstar_tot = mstar_tot+mm(jpart) nstar_tot = nstar_tot+1 nstar_loc = nstar_loc+1 endif ! Check the End Of Block if(kpart_restart.ge.header_part%npart) then eob_restart=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BCAST(eob_restart,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ii,nvector ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(zz,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(tt,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BARRIER(MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif !HERE: transform particle positions and velocities ! xx(i,1:3) = xx(i,1:3)-restart_ic_center(1:3) xx(i,1:3) = xx(i,1:3) - 0.5*5.0d2 ! shift positions by half the original box size xx(i,1:3) = xx(i,1:3) - lmc_com ! shift positions to the LMC CoM vv(i,1:3) = vv(i,1:3) - lmc_cov/scale_v ! shift vel to the LMC CoV !Rotate all vectors counter-clockwise around x axis by 66 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_1*x_2_save - sin_theta_1*x_3_save xx(i,3) = sin_theta_1*x_2_save + cos_theta_1*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_1*v_2_save - sin_theta_1*v_3_save vv(i,3) = sin_theta_1*v_2_save + cos_theta_1*v_3_save !Rotate all vectors counter-clockwise around z axis by 231.2 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_2*x_1_save - sin_theta_2*x_2_save xx(i,2) = sin_theta_2*x_1_save + cos_theta_2*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_2*v_1_save - sin_theta_2*v_2_save vv(i,2) = sin_theta_2*v_1_save + cos_theta_2*v_2_save !Translate positons xx(i,1:3) = xx(i,1:3) + r_shift !Translate velocities vv(i,1:3) = vv(i,1:3) + v_shift/scale_v !Rotate all vectors counter-clockwise around x axis by 31.9 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_3*x_2_save - sin_theta_3*x_3_save xx(i,3) = sin_theta_3*x_2_save + cos_theta_3*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_3*v_2_save - sin_theta_3*v_3_save vv(i,3) = sin_theta_3*v_2_save + cos_theta_3*v_3_save !Rotate all vectors counter-clockwise around z axis by 18.5 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_4*x_1_save - sin_theta_4*x_2_save xx(i,2) = sin_theta_4*x_1_save + cos_theta_4*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_4*v_1_save - sin_theta_4*v_2_save vv(i,2) = sin_theta_4*v_1_save + cos_theta_4*v_2_save !Shift positions by half the new box size xx(i,1:3) = xx(i,1:3) + 0.5*boxlen if(xx(i,1).ge.0d0.and.xx(i,1).le.boxlen.and. & & xx(i,2).ge.0d0.and.xx(i,2).le.boxlen.and. & & xx(i,3).ge.0d0.and.xx(i,3).le.boxlen) then ipart = ipart+1 if(ipart.gt.npartmax) then write(*,*) 'Increase npartmax' error=.true. #ifndef WITHOUTMPI call MPI_BCAST(error,1,MPI_LOGICAL,0,MPI_COMM_WORLD,info) #endif endif xp(ipart,1:3) = xx(i,1:3) vp(ipart,1:3) = vv(i,1:3) !CHANGED BY TTG MAY 2017 ! idp(ipart) = ii(i)+1 idp(ipart) = ii(i) !TTG (MAR 2017): this is the myDICE component number (even = gas; odd = DM/stars) mp(ipart) = mm(i) !ADDED BY TTG MAY 2017 up(ipart) = uu(i) levelp(ipart) = levelmin if(star) then tp(ipart) = tt(i) if(metal) then zp(ipart) = zz(i) endif endif endif #ifndef WITOUTMPI endif #endif enddo #ifndef WITOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(error) call clean_stop enddo if(myid==1)then ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) scale_m = scale_d*scale_l**3 call title(abs(nrestart),nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/amr_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(.not.ok)then write(*,*) TRIM(fileloc),' not found' call clean_stop endif ilun2 = 2 OPEN(unit=ilun2,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos=1 read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ncpu; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ndim; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nx,header_amr%ny,header_amr%nz; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nlevelmax; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ngridmax; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nboundary; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ngrid_current; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%boxlen; mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Read time variables read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%noutput,header_amr%iout,header_amr%ifout; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%tout(1:header_amr%noutput); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%aout(1:header_amr%noutput); mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Old output times read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%t; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%dtold(1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%dtnew(1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%nstep,header_amr%nstep_coarse; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%einit,header_amr%mass_tot_0,header_amr%rho_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%omega_m,header_amr%omega_l,header_amr%omega_k, & & header_amr%omega_b,header_amr%h0,header_amr%aexp_ini,header_amr%boxlen_ini; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%aexp,header_amr%hexp,header_amr%aexp_old,header_amr%epot_tot_int,header_amr%epot_tot_old; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%mass_sph; mypos=mypos+sizeof(dummy_int)+size_blck_restart header_amr%twotondim=2**header_amr%ndim header_amr%twondim=2*header_amr%ndim ! Read levels variables if(icpu==1) then allocate(header_amr%headl(1:header_amr%ncpu,1:header_amr%nlevelmax)) allocate(header_amr%taill(1:header_amr%ncpu,1:header_amr%nlevelmax)) allocate(header_amr%numbl(1:header_amr%ncpu,1:header_amr%nlevelmax)) allocate(header_amr%numbtot(1:10,1:header_amr%nlevelmax)) endif read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%headl(1:header_amr%ncpu,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%taill(1:header_amr%ncpu,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%numbl(1:header_amr%ncpu,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%numbtot(1:10,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Read boundary linked list if(icpu==1) then allocate(header_amr%headb (1:MAXBOUND,1:header_amr%nlevelmax)) allocate(header_amr%tailb (1:MAXBOUND,1:header_amr%nlevelmax)) allocate(header_amr%numbb (1:MAXBOUND,1:header_amr%nlevelmax)) allocate(header_amr%boundary(1:MAXBOUND,1:header_amr%nlevelmax)) endif if(simple_boundary)then read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%headb(1:header_amr%nboundary,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%tailb(1:header_amr%nboundary,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%numbb(1:header_amr%nboundary,1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck_restart end if ! Read free memory read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%headf,header_amr%tailf,header_amr%numbf,header_amr%used_mem,header_amr%used_mem_tot; mypos=mypos+sizeof(dummy_int)+size_blck_restart ! Read cpu boundaries read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%ordering; mypos=mypos+sizeof(dummy_int)+size_blck_restart header_amr%nbilevelmax=ceiling(log(dble(header_amr%ncpu))/log(2.0)) header_amr%nbinodes=2**(nbilevelmax+1)-1 header_amr%ndomain=header_amr%ncpu*overload if(icpu==1) allocate(header_amr%bound_key (0:header_amr%ndomain)) if(header_amr%ordering=='bisection') then read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_wall(1:header_amr%nbinodes); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_next(1:header_amr%nbinodes,1:2); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_indx(1:header_amr%nbinodes); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_cpubox_min(1:header_amr%ncpu,1:header_amr%ndim); mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bisec_cpubox_max(1:header_amr%ncpu,1:header_amr%ndim); mypos=mypos+sizeof(dummy_int)+size_blck_restart else read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun2,pos=mypos)header_amr%bound_key(0:header_amr%ndomain); mypos=mypos+sizeof(dummy_int)+size_blck_restart endif ! Read coarse level ! Son array read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Flag array read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! cpu_map array read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart if(icpu==1) then allocate(amr_pos_blck_restart(1:header_amr%ndim,1:header_amr%nlevelmax,1:header_amr%nboundary+header_amr%ncpu)) allocate(amr_son_blck_restart(1:header_amr%nlevelmax,1:header_amr%nboundary+header_amr%ncpu,1:header_amr%twotondim)) endif ! Read fine levels do ilevel=1,header_amr%nlevelmax do ibound=1,header_amr%nboundary+header_amr%ncpu if(ibound<=header_amr%ncpu)then ncache=header_amr%numbl(ibound,ilevel) else ncache=header_amr%numbb(ibound-header_amr%ncpu,ilevel) end if if(ncache>0)then ! Read grid index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read next index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read prev index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read grid center do idim=1,header_amr%ndim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) amr_pos_blck_restart(idim,ilevel,ibound) = mypos; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(size_blck_restart.ne.ncache*sizeof(dummy_real_restart)) then write(*,*) 'AMR -> Grid center block size does not correspond to ncache' call clean_stop endif end do ! Read father index read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart ! Read nbor index do ind=1,header_amr%twondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart end do ! Read son index do ind=1,header_amr%twotondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) amr_son_blck_restart(ilevel,ibound,ind) = mypos; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(size_blck_restart.ne.ncache*sizeof(dummy_int)) then write(*,*) 'AMR -> Son index block size does not correspond to ncache' call clean_stop endif end do ! Read cpu map do ind=1,header_amr%twotondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart end do ! Read refinement map do ind=1,header_amr%twotondim read(ilun2,pos=mypos)size_blck_restart; mypos=mypos+2*sizeof(dummy_int)+size_blck_restart end do endif end do end do call title(abs(nrestart),nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/hydro_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(.not.ok)then write(*,*) TRIM(fileloc),' not found' call clean_stop endif ilun3 = 3 OPEN(unit=ilun3,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos=1 read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%ncpu; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%nvar; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%ndim; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%nlevelmax; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%nboundary; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)header_hydro%gamma; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(icpu==1) & &allocate(hydro_var_blck_restart(1:header_amr%nlevelmax,1:header_amr%nboundary+header_amr%ncpu,1:header_amr%twotondim,1:header_hydro%nvar)) do ilevel=1,header_hydro%nlevelmax do ibound=1,header_hydro%nboundary+header_hydro%ncpu if(ibound<=header_hydro%ncpu)then ncache=header_amr%numbl(ibound,ilevel) else ncache=header_amr%numbb(ibound-header_hydro%ncpu,ilevel) end if read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)ilevel2; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun3,pos=mypos)numbl2; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(numbl2.ne.ncache)then write(*,*)'File hydro.tmp is not compatible' write(*,*)'Found =',numbl2,' for level ',ilevel2 write(*,*)'Expected=',ncache,' for level ',ilevel end if if(ncache>0)then ! Loop over cells do ind=1,header_amr%twotondim ! Read all hydro var do ivar=1,header_hydro%nvar read(ilun3,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) hydro_var_blck_restart(ilevel,ibound,ind,ivar)=mypos mypos=mypos+sizeof(dummy_int)+size_blck_restart if(size_blck_restart.ne.ncache*sizeof(dummy_real_restart)) then write(*,*) 'HYDRO -> Var block size does not correspond to ncache' call clean_stop endif end do end do end if end do end do if(nvector/header_amr%twotondim==0) then write(*,*) 'Recompile with a greater value for NVECTOR' call clean_stop endif endif if(icpu==1) then #ifndef WITHOUTMPI call MPI_BCAST(header_amr%nlevelmax,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%ndim,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%twotondim,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%ncpu,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%nboundary,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%ifout,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%t,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(header_amr%iout,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(header_amr%tout,MAXOUT ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(header_amr%aout,MAXOUT ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(header_amr%noutput,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%nstep_coarse,1,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%nstep,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%boxlen,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(header_amr%einit,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%mass_tot_0,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%rho_tot,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_hydro%nvar,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_hydro%ndim,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) if(cosmo) then call MPI_BCAST(header_amr%omega_m,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%omega_l,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%h0,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%boxlen_ini,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%aexp,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) endif call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1) write(*,'(A50)')'__________________________________________________' ! Number of passive scalars to load (does NOT include internal energy) nvar_min = min(header_hydro%nvar-header_hydro%ndim-1,nvar-ndim-1)-1 if(myid==1) write(*,*) '[Info] Number of passive variables [restart_passive_var]: ', nvar_min ! restart_boxlen = header_amr%boxlen if(cosmo) then omega_m = header_amr%omega_m omega_l = header_amr%omega_l h0 = header_amr%h0 boxlen_ini = header_amr%boxlen_ini aexp = header_amr%aexp aexp_ini = aexp endif allocate(pasvar(1:nvector,1:nvar_min)) ! Check passive hydro variables indices ! if(myid==1) write(*,'(A50)')'__________________________________________________' do ivar=1,nvar_min if(myid==1) write(*,'(A,I2,A,I2)') ' [Info] Passive variable ',restart_passive_vars(ivar),' loaded in var',ndim+2+ivar if(restart_passive_vars(ivar).gt.header_hydro%nvar) then if(myid==1) write(*,*) '[Error] ivar=',restart_passive_vars(ivar),' is empty in the restart output' call clean_stop endif ! if(restart_passive_vars(ivar).lt.header_amr%ndim+2) then if(restart_passive_vars(ivar).le.header_amr%ndim+2) then ! include internal energy / pressure if(myid==1) write(*,*) '[Error] ivar=',restart_passive_vars(ivar),' is an active variable' if(myid==1) write(*,*) '[Info] Additional variables have indices from ', ndim+2+nvar_min-1, 'to', header_hydro%nvar call clean_stop endif enddo if(myid==1) write(*,'(A50)')'__________________________________________________' ! (Re-)setting simulation time if(.not.reset_time) then t = header_amr%t ifout = header_amr%ifout !ADDED BY TTG MAY 2017 ! noutput = header_amr%noutput !-> not needed iout = header_amr%iout ! tout(1:noutput)= header_amr%tout(1:header_amr%noutput) !-> not needed ! aout(1:noutput)= header_amr%aout(1:header_amr%noutput) !-> not needed ! if(ifout.gt.abs(nrestart)+1) ifout=abs(nrestart)+1 !-> not needed nstep_coarse = header_amr%nstep_coarse nstep = header_amr%nstep endif ! (Re-)setting mass / energy / density conservation !ADDED BY TTG MAY 2017 if(.not.reset_cvars) then einit = header_amr%einit mass_tot_0= header_amr%mass_tot_0 rho_tot = header_amr%rho_tot endif ! Compute movie frame number if applicable if(imovout>0) then do i=2,imovout if(aendmov>0)then if(aexp>amovout(i-1).and.aexptmovout(i-1).and.t0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=header_amr%boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**header_amr%ndim do ind=1,header_amr%twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do do ibound=1,header_amr%nboundary+header_amr%ncpu if(myid==1) then if(ibound<=header_amr%ncpu)then ncache=header_amr%numbl(ibound,ilevel) else ncache=header_amr%numbb(ibound-header_amr%ncpu,ilevel) end if endif #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) call MPI_BCAST(ncache,1,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(ncache>0.and.ibound.eq.icpu) then kpart_restart = 0 eob_restart = .false. do while(.not.eob_restart) xx = 0. xxg = 0. vv = 0. mm = 0. tt = 0. pasvar = 0. uu = 0. jpart = 0 if(myid==1) then do i=1,nvector/header_amr%twotondim ! All particles counter kpart_restart=kpart_restart+1 ! Read the grid center one time per twotondim cells read_center=.true. ! Loop over cells do ind=1,header_amr%twotondim read(ilun2,pos=amr_son_blck_restart(ilevel,ibound,ind)+sizeof(dummy_int)*(kpart_restart-1)) son1 ! Consider leaf cells only if(son1==0) then jpart = jpart+1 lpart_restart = lpart_restart+1 ! Reading grid center ! TTG 2017: Converting to physical units is this taken care of when reading velocities below; ! This needs to be done this way since reading will be executed only once per oct! if(read_center) then do idim=1,ndim read(ilun2,pos=amr_pos_blck_restart(idim,ilevel,ibound)+sizeof(dummy_real_restart)*(kpart_restart-1)) xxg(idim) end do read_center=.false. endif ! Reading cell density read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,1)+sizeof(dummy_real_restart)*(kpart_restart-1)) mm(jpart) if(mm(jpart).lt.restart_rho_min) restart_rho_min = mm(jpart) if(mm(jpart).gt.restart_rho_max) restart_rho_max = mm(jpart) ! Converting to mass mm(jpart)=mm(jpart)*vol_loc ! Updating total mass mgas_tot_restart=mgas_tot_restart+mm(jpart) ! Updating leaf cells counter ngas_loc = ngas_loc+1 ! Reading velocities AND convert grid centre to physical units do idim=1,ndim read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,idim+1)+sizeof(dummy_real_restart)*(kpart_restart-1)) vv(jpart,idim) xx(jpart,idim)=(xxg(idim)+xc(ind,idim)-skip_loc(idim))*scale end do ! TTG MAY 2017: reading gas thermal pressure read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,header_amr%ndim+2)+sizeof(dummy_real_restart)*(kpart_restart-1)) uu(jpart) ! TTG MAY 2017: transform to SPECIFIC internal energy uu(jpart)=uu(jpart)/(header_hydro%gamma-1.d0)/(mm(jpart)/vol_loc) ! Reading passive hydro variables do ivar=1,nvar_min if(restart_passive_vars(ivar).gt.header_amr%ndim+2.and.restart_passive_vars(ivar).le.header_hydro%nvar) then read(ilun3,pos=hydro_var_blck_restart(ilevel,ibound,ind,restart_passive_vars(ivar))+sizeof(dummy_real_restart)*(kpart_restart-1))& &pasvar(jpart,ivar) if(metal.and.((ndim+2+ivar)==imetal)) zz(jpart) = pasvar(jpart,ivar) if((ndim+2+ivar)==itracer) trc(jpart) = pasvar(jpart,ivar) endif enddo endif enddo ! Check the End Of Block if(kpart_restart.ge.ncache) then eob_restart=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) call MPI_BCAST(eob_restart,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(kpart_restart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) ! call MPI_BCAST(pasvar,nvector*nvar_min ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(zz,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(trc,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif !HERE: transform particle positions and velocities ! xx(i,1:3) = xx(i,1:3)-restart_ic_center(1:3) xx(i,1:3) = xx(i,1:3) - 0.5*5.0d2 ! shift positions by half the original box size xx(i,1:3) = xx(i,1:3) - lmc_com ! shift positions to the LMC CoM vv(i,1:3) = vv(i,1:3) - lmc_cov/scale_v ! shift vel to the LMC CoV !Rotate all vectors counter-clockwise around x axis by 66 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_1*x_2_save - sin_theta_1*x_3_save xx(i,3) = sin_theta_1*x_2_save + cos_theta_1*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_1*v_2_save - sin_theta_1*v_3_save vv(i,3) = sin_theta_1*v_2_save + cos_theta_1*v_3_save !Rotate all vectors counter-clockwise around z axis by 231.2 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_2*x_1_save - sin_theta_2*x_2_save xx(i,2) = sin_theta_2*x_1_save + cos_theta_2*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_2*v_1_save - sin_theta_2*v_2_save vv(i,2) = sin_theta_2*v_1_save + cos_theta_2*v_2_save !Translate positons xx(i,1:3) = xx(i,1:3) + r_shift !Translate velocities vv(i,1:3) = vv(i,1:3) + v_shift/scale_v !Rotate all vectors counter-clockwise around x axis by 31.9 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_3*x_2_save - sin_theta_3*x_3_save xx(i,3) = sin_theta_3*x_2_save + cos_theta_3*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_3*v_2_save - sin_theta_3*v_3_save vv(i,3) = sin_theta_3*v_2_save + cos_theta_3*v_3_save !Rotate all vectors counter-clockwise around z axis by 18.5 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_4*x_1_save - sin_theta_4*x_2_save xx(i,2) = sin_theta_4*x_1_save + cos_theta_4*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_4*v_1_save - sin_theta_4*v_2_save vv(i,2) = sin_theta_4*v_1_save + cos_theta_4*v_2_save !Shift positions by half the new box size xx(i,1:3) = xx(i,1:3) + 0.5*boxlen if(xx(i,1).ge.0d0.and.xx(i,1).le.boxlen.and. & & xx(i,2).ge.0d0.and.xx(i,2).le.boxlen.and. & & xx(i,3).ge.0d0.and.xx(i,3).le.boxlen) then ipart = ipart+1 if(ipart.gt.npartmax) then write(*,*) 'Increase npartmax' error=.true. #ifndef WITHOUTMPI call MPI_BCAST(error,1,MPI_LOGICAL,0,MPI_COMM_WORLD,info) #endif endif xp(ipart,1:3) = xx(i,1:3) vp(ipart,1:3) = vv(i,1:3) mp(ipart) = mm(i) !ADDED BY TTG MAY 2017 up(ipart) = uu(i) ! Flagged as gas particles ! idp(ipart) = 1 !CHANGED BY TTG MAY 2017 ! Flagged as gas particles according to myDICE (gas -> even id; collisionless -> odd id) idp(ipart) = 2 !CHANGED BY TTG MAY 2017 ! levelp(ipart) = ilevel levelp(ipart) = levelmin ! do ivar=1,nvar_min ! if(metal.and.((ndim+2+ivar)==imetal)) zp(ipart) = pasvar(i,ivar) ! if((ndim+2+ivar)==itracer) trcp(ipart) = pasvar(i,ivar) ! end do zp(ipart) = zz(i) trcp(ipart) = trc(i) endif #ifndef WITOUTMPI endif #endif enddo #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(error) call clean_stop enddo endif enddo enddo if(myid==1) then call title(abs(nrestart),nchar) fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/sink_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(sink.and.ok)then ilun4 = 4 OPEN(unit=ilun4,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos=1 read(ilun4,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun4,pos=mypos)header_sink%nsink; mypos=mypos+sizeof(dummy_int)+size_blck_restart read(ilun4,pos=mypos)size_blck_restart; mypos=mypos+sizeof(dummy_int) read(ilun4,pos=mypos)header_sink%nindsink; mypos=mypos+sizeof(dummy_int)+size_blck_restart if(header_sink%nsink>0)then ! Sink mass read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_mass_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink birth epoch read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_birth_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink position do idim=1,ndim read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_pos_blck_restart(idim) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) end do ! Sink velocitiy do idim=1,ndim read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_vel_blck_restart(idim) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) end do ! Sink angular momentum do idim=1,ndim read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_am_blck_restart(idim) = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) end do ! Sink accumulated rest mass energy read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_dm_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink accretion rate read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_ar_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink index read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_index_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink new born boolean read(ilun4,pos=mypos) size_blck_restart; mypos = mypos+sizeof(dummy_int) sink_newb_blck_restart = mypos; mypos = mypos+size_blck_restart+sizeof(dummy_int) ! Sink int level read(ilun4,pos=mypos) sinkint_level; mypos=mypos+sizeof(dummy_int)+size_blck_restart endif eob_restart = .false. kpart_restart = 0 do while(.not.eob_restart) xx=0. vv=0. ii=0. mm=0. tt=0. zz=0. aa=0. dd=0. ll=0. !ADDED BY TTG MAY 2017 uu=0. nn=.false. if(myid==1)then jpart=0 do i=1,nvector jpart=jpart+1 ! All particles counter kpart_restart=kpart_restart+1 ! Reading ramses sink file line-by-line do idim=1,ndim read(ilun4,pos=sink_pos_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) xx(jpart,idim) read(ilun4,pos=sink_vel_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) vv(jpart,idim) read(ilun4,pos=sink_am_blck_restart(idim)+sizeof(dummy_real_restart)*(kpart_restart-1)) ll(jpart,idim) end do read(ilun4,pos=sink_mass_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) mm(jpart) read(ilun4,pos=sink_index_blck_restart+sizeof(dummy_int)*(kpart_restart-1)) ii(jpart) read(ilun4,pos=sink_dm_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) dd(jpart) read(ilun4,pos=sink_ar_blck_restart+sizeof(dummy_real_restart)*(kpart_restart-1)) aa(jpart) read(ilun4,pos=sink_newb_blck_restart+sizeof(dummy_logical)*(kpart_restart-1)) nn(jpart) ! Updating total masses if(tt(jpart)==0d0) then msink_tot = msink_tot+mm(jpart) nsink_tot = nsink_tot+1 nsink_loc = nsink_loc+1 endif ! Check the End Of Block if(kpart_restart.ge.header_part%npart) then eob_restart=.true. exit endif enddo endif #ifndef WITHOUTMPI call MPI_BCAST(eob_restart,1 ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(xx,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(vv,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ll,nvector*3 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(ii,nvector ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call MPI_BCAST(mm,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(nn,nvector ,MPI_LOGICAL ,0,MPI_COMM_WORLD,info) call MPI_BCAST(tt,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(uu,nvector ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(jpart,1 ,MPI_INTEGER ,0,MPI_COMM_WORLD,info) call cmp_cpumap(xx,cc,jpart) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif do i=1,jpart #ifndef WITHOUTMPI ! Check the CPU map if(cc(i)==myid)then #endif !HERE: transform particle positions and velocities ! xx(i,1:3) = xx(i,1:3)-restart_ic_center(1:3) xx(i,1:3) = xx(i,1:3) - 0.5*5.0d2 ! shift positions by half the original box size xx(i,1:3) = xx(i,1:3) - lmc_com ! shift positions to the LMC CoM vv(i,1:3) = vv(i,1:3) - lmc_cov/scale_v ! shift vel to the LMC CoV !Rotate all vectors counter-clockwise around x axis by 66 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_1*x_2_save - sin_theta_1*x_3_save xx(i,3) = sin_theta_1*x_2_save + cos_theta_1*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_1*v_2_save - sin_theta_1*v_3_save vv(i,3) = sin_theta_1*v_2_save + cos_theta_1*v_3_save !Rotate all vectors counter-clockwise around z axis by 231.2 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_2*x_1_save - sin_theta_2*x_2_save xx(i,2) = sin_theta_2*x_1_save + cos_theta_2*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_2*v_1_save - sin_theta_2*v_2_save vv(i,2) = sin_theta_2*v_1_save + cos_theta_2*v_2_save !Translate positons xx(i,1:3) = xx(i,1:3) + r_shift !Translate velocities vv(i,1:3) = vv(i,1:3) + v_shift/scale_v !Rotate all vectors counter-clockwise around x axis by 31.9 degree !x-component left untouched x_2_save = xx(i,2); x_3_save = xx(i,3) xx(i,2) = cos_theta_3*x_2_save - sin_theta_3*x_3_save xx(i,3) = sin_theta_3*x_2_save + cos_theta_3*x_3_save v_2_save = vv(i,2); v_3_save = vv(i,3) vv(i,2) = cos_theta_3*v_2_save - sin_theta_3*v_3_save vv(i,3) = sin_theta_3*v_2_save + cos_theta_3*v_3_save !Rotate all vectors counter-clockwise around z axis by 18.5 degree !z-component left untouched x_1_save = xx(i,1); x_2_save = xx(i,2) xx(i,1) = cos_theta_4*x_1_save - sin_theta_4*x_2_save xx(i,2) = sin_theta_4*x_1_save + cos_theta_4*x_2_save v_1_save = vv(i,1); v_2_save = vv(i,2) vv(i,1) = cos_theta_4*v_1_save - sin_theta_4*v_2_save vv(i,2) = sin_theta_4*v_1_save + cos_theta_4*v_2_save !Shift positions by half the new box size xx(i,1:3) = xx(i,1:3) + 0.5*boxlen if(xx(i,1).ge.0d0.and.xx(i,1).le.boxlen.and. & & xx(i,2).ge.0d0.and.xx(i,2).le.boxlen.and. & & xx(i,3).ge.0d0.and.xx(i,3).le.boxlen) then ipart = ipart+1 if(ipart.gt.nsinkmax) then write(*,*) 'Increase nsinkmax' error=.true. #ifndef WITHOUTMPI call MPI_BCAST(error,1,MPI_LOGICAL,0,MPI_COMM_WORLD,info) #endif endif xsink(ipart,1:3) = xx(i,1:3) vsink(ipart,1:3) = vv(i,1:3) lsink(ipart,1:3) = ll(i,1:3) msink(ipart) = mm(i) tsink(ipart) = tt(i) delta_mass(ipart) = dd(i) acc_rate(ipart) = aa(i) idsink(ipart) = ii(i) new_born(ipart) = nn(i) endif #ifndef WITOUTMPI endif #endif enddo #ifndef WITOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) if(error) call clean_stop #endif enddo call compute_ncloud_sink if(ir_feedback)then do i=1,nsink acc_lum(i)=ir_eff*acc_rate(i)*msink(i)/(5*6.955d10/scale_l) end do end if endif endif if(myid==1) then close(ilun1) close(ilun2) close(ilun3) close(ilun4) write(*,*) 'CPU',icpu,' -> [',ngas_loc,'cells/',nstar_loc,'stars/',nhalo_loc,'dm]' icpu = icpu+1 if(icpu.gt.header_part%ncpu) eocpu=.true. endif #ifndef WITHOUTMPI call MPI_BCAST(eocpu,1 ,MPI_LOGICAL,0,MPI_COMM_WORLD,info) call MPI_BCAST(icpu,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(nstar_tot,1 ,MPI_INTEGER,0,MPI_COMM_WORLD,info) call MPI_BCAST(mstar_tot,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) !ADDED BY TTG MAY 2017 call MPI_BCAST(restart_rho_min,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(restart_rho_max,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) #endif enddo if(myid==1) then write(*,'(a50)')'__________________________________________________' write(*,*)' RAMSES restart summary' write(*,'(A50)')'__________________________________________________' write(*,'(a32,i10)') 'Restart snapshot [ifout]: ',ifout-1 write(*,'(a32,1pe10.4)') 'Restart time [t]: ',t write(*,'(a32,1pe10.4)') 'Next snapshot time [tout(iout)]: ',tout(iout) write(*,'(a32,i10)') 'Total snapshots [noutput]: ',noutput write(*,'(a32,i10)') 'Main step [nstep_coarse]: ',nstep_coarse write(*,'(a32,i10)') 'Fine step [nstep]: ',nstep write(*,'(a32,i10)') 'CPUs: ',header_amr%ncpu write(*,'(a32,i10)') 'DM particles: ',nhalo_tot write(*,'(a32,1pe10.2)') 'M_DM [Msun]: ',mhalo_tot*scale_m/msol write(*,'(a32,i10)') 'STAR particles: ',nstar_tot write(*,'(a32,1pe10.2)') 'M_stars [Msun]: ',mstar_tot*scale_m/msol if(hydro) write(*,'(a32,i10)') 'GAS particles [leaf cells]: ',lpart_restart if(hydro) write(*,'(a32,1pe10.2)') 'M_gas [Msun]: ',mgas_tot_restart*scale_m/msol if(hydro) write(*,'(a32,1pe10.2)') 'rho_min [cm^-3]: ',restart_rho_min if(hydro) write(*,'(a32,1pe10.2)') 'rho_max [cm^-3]: ',restart_rho_max if(sink) write(*,'(a32,i10)') 'SINK particles: ',nsink_tot if(sink) write(*,'(a32,1pe10.2)') 'M_sink [Msun]: ',msink_tot*scale_m/msol write(*,'(a50)')'__________________________________________________' endif npart = ipart !VERY IMPORTANT: NOW the total of number of particles (DICE IC's + RAMSES file) are computed ! Compute total number of particles npart_cpu = 0 npart_all = 0 npart_cpu(myid) = npart #ifndef WITHOUTMPI call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) npart_cpu(1) = npart_all(1) #endif if(myid==1)then write(*,*) ' npart_tot -> ',sum(npart_all) write(*,'(A50)')'__________________________________________________' close(1) endif do icpu=2,ncpu npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu) end do ! if(debug)write(*,*)'RAMSES file: npart(myid)=',npart,'(',myid,') / ',npart_cpu(ncpu) !This is the end of the modified RESTART patch !------------------ ! DICE_RESTART patch !---------------------------------------------------------------------- case ('gadget') call load_gadget case DEFAULT write(*,*) 'Unsupported format file ' // filetype call clean_stop end select end if if(sink)call init_sink end subroutine init_part #define TIME_START(cs) call SYSTEM_CLOCK(COUNT=cs) #define TIME_END(ce) call SYSTEM_CLOCK(COUNT=ce) #define TIME_SPENT(cs,ce,cr) REAL((ce-cs)/cr) subroutine load_gadget use amr_commons use pm_commons use gadgetreadfilemod implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif logical::ok TYPE(gadgetheadertype) :: gadgetheader integer::numfiles integer::ifile real(dp),dimension(1:nvector,1:3)::xx_dp real, dimension(:, :), allocatable:: pos, vel real(dp)::massparticles integer(kind=8)::allparticles integer(i8b), dimension(:), allocatable:: ids integer::nparticles, arraysize integer::i, icpu, ipart, info, np, start integer(i8b),dimension(1:ncpu)::npart_cpu,npart_all character(LEN=256)::filename integer ,dimension(1:nvector)::cc integer :: clock_start, clock_end, clock_rate integer :: mpi_cs, mpi_ce real:: gadgetvfact ! Local particle count ipart=0 call SYSTEM_CLOCK(COUNT_RATE=clock_rate) if(TRIM(initfile(levelmin)).NE.' ')then filename=TRIM(initfile(levelmin)) ! read first header to get information call gadgetreadheader(filename, 0, gadgetheader, ok) if(.not.ok) call clean_stop numfiles = gadgetheader%numfiles gadgetvfact = SQRT(aexp) / gadgetheader%boxsize * aexp / 100. #ifndef LONGINT allparticles=int(gadgetheader%nparttotal(2),kind=8) #else allparticles=int(gadgetheader%nparttotal(2),kind=8) & & +int(gadgetheader%totalhighword(2),kind=8)*4294967296 !2^32 #endif massparticles=1d0/dble(allparticles) do ifile=0,numfiles-1 call gadgetreadheader(filename, ifile, gadgetheader, ok) nparticles = gadgetheader%npart(2) allocate(pos(3,nparticles)) allocate(vel(3,nparticles)) allocate(ids(nparticles)) TIME_START(clock_start) call gadgetreadfile(filename,ifile,gadgetheader, pos, vel, ids) TIME_END(clock_end) if(debug) write(*,*) myid, ':Read ', nparticles, ' from gadget file ', ifile, ' in ', & TIME_SPENT(clock_start, clock_end, clock_rate) start = 1 TIME_START(clock_start) #ifndef WITHOUTMPI do i=1,nparticles xx_dp(1,1) = pos(1,i)/gadgetheader%boxsize xx_dp(1,2) = pos(2,i)/gadgetheader%boxsize xx_dp(1,3) = pos(3,i)/gadgetheader%boxsize call cmp_cpumap(xx_dp,cc,1) if(cc(1)==myid)then #endif ipart=ipart+1 if (ipart .ge. size(mp)) then write(*,*) 'For ', myid, ipart, ' exceeds ', size(mp) call clean_stop end if xp(ipart,1:3)=xx_dp(1,1:3) vp(ipart,1) =vel(1, i) * gadgetvfact vp(ipart,2) =vel(2, i) * gadgetvfact vp(ipart,3) =vel(3, i) * gadgetvfact mp(ipart) = massparticles levelp(ipart)=levelmin idp(ipart) =ids(i) #ifndef WITHOUTMPI endif enddo TIME_END(clock_end) if(debug) write(*,*) myid, ':Processed ', nparticles, ' in ',& & TIME_SPENT(clock_start, clock_end, clock_rate), ' ipart now ', ipart #endif deallocate(pos,vel,ids) end do end if npart=ipart ! Compute total number of particleclock_rate npart_cpu=0; npart_all=0 npart_cpu(myid)=npart #ifndef WITHOUTMPI #ifndef LONGINT call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) #else call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,info) #endif npart_cpu(1)=npart_all(1) #endif do icpu=2,ncpu npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu) end do write(*,*)'npart=',npart,'/',npartmax end subroutine load_gadget ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/init_poisson.f90 subroutine init_poisson use pm_commons use amr_commons use poisson_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ncell,ncache,iskip,igrid,i,ilevel,ind,ivar integer::nvar2,ilevel2,numbl2,ilun,ibound,istart,info integer::ncpu2,ndim2,nlevelmax2,nboundary2 integer ,dimension(:),allocatable::ind_grid real(dp),dimension(:),allocatable::xx ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar,ncharcpu integer,parameter::tag=1114 integer::dummy_io,info2 if(verbose)write(*,*)'Entering init_poisson' !------------------------------------------------------ ! Allocate cell centered variables arrays !------------------------------------------------------ ncell=ncoarse+twotondim*ngridmax allocate(rho (1:ncell)) allocate(phi (1:ncell)) allocate(phi_old (1:ncell)) allocate(f (1:ncell,1:3)) rho=0.0D0; phi=0.0D0; f=0.0D0 if(cic_levelmax>0)then allocate(rho_top(1:ncell)) rho_top=0d0 endif !------------------------------------------------------ ! Allocate multigrid variables !------------------------------------------------------ ! Allocate communicators for coarser multigrid levels allocate(active_mg (1:ncpu,1:nlevelmax-1)) allocate(emission_mg (1:ncpu,1:nlevelmax-1)) do ilevel=1,nlevelmax-1 do i=1,ncpu active_mg (i,ilevel)%ngrid=0 active_mg (i,ilevel)%npart=0 emission_mg (i,ilevel)%ngrid=0 emission_mg (i,ilevel)%npart=0 end do end do allocate(safe_mode(1:nlevelmax)) safe_mode = .false. !-------------------------------- ! For a restart, read poisson file !-------------------------------- if(nrestart>0)then ilun=ncpu+myid+10 call title(nrestart,nchar) if(IOGROUPSIZEREP>0)then call title(((myid-1)/IOGROUPSIZEREP)+1,ncharcpu) ! CHANGED BY TTG (FEB 2017) ! fileloc='output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/grav_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/grav_'//TRIM(nchar)//'.out' else ! CHANGED BY TTG (FEB 2017) ! fileloc='output_'//TRIM(nchar)//'/grav_'//TRIM(nchar)//'.out' fileloc=TRIM(output_dir)//'output_'//TRIM(nchar)//'/grav_'//TRIM(nchar)//'.out' endif call title(myid,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(unit=ilun,file=fileloc,form='unformatted') read(ilun)ncpu2 read(ilun)ndim2 read(ilun)nlevelmax2 read(ilun)nboundary2 if(ndim2.ne.ndim+1)then if(ndim2.ne.ndim)then write(*,*)'File poisson.tmp is not compatible' write(*,*)'Found =',ndim2 write(*,*)'Expected=',ndim+1 call clean_stop else if(myid==1) write(*,*)'Assuming pre commit bce4454 output format' endif end if do ilevel=1,nlevelmax2 do ibound=1,nboundary+ncpu if(ibound<=ncpu)then ncache=numbl(ibound,ilevel) istart=headl(ibound,ilevel) else ncache=numbb(ibound-ncpu,ilevel) istart=headb(ibound-ncpu,ilevel) end if read(ilun)ilevel2 read(ilun)numbl2 if(numbl2.ne.ncache)then write(*,*)'File poisson.tmp is not compatible' write(*,*)'Found =',numbl2,' for level ',ilevel2 write(*,*)'Expected=',ncache,' for level ',ilevel end if if(ncache>0)then allocate(ind_grid(1:ncache)) allocate(xx(1:ncache)) ! Loop over level grids igrid=istart do i=1,ncache ind_grid(i)=igrid igrid=next(igrid) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax ! Read potential read(ilun)xx do i=1,ncache phi(ind_grid(i)+iskip)=xx(i) end do ! Read force do ivar=1,ndim read(ilun)xx do i=1,ncache f(ind_grid(i)+iskip,ivar)=xx(i) end do end do end do deallocate(ind_grid,xx) end if end do end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif #ifndef WITHOUTMPI if(debug)write(*,*)'poisson.tmp read for processor ',myid call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(verbose)write(*,*)'POISSON backup files read completed' end if end subroutine init_poisson ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/init_refine.f90 !################################################################ !################################################################ !################################################################ !################################################################ subroutine init_refine use amr_commons use pm_commons use dice_commons implicit none !------------------------------------------- ! This routine builds the initial AMR grid !------------------------------------------- integer::ilevel if(myid==1)write(*,*)'Building initial AMR grid' init=.true. ! Base refinement do ilevel=1,levelmin call flag call refine end do ! Further refinements if necessary do ilevel=levelmin+1,nlevelmax if(initfile(levelmin).ne.' '.and.initfile(ilevel).eq.' ')exit if(hydro)call init_flow #ifdef RT if(rt)call rt_init_flow #endif if(ivar_refine==0)call init_refmap call flag call refine if(nremap>0)call load_balance if(numbtot(1,ilevel)==0)exit end do ! Final pass to initialize the flow init=.false. if(hydro)call init_flow #ifdef RT if(rt)call rt_init_flow #endif end subroutine init_refine !################################################################ !################################################################ !################################################################ !################################################################ subroutine init_refine_2 !-------------------------------------------------------------- ! This routine builds additional refinements to the ! the initial AMR grid for filetype ne 'grafic' ! DICE patch: It is ensured that all the particles are ! transfered down to level 1 before initialising the grid ! This also applies to the gas particles obtained from the AMR ! to particle conversion in the init_part.f90 RESTART patch !-------------------------------------------------------------- use amr_commons use hydro_commons #ifdef RT use rt_hydro_commons #endif use pm_commons use poisson_commons use dice_commons ! RESTART patch use restart_commons ! RESTART patch implicit none integer::ilevel,i,ivar real(dp)::scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2 real(dp)::eps_star2 call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) if(filetype.eq.'grafic')return if(myid==1.and.amr_struct) then write(*,*) 'Initial conditions with AMR data structure' write(*,'(A50)')'__________________________________________________' end if do i=levelmin,nlevelmax+1 ! DICE / RESTART patch do ilevel=levelmin-1,1,-1 if(pic)call merge_tree_fine(ilevel) enddo ! ---------- call refine_coarse do ilevel=1,nlevelmax call build_comm(ilevel) call make_virtual_fine_int(cpu_map(1),ilevel) call refine_fine(ilevel) ! DICE / RESTART patch if(pic)call make_tree_fine(ilevel) ! ---------- if(hydro)call init_flow_fine(ilevel) ! DICE / RESTART patch if(pic)then call kill_tree_fine(ilevel) call virtual_tree_fine(ilevel) endif ! ---------- #ifdef RT if(rt)call rt_init_flow_fine(ilevel) #endif end do ! DICE / RESTART patch do ilevel=nlevelmax-1,levelmin,-1 if(pic)call merge_tree_fine(ilevel) enddo ! ---------- if(nremap>0)call load_balance do ilevel=levelmin,nlevelmax if(pic)call make_tree_fine(ilevel) if(poisson)call rho_fine(ilevel,2) if(hydro)call init_flow_fine(ilevel) if(pic)then call kill_tree_fine(ilevel) call virtual_tree_fine(ilevel) endif end do do ilevel=nlevelmax,levelmin,-1 if(pic)call merge_tree_fine(ilevel) if(hydro)then call upload_fine(ilevel) #ifdef SOLVERmhd do ivar=1,nvar+3 #else do ivar=1,nvar #endif call make_virtual_fine_dp(uold(1,ivar),ilevel) #ifdef SOLVERmhd end do #else end do #endif if(simple_boundary)call make_boundary_hydro(ilevel) endif #ifdef RT if(rt)then call rt_upload_fine(ilevel) do ivar=1,nrtvar call make_virtual_fine_dp(rtuold(1,ivar),ilevel) end do if(simple_boundary)call rt_make_boundary_hydro(ilevel) end if #endif end do do ilevel=nlevelmax,1,-1 call flag_fine(ilevel,2) end do call flag_coarse end do ! DICE / RESTART patch do ilevel=levelmin-1,1,-1 if(pic)call merge_tree_fine(ilevel) enddo call kill_gas_part(1) do ilevel=1,nlevelmax if(pic)then call make_tree_fine(ilevel) call kill_tree_fine(ilevel) call virtual_tree_fine(ilevel) endif end do do ilevel=nlevelmax,levelmin,-1 call merge_tree_fine(ilevel) end do deallocate(up) if(sf_virial)then eps_star2=eps_star eps_star=0d0 do ilevel=nlevelmax,levelmin,-1 call star_formation(ilevel) enddo eps_star=eps_star2 endif dice_init=.false. ! ---------- ! RESTART patch restart_init=.false. ! RESTART patch #ifdef RT if(rt_is_init_xion .and. rt_nregion .eq. 0) then if(myid==1) write(*,*) 'Initializing ionization states from T profile' do ilevel=nlevelmax,1,-1 call rt_init_xion(ilevel) call upload_fine(ilevel) end do endif #endif end subroutine init_refine_2 !################################################################ !################################################################ !################################################################ !################################################################ subroutine kill_gas_part(ilevel) use pm_commons use amr_commons implicit none integer::ilevel #ifndef WITHOUTMPI include 'mpif.h' #endif !-------------------------------------------------------- ! This subroutine removes the gas particles ! initially present in the gadget1 DICE output ! This also applies to the gas particles obtained from the AMR ! to particle conversion in the init_part.f90 RESTART patch !-------------------------------------------------------- integer::igrid,jgrid,ipart,jpart,next_part integer::ig,ip,npart1,npart2,icpu,info integer,dimension(1:nvector)::ind_grid,ind_part,ind_grid_part logical,dimension(1:nvector)::ok=.true. integer::npart_all integer,dimension(1:ncpu)::npart_cpu,npart_cpu_all npart_cpu = 0 npart_all = 0 if(numbtot(1,ilevel)==0)return ! Gather gas particles. ! Loop over cpus do icpu=1,ncpu igrid=headl(icpu,ilevel) ig=0 ip=0 ! Loop over grids do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid npart2=0 ! Count gas particles if(npart1>0)then ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ! if(idp(ipart).eq.1) then !TTG (FEB 2017): select gas particles (defined by init_part.f90 to have ID = 1) if(MOD(idp(ipart),2).eq.0)then !TTG (MAR 2017): select gas particles (defined by DICE / RESTART to have even ID) npart2=npart2+1 endif ipart=next_part ! Go to next particle end do npart_cpu(myid)=npart_cpu(myid)+npart2 endif ! Gather gas particles if(npart2>0)then ig=ig+1 ind_grid(ig)=igrid ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ! Select only gas particles ! if(idp(ipart).eq.1) then !TTG (FEB 2017): select gas particles (defined by init_part.f90 to have ID = 1) if(MOD(idp(ipart),2).eq.0)then !TTG (MAR 2017): select gas particles (defined by DICE/ RESTART to have even ID) if(ig==0)then ig=1 ind_grid(ig)=igrid end if ip=ip+1 ind_part(ip)=ipart ind_grid_part(ip)=ig endif if(ip==nvector)then call remove_list(ind_part,ind_grid_part,ok,ip) call add_free_cond(ind_part,ok,ip) ip=0 ig=0 end if ipart=next_part ! Go to next particle end do ! End loop over particles end if igrid=next(igrid) ! Go to next grid end do ! End loop over grids if(ip>0)then call remove_list(ind_part,ind_grid_part,ok,ip) call add_free_cond(ind_part,ok,ip) end if end do #ifndef WITHOUTMPI ! Give an array of number of gas on each cpu available to all cpus call MPI_ALLREDUCE(npart_cpu,npart_cpu_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) #endif npart_all=sum(npart_cpu_all(1:ncpu)) if(npart_all>0) then if(myid==1) then write(*,'(A50)')'__________________________________________________' write(*,'(A,I15)')' Gas particles deleted ->',npart_all write(*,'(A50)')'__________________________________________________' endif endif npart_cpu(myid)=npart #ifndef WITHOUTMPI ! Give an array of number of gas on each cpu available to all cpus call MPI_ALLREDUCE(npart_cpu,npart_cpu_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) #endif npart_all=sum(npart_cpu_all(1:ncpu)) if(npart_all>0) then if(myid==1) then write(*,'(A50)')'__________________________________________________' write(*,'(A,I15)')' Remaining particles ->',npart_all write(*,'(A50)')'__________________________________________________' endif endif do icpu=1,ncpu igrid=headl(icpu,ilevel) ig=0 ip=0 ! Loop over grids do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid npart2=0 ! Count gas particles if(npart1>0)then ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ! CHANGED BY TTG (MAR 2017): identify particles by their DICE / RESTART component number; no need to change anything ! if(idp(ipart).gt.0) idp(ipart)=idp(ipart)-1 !TTG (FEB 2017): here the actual Gadget type is recovered ipart=next_part ! Go to next particle end do npart_cpu(myid)=npart_cpu(myid)+npart2 endif end do end do 111 format(' Entering kill_gas_part for level ',I2) !--------------------------------------------- end subroutine ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/init_time.f90 subroutine init_time use amr_commons use hydro_commons use pm_commons use cooling_module #ifdef grackle use grackle_parameters #endif #ifdef RT use rt_cooling_module #endif implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::i,Nmodel,info real(kind=8)::T2_sim real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v logical::file_exists ! if(nrestart==0)then ! RESTART patch if(nrestart<=0)then ! RESTART patch if(cosmo)then ! Get cosmological parameters from input files call init_cosmo else ! Get parameters from input files if(initfile(levelmin).ne.' '.and.filetype.eq.'grafic')then call init_file endif t=0.0 aexp=1.0 end if end if if(cosmo)then ! Allocate look-up tables n_frw=1000 allocate(aexp_frw(0:n_frw),hexp_frw(0:n_frw)) allocate(tau_frw(0:n_frw),t_frw(0:n_frw)) ! Compute Friedman model look up table if(myid==1)write(*,*)'Computing Friedman model' call friedman(dble(omega_m),dble(omega_l),dble(omega_k), & & 1.d-6,dble(aexp_ini), & & aexp_frw,hexp_frw,tau_frw,t_frw,n_frw) ! Compute initial conformal time ! Find neighboring expansion factors i=1 do while(aexp_frw(i)>aexp.and.i0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif INQUIRE(file=filename,exist=ok) if(.not.ok)then if(myid==1)then write(*,*)'File '//TRIM(filename)//' does not exist' end if call clean_stop end if open(10,file=filename,form='unformatted') if(myid==1)write(*,*)'Reading file '//TRIM(filename) rewind 10 read(10)n1(ilevel),n2(ilevel),n3(ilevel),dxini0 & & ,xoff10,xoff20,xoff30 & & ,astart0,omega_m0,omega_l0,h00 close(10) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif dxini(ilevel)=dxini0 xoff1(ilevel)=xoff10 xoff2(ilevel)=xoff20 xoff3(ilevel)=xoff30 nlevelmax_part=nlevelmax_part+1 endif end do ! Check compatibility with run parameters nx_loc=icoarse_max-icoarse_min+1 ny_loc=jcoarse_max-jcoarse_min+1 nz_loc=kcoarse_max-kcoarse_min+1 if( nx_loc.ne.n1(levelmin)/2**levelmin & & .or. ny_loc.ne.n2(levelmin)/2**levelmin & & .or. nz_loc.ne.n3(levelmin)/2**levelmin) then write(*,*)'coarser grid is not compatible with initial conditions file' write(*,*)'Found n1=',n1(levelmin),& & ' n2=',n2(levelmin),& & ' n3=',n3(levelmin) write(*,*)'Expected n1=',nx_loc*2**levelmin & & ,' n2=',ny_loc*2**levelmin & & ,' n3=',nz_loc*2**levelmin call clean_stop end if ! Write initial conditions parameters if(myid==1)then do ilevel=levelmin,nlevelmax_part write(*,'(' Initial conditions for level =',I4)')ilevel write(*,'(' n1=',I4,' n2=',I4,' n3=',I4)') & & n1(ilevel),& & n2(ilevel),& & n3(ilevel) write(*,'(' dx=',1pe10.3)')dxini(ilevel) write(*,'(' xoff=',1pe10.3,' yoff=',1pe10.3,' zoff=',& & 1pe10.3)') & & xoff1(ilevel),& & xoff2(ilevel),& & xoff3(ilevel) end do end if end subroutine init_file subroutine init_cosmo use amr_commons use hydro_commons use pm_commons use gadgetreadfilemod use dice_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif !------------------------------------------------------ ! Read cosmological and geometrical parameters ! in the initial condition files. ! Initial conditions are supposed to be made by ! Bertschinger's grafic version 2.0 code. !------------------------------------------------------ integer:: ilevel real(sp)::dxini0,xoff10,xoff20,xoff30,astart0,omega_m0,omega_l0,h00 ! CHANGED BY TTG MAY 2017 ! character(LEN=80)::filename character(LEN=256)::filename character(LEN=5)::nchar logical::ok TYPE(gadgetheadertype) :: gadgetheader integer::i integer,parameter::tag=1117 integer::dummy_io,info2 ! RESTART patch integer::ilun,mypos,size_blck,dummy_int,info,icpu ! CHANGED BY TTG MAY 2017 ! character(LEN=80)::fileloc character(LEN=256)::fileloc TYPE ramses_amr_headertype integer::ncpu integer::ndim integer::nx,ny,nz integer::nlevelmax integer::ngridmax integer::nboundary integer::ngrid_current real(dp)::boxlen integer::noutput,iout,ifout real(dp),dimension(1:MAXOUT)::tout real(dp),dimension(1:MAXOUT)::aout real(dp)::t real(dp),dimension(1:MAXLEVEL)::dtold real(dp),dimension(1:MAXLEVEL)::dtnew integer::nstep,nstep_coarse real(dp)::einit,mass_tot_0,rho_tot real(dp)::omega_m,omega_l,omega_k,omega_b,h0,aexp_ini,boxlen_ini real(dp)::aexp,hexp,aexp_old,epot_tot_int,epot_tot_old real(dp)::mass_sph END TYPE ramses_amr_headertype type(ramses_amr_headertype) :: header_amr ! RESTART patch if(verbose)write(*,*)'Entering init_cosmo' if(initfile(levelmin)==' ')then write(*,*)'You need to specifiy at least one level of initial condition' call clean_stop end if SELECT CASE (filetype) case ('grafic', 'ascii') ! Reading initial conditions parameters only aexp=2.0 nlevelmax_part=levelmin-1 do ilevel=levelmin,nlevelmax if(initfile(ilevel).ne.' ')then if(multiple)then call title(myid,nchar) filename=TRIM(initfile(ilevel))//'/dir_deltab/ic_deltab.'//TRIM(nchar) else filename=TRIM(initfile(ilevel))//'/ic_deltab' endif ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif INQUIRE(file=filename,exist=ok) if(.not.ok)then if(myid==1)then write(*,*)'File '//TRIM(filename)//' does not exist' end if call clean_stop end if open(10,file=filename,form='unformatted') if(myid==1)write(*,*)'Reading file '//TRIM(filename) rewind 10 read(10)n1(ilevel),n2(ilevel),n3(ilevel),dxini0 & & ,xoff10,xoff20,xoff30 & & ,astart0,omega_m0,omega_l0,h00 close(10) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif dxini(ilevel)=dxini0 xoff1(ilevel)=xoff10 xoff2(ilevel)=xoff20 xoff3(ilevel)=xoff30 astart(ilevel)=astart0 omega_m=omega_m0 omega_l=omega_l0 h0=h00 aexp=MIN(aexp,astart(ilevel)) nlevelmax_part=nlevelmax_part+1 ! Compute SPH equivalent mass (initial gas mass resolution) mass_sph=omega_b/omega_m*0.5d0**(ndim*ilevel) endif end do ! Compute initial expansion factor if(aexp_ini.lt.1.0)then aexp=aexp_ini else aexp_ini=aexp endif ! Check compatibility with run parameters if(.not. multiple) then if( nx.ne.n1(levelmin)/2**levelmin & & .or. ny.ne.n2(levelmin)/2**levelmin & & .or. nz.ne.n3(levelmin)/2**levelmin) then write(*,*)'coarser grid is not compatible with initial conditions file' write(*,*)'Found n1=',n1(levelmin),& & ' n2=',n2(levelmin),& & ' n3=',n3(levelmin) write(*,*)'Expected n1=',nx*2**levelmin & & ,' n2=',ny*2**levelmin & & ,' n3=',nz*2**levelmin call clean_stop endif end if ! Compute box length in the initial conditions in units of h-1 Mpc boxlen_ini=dble(nx)*2**levelmin*dxini(levelmin)*(h0/100.) CASE ('gadget') if (verbose) write(*,*)'Reading in gadget format from '//TRIM(initfile(levelmin)) call gadgetreadheader(TRIM(initfile(levelmin)), 0, gadgetheader, ok) if(.not.ok) call clean_stop do i=1,6 if (i .ne. 2) then if (gadgetheader%nparttotal(i) .ne. 0) then write(*,*) 'Non DM particles present in bin ', i call clean_stop endif endif enddo if (gadgetheader%mass(2) == 0) then write(*,*) 'Particles have different masses, not supported' call clean_stop endif omega_m = gadgetheader%omega0 omega_l = gadgetheader%omegalambda h0 = gadgetheader%hubbleparam * 100.d0 boxlen_ini = gadgetheader%boxsize aexp = gadgetheader%time aexp_ini = aexp ! Compute SPH equivalent mass (initial gas mass resolution) mass_sph=omega_b/omega_m*0.5d0**(ndim*levelmin) nlevelmax_part = levelmin astart(levelmin) = aexp xoff1(levelmin)=0 xoff2(levelmin)=0 xoff3(levelmin)=0 dxini(levelmin) = boxlen_ini/(nx*2**levelmin*(h0/100.0)) CASE ('dice') if (verbose) write(*,*)'Reading in gadget format from'//TRIM(initfile(levelmin))//'/'//TRIM(ic_file) call gadgetreadheader(TRIM(initfile(levelmin))//'/'//TRIM(ic_file), 0,gadgetheader, ok) if(.not.ok) call clean_stop omega_m = gadgetheader%omega0 omega_l = gadgetheader%omegalambda h0 = gadgetheader%hubbleparam * 100.d0 if(gadgetheader%boxsize>0d0) then boxlen_ini = gadgetheader%boxsize/1e3 else boxlen_ini = boxlen endif aexp = gadgetheader%time aexp_ini = aexp ! Compute SPH equivalent mass (initial gas mass resolution) mass_sph=omega_b/omega_m*0.5d0**(ndim*levelmin) nlevelmax_part = levelmin astart(levelmin) = aexp xoff1(levelmin)=0 xoff2(levelmin)=0 xoff3(levelmin)=0 dxini(levelmin) = boxlen_ini/(nx*2**levelmin*(h0/100.0)) ! RESTART patch CASE ('ramses') if(myid==1)then icpu = 1 ! Conversion factor from user units to cgs units call title(abs(nrestart),nchar) fileloc='output_'//TRIM(nchar)//'/amr_'//TRIM(nchar)//'.out' call title(icpu,nchar) fileloc=TRIM(fileloc)//TRIM(nchar) INQUIRE(file=fileloc,exist=ok) if(.not.ok)then write(*,*) TRIM(fileloc),' not found' call clean_stop endif ilun = 2 OPEN(unit=ilun,file=fileloc,status='old',action='read',form='unformatted',access='stream') mypos = 1 read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%ncpu; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%ndim; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%nx,header_amr%ny,header_amr%nz; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%nlevelmax; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%ngridmax; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%nboundary; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%ngrid_current; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%boxlen; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%noutput,header_amr%iout,header_amr%ifout; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%tout(1:header_amr%noutput); mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%aout(1:header_amr%noutput); mypos=mypos+sizeof(dummy_int)+size_blck ! Old output times read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%t; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%dtold(1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%dtnew(1:header_amr%nlevelmax); mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%nstep,header_amr%nstep_coarse; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%einit,header_amr%mass_tot_0,header_amr%rho_tot; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%omega_m,header_amr%omega_l,header_amr%omega_k, & & header_amr%omega_b,header_amr%h0,header_amr%aexp_ini,header_amr%boxlen_ini; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%aexp,header_amr%hexp,header_amr%aexp_old,header_amr%epot_tot_int,header_amr%epot_tot_old; mypos=mypos+sizeof(dummy_int)+size_blck read(ilun,pos=mypos)size_blck; mypos=mypos+sizeof(dummy_int) read(ilun,pos=mypos)header_amr%mass_sph; mypos=mypos+sizeof(dummy_int)+size_blck close(ilun) endif #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%t,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%omega_m,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%omega_l,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%h0,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%boxlen_ini,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BCAST(header_amr%aexp,1 ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif t = header_amr%t omega_m = header_amr%omega_m omega_l = header_amr%omega_l h0 = header_amr%h0 boxlen_ini = header_amr%boxlen_ini aexp = header_amr%aexp if(myid==1) write(*,*) 'aexp restart = ',aexp aexp_ini = aexp mass_sph=omega_b/omega_m*0.5d0**(ndim*levelmin) nlevelmax_part = levelmin astart(levelmin) = aexp xoff1(levelmin)=0 xoff2(levelmin)=0 xoff3(levelmin)=0 dxini(levelmin) = boxlen_ini/(nx*2**levelmin*(h0/100.0)) ! RESTART patch CASE DEFAULT write(*,*) 'Unsupported input format '//filetype call clean_stop END SELECT ! Write cosmological parameters if(myid==1)then write(*,'(' Cosmological parameters:')') write(*,'(' aexp=',1pe10.3,' H0=',1pe10.3,' km s-1 Mpc-1')')aexp,h0 write(*,'(' omega_m=',F7.3,' omega_l=',F7.3,' omega_b=',F7.3)')omega_m,omega_l,omega_b write(*,'(' box size=',1pe10.3,' h-1 Mpc')')boxlen_ini end if omega_k=1.d0-omega_l-omega_m ! Compute linear scaling factor between aexp and astart(ilevel) do ilevel=levelmin,nlevelmax_part dfact(ilevel)=d1a(aexp)/d1a(astart(ilevel)) vfact(ilevel)=astart(ilevel)*fpeebl(astart(ilevel)) & ! Same scale factor as in grafic1 & *sqrt(omega_m/astart(ilevel)+omega_l*astart(ilevel)*astart(ilevel)+omega_k) & & /astart(ilevel)*h0 end do ! Write initial conditions parameters do ilevel=levelmin,nlevelmax_part if(myid==1)then write(*,'(' Initial conditions for level =',I4)')ilevel write(*,'(' dx=',1pe10.3,' h-1 Mpc')')dxini(ilevel)*h0/100. endif if(.not.multiple)then if(myid==1)then write(*,'(' n1=',I4,' n2=',I4,' n3=',I4)') & & n1(ilevel),& & n2(ilevel),& & n3(ilevel) write(*,'(' xoff=',1pe10.3,' yoff=',1pe10.3,' zoff=',& & 1pe10.3,' h-1 Mpc')') & & xoff1(ilevel)*h0/100.,& & xoff2(ilevel)*h0/100.,& & xoff3(ilevel)*h0/100. endif else write(*,'(' myid=',I4,' n1=',I4,' n2=',I4,' n3=',I4)') & & myid,n1(ilevel),n2(ilevel),n3(ilevel) write(*,'(' myid=',I4,' xoff=',1pe10.3,' yoff=',1pe10.3,' zoff=',& & 1pe10.3,' h-1 Mpc')') & & myid,xoff1(ilevel)*h0/100.,& & xoff2(ilevel)*h0/100.,& & xoff3(ilevel)*h0/100. endif end do ! Scale displacement in Mpc to code velocity (v=dx/dtau) ! in coarse cell units per conformal time vfact(1)=aexp*fpeebl(aexp)*sqrt(omega_m/aexp+omega_l*aexp*aexp+omega_k) ! This scale factor is different from vfact in grafic by h0/aexp contains !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc function fy(a) implicit none ! Computes the integrand real(dp)::fy real(dp)::y,a y=omega_m*(1.d0/a-1.d0) + omega_l*(a*a-1.d0) + 1.d0 fy=1.d0/y**1.5d0 return end function fy !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc function d1a(a) implicit none real(dp)::d1a ! Computes the linear growing mode D1 in a Friedmann-Robertson-Walker ! universe. See Peebles LSSU sections 11 and 14. real(dp)::a,y12,y,eps eps=1.0d-6 if(a .le. 0.0d0)then write(*,*)'a=',a call clean_stop end if y=omega_m*(1.d0/a-1.d0) + omega_l*(a*a-1.d0) + 1.d0 if(y .lt. 0.0D0)then write(*,*)'y=',y call clean_stop end if y12=y**0.5d0 d1a=y12/a*rombint(eps,a,eps) return end function d1a !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !! function ad1(d1) !! implicit none !! real(dp)::ad1 !! real(dp)::a,d1,da !! integer::niter !! ! Inverts the relation d1(a) given by function d1a(a) using !! ! Newton-Raphson. !! if (d1.eq.0.0) stop 'ad1 undefined for d1=0!' !! ! Initial guess for Newton-Raphson iteration, good for Omega near 1. !! a=1.e-7 !! niter=0 !! 10 niter=niter+1 !! da=(d1/d1a(a)-1.d0)/fpeebl(a)*a !! a=a+da !! if (abs(da).gt.1.0e-8.and.niter.lt.10) go to 10 !! ad1=a !! return !! end function ad1 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc function fpeebl(a) implicit none real(dp) :: fpeebl,a ! Computes the growth factor f=d\log D1/d\log a. real(dp) :: fact,y,eps eps=1.0d-6 y=omega_m*(1.d0/a-1.d0) + omega_l*(a*a-1.d0) + 1.d0 fact=rombint(eps,a,eps) fpeebl=(omega_l*a*a-0.5d0*omega_m/a)/y - 1.d0 + a*fy(a)/fact return end function fpeebl !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc function rombint(a,b,tol) implicit none real(dp)::rombint ! ! Rombint returns the integral from a to b of f(x)dx using Romberg ! integration. The method converges provided that f(x) is continuous ! in (a,b). The function f must be double precision and must be ! declared external in the calling routine. ! tol indicates the desired relative accuracy in the integral. ! integer::maxiter=16,maxj=5 real(dp),dimension(100):: g real(dp)::a,b,tol,fourj real(dp)::h,error,gmax,g0,g1 integer::nint,i,j,k,jmax h=0.5d0*(b-a) gmax=h*(fy(a)+fy(b)) g(1)=gmax nint=1 error=1.0d20 i=0 10 i=i+1 if(.not. (i>maxiter.or.(i>5.and.abs(error)maxiter.and.abs(error)>tol) & & write(*,*) 'Rombint failed to converge; integral, error=', & & rombint,error return end function rombint end subroutine init_cosmo subroutine friedman(O_mat_0,O_vac_0,O_k_0,alpha,axp_min, & & axp_out,hexp_out,tau_out,t_out,ntable) use amr_parameters implicit none integer::ntable real(kind=8)::O_mat_0, O_vac_0, O_k_0 real(kind=8)::alpha,axp_min real(dp),dimension(0:ntable)::axp_out,hexp_out,tau_out,t_out ! ######################################################! ! This subroutine assumes that axp = 1 at z = 0 (today) ! ! and that t and tau = 0 at z = 0 (today). ! ! axp is the expansion factor, hexp the Hubble constant ! ! defined as hexp=1/axp*daxp/dtau, tau the conformal ! ! time, and t the look-back time, both in unit of 1/H0. ! ! alpha is the required accuracy and axp_min is the ! ! starting expansion factor of the look-up table. ! ! ntable is the required size of the look-up table. ! ! ######################################################! real(kind=8)::axp_tau, axp_t real(kind=8)::axp_tau_pre, axp_t_pre real(kind=8)::dadtau, dadt real(kind=8)::dtau,dt real(kind=8)::tau,t integer::nstep,nout,nskip if( (O_mat_0+O_vac_0+O_k_0) .ne. 1.0D0 )then write(*,*)'Error: non-physical cosmological constants' write(*,*)'O_mat_0,O_vac_0,O_k_0=',O_mat_0,O_vac_0,O_k_0 write(*,*)'The sum must be equal to 1.0, but ' write(*,*)'O_mat_0+O_vac_0+O_k_0=',O_mat_0+O_vac_0+O_k_0 call clean_stop end if axp_tau = 1.0D0 axp_t = 1.0D0 tau = 0.0D0 t = 0.0D0 nstep = 0 do while ( (axp_tau .ge. axp_min) .or. (axp_t .ge. axp_min) ) nstep = nstep + 1 dtau = alpha * axp_tau / dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0) axp_tau_pre = axp_tau - dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)*dtau/2.d0 axp_tau = axp_tau - dadtau(axp_tau_pre,O_mat_0,O_vac_0,O_k_0)*dtau tau = tau - dtau dt = alpha * axp_t / dadt(axp_t,O_mat_0,O_vac_0,O_k_0) axp_t_pre = axp_t - dadt(axp_t,O_mat_0,O_vac_0,O_k_0)*dt/2.d0 axp_t = axp_t - dadt(axp_t_pre,O_mat_0,O_vac_0,O_k_0)*dt t = t - dt end do ! write(*,666)-t 666 format(' Age of the Universe (in unit of 1/H0)=',1pe10.3) nskip=nstep/ntable axp_t = 1.d0 t = 0.d0 axp_tau = 1.d0 tau = 0.d0 nstep = 0 nout=0 t_out(nout)=t tau_out(nout)=tau axp_out(nout)=axp_tau hexp_out(nout)=dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)/axp_tau do while ( (axp_tau .ge. axp_min) .or. (axp_t .ge. axp_min) ) nstep = nstep + 1 dtau = alpha * axp_tau / dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0) axp_tau_pre = axp_tau - dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)*dtau/2.d0 axp_tau = axp_tau - dadtau(axp_tau_pre,O_mat_0,O_vac_0,O_k_0)*dtau tau = tau - dtau dt = alpha * axp_t / dadt(axp_t,O_mat_0,O_vac_0,O_k_0) axp_t_pre = axp_t - dadt(axp_t,O_mat_0,O_vac_0,O_k_0)*dt/2.d0 axp_t = axp_t - dadt(axp_t_pre,O_mat_0,O_vac_0,O_k_0)*dt t = t - dt if(mod(nstep,nskip)==0)then nout=nout+1 t_out(nout)=t tau_out(nout)=tau axp_out(nout)=axp_tau hexp_out(nout)=dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)/axp_tau end if end do t_out(ntable)=t tau_out(ntable)=tau axp_out(ntable)=axp_tau hexp_out(ntable)=dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)/axp_tau end subroutine friedman function dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0) use amr_parameters real(kind=8)::dadtau,axp_tau,O_mat_0,O_vac_0,O_k_0 dadtau = axp_tau*axp_tau*axp_tau * & & ( O_mat_0 + & & O_vac_0 * axp_tau*axp_tau*axp_tau + & & O_k_0 * axp_tau ) dadtau = sqrt(dadtau) return end function dadtau function dadt(axp_t,O_mat_0,O_vac_0,O_k_0) use amr_parameters real(kind=8)::dadt,axp_t,O_mat_0,O_vac_0,O_k_0 dadt = (1.0D0/axp_t)* & & ( O_mat_0 + & & O_vac_0 * axp_t*axp_t*axp_t + & & O_k_0 * axp_t ) dadt = sqrt(dadt) return end function dadt ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/light_cone.f90 !======================================================================= !======================================================================= !======================================================================= !======================================================================= subroutine output_cone() use amr_commons use pm_commons implicit none #ifndef WITHOUTMPI #include 'mpif.h' #endif integer::info,dummy_io,info2 integer,parameter::tag=1118 character(len=5) :: istep_str ! CHANGED BY TTG (FEB 2017) ! character(len=100) :: conedir, conecmd, conefile character(len=256) :: conedir, conecmd, conefile integer::ilun,nx_loc,ipout,npout,npart_out ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar real(kind=8),dimension(1:3,1:nvector),save::pos,vel real(kind=8),dimension(:,:),allocatable::posout,velout real(kind=8),dimension(:),allocatable::zout real(kind=8),dimension(:,:),allocatable::tmparr real(sp),dimension(:,:),allocatable::xp_out,vp_out real(sp),dimension(:),allocatable::zp_out real(kind=8) :: z1,z2,om0in,omLin,hubin,Lbox real(kind=8) :: observer(3),thetay,thetaz,theta,phi integer::igrid,jgrid,ipart,jpart,idim,icpu,ilevel integer::i,ig,ip,npart1 integer::nalloc1,nalloc2 integer,dimension(1:nvector),save::ind_part logical::opened opened=.false. if(nstep_coarse.lt.2)return z2=1./aexp_old-1. z1=1./aexp-1. if(z2.gt.zmax_cone)return if(abs(z2-z1)<1d-6)return theta=25. phi=17. thetay=thetay_cone thetaz=thetaz_cone om0in=omega_m omLin=omega_l hubin=h0/100. Lbox=boxlen_ini/hubin observer=(/Lbox/2.0,Lbox/2.0,Lbox/2.0/) ilun=3*ncpu+myid+10 ! Determine the filename, dir, etc if(myid==1)write(*,*)'Computing and dumping lightcone' call title(nstep_coarse, istep_str) ! CHANGED BY TTG (FEB 2017) ! conedir = 'cone_' // trim(istep_str) // '/' conedir = TRIM(output_dir)//'cone_' // trim(istep_str) // '/' conecmd = 'mkdir -p ' // trim(conedir) if(.not.withoutmkdir) then if (myid==1) call system(conecmd) endif #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD, info) #endif conefile = trim(conedir)//'cone_'//trim(istep_str)//'.out' call title(myid,nchar) fileloc=TRIM(conefile)//TRIM(nchar) npart_out=0 ipout=0 npout=0 ! Pre-allocate arrays for particle selection ----- nalloc1=nvector allocate(posout(1:3, 1:nalloc1)) allocate(velout(1:3, 1:nalloc1)) allocate(zout(1:nalloc1)) nalloc2=nvector+nstride allocate(xp_out(1:nalloc2,1:3)) allocate(vp_out(1:nalloc2,1:3)) allocate(zp_out(1:nalloc2)) allocate(tmparr(1:3, 1:nalloc2)) ! ------------------------------------------------ ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZECONE>0) then if (mod(myid-1,IOGROUPSIZECONE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif ilevel=levelmin ! Loop over cpus do icpu=1,ncpu ! Loop over grids igrid=headl(icpu,ilevel) ip=0 do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid if(npart1>0)then ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ip=ip+1 ind_part(ip)=ipart if(ip==nvector)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ip pos(idim,i)=xp(ind_part(i),idim)*Lbox vel(idim,i)=vp(ind_part(i),idim) end do end do !=========================================================================== ! Count selection particles call perform_my_selection(.true.,z1,z2, & & om0in,omLin,hubin,Lbox, & & observer,thetay,thetaz,theta,phi, & & pos,vel,ip, & & posout,velout,zout,npout,.false.) call extend_arrays_if_needed() ! Perform actual selection call perform_my_selection(.false.,z1,z2, & & om0in,omLin,hubin,Lbox, & & observer,thetay,thetaz,theta,phi, & & pos,vel,ip, & & posout,velout,zout,npout,.false.) !=========================================================================== if(npout>0)then do idim=1,ndim do i=1,npout xp_out(ipout+i,idim)=posout(idim,i)/Lbox vp_out(ipout+i,idim)=velout(idim,i) end do end do do i=1,npout zp_out(ipout+i)=zout(i) end do ipout=ipout+npout npart_out=npart_out+npout endif ip=0 end if if(ipout>=nstride)then if(.not.opened) then open(ilun,file=TRIM(fileloc),form='unformatted') rewind(ilun) write(ilun)ncpu write(ilun)nstride write(ilun)npart opened=.true. endif do idim=1,ndim write(ilun)xp_out(1:nstride,idim) write(ilun)vp_out(1:nstride,idim) end do write(ilun)zp_out(1:nstride) do idim=1,ndim do i=1,ipout-nstride xp_out(i,idim)=xp_out(i+nstride,idim) vp_out(i,idim)=vp_out(i+nstride,idim) end do end do do i=1,ipout-nstride zp_out(i)=zp_out(i+nstride) end do ipout=ipout-nstride endif ipart=nextp(ipart) ! Go to next particle end do ! End loop over particles end if igrid=next(igrid) ! Go to next grid end do ! End loop over grids if(ip>0)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ip pos(idim,i)=xp(ind_part(i),idim)*Lbox vel(idim,i)=vp(ind_part(i),idim) end do end do !=========================================================================== ! Count selection particles call perform_my_selection(.true.,z1,z2, & & om0in,omLin,hubin,Lbox, & & observer,thetay,thetaz,theta,phi, & & pos,vel,ip, & & posout,velout,zout,npout,.false.) call extend_arrays_if_needed() ! Perform actual selection call perform_my_selection(.false.,z1,z2, & & om0in,omLin,hubin,Lbox, & & observer,thetay,thetaz,theta,phi, & & pos,vel,ip, & & posout,velout,zout,npout,.false.) !=========================================================================== if(npout>0)then do idim=1,ndim do i=1,npout xp_out(ipout+i,idim)=posout(idim,i)/Lbox vp_out(ipout+i,idim)=velout(idim,i) end do end do do i=1,npout zp_out(ipout+i)=zout(i) end do ipout=ipout+npout npart_out=npart_out+npout endif endif if(ipout>=nstride)then if(.not.opened) then open(ilun,file=TRIM(fileloc),form='unformatted') rewind(ilun) write(ilun)ncpu write(ilun)nstride write(ilun)npart opened=.true. endif do idim=1,ndim write(ilun)xp_out(1:nstride,idim) write(ilun)vp_out(1:nstride,idim) end do write(ilun)zp_out(1:nstride) do idim=1,ndim do i=1,ipout-nstride xp_out(i,idim)=xp_out(i+nstride,idim) vp_out(i,idim)=vp_out(i+nstride,idim) end do end do do i=1,ipout-nstride zp_out(i)=zp_out(i+nstride) end do ipout=ipout-nstride endif end do ! End loop over cpus if(ipout>0)then if(.not.opened) then open(ilun,file=TRIM(fileloc),form='unformatted') rewind(ilun) write(ilun)ncpu write(ilun)nstride write(ilun)npart opened=.true. endif do idim=1,ndim write(ilun)xp_out(1:ipout,idim) write(ilun)vp_out(1:ipout,idim) end do write(ilun)zp_out(1:ipout) endif if(opened)close(ilun) if (verbose)write(*,*)'cone output=',myid,npart_out if(npart_out>0) then open(ilun,file=TRIM(fileloc)//'.txt',form='formatted') rewind(ilun) write(ilun,*) ncpu write(ilun,*) nstride write(ilun,*) npart_out write(ilun,*) aexp_old write(ilun,*) aexp close(ilun) endif ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZECONE>0) then if(mod(myid,IOGROUPSIZECONE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif if((opened.and.(npart_out==0)).or.((.not.opened).and.(npart_out>0))) then write(*,*)'Error in output_cone' write(*,*)'npart_out=',npart_out,'opened=',opened stop endif contains ! Extends (deallocates and reallocates) the arrays ! posout, velout, zout, xp_out, vp_out and zp_out ! after npout has been updated, so they can hold enough particles ! ! Reallocation is done in chunks of size alloc_chunk_size, to avoid ! reallocating too frequently. subroutine extend_arrays_if_needed() ! Allocation chunk size integer, parameter :: alloc_chunk_size = 100 integer :: new_nalloc1, new_nalloc2 integer :: nchunks1, nchunks2 if (nalloc1 >= npout .and. nalloc2 >= npout+nstride) return ! Compute new array sizes nchunks1 = npout / alloc_chunk_size if (mod(npout, alloc_chunk_size) > 0) nchunks1=nchunks1+1 nchunks2 = (npout+nstride) / alloc_chunk_size if (mod(npout+nstride, alloc_chunk_size) > 0) nchunks2=nchunks2+1 new_nalloc1 = nchunks1 * alloc_chunk_size new_nalloc2 = nchunks2 * alloc_chunk_size ! Resize temp array deallocate(tmparr) allocate(tmparr(1:3,1:max(new_nalloc1,new_nalloc2))) ! Resize xp_out, vp_out, zp_out do idim=1,ndim tmparr(idim,1:nalloc2)=xp_out(1:nalloc2,idim) end do deallocate(xp_out); allocate(xp_out(1:new_nalloc2,1:3)) do idim=1,ndim xp_out(1:nalloc2,idim)=tmparr(idim,1:nalloc2) end do do idim=1,ndim tmparr(idim,1:nalloc2)=vp_out(1:nalloc2,idim) end do deallocate(vp_out); allocate(vp_out(1:new_nalloc2,1:3)) do idim=1,ndim vp_out(1:nalloc2,idim)=tmparr(idim,1:nalloc2) end do tmparr(1,1:nalloc2)=zp_out(1:nalloc2) deallocate(zp_out); allocate(zp_out(1:new_nalloc2)) zp_out(1:nalloc2)=tmparr(1,1:nalloc2) nalloc2 = new_nalloc2 ! Resize posout, velout, zout do idim=1,ndim tmparr(idim,1:nalloc1)=posout(idim,1:nalloc1) deallocate(posout); allocate(posout(1:3,1:new_nalloc1)) end do do idim=1,ndim posout(idim,1:nalloc1)=tmparr(idim,1:nalloc1) end do do idim=1,ndim tmparr(idim,1:nalloc1)=velout(idim,1:nalloc1) end do deallocate(velout); allocate(velout(1:3,1:new_nalloc1)) do idim=1,ndim velout(idim,1:nalloc1)=tmparr(idim,1:nalloc1) end do tmparr(1,1:nalloc1)=zout(1:nalloc1) deallocate(zout); allocate(zout(1:new_nalloc1)) zout(1:nalloc1)=tmparr(1,1:nalloc1) nalloc1 = new_nalloc1 end subroutine extend_arrays_if_needed end subroutine output_cone subroutine perform_my_selection(justcount,z1,z2, & & om0in,omLin,hubin,Lbox, & & observer,thetay,thetaz,theta,phi, & & pos,vel,npart, & & posout,velout,zout,npartout,verbose) !=========================================================================== ! All the quantities below are real*8 except ! juscount : logical ! npart,npartout : integer*4 ! ! juscount : .true. to just count the particles to be selected. Needed ! to allocate appropriately the arrays posout,velout and zout ! The parameter npartout becomes then an output given the number ! of particles selected. ! .false. to perform the actual selection: npartout is an input ! then posout, velout, zout are appropriate outputs. ! ! z1,z2 : the lightcone part of interest is in between z1 and z2, ! with z1 < z2. If we consider a redshift z(t) where all the ! particles are synchrone, and if coarse timestep is ! a fixed dt, it is most appropriate to choose z1 and z2 such ! that z1=z(t+dt/2) and z2=z(t-dt/2) to have best accuracy. ! ! om0in : the value of the cosmological parameter omega0 (typically 0.3) ! ! omLin : the value of the cosmological constant lambda (typically 0.7) ! ! hubin : the value of H0/100, where H0 is the present Hubble constant ! in km/s/Mpc (typically 0.7) ! ! Lbox : the comoving size of the simulation box in Mpc (NOT in Mpc/h) ! ! observer(3) : the observer position in the box in Mpc, assuming that ! coordinates are in [0,Lbox[ ! ! thetay : half the opening angle in degrees of the lightcone along y direction ! (it should be obviously smaller than 90 degrees to avoid catastrophic ! behavior). The lightcone is assume to be aligned with x axis (after ! appropriates rotations given by angles theta and phi) ! ! thetaz : half the opening angle in degrees of the lightcone along z direction ! Given thetay and thetaz, the area of the survey is thus 4.thetay.thetaz ! ! theta, phi : 2 angles in degrees defining a rotation to avoid alignement of ! the lightcone with the major axes of the simulation box. ! Example : theta=21, phi=17. ! ! pos(3,npart) : comoving positions of the input particles in Mpc, assumed to be ! in [0,Lbox[. ! ! vel(3,npart) : velocities of the input particles (in any unit, it does not ! matter) ! ! npart : number of input particles to be treated ! ! posout(3,npartout) : output comoving positions of selected particles in Mpc. ! ! velout(3,npartout) : output velocities of selected particles ! ! zout(npartout) : output redshift of selected particles ! ! npartout : number of selected particles. To be computed appropriately, ! this routine must be called with juscount=.true., which will give ! npartout as an output. Then this routine must be called with ! juscount=.false. with the correct value of npartout, after having ! allocated correctly arrays posout,velout,zout. !=========================================================================== use amr_parameters, ONLY: nvector implicit none logical :: justcount,verbose integer :: npart,npartout real(kind=8) :: z1,z2,om0in,omLin,hubin,Lbox real(kind=8) :: Omega0,OmegaL,OmegaR,coverH0 real(kind=8) :: observer(3),thetay,thetaz,theta,phi real(kind=8) :: pos(1:3,1:nvector),vel(1:3,1:nvector) real(kind=8) :: posout(3,npartout),velout(3,npartout),zout(npartout) real(kind=8) :: coord_distance real(kind=8) :: thetarad,phirad,thetayrad,thetazrad,tanybound,tanzbound real(kind=8) :: rot(3,3),rotm1(3,3),dist1,dist2,cosy,cosz real(kind=8) :: xcoordfr,ycoordfr,zcoordfr,xcoord,ycoord,zcoord real(kind=8) :: tany,tanz,dist,vxfr,vyfr,vzfr,dxtest1,dxtest2,facnorm real(kind=8) :: pi real(kind=8) :: small=1d-5 integer :: nrepxm,nrepxp,nrepym,nrepyp,nrepzm,nrepzp integer :: i,j,k,np,npartcount if (verbose) write(*,*) 'Entering perform_my_selection' ! pi=3.14159 pi=acos(-1.0d0) ! Initialize cosmological parameters call init_cosmo_cone(om0in,omLin,hubin,Omega0,OmegaL,OmegaR,coverH0) ! Convert angles in radians thetarad=theta*pi/180.0d0 phirad=phi*pi/180.0d0 ! Compute the rotation matrix and its inverse to be in the appropriate frame call compute_rotation_matrix(thetarad,phirad,rot,rotm1) ! Compute comoving distance of the photon planes from the observer ! dist1,dist2=integral of c.dt/a between zero and z1,z2 dist1=coord_distance(z1,Omega0,OmegaL,OmegaR,coverH0) dist2=coord_distance(z2,Omega0,OmegaL,OmegaR,coverH0) ! Convert angles in radians thetayrad=thetay*pi/180.0d0 thetazrad=thetaz*pi/180.0d0 ! Compute the set of replica to be considered call compute_replica(thetayrad,thetazrad,dist1,dist2,observer,Lbox,rot, & & nrepxm,nrepxp,nrepym,nrepyp,nrepzm,nrepzp) facnorm=1.0d0/(dist2-dist1) tanybound=tan(thetayrad) tanzbound=tan(thetazrad) npartcount=0 ! loop on all the replica of potential interest do k=nrepzm,nrepzp,1 do j=nrepym,nrepyp,1 do i=nrepxm,nrepxp,1 do np=1,npart xcoordfr=pos(1,np)+Lbox*dble(i)-observer(1) ycoordfr=pos(2,np)+Lbox*dble(j)-observer(2) zcoordfr=pos(3,np)+Lbox*dble(k)-observer(3) ! Rotation to get in the framework of the photon plane xcoord=xcoordfr*rotm1(1,1)+ & & ycoordfr*rotm1(2,1)+ & & zcoordfr*rotm1(3,1) ycoord=xcoordfr*rotm1(1,2)+ & & ycoordfr*rotm1(2,2)+ & & zcoordfr*rotm1(3,2) zcoord=xcoordfr*rotm1(1,3)+ & & ycoordfr*rotm1(2,3)+ & & zcoordfr*rotm1(3,3) if (xcoord > small) then ! To avoid divergences near the origin tany=abs(ycoord/xcoord) tanz=abs(zcoord/xcoord) dist=sqrt(xcoord**2+ycoord**2+zcoord**2) if (tany <= tanybound .and. tanz <= tanzbound & & .and. dist > dist1 .and. dist <= dist2) then ! This particle is good, we can add it to the list npartcount=npartcount+1 if (.not. justcount) then posout(1,npartcount)=xcoord posout(2,npartcount)=ycoord posout(3,npartcount)=zcoord ! Velocities are rotated vxfr=vel(1,np) vyfr=vel(2,np) vzfr=vel(3,np) velout(1,npartcount)=vxfr*rotm1(1,1)+ & & vyfr*rotm1(2,1)+ & & vzfr*rotm1(3,1) velout(2,npartcount)=vxfr*rotm1(1,2)+ & & vyfr*rotm1(2,2)+ & & vzfr*rotm1(3,2) velout(3,npartcount)=vxfr*rotm1(1,3)+ & & vyfr*rotm1(2,3)+ & & vzfr*rotm1(3,3) ! Compute the redshift of the particle using linear ! interpolation dxtest1=dist-dist1 dxtest2=dist2-dist zout(npartcount)=(dxtest1*z2+dxtest2*z1)*facnorm endif endif endif enddo enddo enddo enddo npartout=npartcount if (verbose) write(*,*) 'End of perform_my_selection' end subroutine perform_my_selection !=========================================================================== subroutine compute_rotation_matrix(thetashiftrad,phishiftrad,rot,rotm1) !=========================================================================== ! Rotations matrixes used to perform the calculations. ! theta and phi are expressed in radians !=========================================================================== implicit none real(kind=8) :: thetashiftrad,phishiftrad real(kind=8) :: rot(3,3),rotm1(3,3) integer :: i,j rot(1,1) = cos(thetashiftrad)*cos(phishiftrad) rot(1,2) = cos(thetashiftrad)*sin(phishiftrad) rot(1,3) = -sin(thetashiftrad) rot(2,1) = -sin(phishiftrad) rot(2,2) = cos(phishiftrad) rot(2,3) = 0.0d0 rot(3,1) = cos(phishiftrad)*sin(thetashiftrad) rot(3,2) = sin(phishiftrad)*sin(thetashiftrad) rot(3,3) = cos(thetashiftrad) do j=1,3 do i=1,3 rotm1(i,j)=rot(j,i) enddo enddo end subroutine compute_rotation_matrix !=========================================================================== subroutine compute_minimum_polygon(x1,x2,thetayrad,thetazrad,sl) !=========================================================================== ! A slice of photons between redshifts z1 and z2 corresponding to coordinates ! x1 and x2 at its center and of opening angles thetay and thetaz is considered. ! We compute the coordinates of the eights points of the mimimum (simple) ! polygon containing it. !=========================================================================== implicit none real(kind=8) :: x1,x2,thetayrad,thetazrad,sl(3,8) real(kind=8) :: r(3),axis(3) ! Part of the polygon close to the observer sl(1,1:4)=x1/sqrt(1.0d0+tan(thetayrad)**2+tan(thetazrad)**2) sl(2,1)=-sl(1,1)*tan(thetayrad) sl(3,1)=-sl(1,1)*tan(thetazrad) sl(2,2)= sl(1,1)*tan(thetayrad) sl(3,2)=-sl(1,1)*tan(thetazrad) sl(2,3)=-sl(1,1)*tan(thetayrad) sl(3,3)= sl(1,1)*tan(thetazrad) sl(2,4)= sl(1,1)*tan(thetayrad) sl(3,4)= sl(1,1)*tan(thetazrad) ! Part of the polygon far away from the observer sl(1,5:8)=x2 sl(2,5)=-x2*tan(thetayrad) sl(3,5)=-x2*tan(thetazrad) sl(2,6)= x2*tan(thetayrad) sl(3,6)=-x2*tan(thetazrad) sl(2,7)=-x2*tan(thetayrad) sl(3,7)= x2*tan(thetazrad) sl(2,8)= x2*tan(thetayrad) sl(3,8)= x2*tan(thetazrad) end subroutine compute_minimum_polygon !=========================================================================== subroutine compute_replica(thetayrad,thetazrad,dist1,dist2,observer,Lbox,rot, & & nrepxm,nrepxp,nrepym,nrepyp,nrepzm,nrepzp) !=========================================================================== ! 2*theta1 and 2*theta2 are the opening angles of the lightcone in degrees. ! The observer position is expressed in comoving Mpc, as well as the simulation ! box size Lbox. Furthermore, the positions of particles inside the simulation ! are supposed to be in [0,Lbox[. ! z1 and z2 are the redshifts of the successive photon planes, z1 < z2 !=========================================================================== implicit none real(kind=8) :: thetayrad,thetazrad,observer(3),Lbox,rot(3,3),dist1,dist2 integer :: nrepxm,nrepxp,nrepym,nrepyp,nrepzm,nrepzp integer :: myint real(kind=8) :: sl(3,8),slfr(3) real(kind=8) :: xplmin,xplmax,yplmin,yplmax,zplmin,zplmax integer :: i,j ! Compute the minimum polygon containing the 2 plans of photons (which ! are slightly curved) call compute_minimum_polygon(dist1,dist2,thetayrad,thetazrad,sl) ! Rotate the minimum polygon in the reference frame of the simulation do j=1,8 do i=1,3 slfr(i)=sl(1,j)*rot(1,i) & & +sl(2,j)*rot(2,i) & & +sl(3,j)*rot(3,i) enddo if (j.eq.1) then xplmin=slfr(1) xplmax=xplmin yplmin=slfr(2) yplmax=yplmin zplmin=slfr(3) zplmax=zplmin else xplmin=min(xplmin,slfr(1)) xplmax=max(xplmax,slfr(1)) yplmin=min(yplmin,slfr(2)) yplmax=max(yplmax,slfr(2)) zplmin=min(zplmin,slfr(3)) zplmax=max(zplmax,slfr(3)) endif enddo ! Uses the fact that a cube will contain the minimum polygon if and only ! if all its edges are contained in the cube to compute the relevant ! replica nrepxm=myint((xplmin+observer(1))/Lbox) nrepxp=myint((xplmax+observer(1))/Lbox) nrepym=myint((yplmin+observer(2))/Lbox) nrepyp=myint((yplmax+observer(2))/Lbox) nrepzm=myint((zplmin+observer(3))/Lbox) nrepzp=myint((zplmax+observer(3))/Lbox) end subroutine compute_replica !=================== !cone cosmo routines !=================== !=========================================================================== subroutine init_cosmo_cone(om0in,omLin,hubin,Omega0,OmegaL,OmegaR,coverH0) !=========================================================================== ! om0in : the value of omega0 ! omLin : the value of Lambda ! We MUST have omega0+Lambda=1.0d0 ! hubin : the value of H0/100 where H0 is the present Hubble constant ! in km/s/Mpc !=========================================================================== implicit none real(kind=8) :: om0in,omLin,hubin real(kind=8) :: Omega0,OmegaL,OmegaR,coverH0 real(kind=8) :: verysmall=1d-6 omega0=om0in omegaL=omLin omegaR=1.0d0-omega0-omegaL if (abs(omegaR) > verysmall) then write(*,*) 'ERROR in propagate_photons, init_cosmo.' write(*,*) 'This routine works only for flat universes, omega0+Lambda=1.' STOP endif coverH0=299792.5d0/(100.0d0*hubin) end subroutine init_cosmo_cone !=========================================================================== function coord_distance(zz,Omega0,OmegaL,OmegaR,coverH0) !=========================================================================== implicit none real(kind=8) :: z,res,coord_distance,zz real(kind=8) :: Omega0,OmegaL,OmegaR,coverH0 z=abs(zz) call qromb(0.d0,z,res,omega0,omegaL,OmegaR) coord_distance=coverH0*res if (zz.lt.0) coord_distance=-coord_distance end function coord_distance !=========================================================================== function funcE(z,Omega0,OmegaL,OmegaR) !=========================================================================== implicit none real(kind=8) :: funcE,z,HsurH0 real(kind=8) :: omega0,omegaL,OmegaR funcE=1.d0/HsurH0(z,Omega0,OmegaL,OmegaR) end function funcE !=========================================================================== function HsurH0(z,omega0,omegaL,OmegaR) !=========================================================================== implicit none real(kind=8) :: z,omega0,omegaL,OmegaR,HsurH0 HsurH0=sqrt(Omega0*(1.d0+z)**3+OmegaR*(1.d0+z)**2+OmegaL) end function HsurH0 !=========================================================================== SUBROUTINE qromb(a,b,ss,omega0,omegaL,OmegaR) !=========================================================================== implicit none INTEGER :: JMAX,JMAXP,K,KM REAL(kind=8) :: a,b,ss,EPS,omega0,omegaL,OmegaR PARAMETER (EPS=1.d-6, JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1) ! USES polint,trapzd INTEGER :: j REAL(kind=8) :: dss,h(JMAXP),s(JMAXP) h(1)=1. do j=1,JMAX call trapzd(a,b,s(j),j,omega0,omegaL,OmegaR) if (j.ge.K) then call polint(h(j-KM),s(j-KM),K,0.d0,ss,dss) if (abs(dss).le.EPS*abs(ss)) return endif s(j+1)=s(j) h(j+1)=0.25*h(j) enddo print *, 'too many steps in qromb' END SUBROUTINE qromb !=========================================================================== SUBROUTINE polint(xa,ya,n,x,y,dy) !=========================================================================== implicit none INTEGER :: n,NMAX REAL(kind=8) :: dy,x,y,xa(n),ya(n) PARAMETER (NMAX=10) INTEGER :: i,m,ns REAL(kind=8) ::den,dif,dift,ho,hp,w,c(NMAX),d(NMAX) ns=1 dif=abs(x-xa(1)) do i=1,n dift=abs(x-xa(i)) if (dift.lt.dif) then ns=i dif=dift endif c(i)=ya(i) d(i)=ya(i) enddo y=ya(ns) ns=ns-1 do m=1,n-1 do i=1,n-m ho=xa(i)-x hp=xa(i+m)-x w=c(i+1)-d(i) den=ho-hp if(den.eq.0.) print *, 'failure in polint' den=w/den d(i)=hp*den c(i)=ho*den enddo if (2*ns.lt.n-m)then dy=c(ns+1) else dy=d(ns) ns=ns-1 endif y=y+dy enddo return END SUBROUTINE polint !=========================================================================== SUBROUTINE trapzd(a,b,s,n,omega0,omegaL,OmegaR) !=========================================================================== implicit none INTEGER :: n REAL(kind=8) :: a,b,s,funcE,omega0,omegaL,OmegaR INTEGER :: it,j REAL(kind=8) :: del,sum,tnm,x if (n.eq.1) then s=0.5*(b-a)*(funcE(a,omega0,omegaL,OmegaR)+funcE(b,omega0,omegaL,OmegaR)) else it=2**(n-2) tnm=it del=(b-a)/tnm x=a+0.5*del sum=0. do j=1,it sum=sum+funcE(x,omega0,omegaL,OmegaR) x=x+del enddo s=0.5*(s+(b-a)*sum/tnm) endif return END SUBROUTINE trapzd !======================================================================= function myint(x) !======================================================================= ! The REAL int function !======================================================================= real(kind=8) :: x integer :: myint if (x >= 0.0d0) then myint=int(x) else myint=int(x)-1 endif end function myint ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/movie.f90 !======================================================================= !======================================================================= !======================================================================= !======================================================================= subroutine output_frame() use amr_commons use pm_commons use hydro_commons #ifdef RT use rt_parameters use rt_hydro_commons #endif implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::dummy_io,info,ierr,iframe integer,parameter::tag=100 character(len=5) :: istep_str ! CHANGED BY TTG (FEB 2017) ! character(len=100) :: moviedir, moviecmd, infofile, sinkfile character(len=256) :: moviedir, moviecmd, infofile, sinkfile #ifdef SOLVERmhd character(len=100),dimension(0:NVAR+6) :: moviefiles #else character(len=100),dimension(0:NVAR+2) :: moviefiles #endif integer::icell,ncache,iskip,irad,ngrid,nlevelmax_frame integer::nframes,rt_nframes,imap,ipart_start integer::ilun,nx_loc,ipout,npout,npart_out,ind,ix,iy,iz integer::imin,imax,jmin,jmax,ii,jj,kk,ll ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar,dummy real(dp)::scale,scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v real(dp)::xcen,ycen,zcen,delx,dely,delz real(dp)::xtmp,ytmp,ztmp,smooth,theta_cam,phi_cam,alpha,beta,smooth_theta,fov_camera,dist_cam real(dp)::xleft_frame,xright_frame,yleft_frame,yright_frame,zleft_frame,zright_frame,rr real(dp)::xleft,xright,yleft,yright,zleft,zright,xcentre,ycentre,zcentre real(dp)::xxleft,xxright,yyleft,yyright,zzleft,zzright,xxcentre,yycentre,zzcentre real(dp)::xpf,ypf,zpf real(dp)::dx_frame,dy_frame,dx,dx_loc,dx_min,pers_corr real(dp)::dx_cell,dy_cell,dz_cell,dvol,dx_proj,weight real(kind=8)::cell_value integer ,dimension(1:nvector)::ind_grid,ind_cell logical,dimension(1:nvector)::ok real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:twotondim,1:3)::xc real(dp),dimension(1:nvector,1:ndim)::xx real(dp),dimension(1:nvector,1:ndim)::xx2 real(kind=8),dimension(:,:,:),allocatable::data_frame real(kind=8),dimension(:,:),allocatable::weights real(kind=8),dimension(:),allocatable::data_single,data_single_all real(kind=8) :: z1,z2,om0in,omLin,hubin,Lbox real(kind=8) :: observer(3),thetay,thetaz,theta,phi,temp,e,uvar real(kind=8) :: pi=3.14159265359 real(dp),dimension(8)::xcube,ycube,zcube integer::igrid,jgrid,ipart,jpart,idim,icpu,ilevel,next_part,icube,iline integer::i,j,ig,ip,npart1 integer::nalloc1,nalloc2 integer::proj_ind,l,nh_temp,nw_temp real(dp)::minx,maxx,miny,maxy,minz,maxz,xpc,ypc,zpc,d1,d2,d3,d4,l1,l2,l3,l4 integer,dimension(1:nvector),save::ind_part,ind_grid_part logical::opened,cube_face character(len=1)::temp_string integer,dimension(6,8)::lind = reshape((/1, 2, 3, 4, 1, 3, 2, 4, & 5, 6, 7, 8, 5, 7, 6, 8, & 1, 5, 2, 6, 1, 2, 5, 6, & 3, 7, 4, 8, 3, 4, 7, 8, & 1, 3, 5, 7, 1, 5, 3, 7, & 2, 4, 6, 8, 2, 6, 4, 8 /) & ,shape(lind),order=(/2,1/)) #ifdef RT character(len=100),dimension(1:NGROUPS) :: rt_moviefiles real(kind=8),dimension(:,:,:),allocatable::rt_data_frame #endif nh_temp = nh_frame nw_temp = nw_frame ! Only one projection available in 2D if((ndim.eq.2).and.(trim(proj_axis).ne.'z')) proj_axis = 'z' do proj_ind=1,LEN(trim(proj_axis)) opened=.false. #if NDIM > 1 if(imov<1)imov=1 if(imov>imovout)return ! Determine the filename, dir, etc if(myid==1)write(*,*)'Computing and dumping movie frame' call title(imov, istep_str) write(temp_string,'(I1)') proj_ind ! CHANGED BY TTG (FEB 2017) ! moviedir = 'movie'//trim(temp_string)//'/' moviedir = TRIM(output_dir)//'movie'//trim(temp_string)//'/' moviecmd = 'mkdir -p '//trim(moviedir) if(.not.withoutmkdir) then #ifdef NOSYSTEM if(myid==1)call PXFMKDIR(TRIM(moviedir),LEN(TRIM(moviedir)),O'755',info) #else if(myid==1)then !CHANGED BY TTG (FEB 2017): gfortran v < 4.6 does not know about EXECUTE_COMMAND_LINE ! call EXECUTE_COMMAND_LINE(moviecmd,exitstat=ierr,wait=.true.) ! call EXECUTE_COMMAND_LINE(moviecmd,ierr,.true.) call SYSTEM(moviecmd,ierr) endif #ifndef WITHOUTMPI call MPI_BCAST(ierr,1,MPI_INTEGER,0,MPI_COMM_WORLD,info) if(ierr.ne.0 .and. ierr.ne.127)then write(*,*) 'Error - Could not create ',trim(moviedir) call MPI_ABORT(MPI_COMM_WORLD,1,info) stop endif #endif #endif endif infofile = trim(moviedir)//'info_'//trim(istep_str)//'.txt' if(myid==1)call output_info(infofile) #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) #endif moviefiles(0) = trim(moviedir)//'temp_'//trim(istep_str)//'.map' moviefiles(1) = trim(moviedir)//'dens_'//trim(istep_str)//'.map' moviefiles(2) = trim(moviedir)//'vx_'//trim(istep_str)//'.map' moviefiles(3) = trim(moviedir)//'vy_'//trim(istep_str)//'.map' #if NDIM>2 moviefiles(4) = trim(moviedir)//'vz_'//trim(istep_str)//'.map' #endif #if NDIM==2 moviefiles(4) = trim(moviedir)//'pres_'//trim(istep_str)//'.map' #endif #if NDIM>2 moviefiles(5) = trim(moviedir)//'pres_'//trim(istep_str)//'.map' #endif #if NVAR>5 do ll=6,NVAR write(dummy,'(I3.1)') ll moviefiles(ll) = trim(moviedir)//'var'//trim(adjustl(dummy))//'_'//trim(istep_str)//'.map' end do #endif #ifdef SOLVERmhd moviefiles(6) = trim(moviedir)//'bxl_'//trim(istep_str)//'.map' moviefiles(7) = trim(moviedir)//'byl_'//trim(istep_str)//'.map' moviefiles(8) = trim(moviedir)//'bzl_'//trim(istep_str)//'.map' moviefiles(NVAR+1) = trim(moviedir)//'bxr_'//trim(istep_str)//'.map' moviefiles(NVAR+2) = trim(moviedir)//'byr_'//trim(istep_str)//'.map' moviefiles(NVAR+3) = trim(moviedir)//'bzr_'//trim(istep_str)//'.map' moviefiles(NVAR+4) = trim(moviedir)//'pmag_'//trim(istep_str)//'.map' moviefiles(NVAR+5) = trim(moviedir)//'dm_'//trim(istep_str)//'.map' moviefiles(NVAR+6) = trim(moviedir)//'stars_'//trim(istep_str)//'.map' #else moviefiles(NVAR+1) = trim(moviedir)//'dm_'//trim(istep_str)//'.map' moviefiles(NVAR+2) = trim(moviedir)//'stars_'//trim(istep_str)//'.map' #endif #ifdef RT ! Can generate mass weighted averages of cN_i for each group i if(rt) then do ll=1,NGROUPS write(dummy,'(I3.1)') ll rt_moviefiles(ll) = trim(moviedir)//'Fp'//trim(adjustl(dummy))//'_'//trim(istep_str)//'.map' end do endif #endif ! sink filename if(sink)then sinkfile = trim(moviedir)//'sink_'//trim(istep_str)//'.txt' if(myid==1.and.proj_ind==1) call output_sink_csv(sinkfile) endif if(levelmax_frame==0)then nlevelmax_frame=nlevelmax else if (levelmax_frame.gt.nlevelmax)then nlevelmax_frame=nlevelmax else nlevelmax_frame=levelmax_frame endif nframes = 0 #ifdef SOLVERmhd do kk=0,NVAR+6 #else do kk=0,NVAR+2 #endif if(movie_vars(kk).eq.1) nframes = nframes+1 enddo rt_nframes = 0 #ifdef RT if(rt)then do kk=1,NGROUPS if(rt_movie_vars(kk).eq.1) rt_nframes = rt_nframes+1 enddo endif #endif if(nframes+rt_nframes==0) continue ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! Local constants nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) if(xcentre_frame(proj_ind*4-3).eq.0d0) xcentre_frame(proj_ind*4-3) = boxlen/2d0 if(ycentre_frame(proj_ind*4-3).eq.0d0) ycentre_frame(proj_ind*4-3) = boxlen/2d0 if(zcentre_frame(proj_ind*4-3).eq.0d0) zcentre_frame(proj_ind*4-3) = boxlen/2d0 ! Compute frame boundaries if(proj_axis(proj_ind:proj_ind).eq.'x')then xcen=ycentre_frame(proj_ind*4-3)+ycentre_frame(proj_ind*4-2)*aexp+ycentre_frame(proj_ind*4-1)*aexp**2+ycentre_frame(proj_ind*4)*aexp**3 ycen=zcentre_frame(proj_ind*4-3)+zcentre_frame(proj_ind*4-2)*aexp+zcentre_frame(proj_ind*4-1)*aexp**2+zcentre_frame(proj_ind*4)*aexp**3 zcen=xcentre_frame(proj_ind*4-3)+xcentre_frame(proj_ind*4-2)*aexp+xcentre_frame(proj_ind*4-1)*aexp**2+xcentre_frame(proj_ind*4)*aexp**3 elseif(proj_axis(proj_ind:proj_ind).eq.'y')then xcen=xcentre_frame(proj_ind*4-3)+xcentre_frame(proj_ind*4-2)*aexp+xcentre_frame(proj_ind*4-1)*aexp**2+xcentre_frame(proj_ind*4)*aexp**3 ycen=zcentre_frame(proj_ind*4-3)+zcentre_frame(proj_ind*4-2)*aexp+zcentre_frame(proj_ind*4-1)*aexp**2+zcentre_frame(proj_ind*4)*aexp**3 zcen=ycentre_frame(proj_ind*4-3)+ycentre_frame(proj_ind*4-2)*aexp+ycentre_frame(proj_ind*4-1)*aexp**2+ycentre_frame(proj_ind*4)*aexp**3 else xcen=xcentre_frame(proj_ind*4-3)+xcentre_frame(proj_ind*4-2)*aexp+xcentre_frame(proj_ind*4-1)*aexp**2+xcentre_frame(proj_ind*4)*aexp**3 ycen=ycentre_frame(proj_ind*4-3)+ycentre_frame(proj_ind*4-2)*aexp+ycentre_frame(proj_ind*4-1)*aexp**2+ycentre_frame(proj_ind*4)*aexp**3 zcen=zcentre_frame(proj_ind*4-3)+zcentre_frame(proj_ind*4-2)*aexp+zcentre_frame(proj_ind*4-1)*aexp**2+zcentre_frame(proj_ind*4)*aexp**3 endif if(deltax_frame(proj_ind*2-1).eq.0d0 .and. deltay_frame(proj_ind*2-1).gt.0d0)then deltax_frame(proj_ind*2-1)=deltay_frame(proj_ind*2-1)*float(nw_frame)/float(nh_frame) endif if(deltay_frame(proj_ind*2-1).eq.0d0 .and. deltax_frame(proj_ind*2-1).gt.0d0)then deltay_frame(proj_ind*2-1)=deltax_frame(proj_ind*2-1)*float(nh_frame)/float(nw_frame) endif if(deltaz_frame(proj_ind*2-1).eq.0d0)then deltaz_frame(proj_ind*2-1)=boxlen endif delx=deltax_frame(proj_ind*2-1)+deltax_frame(proj_ind*2)/aexp dely=deltay_frame(proj_ind*2-1)+deltay_frame(proj_ind*2)/aexp delz=deltaz_frame(proj_ind*2-1)+deltaz_frame(proj_ind*2)/aexp if(dist_camera(proj_ind).le.0D0) dist_camera(proj_ind) = boxlen ! Camera properties if(cosmo) then if(tend_theta_camera(proj_ind).le.0d0) tend_theta_camera(proj_ind) = aendmov if(tend_phi_camera(proj_ind).le.0d0) tend_phi_camera(proj_ind) = aendmov theta_cam = theta_camera(proj_ind)*pi/180. & +min(max(aexp-tstart_theta_camera(proj_ind),0d0),tend_theta_camera(proj_ind))*dtheta_camera(proj_ind)*pi/180./(aendmov-astartmov) phi_cam = phi_camera(proj_ind)*pi/180. & +min(max(aexp-tstart_theta_camera(proj_ind),0d0),tend_phi_camera(proj_ind))*dphi_camera(proj_ind)*pi/180./(aendmov-astartmov) dist_cam = dist_camera(proj_ind)+min(max(aexp-tstart_theta_camera(proj_ind),0d0),tend_theta_camera(proj_ind))*ddist_camera(proj_ind)/(aendmov-astartmov) else if(tend_theta_camera(proj_ind).le.0d0) tend_theta_camera(proj_ind) = tendmov if(tend_phi_camera(proj_ind).le.0d0) tend_phi_camera(proj_ind) = tendmov theta_cam = theta_camera(proj_ind)*pi/180. & +min(max(t-tstart_theta_camera(proj_ind),0d0),tend_theta_camera(proj_ind))*dtheta_camera(proj_ind)*pi/180./(tendmov-tstartmov) phi_cam = phi_camera(proj_ind)*pi/180. & +min(max(t-tstart_phi_camera(proj_ind),0d0),tend_phi_camera(proj_ind))*dphi_camera(proj_ind)*pi/180./(tendmov-tstartmov) dist_cam = dist_camera(proj_ind)+min(max(t-tstart_theta_camera(proj_ind),0d0),tend_theta_camera(proj_ind))*ddist_camera(proj_ind)/(tendmov-tstartmov) endif if((focal_camera(proj_ind).le.0D0).or.(focal_camera(proj_ind).gt.dist_camera(proj_ind))) focal_camera(proj_ind) = dist_cam fov_camera = atan((delx/2d0)/focal_camera(proj_ind)) #if NDIM>2 if(myid==1) write(*,'(5A,F6.1,A,F6.1,A,F6.3,A,F4.1)') ' Writing frame ', istep_str,' los=',proj_axis(proj_ind:proj_ind), & & ' theta=',theta_cam*180./pi,' phi=',phi_cam*180./pi,' d=',dist_cam,' fov=',fov_camera*180./pi #else if(myid==1) write(*,'(3A,F6.1)') ' Writing frame ', istep_str,' theta=',theta_cam*180./pi #endif ! Frame boundaries xleft_frame = xcen-delx/2. xright_frame = xcen+delx/2. yleft_frame = ycen-dely/2. yright_frame = ycen+dely/2. zleft_frame = zcen-delz/2. zright_frame = zcen+delz/2. ! No cubic shader for 2D simulations if((ndim.eq.2).and.(shader_frame(proj_ind).eq.'cube')) shader_frame(proj_ind) = 'square' ! Allocate image allocate(data_frame(1:nw_frame,1:nh_frame,1:nframes),stat=ierr) if(ierr .ne. 0)then write(*,*) 'Error - Movie frame allocation failed' #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif #ifdef RT if(rt) then allocate(rt_data_frame(1:nw_frame,1:nh_frame,1:rt_nframes),stat=ierr) if(ierr .ne. 0)then write(*,*) 'Error - Movie frame allocation failed' #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,ierr) #else stop #endif endif rt_data_frame(:,:,:) = 0d0 endif #endif allocate(weights(1:nw_frame,1:nh_frame),stat=ierr) if(ierr .ne. 0)then write(*,*) 'Error - Movie frame allocation failed' #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif if(ierr .ne. 0)then write(*,*) 'Error - Movie frame allocation failed' #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif if(method_frame(proj_ind).eq.'min')then data_frame(:,:,:) = 1e-3*huge(0.0) elseif(method_frame(proj_ind).eq.'max')then data_frame(:,:,:) = -1e-3*huge(0.0) else data_frame(:,:,:) = 0.0 endif weights(:,:) = 0d0 dx_frame = delx/dble(nw_frame) dy_frame = dely/dble(nh_frame) if(hydro) then ! Loop over levels do ilevel=levelmin,nlevelmax_frame ! Mesh size at level ilevel in coarse cell units dx=0.5D0**ilevel ! Set position of cell centres relative to grid centre do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do dx_loc=dx*scale dx_min=0.5D0**nlevelmax*scale ncache=active(ilevel)%ngrid dx_proj = (dx_loc/2.0)*smooth_frame(proj_ind) #if NDIM>2 if((shader_frame(proj_ind).eq.'cube').and.(.not.perspective_camera(proj_ind)))then xcube = (/-dx_proj,-dx_proj,-dx_proj,-dx_proj, dx_proj, dx_proj, dx_proj, dx_proj/) ycube = (/-dx_proj,-dx_proj, dx_proj, dx_proj,-dx_proj,-dx_proj, dx_proj, dx_proj/) zcube = (/-dx_proj, dx_proj,-dx_proj, dx_proj,-dx_proj, dx_proj,-dx_proj, dx_proj/) do icube=1,8 xtmp = cos(theta_cam)*xcube(icube)+sin(theta_cam)*ycube(icube) ytmp = cos(theta_cam)*ycube(icube)-sin(theta_cam)*xcube(icube) xcube(icube) = xtmp ycube(icube) = ytmp ytmp = cos(phi_cam)*ycube(icube)+sin(phi_cam)*zcube(icube) ztmp = cos(phi_cam)*zcube(icube)-sin(phi_cam)*ycube(icube) ycube(icube) = ytmp zcube(icube) = ztmp enddo minx = minval(xcube) maxx = maxval(xcube) miny = minval(ycube) maxy = maxval(ycube) minz = minval(zcube) maxz = maxval(zcube) endif #endif ! Loop over grids by vector sweeps do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do ! Loop over cells do ind=1,twotondim ! Gather cell indices iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do ! Gather cell centre positions do idim=1,ndim do i=1,ngrid xx(i,idim)=xg(ind_grid(i),idim)+xc(ind,idim) end do end do ! Rescale position from code units to user units do idim=1,ndim do i=1,ngrid xx(i,idim)=(xx(i,idim)-skip_loc(idim))*scale end do end do ! Check if cell is to be considered do i=1,ngrid ok(i)=son(ind_cell(i))==0.or.ilevel==nlevelmax_frame if(ivar_refine>0.and.zoom_only_frame(proj_ind)) then ok(i)=ok(i).and. & & (uold(ind_cell(i),ivar_refine)/uold(ind_cell(i),1) & & > var_cut_refine) endif if((ok(i)).and.(ivar_frame(proj_ind)>0).and.(ivar_frame(proj_ind)<=nvar))then uvar = uold(ind_cell(i),ivar_frame(proj_ind)) ! Scale temperature to K if(ivar_frame(proj_ind)==ndim+2)then e = 0.0d0 do idim=1,ndim e = e+0.5*uold(ind_cell(i),idim+1)**2/uold(ind_cell(i),1) enddo #if NENER>0 do irad=0,nener-1 e = e+uold(ind_cell(i),inener+irad) enddo #endif #ifdef SOLVERmhd do idim=1,ndim e = e+0.125d0*(uold(ind_cell(i),idim+ndim+2)+uold(ind_cell(i),idim+nvar))**2 enddo #endif ! Pressure uvar = (gamma-1.0)*(uold(ind_cell(i),ivar_frame(proj_ind))-e)*scale_T2 endif ! Switch to primitive variables if(ivar_frame(proj_ind)>1) uvar = uvar/uold(ind_cell(i),1) ! Scale density to cm**-3 if(ivar_frame(proj_ind)==1) uvar = uvar*scale_nH ! Scale velocities to km/s if(ivar_frame(proj_ind)>1.and.ivar_frame(proj_ind)2 ! Centering xx(i,1) = xx(i,1)-xcen xx(i,2) = xx(i,2)-ycen xx(i,3) = xx(i,3)-zcen ! Rotating xtmp = cos(theta_cam)*xx(i,1)+sin(theta_cam)*xx(i,2) ytmp = cos(theta_cam)*xx(i,2)-sin(theta_cam)*xx(i,1) xx(i,1) = xtmp xx(i,2) = ytmp ytmp = cos(phi_cam)*xx(i,2)+sin(phi_cam)*xx(i,3) ztmp = cos(phi_cam)*xx(i,3)-sin(phi_cam)*xx(i,2) xx(i,2) = ytmp xx(i,3) = ztmp ! Perspective correction factor pers_corr = 1.0 if(proj_axis(proj_ind:proj_ind).eq.'x')then if(dist_cam-xx(i,1).lt.0d0) continue if(perspective_camera(proj_ind))then alpha = atan(xx(i,2)/(dist_cam-xx(i,1))) beta = atan(xx(i,3)/(dist_cam-xx(i,1))) if(abs(alpha)/2d0.gt.fov_camera) continue if(abs(beta)/2d0.gt.fov_camera) continue pers_corr = focal_camera(proj_ind)/(dist_cam-xx(i,1)) xx(i,2) = xx(i,2)*pers_corr xx(i,3) = xx(i,3)*pers_corr dx_proj = (dx_loc/2.0)*pers_corr*smooth_frame(proj_ind) endif xcentre = xx(i,2)+ycen ycentre = xx(i,3)+zcen zcentre = xx(i,1)+xcen elseif(proj_axis(proj_ind:proj_ind).eq.'y')then if(dist_cam-xx(i,2).lt.0d0) continue if(perspective_camera(proj_ind))then alpha = atan(xx(i,1)/(dist_cam-xx(i,2))) beta = atan(xx(i,3)/(dist_cam-xx(i,2))) if(abs(alpha)/2d0.gt.fov_camera) continue if(abs(beta)/2d0.gt.fov_camera) continue pers_corr = focal_camera(proj_ind)/(dist_cam-xx(i,2)) xx(i,1) = xx(i,1)*pers_corr xx(i,3) = xx(i,3)*pers_corr dx_proj = (dx_loc/2.0)*pers_corr*smooth_frame(proj_ind) endif xcentre = xx(i,1)+xcen ycentre = xx(i,3)+zcen zcentre = xx(i,2)+ycen else if(dist_cam-xx(i,3).lt.0d0) continue if(perspective_camera(proj_ind))then alpha = atan(xx(i,1)/(dist_cam-xx(i,3))) beta = atan(xx(i,2)/(dist_cam-xx(i,3))) if(abs(alpha)/2d0.gt.fov_camera) continue if(abs(beta)/2d0.gt.fov_camera) continue pers_corr = focal_camera(proj_ind)/(dist_cam-xx(i,3)) xx(i,1) = xx(i,1)*pers_corr xx(i,2) = xx(i,2)*pers_corr dx_proj = (dx_loc/2.0)*pers_corr*smooth_frame(proj_ind) endif xcentre = xx(i,1)+xcen ycentre = xx(i,2)+ycen zcentre = xx(i,3)+zcen endif ! Rotating the cube shader if(shader_frame(proj_ind).eq.'cube'.and.perspective_camera(proj_ind))then xcube = (/-dx_proj,-dx_proj,-dx_proj,-dx_proj, dx_proj, dx_proj, dx_proj, dx_proj/) ycube = (/-dx_proj,-dx_proj, dx_proj, dx_proj,-dx_proj,-dx_proj, dx_proj, dx_proj/) zcube = (/-dx_proj, dx_proj,-dx_proj, dx_proj,-dx_proj, dx_proj,-dx_proj, dx_proj/) do icube=1,8 xtmp = cos(theta_cam)*xcube(icube)+sin(theta_cam)*ycube(icube) ytmp = cos(theta_cam)*ycube(icube)-sin(theta_cam)*xcube(icube) xcube(icube) = xtmp ycube(icube) = ytmp ytmp = cos(phi_cam)*ycube(icube)+sin(phi_cam)*zcube(icube) ztmp = cos(phi_cam)*zcube(icube)-sin(phi_cam)*ycube(icube) ycube(icube) = ytmp zcube(icube) = ztmp ! Additional coordinate dependent rotation for perspective effect xtmp = cos(alpha)*xcube(icube)+sin(alpha)*zcube(icube) ztmp = cos(alpha)*zcube(icube)-sin(alpha)*xcube(icube) xcube(icube) = xtmp zcube(icube) = ztmp ytmp = cos(beta)*ycube(icube)+sin(beta)*zcube(icube) ztmp = cos(beta)*zcube(icube)-sin(beta)*ycube(icube) ycube(icube) = ytmp zcube(icube) = ztmp pers_corr = zcentre/(zcentre-zcube(icube)) xcube(icube) = xcube(icube)*pers_corr ycube(icube) = ycube(icube)*pers_corr enddo minx = minval(xcube) maxx = maxval(xcube) miny = minval(ycube) maxy = maxval(ycube) minz = minval(zcube) maxz = maxval(zcube) endif if(shader_frame(proj_ind).ne.'cube')then minx = -dx_proj maxx = dx_proj miny = -dx_proj maxy = dx_proj minz = -dx_proj maxz = dx_proj endif xleft = xcentre+minx xright = xcentre+maxx yleft = ycentre+miny yright = ycentre+maxy zleft = zcentre+minz zright = zcentre+maxz if( xright.lt.xleft_frame.or.xleft.ge.xright_frame.or.& & yright.lt.yleft_frame.or.yleft.ge.yright_frame.or.& & zright.lt.zleft_frame.or.zleft.ge.zright_frame)cycle #else xx(i,1) = xx(i,1)-xcen xx(i,2) = xx(i,2)-ycen ! Rotating xtmp = cos(theta_cam)*xx(i,1)+sin(theta_cam)*xx(i,2) ytmp = cos(theta_cam)*xx(i,2)-sin(theta_cam)*xx(i,1) xx(i,1) = xtmp xx(i,2) = ytmp xcentre = xx(i,1)+xcen ycentre = xx(i,2)+ycen xleft = xcentre-dx_proj xright = xcentre+dx_proj yleft = ycentre-dx_proj yright = ycentre+dx_proj if( xright.lt.xleft_frame.or.xleft.ge.xright_frame.or.& & yright.lt.yleft_frame.or.yleft.ge.yright_frame)cycle #endif ! Compute map indices for the cell if(xleft>xleft_frame)then imin=min(int((xleft-xleft_frame)/dx_frame)+1,nw_frame) else imin=1 endif imax=min(int((xright-xleft_frame)/dx_frame)+1,nw_frame) if(yleft>yleft_frame)then jmin=min(int((yleft-yleft_frame)/dy_frame)+1,nh_frame) ! change else jmin=1 endif jmax=min(int((yright-yleft_frame)/dy_frame)+1,nh_frame) ! change ! Fill up map with projected mass do ii=imin,imax ! Pixel x-axis position xxleft = xleft_frame+dble(ii-1)*dx_frame xxright = xxleft+dx_frame xxcentre = xxleft+0.5*dx_frame dx_cell = dx_frame/dx_proj do jj=jmin,jmax ! Pixel y-axis position yyleft = yleft_frame+dble(jj-1)*dy_frame yyright = yyleft+dy_frame yycentre = yyleft+0.5*dy_frame dy_cell = dx_frame/dx_proj xpc = xxcentre-xcentre ypc = yycentre-ycentre if(abs(xxcentre-xleft).lt.1d-2*dx_frame) xpc = xpc-1e-2*dx_frame if(abs(yycentre-yleft).lt.1d-2*dx_frame) ypc = ypc-1e-2*dx_frame if(abs(xxcentre-xright).lt.1d-2*dx_frame) xpc = xpc-1e-2*dx_frame if(abs(yycentre-yright).lt.1d-2*dx_frame) ypc = ypc-1e-2*dx_frame #if NDIM>2 if(shader_frame(proj_ind).eq.'cube')then cube_face = .false. if(sqrt(xpc**2+ypc**2).gt.dx_proj*sqrt(3.0)) goto 666 ! Filling the 6 cube shader faces do iline=1,6 l1 = (ycube(lind(iline,2))-ycube(lind(iline,1)))**2+(xcube(lind(iline,2))-xcube(lind(iline,1)))**2 l2 = (ycube(lind(iline,4))-ycube(lind(iline,3)))**2+(xcube(lind(iline,4))-xcube(lind(iline,3)))**2 if(l1.eq.0d0) cycle if(l2.eq.0d0) cycle d1 = ((ycube(lind(iline,2))-ycube(lind(iline,1)))*xpc-(xcube(lind(iline,2))-xcube(lind(iline,1)))*ypc+xcube(lind(iline,2))*ycube(lind(iline,1))-ycube(lind(iline,2))*xcube(lind(iline,1)))/l1 d2 = ((ycube(lind(iline,4))-ycube(lind(iline,3)))*xpc-(xcube(lind(iline,4))-xcube(lind(iline,3)))*ypc+xcube(lind(iline,4))*ycube(lind(iline,3))-ycube(lind(iline,4))*xcube(lind(iline,3)))/l2 if(d1.eq.-sign(d1,d2)) cube_face=.true. if(.not.cube_face) cycle l3 = (ycube(lind(iline,6))-ycube(lind(iline,5)))**2+(xcube(lind(iline,6))-xcube(lind(iline,5)))**2 l4 = (ycube(lind(iline,8))-ycube(lind(iline,7)))**2+(xcube(lind(iline,8))-xcube(lind(iline,7)))**2 if(l3.eq.0d0) cycle if(l4.eq.0d0) cycle d3 = ((ycube(lind(iline,6))-ycube(lind(iline,5)))*xpc-(xcube(lind(iline,6))-xcube(lind(iline,5)))*ypc+xcube(lind(iline,6))*ycube(lind(iline,5))-ycube(lind(iline,6))*xcube(lind(iline,5)))/l3 d4 = ((ycube(lind(iline,8))-ycube(lind(iline,7)))*xpc-(xcube(lind(iline,8))-xcube(lind(iline,7)))*ypc+xcube(lind(iline,8))*ycube(lind(iline,7))-ycube(lind(iline,8))*xcube(lind(iline,7)))/l4 ! Within the projected face? if(d3.eq.sign(d3,d4)) cube_face=.false. if(cube_face) exit enddo 666 continue endif #endif if((shader_frame(proj_ind).eq.'cube' & .and.(cube_face)) & .or.(shader_frame(proj_ind).eq.'sphere' & .and.sqrt(xpc**2+ypc**2).le.dx_proj) & .or.(shader_frame(proj_ind).eq.'square' & .and.(abs(xpc).lt.dx_proj) & .and.(abs(ypc).lt.dx_proj)))then ! Intersection volume dvol = dx_cell*dy_cell if(method_frame(proj_ind).eq.'mean_mass')then weight = dvol*uold(ind_cell(i),1)*dx_loc**3 elseif(method_frame(proj_ind).eq.'mean_dens')then weight = dvol*uold(ind_cell(i),1) elseif(method_frame(proj_ind).eq.'mean_vol')then weight = dvol*dx_loc**3 elseif(method_frame(proj_ind).eq.'sum')then weight = 1.0 endif ! Update weights map if(method_frame(proj_ind)(1:4).eq.'mean')then weights(ii,jj) = weights(ii,jj)+weight endif imap = 1 #ifdef SOLVERmhd do kk=0,NVAR+4 #else do kk=0,NVAR #endif if(movie_vars(kk).eq.1)then ! Temperature map case if(kk==0)then e = 0.0d0 do idim=1,ndim e = e+0.5*uold(ind_cell(i),idim+1)**2/max(uold(ind_cell(i),1),smallr) enddo #if NENER>0 do irad=0,nener-1 e = e+uold(ind_cell(i),inener+irad) enddo #endif #ifdef SOLVERmhd do idim=1,ndim e = e+0.125d0*(uold(ind_cell(i),idim+ndim+2)+uold(ind_cell(i),idim+nvar))**2 enddo #endif uvar = (gamma-1.0)*(uold(ind_cell(i),ndim+2)-e) uvar = uvar/uold(ind_cell(i),1)*scale_T2 endif ! Density map case if(kk==1) then uvar = uold(ind_cell(i),kk) endif ! Other scalars map if(kk>1)then uvar = uold(ind_cell(i),kk)/max(uold(ind_cell(i),1),smallr) endif #ifdef SOLVERmhd ! Magnetic energy map case if(kk.eq.NVAR+4)then uvar = 0.125*(uold(ind_cell(i),6)**2+uold(ind_cell(i),7)**2+uold(ind_cell(i),8)**2 & & + uold(ind_cell(i),NVAR+1)**2+uold(ind_cell(i),NVAR+2)**2+uold(ind_cell(i),NVAR+3)**2) endif #endif ! Frame update if(method_frame(proj_ind).eq.'min')then data_frame(ii,jj,imap) = min(data_frame(ii,jj,imap),uvar) elseif(method_frame(proj_ind).eq.'max')then data_frame(ii,jj,imap) = max(data_frame(ii,jj,imap),uvar) else data_frame(ii,jj,imap) = data_frame(ii,jj,imap)+weight*uvar endif imap = imap+1 endif end do #ifdef RT if(rt) then imap = 1 do kk=1,NGROUPS if(rt_movie_vars(kk).eq.1) then if(method_frame(proj_ind).eq.'min')then rt_data_frame(ii,jj,imap) = & & min(rt_data_frame(ii,jj,imap),rtuold(ind_cell(i),1+(kk-1)*(ndim+1))*rt_c_cgs*uold(ind_cell(i),1) elseif(method_frame(proj_ind).eq.'max')then rt_data_frame(ii,jj,imap) = & & max(rt_data_frame(ii,jj,imap),rtuold(ind_cell(i),1+(kk-1)*(ndim+1))*rt_c_cgs*uold(ind_cell(i),1) else rt_data_frame(ii,jj,imap) = rt_data_frame(ii,jj,imap)+ & & weight*rtuold(ind_cell(i),1+(kk-1)*(ndim+1))*rt_c_cgs*uold(ind_cell(i),1) endif imap = imap+1 endif end do endif #endif endif end do end do end if end do end do ! End loop over cells end do ! End loop over grids end do ! End loop over levels end if ! Loop over particles do j=1,npartmax #if NDIM>2 xpf = xp(j,1)-xcen ypf = xp(j,2)-ycen zpf = xp(j,3)-zcen ! Projection xtmp = cos(theta_cam)*xpf+sin(theta_cam)*ypf ytmp = cos(theta_cam)*ypf-sin(theta_cam)*xpf xpf = xtmp ypf = ytmp ytmp = cos(phi_cam)*ypf+sin(phi_cam)*zpf ztmp = cos(phi_cam)*zpf-sin(phi_cam)*ypf if(proj_axis(proj_ind:proj_ind).eq.'x')then xpf = ytmp ypf = ztmp zpf = xtmp elseif(proj_axis(proj_ind:proj_ind).eq.'y')then xpf = xtmp ypf = ztmp zpf = ytmp else xpf = xtmp ypf = ytmp zpf = ztmp endif if(perspective_camera(proj_ind))then xpf = xpf*focal_camera(proj_ind)/(dist_cam-zpf) ypf = ypf*focal_camera(proj_ind)/(dist_cam-zpf) endif xpf = xpf+xcen ypf = ypf+ycen zpf = zpf+zcen if( xpf.lt.xleft_frame.or.xpf.ge.xright_frame.or.& & ypf.lt.yleft_frame.or.ypf.ge.yright_frame.or.& & zpf.lt.zleft_frame.or.zpf.ge.zright_frame)cycle #else xpf = xp(j,1)-xcen ypf = xp(j,2)-ycen xtmp = cos(theta_cam)*xpf+sin(theta_cam)*xpf ytmp = cos(theta_cam)*ypf-sin(theta_cam)*ypf xpf = xtmp ypf = ytmp xpf = xpf+xcen ypf = ypf+xcen if( xpf.lt.xleft_frame.or.xpf.ge.xright_frame.or.& & ypf.lt.yleft_frame.or.ypf.ge.yright_frame)cycle #endif ! Compute map indices for the cell ii = min(int((xpf-xleft_frame)/dx_frame)+1,nw_frame) jj = min(int((ypf-yleft_frame)/dy_frame)+1,nh_frame) ! Fill up map with projected mass #ifdef SOLVERmhd ipart_start = NVAR+5 #else ipart_start = NVAR+1 #endif imap = 1 do kk=0,ipart_start+1 if(movie_vars(kk).eq.1)then if(star) then ! DM particles if((tp(j).eq.0d0).and.(kk.eq.ipart_start)) then if(mass_cut_refine>0.0.and.zoom_only_frame(proj_ind)) then if(mp(j)0d0.and.zoom_only_frame(proj_ind)) then if(mp(j)0)then write(ilun)t,delx,dely,delz else write(ilun)aexp,delx,dely,delz endif write(ilun)nw_frame,nh_frame write(ilun) real(data_frame(:,:,imap),4) close(ilun) ilun = ilun+1 imap = imap+1 end if end do #ifdef RT if(rt) then imap = 1 do kk=1, NGROUPS if (rt_movie_vars(kk).eq.1) then open(ilun,file=TRIM(rt_moviefiles(kk)),form='unformatted',iostat=ierr) if(ierr .ne. 0)then write(*,*) 'Error - Could not open ',TRIM(moviefiles(kk)) #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif rewind(ilun) if(tendmov>0)then write(ilun)t,delx,dely,delz else write(ilun)aexp,delx,dely,delz endif write(ilun)nw_frame,nh_frame write(ilun)real(rt_data_frame(:,:,imap),4) close(ilun) ilun = ilun+1 imap = imap+1 end if end do endif #endif endif deallocate(data_frame) #ifdef RT if(rt) deallocate(rt_data_frame) #endif #endif ! Update counter if(proj_ind.eq.len(trim(proj_axis))) then ! Increase counter and skip frames if timestep is large imov=imov+1 do while((amovout(imov)2 if(ANY(movie_vars_txt=='vz ')) movie_vars(4)=1 #endif #if NDIM==2 if(ANY(movie_vars_txt=='pres ')) movie_vars(4)=1 #endif #if NDIM>2 if(ANY(movie_vars_txt=='pres ')) movie_vars(5)=1 #endif #if NVAR>5 do ll=6,NVAR write(dummy,'(I3.1)') ll if(ANY(movie_vars_txt=='var'//trim(adjustl(dummy))//' ')) movie_vars(ll)=1 end do #endif #ifdef SOLVERmhd if(ANY(movie_vars_txt=='bxl ')) movie_vars(6)=1 if(ANY(movie_vars_txt=='byl ')) movie_vars(7)=1 if(ANY(movie_vars_txt=='bzl ')) movie_vars(8)=1 if(ANY(movie_vars_txt=='bxr ')) movie_vars(NVAR+1)=1 if(ANY(movie_vars_txt=='byr ')) movie_vars(NVAR+2)=1 if(ANY(movie_vars_txt=='bzr ')) movie_vars(NVAR+3)=1 if(ANY(movie_vars_txt=='pmag ')) movie_vars(NVAR+4)=1 if(ANY(movie_vars_txt=='dm ')) movie_vars(NVAR+5)=1 if(ANY(movie_vars_txt=='stars')) movie_vars(NVAR+6)=1 #else if(ANY(movie_vars_txt=='dm ')) movie_vars(NVAR+1)=1 if(ANY(movie_vars_txt=='stars')) movie_vars(NVAR+2)=1 #endif #ifdef RT do ll=1,NGROUPS write(dummy,'(I3.1)') ll if(ANY(movie_vars_txt=='Fp'//trim(adjustl(dummy))//' ')) rt_movie_vars(ll)=1 enddo #endif end subroutine set_movie_vars ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/output_amr.f90 !######################################################################### !######################################################################### !######################################################################### !######################################################################### subroutine dump_all use amr_commons use pm_commons use hydro_commons use cooling_module implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character::nml_char character(LEN=256)::nml_char character(LEN=5)::nchar,ncharcpu ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename,filedir,filedirini,filecmd character(LEN=256)::filename,filedir,filedirini,filecmd integer::i,itest,info,irec,ierr if(nstep_coarse==nstep_coarse_old.and.nstep_coarse>0)return if(nstep_coarse==0.and.nrestart>0)return if(verbose)write(*,*)'Entering dump_all' call write_screen call title(ifout,nchar) ifout=ifout+1 if(t>=tout(iout).or.aexp>=aout(iout))iout=iout+1 output_done=.true. ! ADDED BY TTG MAY 2017 if(myid==1) write(*,*)'Dumping output '//TRIM(nchar)//' at t = ', t if(IOGROUPSIZEREP>0)call title(((myid-1)/IOGROUPSIZEREP)+1,ncharcpu) if(ndim>1)then if(IOGROUPSIZEREP>0) then ! CHANGED BY TTG (FEB 2017) ! filedirini='output_'//TRIM(nchar)//'/' ! filedir='output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/' filedirini=TRIM(output_dir)//'output_'//TRIM(nchar)//'/' filedir=TRIM(output_dir)//'output_'//TRIM(nchar)//'/group_'//TRIM(ncharcpu)//'/' else ! CHANGED BY TTG (FEB 2017) ! filedir='output_'//TRIM(nchar)//'/' filedir=TRIM(output_dir)//'output_'//TRIM(nchar)//'/' endif filecmd='mkdir -p '//TRIM(filedir) if (.not.withoutmkdir) then #ifdef NOSYSTEM call PXFMKDIR(TRIM(filedirini),LEN(TRIM(filedirini)),O'755',info) call PXFMKDIR(TRIM(filedir),LEN(TRIM(filedir)),O'755',info) #else !CHANGED BY TTG (FEB 2017): gfortran v < 4.6 does not know about EXECUTE_COMMAND_LINE ! call EXECUTE_COMMAND_LINE(filecmd,exitstat=ierr,wait=.true.) ! call EXECUTE_COMMAND_LINE(filecmd,ierr,.true.) call SYSTEM(filecmd,ierr) if(ierr.ne.0 .and. ierr.ne.127)then write(*,*) 'Error - Could not create ',trim(filedir),' error code=',ierr #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,info) #else stop #endif endif #endif endif #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'Start backup header' ! Output header: must be called by each process ! filename=TRIM(filedir)//'header_'//TRIM(nchar)//'.txt' call output_header(filename) #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup header' if(myid==1.and.print_when_io) write(*,*)'Start backup info etc.' ! Only master process if(myid==1)then filename=TRIM(filedir)//'info_'//TRIM(nchar)//'.txt' call output_info(filename) filename=TRIM(filedir)//'makefile.txt' call output_makefile(filename) filename=TRIM(filedir)//'patches.txt' call output_patch(filename) if(hydro)then filename=TRIM(filedir)//'hydro_file_descriptor.txt' call file_descriptor_hydro(filename) end if if(cooling .and. .not. neq_chem)then filename=TRIM(filedir)//'cooling_'//TRIM(nchar)//'.out' call output_cool(filename) end if if(sink)then filename=TRIM(filedir)//'sink_'//TRIM(nchar)//'.info' call output_sink(filename) filename=TRIM(filedir)//'sink_'//TRIM(nchar)//'.csv' call output_sink_csv(filename) endif ! Copy namelist file to output directory filename=TRIM(filedir)//'namelist.txt' ! CHANGED BY TTG (FEB 2017) ! OPEN(UNIT=10, FILE=namelist_file, ACCESS='DIRECT', STATUS='OLD', & ! & ACTION='READ', IOSTAT=IERR, RECL=1) ! OPEN(UNIT=11, FILE=filename, ACCESS='DIRECT', STATUS='REPLACE', & ! & ACTION='WRITE', IOSTAT=IERR, RECL=1) ! IREC = 1 ! DO ! READ(UNIT=10, REC=IREC, IOSTAT=IERR)nml_char ! IF (IERR.NE.0) EXIT ! WRITE(UNIT=11, REC=IREC)nml_char ! IREC = IREC + 1 ! END DO ! CLOSE(10) ! CLOSE(11) OPEN(10,file=namelist_file) OPEN(11,file=filename) DO READ(10,'(A256)',IOSTAT=IERR)nml_char WRITE(11,*) TRIM(nml_char) IF (IERR.NE.0) EXIT END DO CLOSE(10) CLOSE(11) ! Copy compilation details to output directory filename=TRIM(filedir)//'compilation.txt' OPEN(UNIT=11, FILE=filename, FORM='formatted') write(11,'(' compile date = ',A)')TRIM(builddate) write(11,'(' patch dir = ',A)')TRIM(patchdir) write(11,'(' remote repo = ',A)')TRIM(gitrepo) write(11,'(' local branch = ',A)')TRIM(gitbranch) write(11,'(' last commit = ',A)')TRIM(githash) CLOSE(11) endif #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup info etc.' if(myid==1.and.print_when_io) write(*,*)'Start backup amr' filename=TRIM(filedir)//'amr_'//TRIM(nchar)//'.out' call backup_amr(filename) #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup amr' if(hydro)then if(myid==1.and.print_when_io) write(*,*)'Start backup hydro' filename=TRIM(filedir)//'hydro_'//TRIM(nchar)//'.out' call backup_hydro(filename) #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup hydro' end if #ifdef RT if(rt.or.neq_chem)then if(myid==1.and.print_when_io) write(*,*)'Start backup rt' filename=TRIM(filedir)//'rt_'//TRIM(nchar)//'.out' call rt_backup_hydro(filename) #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup rt' endif #endif if(pic)then if(myid==1.and.print_when_io) write(*,*)'Start backup part' filename=TRIM(filedir)//'part_'//TRIM(nchar)//'.out' call backup_part(filename) if(sink)then filename=TRIM(filedir)//'sink_'//TRIM(nchar)//'.out' call backup_sink(filename) end if #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup part' end if if(poisson)then if(myid==1.and.print_when_io) write(*,*)'Start backup poisson' filename=TRIM(filedir)//'grav_'//TRIM(nchar)//'.out' call backup_poisson(filename) #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup poisson' end if #ifdef ATON if(aton)then if(myid==1.and.print_when_io) write(*,*)'Start backup rad' filename=TRIM(filedir)//'rad_'//TRIM(nchar)//'.out' call backup_radiation(filename) filename=TRIM(filedir)//'radgpu_'//TRIM(nchar)//'.out' call store_radiation(filename) #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup rad' end if #endif if (gadget_output) then if(myid==1.and.print_when_io) write(*,*)'Start backup gadget format' filename=TRIM(filedir)//'gsnapshot_'//TRIM(nchar) call savegadget(filename) #ifndef WITHOUTMPI if(synchro_when_io) call MPI_BARRIER(MPI_COMM_WORLD,info) #endif if(myid==1.and.print_when_io) write(*,*)'End backup gadget format' end if end if end subroutine dump_all !######################################################################### !######################################################################### !######################################################################### !######################################################################### subroutine backup_amr(filename) use amr_commons use hydro_commons use pm_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename integer::nx_loc,ny_loc,nz_loc,ilun integer::ilevel,ibound,ncache,istart,i,igrid,idim,ind,iskip integer,allocatable,dimension(:)::ind_grid,iig real(dp),allocatable,dimension(:)::xdp real(sp),allocatable,dimension(:)::xsp real(dp),dimension(1:3)::skip_loc ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v real(dp)::scale integer,parameter::tag=1120 integer::dummy_io,info2 if(verbose)write(*,*)'Entering backup_amr' ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! Local constants nx_loc=nx; ny_loc=ny; nz_loc=nz if(ndim>0)nx_loc=(icoarse_max-icoarse_min+1) if(ndim>1)ny_loc=(jcoarse_max-jcoarse_min+1) if(ndim>2)nz_loc=(kcoarse_max-kcoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) !----------------------------------- ! Output amr grid in file !----------------------------------- ilun=myid+10 call title(myid,nchar) fileloc=TRIM(filename)//TRIM(nchar) ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(unit=ilun,file=fileloc,form='unformatted') ! Write grid variables write(ilun)ncpu write(ilun)ndim write(ilun)nx,ny,nz write(ilun)nlevelmax write(ilun)ngridmax write(ilun)nboundary write(ilun)ngrid_current write(ilun)boxlen ! Write time variables write(ilun)noutput,iout,ifout write(ilun)tout(1:noutput) write(ilun)aout(1:noutput) write(ilun)t write(ilun)dtold(1:nlevelmax) write(ilun)dtnew(1:nlevelmax) write(ilun)nstep,nstep_coarse write(ilun)einit,mass_tot_0,rho_tot write(ilun)omega_m,omega_l,omega_k,omega_b,h0,aexp_ini,boxlen_ini write(ilun)aexp,hexp,aexp_old,epot_tot_int,epot_tot_old write(ilun)mass_sph ! Write levels variables write(ilun)headl(1:ncpu,1:nlevelmax) write(ilun)taill(1:ncpu,1:nlevelmax) write(ilun)numbl(1:ncpu,1:nlevelmax) write(ilun)numbtot(1:10,1:nlevelmax) ! Read boundary linked list if(simple_boundary)then write(ilun)headb(1:nboundary,1:nlevelmax) write(ilun)tailb(1:nboundary,1:nlevelmax) write(ilun)numbb(1:nboundary,1:nlevelmax) end if ! Write free memory write(ilun)headf,tailf,numbf,used_mem,used_mem_tot ! Write cpu boundaries write(ilun)ordering if(ordering=='bisection') then write(ilun)bisec_wall(1:nbinodes) write(ilun)bisec_next(1:nbinodes,1:2) write(ilun)bisec_indx(1:nbinodes) write(ilun)bisec_cpubox_min(1:ncpu,1:ndim) write(ilun)bisec_cpubox_max(1:ncpu,1:ndim) else write(ilun)bound_key(0:ndomain) endif ! Write coarse level write(ilun)son(1:ncoarse) write(ilun)flag1(1:ncoarse) write(ilun)cpu_map(1:ncoarse) ! Write fine levels do ilevel=1,nlevelmax do ibound=1,nboundary+ncpu if(ibound<=ncpu)then ncache=numbl(ibound,ilevel) istart=headl(ibound,ilevel) else ncache=numbb(ibound-ncpu,ilevel) istart=headb(ibound-ncpu,ilevel) end if if(ncache>0)then allocate(ind_grid(1:ncache),xdp(1:ncache),iig(1:ncache)) ! Write grid index igrid=istart do i=1,ncache ind_grid(i)=igrid igrid=next(igrid) end do write(ilun)ind_grid ! Write next index do i=1,ncache iig(i)=next(ind_grid(i)) end do write(ilun)iig ! Write prev index do i=1,ncache iig(i)=prev(ind_grid(i)) end do write(ilun)iig ! Write grid center do idim=1,ndim do i=1,ncache xdp(i)=xg(ind_grid(i),idim) end do write(ilun)xdp end do ! Write father index do i=1,ncache iig(i)=father(ind_grid(i)) end do write(ilun)iig ! Write nbor index do ind=1,twondim do i=1,ncache iig(i)=nbor(ind_grid(i),ind) end do write(ilun)iig end do ! Write son index do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ncache iig(i)=son(ind_grid(i)+iskip) end do write(ilun)iig end do ! Write cpu map do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ncache iig(i)=cpu_map(ind_grid(i)+iskip) end do write(ilun)iig end do ! Write refinement map do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ncache iig(i)=flag1(ind_grid(i)+iskip) end do write(ilun)iig end do deallocate(xdp,iig,ind_grid) end if end do end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif end subroutine backup_amr !######################################################################### !######################################################################### !######################################################################### !######################################################################### subroutine output_info(filename) use amr_commons use hydro_commons use pm_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename integer::nx_loc,ny_loc,nz_loc,ilun,icpu,idom,ierr real(dp)::scale real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar if(verbose)write(*,*)'Entering output_info' ilun=11 ! Conversion factor from user units to cgs units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! Local constants nx_loc=nx; ny_loc=ny; nz_loc=nz if(ndim>0)nx_loc=(icoarse_max-icoarse_min+1) if(ndim>1)ny_loc=(jcoarse_max-jcoarse_min+1) if(ndim>2)nz_loc=(kcoarse_max-kcoarse_min+1) scale=boxlen/dble(nx_loc) ! Open file fileloc=TRIM(filename) open(unit=ilun,file=fileloc,form='formatted',iostat=ierr) if(ierr .ne. 0)then write(*,*) 'Error - Could not write ',fileloc #ifndef WITHOUTMPI call MPI_ABORT(MPI_COMM_WORLD,1,ierr) #else stop #endif endif ! Write run parameters write(ilun,'('ncpu =',I11)')ncpu write(ilun,'('ndim =',I11)')ndim write(ilun,'('levelmin =',I11)')levelmin write(ilun,'('levelmax =',I11)')nlevelmax write(ilun,'('ngridmax =',I11)')ngridmax write(ilun,'('nstep_coarse=',I11)')nstep_coarse write(ilun,*) ! Write physical parameters write(ilun,'('boxlen =',E23.15)')scale write(ilun,'('time =',E23.15)')t write(ilun,'('aexp =',E23.15)')aexp write(ilun,'('H0 =',E23.15)')h0 write(ilun,'('omega_m =',E23.15)')omega_m write(ilun,'('omega_l =',E23.15)')omega_l write(ilun,'('omega_k =',E23.15)')omega_k write(ilun,'('omega_b =',E23.15)')omega_b write(ilun,'('unit_l =',E23.15)')scale_l write(ilun,'('unit_d =',E23.15)')scale_d write(ilun,'('unit_t =',E23.15)')scale_t write(ilun,*) ! Write ordering information write(ilun,'('ordering type=',A80)')ordering if(ordering=='bisection') then do icpu=1,ncpu ! write 2*ndim floats for cpu bound box write(ilun,'(E23.15)')bisec_cpubox_min(icpu,:),bisec_cpubox_max(icpu,:) ! write 1 float for cpu load write(ilun,'(E23.15)')dble(bisec_cpu_load(icpu)) end do else write(ilun,'(' DOMAIN ind_min ind_max')') do idom=1,ndomain write(ilun,'(I8,1X,E23.15,1X,E23.15)')idom,bound_key(idom-1),bound_key(idom) end do endif close(ilun) end subroutine output_info !######################################################################### !######################################################################### !######################################################################### !######################################################################### subroutine output_header(filename) use amr_commons use hydro_commons use pm_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename integer::info,ilun integer(i8b)::tmp_long,npart_tot ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc if(verbose)write(*,*)'Entering output_header' ! Compute total number of particles #ifndef WITHOUTMPI #ifndef LONGINT call MPI_ALLREDUCE(npart,npart_tot,1,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) #else tmp_long=npart call MPI_ALLREDUCE(tmp_long,npart_tot,1,MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,info) #endif #endif #ifdef WITHOUTMPI npart_tot=npart #endif if(myid==1)then ilun=myid+10 ! Open file fileloc=TRIM(filename) open(unit=ilun,file=fileloc,form='formatted') ! Write header information write(ilun,*)'Total number of particles' write(ilun,*)npart_tot write(ilun,*)'Total number of dark matter particles' write(ilun,*)npart_tot-nstar_tot write(ilun,*)'Total number of star particles' write(ilun,*)nstar_tot write(ilun,*)'Total number of sink particles' write(ilun,*)nsink ! Keep track of what particle fields are present write(ilun,*)'Particle fields' write(ilun,'(a)',advance='no')'pos vel mass iord level ' #ifdef OUTPUT_PARTICLE_POTENTIAL write(ilun,'(a)',advance='no')'phi ' #endif if(star.or.sink) then write(ilun,'(a)',advance='no')'tform ' if(metal) then write(ilun,'(a)',advance='no')'metal ' endif endif close(ilun) endif end subroutine output_header !######################################################################### !######################################################################### !######################################################################### !######################################################################### subroutine savegadget(filename) use amr_commons use hydro_commons use pm_commons use gadgetreadfilemod implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename TYPE (gadgetheadertype) :: header real,allocatable,dimension(:,:)::pos, vel integer(i8b),allocatable,dimension(:)::ids integer::i, idim, ipart real:: gadgetvfact integer::info integer(i8b)::npart_tot, npart_loc real, parameter:: RHOcrit = 2.7755d11 #ifndef WITHOUTMPI npart_loc=npart #ifndef LONGINT call MPI_ALLREDUCE(npart_loc,npart_tot,1,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info) #else call MPI_ALLREDUCE(npart_loc,npart_tot,1,MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,info) #endif #else npart_tot=npart #endif allocate(pos(ndim, npart), vel(ndim, npart), ids(npart)) gadgetvfact = 100.0 * boxlen_ini / aexp / SQRT(aexp) header%npart = 0 header%npart(2) = npart header%mass = 0 header%mass(2) = omega_m*RHOcrit*(boxlen_ini)**3/npart_tot/1.d10 header%time = aexp header%redshift = 1.d0/aexp-1.d0 header%flag_sfr = 0 header%nparttotal = 0 #ifndef LONGINT header%nparttotal(2) = npart_tot #else header%nparttotal(2) = MOD(npart_tot,4294967296) #endif header%flag_cooling = 0 header%numfiles = ncpu header%boxsize = boxlen_ini header%omega0 = omega_m header%omegalambda = omega_l header%hubbleparam = h0/100.0 header%flag_stellarage = 0 header%flag_metals = 0 header%totalhighword = 0 #ifndef LONGINT header%totalhighword(2) = 0 #else header%totalhighword(2) = npart_tot/4294967296 #endif header%flag_entropy_instead_u = 0 header%flag_doubleprecision = 0 header%flag_ic_info = 0 header%lpt_scalingfactor = 0 header%unused = ' ' do idim=1,ndim ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 if (ipart .gt. npart) then write(*,*) myid, 'Ipart=',ipart, 'exceeds', npart call clean_stop endif pos(idim, ipart)=xp(i,idim) * boxlen_ini vel(idim, ipart)=vp(i,idim) * gadgetvfact if (idim.eq.1) ids(ipart) = idp(i) end if end do end do call gadgetwritefile(filename, myid-1, header, pos, vel, ids) deallocate(pos, vel, ids) end subroutine savegadget ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/output_hydro.f90 subroutine file_descriptor_hydro(filename) use amr_commons use hydro_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename ! character(LEN=80)::fileloc character(LEN=256)::filename character(LEN=256)::fileloc integer::ivar,ilun if(verbose)write(*,*)'Entering file_descriptor_hydro' ilun=11 ! Open file fileloc=TRIM(filename) open(unit=ilun,file=fileloc,form='formatted') ! Write run parameters write(ilun,'('nvar =',I11)')nvar ivar=1 write(ilun,'('variable #',I2,': density')')ivar ivar=2 write(ilun,'('variable #',I2,': velocity_x')')ivar if(ndim>1)then ivar=3 write(ilun,'('variable #',I2,': velocity_y')')ivar endif if(ndim>2)then ivar=4 write(ilun,'('variable #',I2,': velocity_z')')ivar endif #if NENER>0 ! Non-thermal pressures do ivar=ndim+2,ndim+1+nener write(ilun,'('variable #',I2,': non_thermal_pressure_',I1)')ivar,ivar-ndim-1 end do #endif ivar=ndim+2+nener write(ilun,'('variable #',I2,': thermal_pressure')')ivar #if NVAR>NDIM+2+NENER ! Passive scalars do ivar=ndim+3+nener,nvar write(ilun,'('variable #',I2,': passive_scalar_',I1)')ivar,ivar-ndim-2-nener end do #endif close(ilun) end subroutine file_descriptor_hydro subroutine backup_hydro(filename) use amr_commons use hydro_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename integer::i,ivar,ncache,ind,ilevel,igrid,iskip,ilun,istart,ibound,irad integer,allocatable,dimension(:)::ind_grid real(dp),allocatable,dimension(:)::xdp character(LEN=5)::nchar ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc integer,parameter::tag=1121 integer::dummy_io,info2 if(verbose)write(*,*)'Entering backup_hydro' ilun=ncpu+myid+10 call title(myid,nchar) fileloc=TRIM(filename)//TRIM(nchar) ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(unit=ilun,file=fileloc,form='unformatted') write(ilun)ncpu write(ilun)nvar write(ilun)ndim write(ilun)nlevelmax write(ilun)nboundary write(ilun)gamma do ilevel=1,nlevelmax do ibound=1,nboundary+ncpu if(ibound<=ncpu)then ncache=numbl(ibound,ilevel) istart=headl(ibound,ilevel) else ncache=numbb(ibound-ncpu,ilevel) istart=headb(ibound-ncpu,ilevel) end if write(ilun)ilevel write(ilun)ncache if(ncache>0)then allocate(ind_grid(1:ncache),xdp(1:ncache)) ! Loop over level grids igrid=istart do i=1,ncache ind_grid(i)=igrid igrid=next(igrid) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do ivar=1,ndim+1 if(ivar==1)then ! Write density do i=1,ncache xdp(i)=uold(ind_grid(i)+iskip,1) end do else if(ivar>=2.and.ivar<=ndim+1)then ! Write velocity field do i=1,ncache xdp(i)=uold(ind_grid(i)+iskip,ivar)/max(uold(ind_grid(i)+iskip,1),smallr) end do endif write(ilun)xdp end do #if NENER>0 ! Write non-thermal pressures do ivar=ndim+3,ndim+2+nener do i=1,ncache xdp(i)=(gamma_rad(ivar-ndim-2)-1d0)*uold(ind_grid(i)+iskip,ivar) end do write(ilun)xdp end do #endif ! Write thermal pressure do i=1,ncache xdp(i)=uold(ind_grid(i)+iskip,ndim+2) xdp(i)=xdp(i)-0.5d0*uold(ind_grid(i)+iskip,2)**2/max(uold(ind_grid(i)+iskip,1),smallr) #if NDIM>1 xdp(i)=xdp(i)-0.5d0*uold(ind_grid(i)+iskip,3)**2/max(uold(ind_grid(i)+iskip,1),smallr) #endif #if NDIM>2 xdp(i)=xdp(i)-0.5d0*uold(ind_grid(i)+iskip,4)**2/max(uold(ind_grid(i)+iskip,1),smallr) #endif #if NENER>0 do irad=1,nener xdp(i)=xdp(i)-uold(ind_grid(i)+iskip,ndim+2+irad) end do #endif xdp(i)=(gamma-1d0)*xdp(i) end do write(ilun)xdp #if NVAR>NDIM+2+NENER ! Write passive scalars do ivar=ndim+3+nener,nvar do i=1,ncache xdp(i)=uold(ind_grid(i)+iskip,ivar)/max(uold(ind_grid(i)+iskip,1),smallr) end do write(ilun)xdp end do #endif end do deallocate(ind_grid, xdp) end if end do end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif end subroutine backup_hydro ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/output_part.f90 subroutine backup_part(filename) use amr_commons use pm_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename integer::i,idim,ilun,ipart ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc character(LEN=5)::nchar real(dp),allocatable,dimension(:)::xdp integer,allocatable,dimension(:)::ii integer(i8b),allocatable,dimension(:)::ii8 integer,allocatable,dimension(:)::ll logical,allocatable,dimension(:)::nb integer,parameter::tag=1122 integer::dummy_io,info2 if(verbose)write(*,*)'Entering backup_part' ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif ilun=2*ncpu+myid+10 call title(myid,nchar) fileloc=TRIM(filename)//TRIM(nchar) open(unit=ilun,file=TRIM(fileloc),form='unformatted') rewind(ilun) ! Write header write(ilun)ncpu write(ilun)ndim write(ilun)npart write(ilun)localseed write(ilun)nstar_tot write(ilun)mstar_tot write(ilun)mstar_lost write(ilun)nsink ! Write position allocate(xdp(1:npart)) do idim=1,ndim ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 xdp(ipart)=xp(i,idim) end if end do write(ilun)xdp end do ! Write velocity do idim=1,ndim ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 xdp(ipart)=vp(i,idim) end if end do write(ilun)xdp end do ! Write mass ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 xdp(ipart)=mp(i) end if end do write(ilun)xdp deallocate(xdp) ! Write identity allocate(ii8(1:npart)) ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 ii8(ipart)=idp(i) end if end do write(ilun)ii8 deallocate(ii8) ! Write level allocate(ll(1:npart)) ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 ll(ipart)=levelp(i) end if end do write(ilun)ll deallocate(ll) #ifdef OUTPUT_PARTICLE_POTENTIAL ! Write potential (added by AP) allocate(xdp(1:npart)) ipart=0 do i=1, npartmax if(levelp(i)>0) then ipart=ipart+1 xdp(ipart)=ptcl_phi(i) end if end do write(ilun)xdp deallocate(xdp) #endif ! Write birth epoch if(star.or.sink)then allocate(xdp(1:npart)) ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 xdp(ipart)=tp(i) end if end do write(ilun)xdp ! CHANGED BY TTG (FEB 2017) ! Write metallicity ! if(metal)then ! ipart=0 ! do i=1,npartmax ! if(levelp(i)>0)then ! ipart=ipart+1 ! xdp(ipart)=zp(i) ! end if ! end do ! write(ilun)xdp ! end if deallocate(xdp) end if ! ADDED BY TTG (FEB 2017) ! to allow the use of metallicity as a tracer for different gas components ! Write metallicity if(metal)then allocate(xdp(1:npart)) ipart=0 do i=1,npartmax if(levelp(i)>0)then ipart=ipart+1 xdp(ipart)=zp(i) end if end do write(ilun)xdp deallocate(xdp) end if close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif end subroutine backup_part ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/output_poisson.f90 subroutine backup_poisson(filename) use amr_commons use poisson_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::filename character(LEN=256)::filename integer::i,ivar,ncache,ind,ilevel,igrid,iskip,ilun,istart,ibound integer,allocatable,dimension(:)::ind_grid real(dp),allocatable,dimension(:)::xdp character(LEN=5)::nchar ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::fileloc character(LEN=256)::fileloc integer,parameter::tag=1123 integer::dummy_io,info2 if(verbose)write(*,*)'Entering backup_poisson' ilun=ncpu+myid+10 call title(myid,nchar) fileloc=TRIM(filename)//TRIM(nchar) ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif open(unit=ilun,file=fileloc,form='unformatted') write(ilun)ncpu write(ilun)ndim+1 write(ilun)nlevelmax write(ilun)nboundary do ilevel=1,nlevelmax do ibound=1,nboundary+ncpu if(ibound<=ncpu)then ncache=numbl(ibound,ilevel) istart=headl(ibound,ilevel) else ncache=numbb(ibound-ncpu,ilevel) istart=headb(ibound-ncpu,ilevel) end if write(ilun)ilevel write(ilun)ncache if(ncache>0)then allocate(ind_grid(1:ncache),xdp(1:ncache)) ! Loop over level grids igrid=istart do i=1,ncache ind_grid(i)=igrid igrid=next(igrid) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax ! Write potential do i=1,ncache xdp(i)=phi(ind_grid(i)+iskip) end do write(ilun)xdp ! Write force do ivar=1,ndim do i=1,ncache xdp(i)=f(ind_grid(i)+iskip,ivar) end do write(ilun)xdp end do end do deallocate(ind_grid, xdp) end if end do end do close(ilun) ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif end subroutine backup_poisson ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/particle_tree.f90 !################################################################ !################################################################ !################################################################ !################################################################ subroutine init_tree use pm_commons use amr_commons use dice_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif !------------------------------------------------------ ! This subroutine build the particle linked list at the ! coarse level for ALL the particles in the box. ! This routine should be used only as initial set up for ! the particle tree. !------------------------------------------------------ integer::ipart,idim,i,nxny,ilevel integer::npart1,info,icpu,nx_loc logical::error real(dp),dimension(1:3)::xbound integer,dimension(1:nvector),save::ix,iy,iz integer,dimension(1:nvector),save::ind_grid,ind_part logical,dimension(1:nvector),save::ok=.true. real(dp),dimension(1:3)::skip_loc real(dp)::scale if(verbose)write(*,*)' Entering init_tree' ! Local constants nxny=nx*ny xbound(1:3)=(/dble(nx),dble(ny),dble(nz)/) nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) !---------------------------------- ! Initialize particle linked list !---------------------------------- prevp(1)=0; nextp(1)=2 do ipart=2,npartmax-1 prevp(ipart)=ipart-1 nextp(ipart)=ipart+1 end do prevp(npartmax)=npartmax-1; nextp(npartmax)=0 ! Free memory linked list headp_free=npart+1 tailp_free=npartmax numbp_free=tailp_free-headp_free+1 if(numbp_free>0)then prevp(headp_free)=0 end if nextp(tailp_free)=0 #ifndef WITHOUTMPI call MPI_ALLREDUCE(numbp_free,numbp_free_tot,1,MPI_INTEGER,MPI_MIN,& & MPI_COMM_WORLD,info) #endif #ifdef WITHOUTMPI numbp_free_tot=numbp_free #endif !-------------- ! Periodic box !-------------- do idim=1,ndim do ipart=1,npart if(xp(ipart,idim)/scale+skip_loc(idim)<0.0d0) & & xp(ipart,idim)=xp(ipart,idim)+(xbound(idim)-skip_loc(idim))*scale if(xp(ipart,idim)/scale+skip_loc(idim)>=xbound(idim)) & & xp(ipart,idim)=xp(ipart,idim)-(xbound(idim)-skip_loc(idim))*scale end do if(sink)then do ipart=1,nsink if(xsink(ipart,idim)/scale+skip_loc(idim)<0.0d0) & & xsink(ipart,idim)=xsink(ipart,idim)+(xbound(idim)-skip_loc(idim))*scale if(xsink(ipart,idim)/scale+skip_loc(idim)>=xbound(idim)) & & xsink(ipart,idim)=xsink(ipart,idim)-(xbound(idim)-skip_loc(idim))*scale end do endif end do !---------------------------------- ! Reset all linked lists at level 1 !---------------------------------- do i=1,active(1)%ngrid headp(active(1)%igrid(i))=0 tailp(active(1)%igrid(i))=0 numbp(active(1)%igrid(i))=0 end do do icpu=1,ncpu do i=1,reception(icpu,1)%ngrid headp(reception(icpu,1)%igrid(i))=0 tailp(reception(icpu,1)%igrid(i))=0 numbp(reception(icpu,1)%igrid(i))=0 end do end do !------------------------------------------------ ! Build linked list at level 1 by vector sweeps !------------------------------------------------ do ipart=1,npart,nvector npart1=min(nvector,npart-ipart+1) ! Gather particles do i=1,npart1 ind_part(i)=ipart+i-1 end do ! Compute coarse cell #if NDIM>0 do i=1,npart1 ix(i)=int(xp(ind_part(i),1)/scale+skip_loc(1)) end do #endif #if NDIM>1 do i=1,npart1 iy(i)=int(xp(ind_part(i),2)/scale+skip_loc(2)) end do #endif #if NDIM>2 do i=1,npart1 iz(i)=int(xp(ind_part(i),3)/scale+skip_loc(3)) end do #endif ! Compute level 1 grid index error=.false. do i=1,npart1 ind_grid(i)=son(1+ix(i)+nx*iy(i)+nxny*iz(i)) if(ind_grid(i)==0)error=.true. end do if(error)then write(*,*)'Error in init_tree' write(*,*)'Particles appear in unrefined regions' call clean_stop end if ! Add particle to level 1 linked list call add_list(ind_part,ind_grid,ok,npart1) end do ! destroy and recreate cloud particles to account for changes in sink ! radius, newly added sinks, etc do ilevel=levelmin-1,1,-1 call merge_tree_fine(ilevel) end do call kill_entire_cloud(1) call create_cloud_from_sink ! Sort particles down to levelmin do ilevel=1,levelmin-1 call make_tree_fine(ilevel) call kill_tree_fine(ilevel) ! Update boundary conditions for remaining particles call virtual_tree_fine(ilevel) end do end subroutine init_tree !################################################################ !################################################################ !################################################################ !################################################################ subroutine make_tree_fine(ilevel) use pm_commons use amr_commons implicit none integer::ilevel !----------------------------------------------------------------------- ! This subroutine checks if particles have moved from their parent grid ! to one of the 3**ndim neighboring sister grids. The particle is then ! disconnected from the parent grid linked list, and connected to the ! corresponding sister grid linked list. If the sister grid does ! not exist, the particle is left to its original parent grid. ! Particles must not move to a distance greater than direct neighbors ! boundaries. Otherwise an error message is issued and the code stops. !----------------------------------------------------------------------- integer::idim,nx_loc real(dp)::dx,scale real(dp),dimension(1:3)::xbound real(dp),dimension(1:3)::skip_loc integer::igrid,jgrid,ipart,jpart,next_part integer::ig,ip,npart1,icpu integer,dimension(1:nvector),save::ind_grid,ind_part,ind_grid_part if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Mesh spacing in that level dx=0.5D0**ilevel xbound(1:3)=(/dble(nx),dble(ny),dble(nz)/) nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) ! Loop over cpus do icpu=1,ncpu igrid=headl(icpu,ilevel) ig=0 ip=0 ! Loop over grids do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid if(npart1>0)then ig=ig+1 ind_grid(ig)=igrid ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) if(ig==0)then ig=1 ind_grid(ig)=igrid end if ip=ip+1 ind_part(ip)=ipart ind_grid_part(ip)=ig ! Gather nvector particles if(ip==nvector)then call check_tree(ind_grid,ind_part,ind_grid_part,ig,ip,ilevel) ip=0 ig=0 end if ipart=next_part ! Go to next particle end do ! End loop over particles end if igrid=next(igrid) ! Go to next grid end do ! End loop over grids if(ip>0)call check_tree(ind_grid,ind_part,ind_grid_part,ig,ip,ilevel) end do ! End loop over cpus ! Periodic boundaries if(sink)then do idim=1,ndim do ipart=1,nsink if(xsink(ipart,idim)/scale+skip_loc(idim)<0.0d0) & & xsink(ipart,idim)=xsink(ipart,idim)+(xbound(idim)-skip_loc(idim))*scale if(xsink(ipart,idim)/scale+skip_loc(idim)>=xbound(idim)) & & xsink(ipart,idim)=xsink(ipart,idim)-(xbound(idim)-skip_loc(idim))*scale end do end do endif 111 format(' Entering make_tree_fine for level ',I2) end subroutine make_tree_fine !################################################################ !################################################################ !################################################################ !################################################################ subroutine check_tree(ind_grid,ind_part,ind_grid_part,ng,np,ilevel) use amr_commons use pm_commons implicit none integer::ng,np,ilevel integer,dimension(1:nvector)::ind_grid integer,dimension(1:nvector)::ind_grid_part,ind_part !----------------------------------------------------------------------- ! This routine is called by make_tree_fine. !----------------------------------------------------------------------- logical::error integer::i,j,idim,nx_loc real(dp)::dx,xxx,scale real(dp),dimension(1:3)::xbound ! Grid-based arrays integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids real(dp),dimension(1:nvector,1:ndim),save::x0 integer ,dimension(1:nvector),save::ind_father ! Particle-based arrays integer,dimension(1:nvector),save::ind_son,igrid_son integer,dimension(1:nvector),save::list1,list2 logical,dimension(1:nvector),save::ok real(dp),dimension(1:3)::skip_loc ! Mesh spacing in that level dx=0.5D0**ilevel xbound(1:3)=(/dble(nx),dble(ny),dble(nz)/) nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ng x0(i,idim)=xg(ind_grid(i),idim)-3.0D0*dx end do end do ! Gather 27 neighboring father cells (should be present anytime !) do i=1,ng ind_father(i)=father(ind_grid(i)) end do call get3cubefather(ind_father,nbors_father_cells,nbors_father_grids,ng,ilevel) ! Compute particle position in 3-cube error=.false. ind_son(1:np)=1 ok(1:np)=.false. do idim=1,ndim do j=1,np i=int((xp(ind_part(j),idim)/scale+skip_loc(idim)-x0(ind_grid_part(j),idim))/dx/2.0D0) if(i<0.or.i>2)error=.true. ind_son(j)=ind_son(j)+i*3**(idim-1) ! Check if particle has escaped from its parent grid ok(j)=ok(j).or.i.ne.1 end do end do if(error)then write(*,*)'Problem in check_tree at level ',ilevel write(*,*)'A particle has moved outside allowed boundaries' do idim=1,ndim do j=1,np i=int((xp(ind_part(j),idim)/scale+skip_loc(idim)-x0(ind_grid_part(j),idim))/dx/2.0D0) if(i<0.or.i>2)then write(*,*)xp(ind_part(j),idim),x0(ind_grid_part(j),idim) endif end do end do stop end if ! Compute neighboring grid index do j=1,np igrid_son(j)=son(nbors_father_cells(ind_grid_part(j),ind_son(j))) end do ! If escaped particle sits in unrefined cell, leave it to its parent grid. ! For ilevel=levelmin, this should never happen. do j=1,np if(igrid_son(j)==0)ok(j)=.false. end do ! Periodic box do idim=1,ndim do j=1,np if(ok(j))then xxx=xp(ind_part(j),idim)/scale+skip_loc(idim)-xg(igrid_son(j),idim) if(xxx> xbound(idim)/2.0)then xp(ind_part(j),idim)=xp(ind_part(j),idim)-(xbound(idim)-skip_loc(idim))*scale endif if(xxx<-xbound(idim)/2.0)then xp(ind_part(j),idim)=xp(ind_part(j),idim)+(xbound(idim)-skip_loc(idim))*scale endif endif enddo enddo ! Switch particles linked list do j=1,np if(ok(j))then list1(j)=ind_grid(ind_grid_part(j)) list2(j)=igrid_son(j) end if end do call remove_list(ind_part,list1,ok,np) call add_list(ind_part,list2,ok,np) end subroutine check_tree !################################################################ !################################################################ !################################################################ !################################################################ subroutine kill_tree_fine(ilevel) use pm_commons use amr_commons implicit none integer::ilevel !------------------------------------------------------------------------ ! This routine sorts particle between ilevel grids and their ! ilevel+1 children grids. Particles are disconnected from their parent ! grid linked list and connected to their corresponding child grid linked ! list. If the child grid does not exist, the particle is left to its ! original parent grid. !------------------------------------------------------------------------ integer::igrid,jgrid,ipart,jpart,next_part integer::i,ig,ip,npart1,icpu integer,dimension(1:nvector),save::ind_grid,ind_part,ind_grid_part if(numbtot(1,ilevel)==0)return if(ilevel==nlevelmax)return if(numbtot(1,ilevel+1)==0)return if(verbose)write(*,111)ilevel ! Reset all linked lists at level ilevel+1 do i=1,active(ilevel+1)%ngrid headp(active(ilevel+1)%igrid(i))=0 tailp(active(ilevel+1)%igrid(i))=0 numbp(active(ilevel+1)%igrid(i))=0 end do do icpu=1,ncpu do i=1,reception(icpu,ilevel+1)%ngrid headp(reception(icpu,ilevel+1)%igrid(i))=0 tailp(reception(icpu,ilevel+1)%igrid(i))=0 numbp(reception(icpu,ilevel+1)%igrid(i))=0 end do end do ! Sort particles between ilevel and ilevel+1 ! Loop over cpus do icpu=1,ncpu igrid=headl(icpu,ilevel) ig=0 ip=0 ! Loop over grids do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid if(npart1>0)then ig=ig+1 ind_grid(ig)=igrid ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) if(ig==0)then ig=1 ind_grid(ig)=igrid end if ip=ip+1 ind_part(ip)=ipart ind_grid_part(ip)=ig if(ip==nvector)then call kill_tree(ind_grid,ind_part,ind_grid_part,ig,ip,ilevel) ip=0 ig=0 end if ipart=next_part ! Go to next particle end do ! End loop over particles end if igrid=next(igrid) ! Go to next grid end do ! End loop over grids if(ip>0)call kill_tree(ind_grid,ind_part,ind_grid_part,ig,ip,ilevel) end do ! End loop over cpus 111 format(' Entering kill_tree_fine for level ',I2) end subroutine kill_tree_fine !################################################################ !################################################################ !################################################################ !################################################################ subroutine kill_tree(ind_grid,ind_part,ind_grid_part,ng,np,ilevel) use amr_commons use pm_commons implicit none integer::ng,np,ilevel integer,dimension(1:nvector)::ind_grid integer,dimension(1:nvector)::ind_grid_part,ind_part !----------------------------------------------------------------------- ! This routine is called by subroutine kill_tree_fine. !----------------------------------------------------------------------- integer::i,j,idim,nx_loc real(dp)::dx,xxx,scale ! Grid based arrays real(dp),dimension(1:nvector,1:ndim),save::x0 ! Particle based arrays integer,dimension(1:nvector),save::igrid_son,ind_son integer,dimension(1:nvector),save::list1,list2 logical,dimension(1:nvector),save::ok real(dp),dimension(1:3)::skip_loc ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) ! Compute lower left corner of grid do idim=1,ndim do i=1,ng x0(i,idim)=xg(ind_grid(i),idim)-dx end do end do ! Select only particles within grid boundaries ok(1:np)=.true. do idim=1,ndim do j=1,np xxx=(xp(ind_part(j),idim)/scale+skip_loc(idim)-x0(ind_grid_part(j),idim))/dx ok(j)=ok(j) .and. (xxx >= 0.d0 .and. xxx < 2.0d0) end do end do ! Determines in which son particles sit ind_son(1:np)=0 do idim=1,ndim do j=1,np i=int((xp(ind_part(j),idim)/scale+skip_loc(idim)-x0(ind_grid_part(j),idim))/dx) ind_son(j)=ind_son(j)+i*2**(idim-1) end do end do do j=1,np ind_son(j)=ncoarse+ind_son(j)*ngridmax+ind_grid(ind_grid_part(j)) end do ! Determine which son cell is refined igrid_son(1:np)=0 do j=1,np if(ok(j))igrid_son(j)=son(ind_son(j)) end do do j=1,np ok(j)=igrid_son(j)>0 end do ! Compute particle linked list do j=1,np if(ok(j))then list1(j)=ind_grid(ind_grid_part(j)) list2(j)=igrid_son(j) end if end do ! Remove particles from their original linked lists call remove_list(ind_part,list1,ok,np) ! Add particles to their new linked lists call add_list(ind_part,list2,ok,np) end subroutine kill_tree !################################################################ !################################################################ !################################################################ !################################################################ subroutine merge_tree_fine(ilevel) use pm_commons use amr_commons implicit none integer::ilevel !-------------------------------------------------------------------- ! This routine disconnects all particles contained in children grids ! and connects them to their parent grid linked list. !--------------------------------------------------------------- integer::igrid,iskip,icpu integer::i,ind,ncache,ngrid integer,dimension(1:nvector),save::ind_grid,ind_cell,ind_grid_son logical,dimension(1:nvector),save::ok if(numbtot(1,ilevel)==0)return if(ilevel==nlevelmax)return if(verbose)write(*,111)ilevel ! Loop over cpus do icpu=1,ncpu if(icpu==myid)then ncache=active(ilevel)%ngrid else ncache=reception(icpu,ilevel)%ngrid end if ! Loop over grids by vector sweeps do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) if(icpu==myid)then do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do else do i=1,ngrid ind_grid(i)=reception(icpu,ilevel)%igrid(igrid+i-1) end do end if ! Loop over children grids do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,ngrid ind_cell(i)=iskip+ind_grid(i) end do do i=1,ngrid ind_grid_son(i)=son(ind_cell(i)) end do do i=1,ngrid ok(i)=ind_grid_son(i)>0 end do do i=1,ngrid if(ok(i))then if(numbp(ind_grid_son(i))>0)then if(numbp(ind_grid(i))>0)then ! Connect son linked list at the tail of father linked list nextp(tailp(ind_grid(i)))=headp(ind_grid_son(i)) prevp(headp(ind_grid_son(i)))=tailp(ind_grid(i)) numbp(ind_grid(i))=numbp(ind_grid(i))+numbp(ind_grid_son(i)) tailp(ind_grid(i))=tailp(ind_grid_son(i)) else ! Initialize father linked list headp(ind_grid(i))=headp(ind_grid_son(i)) tailp(ind_grid(i))=tailp(ind_grid_son(i)) numbp(ind_grid(i))=numbp(ind_grid_son(i)) end if end if end if end do end do ! End loop over children end do ! End loop over grids end do ! End loop over cpus 111 format(' Entering merge_tree_fine for level ',I2) end subroutine merge_tree_fine !################################################################ !################################################################ !################################################################ !################################################################ subroutine virtual_tree_fine(ilevel) use pm_commons use amr_commons use dice_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel !----------------------------------------------------------------------- ! This subroutine move particles across processors boundaries. !----------------------------------------------------------------------- integer::igrid,ipart,jpart,ncache_tot,next_part integer::ip,ipcom,npart1,icpu,ncache integer::info,buf_count,tag=101,tagf=102,tagu=102 integer::countsend,countrecv #ifndef WITHOUTMPI integer,dimension(MPI_STATUS_SIZE,2*ncpu)::statuses integer,dimension(2*ncpu)::reqsend,reqrecv integer,dimension(ncpu)::sendbuf,recvbuf #endif integer,dimension(1:nvector),save::ind_part,ind_list,ind_com logical::ok_free,ok_all integer::particle_data_width if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel #ifdef WITHOUTMPI return #endif #ifndef WITHOUTMPI ! Count particle sitting in virtual boundaries do icpu=1,ncpu reception(icpu,ilevel)%npart=0 do igrid=1,reception(icpu,ilevel)%ngrid reception(icpu,ilevel)%npart=reception(icpu,ilevel)%npart+& & numbp(reception(icpu,ilevel)%igrid(igrid)) end do sendbuf(icpu)=reception(icpu,ilevel)%npart end do ! Calculate how many particle properties are being transferred particle_data_width = twondim+1 ! CHANGED BY TTG (FEB 2017) ! to allow the use of metallicity as a tracer for different gas components ! DICE / RESTART specific ! if(star.or.sink)then if(metal)then particle_data_width=twondim+3 else particle_data_width=twondim+2 endif ! endif #ifdef OUTPUT_PARTICLE_POTENTIAL particle_data_width=particle_data_width+1 #endif ! DICE / RESTART patch: add gas temperature (and allow for an additional passive tracer) if(dice_init) particle_data_width=particle_data_width+2 ! Allocate communication buffer in emission do icpu=1,ncpu ncache=reception(icpu,ilevel)%npart if(ncache>0)then ! Allocate reception buffer allocate(reception(icpu,ilevel)%fp(1:ncache,1:3)) allocate(reception(icpu,ilevel)%up(1:ncache,1:particle_data_width)) end if end do ! Gather particle in communication buffer do icpu=1,ncpu if(reception(icpu,ilevel)%npart>0)then ! Gather particles by vector sweeps ipcom=0 ip=0 do igrid=1,reception(icpu,ilevel)%ngrid npart1=numbp(reception(icpu,ilevel)%igrid(igrid)) ipart =headp(reception(icpu,ilevel)%igrid(igrid)) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ip=ip+1 ipcom=ipcom+1 ind_com (ip)=ipcom ind_part(ip)=ipart ind_list(ip)=reception(icpu,ilevel)%igrid(igrid) reception(icpu,ilevel)%fp(ipcom,1)=igrid if(ip==nvector)then call fill_comm(ind_part,ind_com,ind_list,ip,ilevel,icpu) ip=0 end if ipart=next_part ! Go to next particle end do end do if(ip>0)call fill_comm(ind_part,ind_com,ind_list,ip,ilevel,icpu) end if end do ! Communicate virtual particle number to parent cpu call MPI_ALLTOALL(sendbuf,1,MPI_INTEGER,recvbuf,1,MPI_INTEGER,MPI_COMM_WORLD,info) ! Allocate communication buffer in reception do icpu=1,ncpu emission(icpu,ilevel)%npart=recvbuf(icpu) ncache=emission(icpu,ilevel)%npart if(ncache>0)then ! Allocate reception buffer allocate(emission(icpu,ilevel)%fp(1:ncache,1:3)) allocate(emission(icpu,ilevel)%up(1:ncache,1:particle_data_width)) end if end do ! Receive particles countrecv=0 do icpu=1,ncpu ncache=emission(icpu,ilevel)%npart if(ncache>0)then buf_count=ncache*3 countrecv=countrecv+1 #ifndef LONGINT call MPI_IRECV(emission(icpu,ilevel)%fp,buf_count, & & MPI_INTEGER,icpu-1,& & tagf,MPI_COMM_WORLD,reqrecv(countrecv),info) #else call MPI_IRECV(emission(icpu,ilevel)%fp,buf_count, & & MPI_INTEGER8,icpu-1,& & tagf,MPI_COMM_WORLD,reqrecv(countrecv),info) #endif buf_count=ncache*particle_data_width countrecv=countrecv+1 call MPI_IRECV(emission(icpu,ilevel)%up,buf_count, & & MPI_DOUBLE_PRECISION,icpu-1,& & tagu,MPI_COMM_WORLD,reqrecv(countrecv),info) end if end do ! Send particles countsend=0 do icpu=1,ncpu ncache=reception(icpu,ilevel)%npart if(ncache>0)then buf_count=ncache*3 countsend=countsend+1 #ifndef LONGINT call MPI_ISEND(reception(icpu,ilevel)%fp,buf_count, & & MPI_INTEGER,icpu-1,& & tagf,MPI_COMM_WORLD,reqsend(countsend),info) #else call MPI_ISEND(reception(icpu,ilevel)%fp,buf_count, & & MPI_INTEGER8,icpu-1,& & tagf,MPI_COMM_WORLD,reqsend(countsend),info) #endif buf_count=ncache*particle_data_width countsend=countsend+1 call MPI_ISEND(reception(icpu,ilevel)%up,buf_count, & & MPI_DOUBLE_PRECISION,icpu-1,& & tagu,MPI_COMM_WORLD,reqsend(countsend),info) end if end do ! Wait for full completion of receives call MPI_WAITALL(countrecv,reqrecv,statuses,info) ! Compute total number of newly created particles ncache_tot=0 do icpu=1,ncpu ncache_tot=ncache_tot+emission(icpu,ilevel)%npart end do ! Wait for full completion of sends call MPI_WAITALL(countsend,reqsend,statuses,info) call MPI_ALLREDUCE(numbp_free,numbp_free_tot,1,MPI_INTEGER,MPI_MIN,& & MPI_COMM_WORLD,info) ok_free=(numbp_free-ncache_tot)>=0 if(.not. ok_free)then write(*,*)'No more free memory for particles' write(*,*)'Increase npartmax' write(*,*)numbp_free,ncache_tot write(*,*)myid write(*,*)emission(1:ncpu,ilevel)%npart write(*,*)'============================' write(*,*)reception(1:ncpu,ilevel)%npart call MPI_ABORT(MPI_COMM_WORLD,1,info) end if ! Scatter new particles from communication buffer do icpu=1,ncpu ! Loop over particles by vector sweeps ncache=emission(icpu,ilevel)%npart do ipart=1,ncache,nvector npart1=min(nvector,ncache-ipart+1) do ip=1,npart1 ind_com(ip)=ipart+ip-1 end do call empty_comm(ind_com,npart1,ilevel,icpu) end do end do ! Deallocate temporary communication buffers do icpu=1,ncpu ncache=emission(icpu,ilevel)%npart if(ncache>0)then deallocate(emission(icpu,ilevel)%fp) deallocate(emission(icpu,ilevel)%up) end if ncache=reception(icpu,ilevel)%npart if(ncache>0)then deallocate(reception(icpu,ilevel)%fp) deallocate(reception(icpu,ilevel)%up) end if end do #endif 111 format(' Entering virtual_tree_fine for level ',I2) end subroutine virtual_tree_fine !################################################################ !################################################################ !################################################################ !################################################################ subroutine fill_comm(ind_part,ind_com,ind_list,np,ilevel,icpu) use pm_commons use amr_commons use dice_commons implicit none integer::np,ilevel,icpu integer,dimension(1:nvector)::ind_part,ind_com,ind_list integer::current_property integer::i,idim logical,dimension(1:nvector),save::ok=.true. ! Gather particle level and identity do i=1,np reception(icpu,ilevel)%fp(ind_com(i),2)=levelp(ind_part(i)) reception(icpu,ilevel)%fp(ind_com(i),3)=idp (ind_part(i)) end do ! Gather particle position and velocity do idim=1,ndim do i=1,np reception(icpu,ilevel)%up(ind_com(i),idim )=xp(ind_part(i),idim) reception(icpu,ilevel)%up(ind_com(i),idim+ndim)=vp(ind_part(i),idim) end do end do current_property = twondim+1 ! Gather particle mass do i=1,np reception(icpu,ilevel)%up(ind_com(i),current_property)=mp(ind_part(i)) end do current_property = current_property+1 #ifdef OUTPUT_PARTICLE_POTENTIAL ! Gather particle potential do i=1,np reception(icpu,ilevel)%up(ind_com(i),current_property)=ptcl_phi(ind_part(i)) end do current_property = current_property+1 #endif ! Gather particle birth epoch if(star.or.sink)then do i=1,np reception(icpu,ilevel)%up(ind_com(i),current_property)=tp(ind_part(i)) end do current_property = current_property+1 ! CHANGED BY TTG (FEB 2017) ! if(metal)then ! do i=1,np ! reception(icpu,ilevel)%up(ind_com(i),current_property)=zp(ind_part(i)) ! end do ! current_property = current_property+1 ! end if end if ! ADDED BY TTG (FEB 2017) ! to allow the use of metallicity for gas components ! DICE / RESTART specific if(metal)then do i=1,np reception(icpu,ilevel)%up(ind_com(i),current_property)=zp(ind_part(i)) end do current_property = current_property+1 end if ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) do i=1,np reception(icpu,ilevel)%up(ind_com(i),current_property)=trcp(ind_part(i)) end do current_property = current_property+1 ! DICE / RESTART patch: gas temperature if(dice_init) then do i=1,np reception(icpu,ilevel)%up(ind_com(i),current_property)=up(ind_part(i)) end do current_property = current_property+1 if(cosmo) then do i=1,np reception(icpu,ilevel)%up(ind_com(i),current_property)=maskp(ind_part(i)) end do current_property = current_property+1 endif endif ! Remove particles from parent linked list call remove_list(ind_part,ind_list,ok,np) call add_free(ind_part,np) end subroutine fill_comm !################################################################ !################################################################ !################################################################ !################################################################ subroutine empty_comm(ind_com,np,ilevel,icpu) use pm_commons use amr_commons use dice_commons implicit none integer::np,icpu,ilevel integer,dimension(1:nvector)::ind_com integer::i,idim,igrid integer,dimension(1:nvector),save::ind_list,ind_part logical,dimension(1:nvector),save::ok=.true. integer::current_property ! Compute parent grid index do i=1,np igrid=emission(icpu,ilevel)%fp(ind_com(i),1) ind_list(i)=emission(icpu,ilevel)%igrid(igrid) end do ! Add particle to parent linked list call remove_free(ind_part,np) call add_list(ind_part,ind_list,ok,np) ! Scatter particle level and identity do i=1,np levelp(ind_part(i))=emission(icpu,ilevel)%fp(ind_com(i),2) idp (ind_part(i))=emission(icpu,ilevel)%fp(ind_com(i),3) end do ! Scatter particle position and velocity do idim=1,ndim do i=1,np xp(ind_part(i),idim)=emission(icpu,ilevel)%up(ind_com(i),idim ) vp(ind_part(i),idim)=emission(icpu,ilevel)%up(ind_com(i),idim+ndim) end do end do current_property = twondim+1 ! Scatter particle mass do i=1,np mp(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) end do current_property = current_property+1 #ifdef OUTPUT_PARTICLE_POTENTIAL ! Scatter particle phi do i=1,np ptcl_phi(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) end do current_property = current_property+1 #endif ! Scatter particle birth eopch if(star.or.sink)then do i=1,np tp(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) end do current_property = current_property+1 ! CHANGED BY TTG (FEB 2017) ! if(metal)then ! do i=1,np ! zp(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) ! end do ! current_property = current_property+1 ! end if end if ! ADDED BY TTG (FEB 2017) ! to allow the use of metallicity for gas components ! DICE / RESTART specific if(metal)then do i=1,np zp(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) end do current_property = current_property+1 end if ! ADDED BY TTG APR 2017: gas particle tracer (passive scalar) do i=1,np trcp(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) end do current_property = current_property+1 ! DICE / RESTART patch: gas temperature if(dice_init) then do i=1,np up(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) end do current_property = current_property+1 if(cosmo) then do i=1,np maskp(ind_part(i))=emission(icpu,ilevel)%up(ind_com(i),current_property) end do current_property = current_property+1 endif endif end subroutine empty_comm !################################################################ !################################################################ !################################################################ !################################################################ ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/pm_commons.f90 module pm_commons use amr_parameters use pm_parameters use random ! Sink particle related arrays real(dp),allocatable,dimension(:)::msink,c2sink,oksink_new,oksink_all real(dp),allocatable,dimension(:)::tsink,tsink_new,tsink_all real(dp),allocatable,dimension(:)::msink_new,msink_all real(dp),allocatable,dimension(:)::mseed,mseed_new,mseed_all real(dp),allocatable,dimension(:)::xmsink real(dp),allocatable,dimension(:)::dMsink_overdt,dMBHoverdt real(dp),allocatable,dimension(:)::rho_gas,volume_gas,eps_sink real(dp),allocatable,dimension(:,:)::vel_gas real(dp),allocatable,dimension(:)::delta_mass,delta_mass_new,delta_mass_all real(dp),allocatable,dimension(:)::wden,weth,wvol,wdiv,wden_new,weth_new,wvol_new,wdiv_new real(dp),allocatable,dimension(:,:)::wmom,wmom_new real(dp),allocatable,dimension(:,:)::vsink,vsink_new,vsink_all real(dp),allocatable,dimension(:,:)::fsink,fsink_new,fsink_all real(dp),allocatable,dimension(:,:,:)::vsnew,vsold real(dp),allocatable,dimension(:,:,:)::fsink_partial,sink_jump real(dp),allocatable,dimension(:,:)::lsink,lsink_new,lsink_all!sink angular momentum real(dp),allocatable,dimension(:,:)::xsink,xsink_new,xsink_all real(dp),allocatable,dimension(:)::acc_rate,acc_lum !sink accretion rate and luminosity real(dp),allocatable,dimension(:,:)::weighted_density,weighted_volume,weighted_ethermal,weighted_divergence real(dp),allocatable,dimension(:,:,:)::weighted_momentum real(dp),allocatable,dimension(:)::dt_acc ! maximum timestep allowed by the sink real(dp),allocatable,dimension(:)::rho_sink_tff integer,allocatable,dimension(:)::idsink,idsink_new,idsink_old,idsink_all logical,allocatable,dimension(:,:)::level_sink,level_sink_new logical,allocatable,dimension(:)::ok_blast_agn,ok_blast_agn_all,direct_force_sink logical,allocatable,dimension(:)::new_born,new_born_all,new_born_new integer,allocatable,dimension(:)::idsink_sort integer::ncloud_sink,ncloud_sink_massive integer::nindsink=0 integer::sinkint_level=0 ! maximum level currently active is where the global sink variables are updated real(dp)::ssoft ! sink softening lenght in code units ! Particles related arrays real(dp),allocatable,dimension(:,:)::xp ! Positions real(dp),allocatable,dimension(:,:)::vp ! Velocities real(dp),allocatable,dimension(:) ::mp ! Masses #ifdef OUTPUT_PARTICLE_POTENTIAL real(dp),allocatable,dimension(:) ::ptcl_phi ! Potential of particle added by AP for output purposes #endif real(dp),allocatable,dimension(:) ::tp ! Birth epoch real(dp),allocatable,dimension(:,:)::weightp ! weight of cloud parts for sink accretion only real(dp),allocatable,dimension(:) ::zp ! Birth metallicity integer ,allocatable,dimension(:) ::nextp ! Next particle in list integer ,allocatable,dimension(:) ::prevp ! Previous particle in list integer ,allocatable,dimension(:) ::levelp ! Current level of particle integer(i8b),allocatable,dimension(:)::idp ! Identity of particle ! ADDED BY TTG APR 2017 real(dp),allocatable,dimension(:) ::trcp ! gas particle tracer (passive scalar) ! Tree related arrays integer ,allocatable,dimension(:) ::headp ! Head particle in grid integer ,allocatable,dimension(:) ::tailp ! Tail particle in grid integer ,allocatable,dimension(:) ::numbp ! Number of particles in grid ! Global particle linked lists integer::headp_free,tailp_free,numbp_free=0,numbp_free_tot=0 ! Local and current seed for random number generator integer,dimension(IRandNumSize) :: localseed=-1 contains function cross(a,b) use amr_parameters, only:dp real(dp),dimension(1:3)::a,b real(dp),dimension(1:3)::cross !computes the cross product c= a x b cross(1)=a(2)*b(3)-a(3)*b(2) cross(2)=a(3)*b(1)-a(1)*b(3) cross(3)=a(1)*b(2)-a(2)*b(1) end function cross end module pm_commons ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/read_hydro_params.f90 ! TTG 2017: called from read_params.f90 subroutine read_hydro_params(nml_ok) use amr_commons use hydro_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif logical::nml_ok !-------------------------------------------------- ! Local variables !-------------------------------------------------- integer::i,idim,nboundary_true=0 integer ,dimension(1:MAXBOUND)::bound_type real(dp)::scale,ek_bound !-------------------------------------------------- ! Namelist definitions !-------------------------------------------------- namelist/init_params/filetype,initfile,multiple,nregion,region_type & & ,x_center,y_center,z_center,aexp_ini & & ,length_x,length_y,length_z,exp_region & #if NENER>0 & ,prad_region & #endif #if NVAR>NDIM+2+NENER & ,var_region & #endif & ,d_region,u_region,v_region,w_region,p_region namelist/hydro_params/gamma,courant_factor,smallr,smallc & & ,niter_riemann,slope_type,difmag & #if NENER>0 & ,gamma_rad & #endif & ,pressure_fix,beta_fix,scheme,riemann namelist/refine_params/x_refine,y_refine,z_refine,r_refine & & ,a_refine,b_refine,exp_refine,jeans_refine,mass_cut_refine & & ,m_refine,mass_sph,err_grad_d,err_grad_p,err_grad_u & & ,floor_d,floor_u,floor_p,ivar_refine,var_cut_refine & & ,interpol_var,interpol_type,sink_refine namelist/boundary_params/nboundary,bound_type & & ,ibound_min,ibound_max,jbound_min,jbound_max & & ,kbound_min,kbound_max & #if NENER>0 & ,prad_bound & #endif #if NVAR>NDIM+2+NENER & ,var_bound & #endif & ,d_bound,u_bound,v_bound,w_bound,p_bound,no_inflow namelist/physics_params/omega_b,cooling,haardt_madau,metal,isothermal & & ,m_star,t_star,n_star,T2_star,g_star,del_star,eps_star,jeans_ncells & & ,eta_sn,eta_ssn,yield,rbubble,f_ek,ndebris,f_w,mass_gmc,kappa_IR & & ,J21,a_spec,z_ave,z_reion,ind_rsink,delayed_cooling,T2max & & ,self_shielding,smbh,agn & & ,units_density,units_time,units_length,neq_chem,ir_feedback,ir_eff,t_diss,t_sne & & ,sf_virial,sf_trelax,sf_tdiss,sf_model,sf_log_properties,sf_imf & & ,mass_star_max,mass_sne_min,sf_compressive #ifdef grackle namelist/grackle_params/use_grackle,grackle_with_radiative_cooling,grackle_primordial_chemistry,grackle_metal_cooling & & ,grackle_UVbackground,grackle_cmb_temperature_floor,grackle_h2_on_dust,grackle_photoelectric_heating & & ,grackle_use_volumetric_heating_rate,grackle_use_specific_heating_rate,grackle_three_body_rate,grackle_cie_cooling & & ,grackle_h2_optical_depth_approximation,grackle_ih2co,grackle_ipiht,grackle_NumberOfTemperatureBins,grackle_CaseBRecombination & & ,grackle_Compton_xray_heating,grackle_LWbackground_sawtooth_suppression,grackle_NumberOfDustTemperatureBins,grackle_use_radiative_transfer & & ,grackle_radiative_transfer_coupled_rate_solver,grackle_radiative_transfer_intermediate_step,grackle_radiative_transfer_hydrogen_only & & ,grackle_self_shielding_method,grackle_Gamma,grackle_photoelectric_heating_rate,grackle_HydrogenFractionByMass & & ,grackle_DeuteriumToHydrogenRatio,grackle_SolarMetalFractionByMass,grackle_TemperatureStart,grackle_TemperatureEnd & & ,grackle_DustTemperatureStart,grackle_DustTemperatureEnd,grackle_LWbackground_intensity,grackle_UVbackground_redshift_on & & ,grackle_UVbackground_redshift_off,grackle_UVbackground_redshift_fullon,grackle_UVbackground_redshift_drop & & ,grackle_cloudy_electron_fraction_factor,grackle_data_file #endif ! Read namelist file ! TTG 2017: called from read_params.f90 rewind(1) read(1,NML=init_params,END=101) if(myid==1)write(*,*)'-> Found INIT_PARAMS block' goto 102 101 write(*,*)' You need to set up namelist &INIT_PARAMS in parameter file' call clean_stop 102 rewind(1) ! CHANGED BY TTG APR 2017 ! if(nlevelmax>levelmin)read(1,NML=refine_params) if(nlevelmax>levelmin)then read(1,NML=refine_params) if(myid==1)write(*,*)'-> Found REFINE_PARAMS block' endif rewind(1) ! CHANGED BY TTG APR 2017 ! if(hydro)read(1,NML=hydro_params) if(hydro)then read(1,NML=hydro_params) if(myid==1)write(*,*)'-> Found HYDRO_PARAMS block' endif rewind(1) read(1,NML=boundary_params,END=103) if(myid==1)write(*,*)'-> Found BOUNDARY_PARAMS block' simple_boundary=.true. goto 104 103 simple_boundary=.false. 104 if(nboundary>MAXBOUND)then write(*,*) 'Error: nboundary>MAXBOUND' call clean_stop end if rewind(1) read(1,NML=physics_params,END=105) if(myid==1)write(*,*)'-> Found PHYSICS_PARAMS block' 105 continue #ifdef grackle rewind(1) read(1,NML=grackle_params) #endif #ifdef ATON if(aton)call read_radiation_params(1) #endif !-------------------------------------------------- ! Check for dm only cosmo run !-------------------------------------------------- if(.not.hydro)then omega_b = 0.0D0 endif !-------------------------------------------------- ! Check for star formation !-------------------------------------------------- if(t_star>0)then star=.true. pic=.true. else if(eps_star>0)then t_star=0.1635449*(n_star/0.1)**(-0.5)/eps_star star=.true. pic=.true. endif !-------------------------------------------------- ! Check for metal !-------------------------------------------------- if(metal.and.nvar<(ndim+3))then if(myid==1)write(*,*)'Error: metals need nvar >= ndim+3' if(myid==1)write(*,*)'Modify hydro_parameters.f90 and recompile' nml_ok=.false. endif !-------------------------------------------------- ! Check for non-thermal energies !-------------------------------------------------- #if NENER>0 if(nvar<(ndim+2+nener))then if(myid==1)write(*,*)'Error: non-thermal energy need nvar >= ndim+2+nener' if(myid==1)write(*,*)'Modify NENER and recompile' nml_ok=.false. endif #endif !-------------------------------------------------- ! Check ind_rsink !-------------------------------------------------- if(ind_rsink<=0.0d0)then if(myid==1)write(*,*)'Error in the namelist' if(myid==1)write(*,*)'Check ind_rsink' nml_ok=.false. end if !------------------------------------------------- ! This section deals with hydro boundary conditions !------------------------------------------------- if(simple_boundary.and.nboundary==0)then simple_boundary=.false. endif if (simple_boundary)then ! Compute new coarse grid boundaries do i=1,nboundary if(ibound_min(i)*ibound_max(i)==1.and.ndim>0.and.bound_type(i)>0)then nx=nx+1 if(ibound_min(i)==-1)then icoarse_min=icoarse_min+1 icoarse_max=icoarse_max+1 end if nboundary_true=nboundary_true+1 end if end do do i=1,nboundary if(jbound_min(i)*jbound_max(i)==1.and.ndim>1.and.bound_type(i)>0)then ny=ny+1 if(jbound_min(i)==-1)then jcoarse_min=jcoarse_min+1 jcoarse_max=jcoarse_max+1 end if nboundary_true=nboundary_true+1 end if end do do i=1,nboundary if(kbound_min(i)*kbound_max(i)==1.and.ndim>2.and.bound_type(i)>0)then nz=nz+1 if(kbound_min(i)==-1)then kcoarse_min=kcoarse_min+1 kcoarse_max=kcoarse_max+1 end if nboundary_true=nboundary_true+1 end if end do ! Compute boundary geometry do i=1,nboundary if(ibound_min(i)*ibound_max(i)==1.and.ndim>0.and.bound_type(i)>0)then if(ibound_min(i)==-1)then ibound_min(i)=icoarse_min+ibound_min(i) ibound_max(i)=icoarse_min+ibound_max(i) if(bound_type(i)==1)boundary_type(i)=1 if(bound_type(i)==2)boundary_type(i)=11 if(bound_type(i)==3)boundary_type(i)=21 else ibound_min(i)=icoarse_max+ibound_min(i) ibound_max(i)=icoarse_max+ibound_max(i) if(bound_type(i)==1)boundary_type(i)=2 if(bound_type(i)==2)boundary_type(i)=12 if(bound_type(i)==3)boundary_type(i)=22 end if if(ndim>1)jbound_min(i)=jcoarse_min+jbound_min(i) if(ndim>1)jbound_max(i)=jcoarse_max+jbound_max(i) if(ndim>2)kbound_min(i)=kcoarse_min+kbound_min(i) if(ndim>2)kbound_max(i)=kcoarse_max+kbound_max(i) else if(jbound_min(i)*jbound_max(i)==1.and.ndim>1.and.bound_type(i)>0)then ibound_min(i)=icoarse_min+ibound_min(i) ibound_max(i)=icoarse_max+ibound_max(i) if(jbound_min(i)==-1)then jbound_min(i)=jcoarse_min+jbound_min(i) jbound_max(i)=jcoarse_min+jbound_max(i) if(bound_type(i)==1)boundary_type(i)=3 if(bound_type(i)==2)boundary_type(i)=13 if(bound_type(i)==3)boundary_type(i)=23 else jbound_min(i)=jcoarse_max+jbound_min(i) jbound_max(i)=jcoarse_max+jbound_max(i) if(bound_type(i)==1)boundary_type(i)=4 if(bound_type(i)==2)boundary_type(i)=14 if(bound_type(i)==3)boundary_type(i)=24 end if if(ndim>2)kbound_min(i)=kcoarse_min+kbound_min(i) if(ndim>2)kbound_max(i)=kcoarse_max+kbound_max(i) else if(kbound_min(i)*kbound_max(i)==1.and.ndim>2.and.bound_type(i)>0)then ibound_min(i)=icoarse_min+ibound_min(i) ibound_max(i)=icoarse_max+ibound_max(i) jbound_min(i)=jcoarse_min+jbound_min(i) jbound_max(i)=jcoarse_max+jbound_max(i) if(kbound_min(i)==-1)then kbound_min(i)=kcoarse_min+kbound_min(i) kbound_max(i)=kcoarse_min+kbound_max(i) if(bound_type(i)==1)boundary_type(i)=5 if(bound_type(i)==2)boundary_type(i)=15 if(bound_type(i)==3)boundary_type(i)=25 else kbound_min(i)=kcoarse_max+kbound_min(i) kbound_max(i)=kcoarse_max+kbound_max(i) if(bound_type(i)==1)boundary_type(i)=6 if(bound_type(i)==2)boundary_type(i)=16 if(bound_type(i)==3)boundary_type(i)=26 end if end if end do do i=1,nboundary ! Check for errors if( (ibound_min(i)<0.or.ibound_max(i)>(nx-1)) .and. (ndim>0) .and.bound_type(i)>0 )then if(myid==1)write(*,*)'Error in the namelist' if(myid==1)write(*,*)'Check boundary conditions along X direction',i nml_ok=.false. end if if( (jbound_min(i)<0.or.jbound_max(i)>(ny-1)) .and. (ndim>1) .and.bound_type(i)>0)then if(myid==1)write(*,*)'Error in the namelist' if(myid==1)write(*,*)'Check boundary conditions along Y direction',i nml_ok=.false. end if if( (kbound_min(i)<0.or.kbound_max(i)>(nz-1)) .and. (ndim>2) .and.bound_type(i)>0)then if(myid==1)write(*,*)'Error in the namelist' if(myid==1)write(*,*)'Check boundary conditions along Z direction',i nml_ok=.false. end if end do end if nboundary=nboundary_true if(simple_boundary.and.nboundary==0)then simple_boundary=.false. endif !-------------------------------------------------- ! Compute boundary conservative variables !-------------------------------------------------- do i=1,nboundary boundary_var(i,1)=MAX(d_bound(i),smallr) boundary_var(i,2)=d_bound(i)*u_bound(i) #if NDIM>1 boundary_var(i,3)=d_bound(i)*v_bound(i) #endif #if NDIM>2 boundary_var(i,4)=d_bound(i)*w_bound(i) #endif ek_bound=0.0d0 do idim=1,ndim ek_bound=ek_bound+0.5d0*boundary_var(i,idim+1)**2/boundary_var(i,1) end do boundary_var(i,ndim+2)=ek_bound+P_bound(i)/(gamma-1.0d0) end do !----------------------------------- ! Rearrange level dependent arrays !----------------------------------- do i=nlevelmax,levelmin,-1 jeans_refine(i)=jeans_refine(i-levelmin+1) end do do i=1,levelmin-1 jeans_refine(i)=-1.0 end do !----------------------------------- ! Sort out passive variable indices !----------------------------------- inener=ndim+3 ! MUST BE THIS VALUE !!! ! CHANGED BY TTG APR 2017: to allow for a passive scalar with index 6 ! imetal=nener+ndim+3 imetal=nener+ndim+3+1 idelay=imetal if(metal)idelay=imetal+1 ivirial1=idelay ivirial2=idelay if(delayed_cooling)then ivirial1=idelay+1 ivirial2=idelay+1 endif if(sf_virial)then if(sf_compressive) ivirial2=ivirial1+1 endif ixion=ivirial2 if(sf_virial)ixion=ivirial2+1 ichem=ixion if(aton)ichem=ixion+1 if(myid==1.and.hydro.and.(nvar>ndim+2)) then write(*,'(A50)')'__________________________________________________' write(*,*) 'Hydro var indices:' #if NENER>0 write(*,*) ' inener = ',inener #endif ! ADDED BY TTG APR 2017: include a passive scalar with index 6 write(*,*) ' itracer = ',itracer if(metal) write(*,*) ' imetal = ',imetal if(delayed_cooling) write(*,*) ' idelay = ',idelay if(sf_virial)then write(*,*) ' ivirial1 = ',ivirial1 if(sf_compressive) write(*,*) ' ivirial2 = ',ivirial2 endif if(aton) write(*,*) ' ixion = ',ixion #ifdef RT if(rt) write(*,*) ' iIons = ',ichem #endif write(*,'(A50)')'__________________________________________________' endif ! Last variable is ichem end subroutine read_hydro_params ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/read_params.f90 module dice_commons use amr_commons use hydro_commons ! particle data character(len=512)::ic_file, ic_format ! misc real(dp)::IG_rho = 1.0D-5 real(dp)::IG_T2 = 1.0D7 real(dp)::IG_metal = 0.01 real(dp)::ic_scale_pos = 1.0 real(dp)::ic_scale_vel = 1.0 real(dp)::ic_scale_mass = 1.0 real(dp)::ic_scale_u = 1.0 real(dp)::ic_scale_age = 1.0 real(dp)::ic_scale_metal = 1.0 real(dp)::ic_t_restart = 0.0D0 integer::ic_ifout = 1 integer::ic_nfile = 1 integer,dimension(1:6)::ic_skip_type = -1 integer,dimension(1:6)::cosmo_add_gas_index = -1 real(dp),dimension(1:3)::ic_mag_const = (/ 0.0, 0.0, 0.0 /) real(dp),dimension(1:3)::ic_center = (/ 0.0, 0.0, 0.0 /) ! ADDED BY TTG MAY 2017 ! Bulk velocity of all components ! Only relevant for DICE_RESTART patch (filetype='dice_restart') real(dp),dimension(1:3)::ic_velocity = (/ 0.0, 0.0, 0.0 /) character(len=4)::ic_head_name = 'HEAD' character(len=4)::ic_pos_name = 'POS ' character(len=4)::ic_vel_name = 'VEL ' character(len=4)::ic_id_name = 'ID ' character(len=4)::ic_mass_name = 'MASS' character(len=4)::ic_u_name = 'U ' character(len=4)::ic_metal_name = 'Z ' character(len=4)::ic_age_name = 'AGE ' ! Gadget units in cgs real(dp)::gadget_scale_l = 3.085677581282D21 real(dp)::gadget_scale_v = 1.0D5 real(dp)::gadget_scale_m = 1.9891D43 real(dp)::gadget_scale_t = 1.0D6*365*24*3600 real(dp),allocatable,dimension(:)::up real(dp),allocatable,dimension(:)::maskp logical::dice_init = .false. logical::amr_struct = .false. ! magnetic integer,parameter::MAXGAL= 32 real(dp),dimension(1:MAXGAL)::ic_mag_center_x = 0.0 real(dp),dimension(1:MAXGAL)::ic_mag_center_y = 0.0 real(dp),dimension(1:MAXGAL)::ic_mag_center_z = 0.0 real(dp),dimension(1:MAXGAL)::ic_mag_axis_x = 0.0 real(dp),dimension(1:MAXGAL)::ic_mag_axis_y = 0.0 real(dp),dimension(1:MAXGAL)::ic_mag_axis_z = 1.0 real(dp),dimension(1:MAXGAL)::ic_mag_scale_R = 1.0 real(dp),dimension(1:MAXGAL)::ic_mag_scale_H = 1.0 real(dp),dimension(1:MAXGAL)::ic_mag_scale_B = 0.0 end module dice_commons ! RESTART patch ! ADDED BY TTG MAY 2017 module restart_commons use amr_commons use hydro_commons ! misc real(dp)::restart_rho_min=huge(1.d0),restart_rho_max=tiny(1.d0) real(dp),dimension(1:3)::restart_ic_center = (/ 0.0, 0.0, 0.0 /) integer,dimension(1:20)::restart_passive_vars=0 integer::nvar_min logical::restart_init=.false. logical::reset_time=.false. ! reset simulation time logical::reset_cvars=.false. ! reset conserved diagnostics (energy, mass, rho) ! real(dp)::restart_boxlen ! real(dp)::restart_unit_t ! real(dp)::restart_unit_l ! real(dp)::restart_unit_d ! RESTART patch end module restart_commons subroutine read_params use amr_commons use pm_parameters use poisson_parameters use hydro_parameters use dice_commons ! ADDED BY TTG (FEB 2017) use amr_parameters, only: print_when_io ! RESTART patch ! ADDED BY TTG MAY 2017 use restart_commons ! RESTART patch implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif !-------------------------------------------------- ! Local variables !-------------------------------------------------- integer::i,narg,iargc,ierr,levelmax ! CHANGED BY TTG (FEB 2017) ! character(LEN=80)::infile ! character(LEN=80)::cmdarg character(LEN=256)::infile character(LEN=256)::cmdarg integer(kind=8)::ngridtot=0 integer(kind=8)::nparttot=0 real(kind=8)::delta_tout=0,tend=0 real(kind=8)::delta_aout=0,aend=0 logical::nml_ok integer,parameter::tag=1134 integer::dummy_io,info2 !-------------------------------------------------- ! Namelist definitions !-------------------------------------------------- namelist/run_params/clumpfind,cosmo,pic,sink,lightcone,poisson,hydro,rt,verbose,debug & & ,nrestart,ncontrol,nstepmax,nsubcycle,nremap,ordering & & ,bisec_tol,static,geom,overload,cost_weighting,aton,nrestart_quad,restart_remap & & ,static_dm,static_gas,static_stars,convert_birth_times,use_proper_time & & ,print_when_io ! ADDED BY TTG (2017) namelist/output_params/noutput,foutput,fbackup,aout,tout,output_mode & & ,tend,delta_tout,aend,delta_aout,gadget_output & & ,output_dir ! ADDED BY TTG (2017) namelist/amr_params/levelmin,levelmax,ngridmax,ngridtot & & ,npartmax,nparttot,nexpand,boxlen,nlevel_collapse namelist/poisson_params/epsilon,gravity_type,gravity_params & & ,cg_levelmin,cic_levelmax namelist/lightcone_params/thetay_cone,thetaz_cone,zmax_cone namelist/movie_params/levelmax_frame,nw_frame,nh_frame,ivar_frame & & ,xcentre_frame,ycentre_frame,zcentre_frame & & ,deltax_frame,deltay_frame,deltaz_frame,movie,zoom_only_frame & & ,imovout,imov,tstartmov,astartmov,tendmov,aendmov,proj_axis,movie_vars_txt & & ,theta_camera,phi_camera,dtheta_camera,dphi_camera,focal_camera,dist_camera,ddist_camera & & ,perspective_camera,smooth_frame,shader_frame,tstart_theta_camera,tstart_phi_camera & & ,tend_theta_camera,tend_phi_camera,method_frame,varmin_frame,varmax_frame namelist/dice_params/ ic_file,ic_nfile,ic_format,IG_rho,IG_T2,IG_metal & & ,ic_head_name,ic_pos_name,ic_vel_name,ic_id_name,ic_mass_name & & ,ic_u_name,ic_metal_name,ic_age_name & & ,gadget_scale_l, gadget_scale_v, gadget_scale_m ,gadget_scale_t & & ,ic_scale_pos,ic_scale_vel,ic_scale_mass,ic_scale_u,ic_scale_age & & ,ic_scale_metal,ic_center,ic_ifout,amr_struct,ic_t_restart,ic_mag_const & & ,ic_mag_center_x,ic_mag_center_y,ic_mag_center_z & & ,ic_mag_axis_x,ic_mag_axis_y,ic_mag_axis_z & & ,ic_mag_scale_R,ic_mag_scale_H,ic_mag_scale_B,cosmo_add_gas_index,ic_skip_type & & ,ic_velocity !-> ADDED BY TTG MAY 2017 ! RESTART patch ! ADDED BY TTG MAY 2017 logical,save::init_restart_nml=.false. namelist/restart_params/restart_passive_vars & & ,reset_time & & ,reset_cvars & & ,restart_ic_center ! NEW ! RESTART patch ! MPI initialization #ifndef WITHOUTMPI call MPI_INIT(ierr) call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) call MPI_COMM_SIZE(MPI_COMM_WORLD,ncpu,ierr) myid=myid+1 ! Careful with this... #endif #ifdef WITHOUTMPI ncpu=1 myid=1 #endif !-------------------------------------------------- ! Advertise RAMSES !-------------------------------------------------- if(myid==1)then write(*,*)'_/_/_/ _/_/ _/ _/ _/_/_/ _/_/_/_/ _/_/_/ ' write(*,*)'_/ _/ _/ _/ _/_/_/_/ _/ _/ _/ _/ _/ ' write(*,*)'_/ _/ _/ _/ _/ _/ _/ _/ _/ _/ ' write(*,*)'_/_/_/ _/_/_/_/ _/ _/ _/_/ _/_/_/ _/_/ ' write(*,*)'_/ _/ _/ _/ _/ _/ _/ _/ _/ ' write(*,*)'_/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ ' write(*,*)'_/ _/ _/ _/ _/ _/ _/_/_/ _/_/_/_/ _/_/_/ ' write(*,*)' Version 3.0 ' write(*,*)' written by Romain Teyssier (University of Zurich) ' write(*,*)' (c) CEA 1999-2007, UZH 2008-2014 ' write(*,*)' ' write(*,'(' Working with nproc = ',I4,' for ndim = ',I1)')ncpu,ndim ! Check nvar is not too small #ifdef SOLVERhydro write(*,'(' Using solver = hydro with nvar = ',I2)')nvar if(nvar=ndim+2' write(*,'(' Please recompile with -DNVAR=',I2)')ndim+2 call clean_stop endif #endif #ifdef SOLVERmhd write(*,'(' Using solver = mhd with nvar = ',I2)')nvar if(nvar<8)then write(*,*)'You should have: nvar>=8' write(*,'(' Please recompile with -DNVAR=8')') call clean_stop endif #endif !Write I/O group size information if(IOGROUPSIZE>0.or.IOGROUPSIZECONE>0.or.IOGROUPSIZEREP>0)write(*,*)' ' if(IOGROUPSIZE>0) write(*,*)'IOGROUPSIZE=',IOGROUPSIZE if(IOGROUPSIZECONE>0) write(*,*)'IOGROUPSIZECONE=',IOGROUPSIZECONE if(IOGROUPSIZEREP>0) write(*,*)'IOGROUPSIZEREP=',IOGROUPSIZEREP if(IOGROUPSIZE>0.or.IOGROUPSIZECONE>0.or.IOGROUPSIZEREP>0)write(*,*)' ' ! Write information about git version call write_gitinfo ! Read namelist filename from command line argument narg = iargc() IF(narg .LT. 1)THEN write(*,*)'You should type: ramses3d input.nml [nrestart]' write(*,*)'File input.nml should contain a parameter namelist' write(*,*)'nrestart is optional' call clean_stop END IF CALL getarg(1,infile) endif #ifndef WITHOUTMPI ! CHANGED BY TTG (FEB 2017): needs to be consistent with size of infile ! call MPI_BCAST(infile,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(infile,256,MPI_CHARACTER,0,MPI_COMM_WORLD,ierr) #endif !------------------------------------------------- ! Read the namelist !------------------------------------------------- ! Wait for the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif namelist_file=TRIM(infile) ! CHANGED BY TTG (FEB 2017): namelist.txt was not written out properly ! INQUIRE(file=infile,exist=nml_ok) ! if(.not. nml_ok)then ! if(myid==1)then ! write(*,*)'File '//TRIM(infile)//' does not exist' ! endif ! call clean_stop ! end if ! ! open(1,file=infile) INQUIRE(file=namelist_file,exist=nml_ok) if(.not. nml_ok)then if(myid==1)then write(*,*)'File '//TRIM(namelist_file)//' does not exist' endif call clean_stop end if ! ADDED BY TTG (APR 2017) if(myid==1)write(*,*)'Reading namelist file '//TRIM(namelist_file) open(1,file=namelist_file) rewind(1) if(myid==1)write(*,*)'-> Found RUN_PARAMS block' read(1,NML=run_params) rewind(1) if(myid==1)write(*,*)'-> Found OUTPUT_PARAMS block' read(1,NML=output_params) rewind(1) if(myid==1)write(*,*)'-> Found RUN_PARAMS block' read(1,NML=amr_params) rewind(1) read(1,NML=lightcone_params,END=83) if(myid==1)write(*,*)'-> Found LIGHTCONE_PARAMS block' 83 continue rewind(1) read(1,NML=movie_params,END=82) if(myid==1)write(*,*)'-> Found MOVIE_PARAMS block' 82 continue rewind(1) read(1,NML=poisson_params,END=81) if(myid==1)write(*,*)'-> Found POISSON_PARAMS block' 81 continue rewind(1) read(1,NML=dice_params,END=106) if(myid==1)write(*,*)'-> Found DICE_PARAMS block' 106 continue ! RESTART patch ! ADDED BY TTG MAY 2017 rewind(1) read(1,NML=restart_params,END=107) if(myid==1)write(*,*)'-> Found RESTART_PARAMS block' init_restart_nml=.true. 107 continue ! RESTART patch !------------------------------------------------- ! Read optional nrestart command-line argument !------------------------------------------------- if (myid==1 .and. narg == 2) then CALL getarg(2,cmdarg) read(cmdarg,*) nrestart endif #ifndef WITHOUTMPI call MPI_BCAST(nrestart,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) #endif !------------------------------------------------- ! Compute time step for outputs !------------------------------------------------- if(tend>0)then if(delta_tout==0)delta_tout=tend noutput=MIN(int(tend/delta_tout),MAXOUT) do i=1,noutput tout(i)=dble(i)*delta_tout end do else if(aend>0)then if(delta_aout==0)delta_aout=aend noutput=MIN(int(aend/delta_aout),MAXOUT) do i=1,noutput aout(i)=dble(i)*delta_aout end do endif noutput=MIN(noutput,MAXOUT) if(imovout>0) then allocate(tmovout(1:imovout)) allocate(amovout(1:imovout)) tmovout=1d100 amovout=1d100 if(tendmov>0)then do i=1,imovout tmovout(i)=(tendmov-tstartmov)*dble(i)/dble(imovout)+tstartmov enddo endif if(aendmov>0)then do i=1,imovout amovout(i)=(aendmov-astartmov)*dble(i)/dble(imovout)+astartmov enddo endif if(tendmov==0.and.aendmov==0)movie=.false. endif !-------------------------------------------------- ! Check for errors in the namelist so far !-------------------------------------------------- levelmin=MAX(levelmin,1) nlevelmax=levelmax nml_ok=.true. if(levelmin<1)then if(myid==1)write(*,*)'Error in the namelist:' if(myid==1)write(*,*)'levelmin should not be lower than 1 !!!' nml_ok=.false. end if if(nlevelmax1)verbose=.false. if(sink.and.(.not.pic))then pic=.true. endif !if(clumpfind.and.(.not.pic))then ! pic=.true. !endif !if(pic.and.(.not.poisson))then ! poisson=.true. !endif call read_hydro_params(nml_ok) #ifdef RT call rt_read_hydro_params(nml_ok) #endif if (sink)call read_sink_params if (clumpfind .or. sink)call read_clumpfind_params if (movie)call set_movie_vars ! Check for more errors in the namelist ! RESTART patch ! ADDED BY TTG MAY 2017 if(init_restart_nml)then if(nrestart>=0)then if(myid==1)write(*,*)'Error in the namelist:' if(myid==1)write(*,*)'Need to set nrestart < 0 when using RESTART_PARAMS!' nml_ok=.false. endif if((TRIM(filetype)/='ramses').and.(TRIM(filetype)/='dice_restart')) then if(myid==1)write(*,*)'Error in the namelist:' if(myid==1)write(*,*)'Need to set filetype='ramses' or 'dice_restart' with RESTART_PARAMS!' nml_ok=.false. endif else if(nrestart<0)then if(myid==1)write(*,*)'Error in the namelist:' if(myid==1)write(*,*)'Need to set RESTART_PARAMS if nrestart < 0!' nml_ok=.false. endif if(TRIM(filetype)=='ramses') then if(myid==1)write(*,*)'Error in the namelist:' if(myid==1)write(*,*)'Need to set RESTART_PARAMS if filetype='ramses'!' nml_ok=.false. endif endif ! RESTART patch close(1) ! ADDED BY TTG (APR 2017) if(myid==1)write(*,*)'Done reading namelist file' ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif !----------------- ! Max size checks !----------------- if(nlevelmax>MAXLEVEL)then write(*,*) 'Error: nlevelmax>MAXLEVEL' call clean_stop end if if(nregion>MAXREGION)then write(*,*) 'Error: nregion>MAXREGION' call clean_stop end if !----------------------------------- ! Rearrange level dependent arrays !----------------------------------- do i=nlevelmax,levelmin,-1 nexpand (i)=nexpand (i-levelmin+1) nsubcycle (i)=nsubcycle (i-levelmin+1) r_refine (i)=r_refine (i-levelmin+1) a_refine (i)=a_refine (i-levelmin+1) b_refine (i)=b_refine (i-levelmin+1) x_refine (i)=x_refine (i-levelmin+1) y_refine (i)=y_refine (i-levelmin+1) z_refine (i)=z_refine (i-levelmin+1) m_refine (i)=m_refine (i-levelmin+1) exp_refine(i)=exp_refine(i-levelmin+1) initfile (i)=initfile (i-levelmin+1) end do do i=1,levelmin-1 nexpand (i)= 1 nsubcycle (i)= 1 r_refine (i)=-1.0 a_refine (i)= 1.0 b_refine (i)= 1.0 x_refine (i)= 0.0 y_refine (i)= 0.0 z_refine (i)= 0.0 m_refine (i)=-1.0 exp_refine(i)= 2.0 initfile (i)= ' ' end do if(.not.cosmo)then use_proper_time=.false. convert_birth_times=.false. endif if(.not. nml_ok)then if(myid==1)write(*,*)'Too many errors in the namelist' if(myid==1)write(*,*)'Aborting...' call clean_stop end if #ifndef WITHOUTMPI call MPI_BARRIER(MPI_COMM_WORLD,ierr) #endif end subroutine read_params ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/rho_ana.f90 !######################################################### !######################################################### ! TTG 2018 ! Sets a static NFW potential through its density profile ! ! Remember to: ! ! 1) Set gravity_type = -1 in NML POISSON_PARAMS ! 2) Set the appropriate NFW parameter values through ! gravity_params in NML POISSON_PARAMS ! 3) Copy this file into src/rho_ana.f90 ! ! gravity_params are as follows: ! ! 1,2,3 - potential centre (x,y,z) in code units ! relative to boxlen (e.g. 0.5, 0.5, 0.5) ! 4 - total mass in gram ! 5 - virial radius in code units ! 6 - concentration (dimensionless) ! !######################################################### !######################################################### !Density functions function nfw_dens(r,rs) !Navarro, Frenk, and White (1997) density profile !Note that it does not include the density scale factor! !It is included at call time use amr_parameters, only: dp implicit none real(dp)::nfw_dens,r,rs nfw_dens=(1.d0/r)/(rs+r)**2 return end function nfw_dens function formfact(c) !NFW form factor use amr_parameters, only: dp implicit none real(dp)::formfact,c formfact = log(1.d0+c)-c/(1.d0+c) end function formfact subroutine rho_ana(x,d,dx,ncell) use amr_parameters use amr_commons, only: myid use hydro_parameters use poisson_parameters implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ncell ! Number of cells real(dp)::dx ! Cell size real(dp),dimension(1:nvector)::d ! Density real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position. !================================================================ ! This routine generates analytical Poisson source term. ! Positions are in user units: ! x(i,1:3) are in [0,boxlen]**ndim. ! d(i) is the density field in user units. !================================================================ integer::i real(dp)::nfw_dens,formfact real(dp)::rr,rx,ry,rz,xc,yc,zc real(dp)::halo_mass,halo_conc,halo_scaler,halo_virr,halo_dens_norm real(dp)::scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2 real(dp)::scale_m real(dp)::twopi,fourpi real(dp)::grav_const=6.6726d-8 ! cm^3/s^2/g real(dp)::solar_mass=1.989d33 ! g logical,save::first_call=.true. !affects output info if((myid==1).and.(first_call))write(*,*)'Entering rho_ana' twopi = 2.0d0*DACOS(-1.0d0) fourpi = 2.d0*twopi ! get factors to scale input quantities to code units call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) ! mass scale scale_m = scale_d*scale_l**3 !Halo / stellar disc *common* centre xc = ( INT( gravity_params(1) * boxlen / dx ) ) * dx !in code units relative to box yc = ( INT( gravity_params(2) * boxlen / dx ) ) * dx zc = ( INT( gravity_params(3) * boxlen / dx ) ) * dx !DM halo parameters halo_mass = gravity_params(4) / scale_m !DM halo mass (M_200) g -> code units halo_virr = gravity_params(5) !virial radius (r_200) in code units halo_conc = gravity_params(6) !NFW 'concentration' halo_dens_norm = halo_mass / fourpi / formfact(halo_conc) !NFW density normalisation in code units halo_scaler = halo_virr / halo_conc !NFW scale radius in code units !output info if((myid==1).and.(first_call))then write(*,*) write(*,'(a45,1pe10.2)') 'DM halo virial mass [Msun]: ', halo_mass * scale_m / solar_mass write(*,'(a45,1pe10.2)') 'DM halo virial radius [kpc]: ', halo_virr write(*,'(a45,1pe10.2)') 'DM halo 'concentration': ', halo_conc write(*,'(a45,1pe10.2)') 'DM halo scale radius [kpc]: ', halo_scaler write(*,'(a45,1pe10.2)') 'DM halo density norm. [Msun]: ', halo_dens_norm * scale_m / solar_mass !NOTE: the following should [roughly] match the DM halo's rho_scale as computed by DICE !(see IC's log file, component parameters) ! write(*,'(a45,1pe10.2)') 'DM halo density norm. [10^10 Msun kpc^-3]: ',& ! &halo_dens_norm * scale_m / solar_mass * 1.d-10 / halo_scaler**3 write(*,*) endif first_call=.false. ! call clean_stop do i=1,ncell rr=0.0d0; rx=0.0d0; ry=0.0d0; rz=0.0d0 rx=0.0d0; ry=0.0d0; rz=0.0d0 rx = (x(i,1)-xc) ry = (x(i,2)-yc) rz = (x(i,3)-zc) rz=DSQRT(rz*rz) rr = DSQRT(rx*rx+ry*ry+rz*rz) !spherical radius !Set DM halo density d(i) = halo_dens_norm * nfw_dens(rr,halo_scaler) end do end subroutine rho_ana ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/rho_fine.f90 !############################################################################## !############################################################################## !############################################################################## !############################################################################## subroutine rho_fine(ilevel,icount) use amr_commons use pm_commons use hydro_commons use poisson_commons use cooling_module use dice_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel,icount !------------------------------------------------------------------ ! This routine computes the density field at level ilevel using ! the CIC scheme. Particles that are not entirely in ! level ilevel contribute also to the level density field ! (boundary particles) using buffer grids. ! Array flag1, flag2 and phi are used as temporary work space. ! Array rho and cpu_map2 are stored with: ! - rho containing the Poisson source term ! - cpu_map2 containing the refinement map due to particle ! number density criterion (quasi Lagrangian mesh). !------------------------------------------------------------------ integer::iskip,icpu,ind,i,info,nx_loc,ibound,idim real(dp)::dx,d_scale,scale,dx_loc,scalar real(dp)::d0,m_refine_loc,dx_min,vol_min,mstar,msnk,nISM,nCOM real(kind=8)::total,total_all,total2,total2_all,tms real(kind=8),dimension(2)::totals_in,totals_out logical::multigrid=.false. real(kind=8),dimension(1:ndim+1)::multipole_in,multipole_out if(.not. poisson)return if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=icoarse_max-icoarse_min+1 scale=boxlen/dble(nx_loc) dx_loc=dx*scale if(ilevel==levelmin)multipole=0d0 !------------------------------------------------------- ! Initialize rho to analytical and baryon density field !------------------------------------------------------- if(dice_init.and.amr_struct) then if(hydro)call multipole_from_current_level(ilevel) call cic_from_multipole(ilevel) ! Update boundaries call make_virtual_reverse_dp(rho(1),ilevel) call make_virtual_fine_dp (rho(1),ilevel) else if(ilevel==levelmin.or.icount>1)then do i=nlevelmax,ilevel,-1 ! Compute mass multipole if(hydro)call multipole_fine(i) ! Perform TSC using pseudo-particle #ifdef TSC if (ndim==3)then call tsc_from_multipole(i) else write(*,*)'TSC not supported for ndim neq 3' call clean_stop end if #else ! Perform CIC using pseudo-particle call cic_from_multipole(i) #endif ! Update boundaries call make_virtual_reverse_dp(rho(1),i) call make_virtual_fine_dp (rho(1),i) end do end if endif !-------------------------- ! Initialize fields to zero !-------------------------- do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid phi(active(ilevel)%igrid(i)+iskip)=0.0D0 end do if(ilevel==cic_levelmax)then do i=1,active(ilevel)%ngrid rho_top(active(ilevel)%igrid(i)+iskip)=0.0D0 end do endif end do if(cic_levelmax>0.and.ilevel>cic_levelmax)then do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid rho_top(active(ilevel)%igrid(i)+iskip)=rho_top(father(active(ilevel)%igrid(i))) rho(active(ilevel)%igrid(i)+iskip)=rho(active(ilevel)%igrid(i)+iskip)+ & & rho_top(active(ilevel)%igrid(i)+iskip) end do end do endif !------------------------------------------------------------------------- ! Initialize 'number density' field to baryon number density in array phi. !------------------------------------------------------------------------- if(m_refine(ilevel)>-1.0d0)then d_scale=max(mass_sph/dx_loc**ndim,smallr) do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax if(hydro)then if(ivar_refine>0)then do i=1,active(ilevel)%ngrid scalar=uold(active(ilevel)%igrid(i)+iskip,ivar_refine) & & /max(uold(active(ilevel)%igrid(i)+iskip,1),smallr) if(scalar>var_cut_refine)then phi(active(ilevel)%igrid(i)+iskip)= & & rho(active(ilevel)%igrid(i)+iskip)/d_scale endif end do else do i=1,active(ilevel)%ngrid phi(active(ilevel)%igrid(i)+iskip)= & & rho(active(ilevel)%igrid(i)+iskip)/d_scale end do endif endif end do endif !------------------------------------------------------- ! Initialize rho and phi to zero in virtual boundaries !------------------------------------------------------- do icpu=1,ncpu do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,reception(icpu,ilevel)%ngrid rho(reception(icpu,ilevel)%igrid(i)+iskip)=0.0D0 phi(reception(icpu,ilevel)%igrid(i)+iskip)=0.0D0 end do if(ilevel==cic_levelmax)then do i=1,reception(icpu,ilevel)%ngrid rho_top(reception(icpu,ilevel)%igrid(i)+iskip)=0.0D0 end do endif end do end do !--------------------------------------------------------- ! Compute particle contribution to density field !--------------------------------------------------------- ! Compute density due to current level particles if(pic)then call rho_from_current_level(ilevel) end if ! Update boudaries call make_virtual_reverse_dp(rho(1),ilevel) call make_virtual_fine_dp (rho(1),ilevel) if(ilevel==cic_levelmax)then call make_virtual_reverse_dp(rho_top(1),ilevel) endif if(cic_levelmax>0.and.ilevel>=cic_levelmax)then call make_virtual_fine_dp (rho_top(1),ilevel) endif if(m_refine(ilevel)>-1.0d0)then call make_virtual_reverse_dp(phi(1),ilevel) call make_virtual_fine_dp (phi(1),ilevel) endif !-------------------------------------------------------------- ! Compute multipole contribution from all cpus and set rho_tot !-------------------------------------------------------------- #ifndef WITHOUTMPI if(ilevel==levelmin)then multipole_in=multipole call MPI_ALLREDUCE(multipole_in,multipole_out,ndim+1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,info) multipole=multipole_out endif #endif if(nboundary==0)then rho_tot=multipole(1)/scale**ndim if(debug)write(*,*)'rho_average=',rho_tot else rho_tot=0d0 endif !---------------------------------------------------- ! Reset rho and phi in physical boundaries !---------------------------------------------------- do ibound=1,nboundary do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,boundary(ibound,ilevel)%ngrid phi(boundary(ibound,ilevel)%igrid(i)+iskip)=0.0 rho(boundary(ibound,ilevel)%igrid(i)+iskip)=0.0 end do end do end do !----------------------------------------- ! Compute quasi Lagrangian refinement map !----------------------------------------- if(m_refine(ilevel)>-1.0d0)then do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid if(phi(active(ilevel)%igrid(i)+iskip)>=m_refine(ilevel))then cpu_map2(active(ilevel)%igrid(i)+iskip)=1 else cpu_map2(active(ilevel)%igrid(i)+iskip)=0 end if end do end do ! Update boundaries call make_virtual_fine_int(cpu_map2(1),ilevel) end if !! do ind=1,twotondim !! iskip=ncoarse+(ind-1)*ngridmax !! do i=1,active(ilevel)%ngrid !! print*,rho(active(ilevel)%igrid(i)+iskip),rho_tot !! end do !! end do 111 format(' Entering rho_fine for level ',I2) end subroutine rho_fine !############################################################################## !############################################################################## !############################################################################## !############################################################################## subroutine rho_from_current_level(ilevel) use amr_commons use pm_commons use hydro_commons use poisson_commons implicit none integer::ilevel !------------------------------------------------------------------ ! This routine computes the density field at level ilevel using ! the CIC scheme from particles that are not entirely in ! level ilevel (boundary particles). ! Arrays flag1 and flag2 are used as temporary work space. !------------------------------------------------------------------ integer::igrid,jgrid,ipart,jpart,idim,icpu integer::i,ig,ip,npart1 real(dp)::dx integer,dimension(1:nvector),save::ind_grid,ind_cell integer,dimension(1:nvector),save::ind_part,ind_grid_part real(dp),dimension(1:nvector,1:ndim),save::x0 ! Mesh spacing in that level dx=0.5D0**ilevel ! Loop over cpus do icpu=1,ncpu ! Loop over grids igrid=headl(icpu,ilevel) ig=0 ip=0 do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid if(npart1>0)then ig=ig+1 ind_grid(ig)=igrid ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 if(ig==0)then ig=1 ind_grid(ig)=igrid end if ip=ip+1 ind_part(ip)=ipart ind_grid_part(ip)=ig if(ip==nvector)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ig x0(i,idim)=xg(ind_grid(i),idim)-3.0D0*dx end do end do do i=1,ig ind_cell(i)=father(ind_grid(i)) end do #ifdef TSC call tsc_amr(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) #else call cic_amr(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) #endif ip=0 ig=0 end if ipart=nextp(ipart) ! Go to next particle end do ! End loop over particles end if igrid=next(igrid) ! Go to next grid end do ! End loop over grids if(ip>0)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do i=1,ig x0(i,idim)=xg(ind_grid(i),idim)-3.0D0*dx end do end do do i=1,ig ind_cell(i)=father(ind_grid(i)) end do #ifdef TSC call tsc_amr(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) #else call cic_amr(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) #endif end if end do ! End loop over cpus end subroutine rho_from_current_level subroutine multipole_from_current_level(ilevel) use amr_commons use pm_commons use hydro_commons use poisson_commons implicit none integer::ilevel !------------------------------------------------------------------ ! This routine computes the density field at level ilevel using ! the CIC scheme from particles that are not entirely in ! level ilevel (boundary particles). ! Arrays flag1 and flag2 are used as temporary work space. !------------------------------------------------------------------ integer::igrid,jgrid,ipart,jpart,idim,icpu,ind,iskip,ibound integer::i,j,ig,ip,npart1,npart2,next_part real(dp)::dx integer,dimension(1:nvector),save::ind_grid,ind_cell integer,dimension(1:nvector),save::ind_part,ind_grid_part real(dp),dimension(1:nvector,1:ndim),save::x0 !!!!!!!!!!!!!!!!!!!!!!!!!!! integer,dimension(1:nvector),save::ind_leaf,ind_split integer ::ncache,ngrid,info,nx_loc real(dp),dimension(1:nvector,1:ndim),save::xx real(dp),dimension(1:twotondim,1:3)::xc integer ::nleaf,nsplit,ix,iy,iz,iskip_son,ind_son,ind_grid_son,ind_cell_son real(kind=8)::vol,dx_loc,scale,vol_loc,mm real(dp),dimension(1:3)::skip_loc ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do !!!!!!!!!!!!!!!!!!!!!!!!!!! if(verbose)write(*,111)ilevel ! Mesh spacing in that level dx=0.5D0**ilevel ! Initialize unew field to zero do icpu=1,ncpu do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do idim=1,ndim+1 do j=1,reception(icpu,ilevel)%ngrid unew(reception(icpu,ilevel)%igrid(j)+iskip,idim)=0.0D0 end do end do end do end do do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do idim=1,ndim+1 do j=1,active(ilevel)%ngrid unew(active(ilevel)%igrid(j)+iskip,idim)=0.0D0 end do end do end do ! Reset unew in physical boundaries do ibound=1,nboundary do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do idim=1,ndim+1 do j=1,boundary(ibound,ilevel)%ngrid unew(boundary(ibound,ilevel)%igrid(j)+iskip,idim)=0.0 end do end do end do end do ! Loop over cpus do icpu=1,ncpu ! Loop over grids igrid=headl(icpu,ilevel) ig=0 ip=0 do jgrid=1,numbl(icpu,ilevel) npart1=numbp(igrid) ! Number of particles in the grid npart2=0 ! Count gas particles if(npart1>0)then ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ! if(idp(ipart).eq.1) then !TTG (FEB 2017): select gas particles (defined by init_part.f90 to have ID = 1) if(MOD(idp(ipart),2).eq.0)then !TTG (MAR 2017): select gas particles (defined by DICE / RESTART to have even ID) npart2=npart2+1 endif ipart=next_part ! Go to next particle end do endif if(npart2>0)then ig=ig+1 ind_grid(ig)=igrid ipart=headp(igrid) ! Loop over particles do jpart=1,npart1 ! Save next particle <--- Very important !!! next_part=nextp(ipart) ! Select only gas particles ! if(idp(ipart).eq.1) then !TTG (FEB 2017): select gas particles (defined by init_part.f90 to have ID = 1) if(MOD(idp(ipart),2).eq.0)then !TTG (MAR 2017): select gas particles (defined by DICE / RESTART to have even ID) if(ig==0)then ig=1 ind_grid(ig)=igrid end if ip=ip+1 ind_part(ip)=ipart ind_grid_part(ip)=ig endif if(ip==nvector)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do j=1,ig x0(j,idim)=xg(ind_grid(j),idim)-3.0D0*dx end do end do do j=1,ig ind_cell(j)=father(ind_grid(j)) end do call ngp_amr_gas(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) ip=0 ig=0 end if ipart=next_part ! Go to next particle end do ! End loop over particles end if igrid=next(igrid) ! Go to next grid end do ! End loop over grids if(ip>0)then ! Lower left corner of 3x3x3 grid-cube do idim=1,ndim do j=1,ig x0(j,idim)=xg(ind_grid(j),idim)-3.0D0*dx end do end do do j=1,ig ind_cell(j)=father(ind_grid(j)) end do call ngp_amr_gas(ind_cell,ind_part,ind_grid_part,x0,ig,ip,ilevel) end if end do ! End loop over cpus ! Update boundaries do idim=1,ndim+1 call make_virtual_reverse_dp(unew(1,idim),ilevel) call make_virtual_fine_dp(unew(1,idim),ilevel) end do ! Check for over-refinement do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do j=1,active(ilevel)%ngrid if(unew(active(ilevel)%igrid(j)+iskip,1)==0d0) then unew(active(ilevel)%igrid(j)+iskip,1)=smallr*vol_loc do idim=1,ndim unew(active(ilevel)%igrid(j)+iskip,idim+1)=(xg(active(ilevel)%igrid(j),idim)+xc(ind,idim)-skip_loc(idim))*scale & & *unew(active(ilevel)%igrid(j)+iskip,1) end do endif end do end do do idim=1,ndim+1 call make_virtual_fine_dp(unew(1,idim),ilevel) end do 111 format(' Entering multipole_from_current_level for level',i2) end subroutine multipole_from_current_level !############################################################################## !############################################################################## !############################################################################## !############################################################################## subroutine cic_amr(ind_cell,ind_part,ind_grid_part,x0,ng,np,ilevel) use amr_commons use pm_commons use poisson_commons use dice_commons use hydro_commons, ONLY: mass_sph implicit none integer::ng,np,ilevel integer ,dimension(1:nvector)::ind_cell,ind_grid_part,ind_part real(dp),dimension(1:nvector,1:ndim)::x0 !------------------------------------------------------------------ ! This routine computes the density field at level ilevel using ! the CIC scheme. Only cells that are in level ilevel ! are updated by the input particle list. !------------------------------------------------------------------ logical::error integer::j,ind,idim,nx_loc real(dp)::dx,dx_loc,scale,vol_loc ! Grid-based arrays integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids ! Particle-based arrays logical ,dimension(1:nvector),save::ok real(dp),dimension(1:nvector),save::mmm real(dp),dimension(1:nvector),save::ttt=0d0 real(dp),dimension(1:nvector),save::vol2 real(dp),dimension(1:nvector,1:ndim),save::x,dd,dg integer ,dimension(1:nvector,1:ndim),save::ig,id,igg,igd,icg,icd real(dp),dimension(1:nvector,1:twotondim),save::vol integer ,dimension(1:nvector,1:twotondim),save::igrid,icell,indp,kg real(dp),dimension(1:3)::skip_loc ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim ! Gather neighboring father cells (should be present anytime !) call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ng,ilevel) ! Rescale particle position at level ilevel do idim=1,ndim do j=1,np x(j,idim)=xp(ind_part(j),idim)/scale+skip_loc(idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)-x0(ind_grid_part(j),idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/dx end do end do ! Gather particle mass do j=1,np mmm(j)=mp(ind_part(j)) end do if(ilevel==levelmin)then do j=1,np multipole(1)=multipole(1)+mp(ind_part(j)) end do do idim=1,ndim do j=1,np multipole(idim+1)=multipole(idim+1)+mp(ind_part(j))*xp(ind_part(j),idim) end do end do end if ! Gather particle birth epoch if(star)then do j=1,np ttt(j)=tp(ind_part(j)) end do endif ! Check for illegal moves error=.false. do idim=1,ndim do j=1,np if(x(j,idim)<0.5D0.or.x(j,idim)>5.5D0)error=.true. end do end do if(error)then write(*,*)'problem in cic' do idim=1,ndim do j=1,np if(x(j,idim)<0.5D0.or.x(j,idim)>5.5D0)then write(*,*)x(j,1:ndim) endif end do end do stop end if ! CIC at level ilevel (dd: right cloud boundary; dg: left cloud boundary) do idim=1,ndim do j=1,np dd(j,idim)=x(j,idim)+0.5D0 id(j,idim)=dd(j,idim) dd(j,idim)=dd(j,idim)-id(j,idim) dg(j,idim)=1.0D0-dd(j,idim) ig(j,idim)=id(j,idim)-1 end do end do ! Compute cloud volumes #if NDIM==1 do j=1,np vol(j,1)=dg(j,1) vol(j,2)=dd(j,1) end do #endif #if NDIM==2 do j=1,np vol(j,1)=dg(j,1)*dg(j,2) vol(j,2)=dd(j,1)*dg(j,2) vol(j,3)=dg(j,1)*dd(j,2) vol(j,4)=dd(j,1)*dd(j,2) end do #endif #if NDIM==3 do j=1,np vol(j,1)=dg(j,1)*dg(j,2)*dg(j,3) vol(j,2)=dd(j,1)*dg(j,2)*dg(j,3) vol(j,3)=dg(j,1)*dd(j,2)*dg(j,3) vol(j,4)=dd(j,1)*dd(j,2)*dg(j,3) vol(j,5)=dg(j,1)*dg(j,2)*dd(j,3) vol(j,6)=dd(j,1)*dg(j,2)*dd(j,3) vol(j,7)=dg(j,1)*dd(j,2)*dd(j,3) vol(j,8)=dd(j,1)*dd(j,2)*dd(j,3) end do #endif ! Compute parent grids do idim=1,ndim do j=1,np igg(j,idim)=ig(j,idim)/2 igd(j,idim)=id(j,idim)/2 end do end do #if NDIM==1 do j=1,np kg(j,1)=1+igg(j,1) kg(j,2)=1+igd(j,1) end do #endif #if NDIM==2 do j=1,np kg(j,1)=1+igg(j,1)+3*igg(j,2) kg(j,2)=1+igd(j,1)+3*igg(j,2) kg(j,3)=1+igg(j,1)+3*igd(j,2) kg(j,4)=1+igd(j,1)+3*igd(j,2) end do #endif #if NDIM==3 do j=1,np kg(j,1)=1+igg(j,1)+3*igg(j,2)+9*igg(j,3) kg(j,2)=1+igd(j,1)+3*igg(j,2)+9*igg(j,3) kg(j,3)=1+igg(j,1)+3*igd(j,2)+9*igg(j,3) kg(j,4)=1+igd(j,1)+3*igd(j,2)+9*igg(j,3) kg(j,5)=1+igg(j,1)+3*igg(j,2)+9*igd(j,3) kg(j,6)=1+igd(j,1)+3*igg(j,2)+9*igd(j,3) kg(j,7)=1+igg(j,1)+3*igd(j,2)+9*igd(j,3) kg(j,8)=1+igd(j,1)+3*igd(j,2)+9*igd(j,3) end do #endif do ind=1,twotondim do j=1,np igrid(j,ind)=son(nbors_father_cells(ind_grid_part(j),kg(j,ind))) end do end do ! Compute parent cell position do idim=1,ndim do j=1,np icg(j,idim)=ig(j,idim)-2*igg(j,idim) icd(j,idim)=id(j,idim)-2*igd(j,idim) end do end do #if NDIM==1 do j=1,np icell(j,1)=1+icg(j,1) icell(j,2)=1+icd(j,1) end do #endif #if NDIM==2 do j=1,np icell(j,1)=1+icg(j,1)+2*icg(j,2) icell(j,2)=1+icd(j,1)+2*icg(j,2) icell(j,3)=1+icg(j,1)+2*icd(j,2) icell(j,4)=1+icd(j,1)+2*icd(j,2) end do #endif #if NDIM==3 do j=1,np icell(j,1)=1+icg(j,1)+2*icg(j,2)+4*icg(j,3) icell(j,2)=1+icd(j,1)+2*icg(j,2)+4*icg(j,3) icell(j,3)=1+icg(j,1)+2*icd(j,2)+4*icg(j,3) icell(j,4)=1+icd(j,1)+2*icd(j,2)+4*icg(j,3) icell(j,5)=1+icg(j,1)+2*icg(j,2)+4*icd(j,3) icell(j,6)=1+icd(j,1)+2*icg(j,2)+4*icd(j,3) icell(j,7)=1+icg(j,1)+2*icd(j,2)+4*icd(j,3) icell(j,8)=1+icd(j,1)+2*icd(j,2)+4*icd(j,3) end do #endif ! Compute parent cell adress do ind=1,twotondim do j=1,np indp(j,ind)=ncoarse+(icell(j,ind)-1)*ngridmax+igrid(j,ind) end do end do ! Update mass density and number density fields do ind=1,twotondim do j=1,np ok(j)=igrid(j,ind)>0 ! CHANGED BY TTG (MAR 2017): identify particles by their DICE / RESTART component number ! if(dice_init) ok(j)=ok(j).and.(idp(ind_part(j)).ne.1) if(dice_init) ok(j)=ok(j).and.(MOD(idp(ind_part(j)),2).ne.0) end do do j=1,np vol2(j)=mmm(j)*vol(j,ind)/vol_loc end do if(cic_levelmax==0.or.ilevel<=cic_levelmax)then do j=1,np if(ok(j))then rho(indp(j,ind))=rho(indp(j,ind))+vol2(j) end if end do else if(ilevel>cic_levelmax)then do j=1,np if(ok(j).and.ttt(j).ne.0d0)then rho(indp(j,ind))=rho(indp(j,ind))+vol2(j) end if end do endif if(ilevel==cic_levelmax)then do j=1,np if(ok(j).and.ttt(j)==0d0)then rho_top(indp(j,ind))=rho_top(indp(j,ind))+vol2(j) end if end do endif do j=1,np vol2(j)=vol(j,ind) end do ! Remove test particles for static runs if(static)then do j=1,np ok(j)=ok(j).and.mmm(j)>0.0 end do endif ! Remove massive dark matter particle if(mass_cut_refine>0.0)then do j=1,np if(ttt(j)==0d0)then ok(j)=ok(j).and.mmm(j)=cic_levelmax)then do j=1,np if(ok(j).and.ttt(j).ne.0d0)then phi(indp(j,ind))=phi(indp(j,ind))+vol2(j) end if end do endif ! Always refine sinks to the maximum level ! by setting particle number density above m_refine(ilevel) if(sink_refine)then do j=1,np if(idp(ind_part(j))<0.)then ! if (direct_force_sink(-1*idp(ind_part(j))))then phi(indp(j,ind))=phi(indp(j,ind))+m_refine(ilevel) ! endif end if end do end if end do end subroutine cic_amr !########################################################### !########################################################### !########################################################### !########################################################### subroutine multipole_fine(ilevel) use amr_commons use hydro_commons use poisson_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel !------------------------------------------------------------------- ! This routine compute array rho (source term for Poisson equation) ! by first reseting array rho to zero, then ! by affecting the gas density to leaf cells, and finally ! by performing a restriction operation for split cells. ! For pure particle runs, the restriction is not necessary and the ! routine only set rho to zero. On the other hand, for the Multigrid ! solver, the restriction is necessary in any case. !------------------------------------------------------------------- integer ::ind,i,icpu,ncache,igrid,ngrid,iskip,info,ibound,nx_loc integer ::idim,nleaf,nsplit,ix,iy,iz,iskip_son,ind_son,ind_grid_son,ind_cell_son integer,dimension(1:nvector),save::ind_grid,ind_cell,ind_leaf,ind_split real(dp),dimension(1:nvector,1:ndim),save::xx real(dp),dimension(1:nvector),save::dd real(kind=8)::vol,dx,dx_loc,scale,vol_loc,mm real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:twotondim,1:3)::xc if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim do ind=1,twotondim iz=(ind-1)/4 iy=(ind-1-4*iz)/2 ix=(ind-1-2*iy-4*iz) if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx end do ! Initialize fields to zero do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid unew(active(ilevel)%igrid(i)+iskip,1)=0.0D0 end do do idim=1,ndim do i=1,active(ilevel)%ngrid unew(active(ilevel)%igrid(i)+iskip,idim+1)=0.0D0 end do end do end do ! Compute mass multipoles in each cell ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do ! Loop over cells do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax ! Gather cell indices do i=1,ngrid ind_cell(i)=ind_grid(i)+iskip end do ! Gather leaf cells and compute cell centers nleaf=0 do i=1,ngrid if(son(ind_cell(i))==0)then nleaf=nleaf+1 ind_leaf(nleaf)=ind_cell(i) do idim=1,ndim xx(nleaf,idim)=(xg(ind_grid(i),idim)+xc(ind,idim)-skip_loc(idim))*scale end do end if end do ! Compute gas multipole for leaf cells only if(hydro)then do i=1,nleaf mm=max(uold(ind_leaf(i),1),smallr)*vol_loc unew(ind_leaf(i),1)=unew(ind_leaf(i),1)+mm end do do idim=1,ndim do i=1,nleaf mm=max(uold(ind_leaf(i),1),smallr)*vol_loc unew(ind_leaf(i),idim+1)=unew(ind_leaf(i),idim+1)+mm*xx(i,idim) end do end do endif ! Add analytical density profile for leaf cells only if(gravity_type < 0)then ! Call user defined routine rho_ana call rho_ana(xx,dd,dx_loc,nleaf) ! Scatter results to array phi do i=1,nleaf unew(ind_leaf(i),1)=unew(ind_leaf(i),1)+dd(i)*vol_loc end do do idim=1,ndim do i=1,nleaf mm=dd(i)*vol_loc unew(ind_leaf(i),idim+1)=unew(ind_leaf(i),idim+1)+mm*xx(i,idim) end do end do end if ! Gather split cells nsplit=0 do i=1,ngrid if(son(ind_cell(i))>0)then nsplit=nsplit+1 ind_split(nsplit)=ind_cell(i) end if end do ! Add children multipoles do ind_son=1,twotondim iskip_son=ncoarse+(ind_son-1)*ngridmax do i=1,nsplit ind_grid_son=son(ind_split(i)) ind_cell_son=iskip_son+ind_grid_son unew(ind_split(i),1)=unew(ind_split(i),1)+unew(ind_cell_son,1) end do do idim=1,ndim do i=1,nsplit ind_grid_son=son(ind_split(i)) ind_cell_son=iskip_son+ind_grid_son unew(ind_split(i),idim+1)=unew(ind_split(i),idim+1)+unew(ind_cell_son,idim+1) end do end do end do end do enddo ! Update boundaries do idim=1,ndim+1 call make_virtual_fine_dp(unew(1,idim),ilevel) end do 111 format(' Entering multipole_fine for level',i2) end subroutine multipole_fine !########################################################### !########################################################### !########################################################### !########################################################### subroutine ngp_amr_gas(ind_cell,ind_part,ind_grid_part,x0,ng,np,ilevel) use amr_commons use pm_commons use hydro_commons use poisson_commons implicit none integer::ng,np,ilevel integer ,dimension(1:nvector)::ind_cell,ind_grid_part,ind_part real(dp),dimension(1:nvector,1:ndim)::x0 !------------------------------------------------------------------ ! This routine computes the density field at level ilevel using ! the CIC scheme. Only cells that are in level ilevel ! are updated by the input particle list. !------------------------------------------------------------------ integer::j,ind,idim,nx_loc,iskip real(dp)::dx,dx_loc,scale ! Grid-based arrays integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids ! Particle-based arrays logical ,dimension(1:nvector),save::ok real(dp),dimension(1:nvector),save::mmm real(dp),dimension(1:nvector),save::ttt=0d0 real(dp),dimension(1:nvector),save::vol2 real(dp),dimension(1:nvector,1:ndim),save::x,dd,dg integer ,dimension(1:nvector,1:ndim),save::id,igd,icd real(dp),dimension(1:nvector),save::vol integer ,dimension(1:nvector),save::igrid,icell,indp,kg real(dp),dimension(1:3)::skip_loc real(dp),dimension(1:nvector),save::vol_loc ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc(1:nvector)=dx_loc**ndim call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ng,ilevel) ! Rescale position at level ilevel do idim=1,ndim do j=1,np x(j,idim)=xp(ind_part(j),idim)/scale+skip_loc(idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)-x0(ind_grid_part(j),idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/dx end do end do ! NGP at level ilevel do idim=1,ndim do j=1,np id(j,idim)=x(j,idim) end do end do ! Compute parent grids do idim=1,ndim do j=1,np igd(j,idim)=id(j,idim)/2 end do end do do j=1,np kg(j)=1+igd(j,1)+3*igd(j,2)+9*igd(j,3) end do do j=1,np igrid(j)=son(nbors_father_cells(ind_grid_part(j),kg(j))) end do ! Check if particles are entirely in level ilevel ok(1:np)=.true. do j=1,np ok(j)=ok(j).and.igrid(j)>0 end do ! Compute parent cell position do idim=1,ndim do j=1,np if(ok(j)) then icd(j,idim)=id(j,idim)-2*igd(j,idim) endif end do end do do j=1,np if(ok(j)) then icell(j)=1+icd(j,1)+2*icd(j,2)+4*icd(j,3) endif end do ! Compute parent cell adresses do j=1,np if(ok(j))then indp(j)=ncoarse+(icell(j)-1)*ngridmax+igrid(j) else indp(j) = nbors_father_cells(ind_grid_part(j),kg(j)) end if end do if(hydro)then do j=1,np unew(indp(j),1)=unew(indp(j),1)+mp(ind_part(j)) end do do idim=1,ndim do j=1,np unew(indp(j),idim+1)=unew(indp(j),idim+1)+mp(ind_part(j))*xp(ind_part(j),idim) end do end do endif end subroutine ngp_amr_gas !########################################################### !########################################################### !########################################################### !########################################################### subroutine cic_from_multipole(ilevel) use amr_commons use hydro_commons use poisson_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel logical::multigrid !------------------------------------------------------------------- ! This routine compute array rho (source term for Poisson equation) ! by first reseting array rho to zero, then ! by affecting the gas density to leaf cells, and finally ! by performing a restriction operation for split cells. ! For pure particle runs, the restriction is not necessary and the ! routine only set rho to zero. On the other hand, for the Multigrid ! solver, the restriction is necessary in any case. !------------------------------------------------------------------- integer ::ind,i,j,icpu,ncache,ngrid,iskip,info,ibound,nx_loc integer ::idim,nleaf,ix,iy,iz,igrid integer,dimension(1:nvector),save::ind_grid if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Initialize density field to zero do icpu=1,ncpu do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,reception(icpu,ilevel)%ngrid rho(reception(icpu,ilevel)%igrid(i)+iskip)=0.0D0 end do end do end do do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid rho(active(ilevel)%igrid(i)+iskip)=0.0D0 end do end do ! Reset rho in physical boundaries do ibound=1,nboundary do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,boundary(ibound,ilevel)%ngrid rho(boundary(ibound,ilevel)%igrid(i)+iskip)=0.0 end do end do end do if(hydro)then ! Perform a restriction over split cells (ilevel+1) ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ! Gather nvector grids ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do call cic_cell(ind_grid,ngrid,ilevel) end do end if 111 format(' Entering cic_from_multipole for level',i2) end subroutine cic_from_multipole !########################################################### !########################################################### !########################################################### !########################################################### subroutine cic_cell(ind_grid,ngrid,ilevel) use amr_commons use poisson_commons use hydro_commons, ONLY: unew implicit none integer::ngrid,ilevel integer,dimension(1:nvector)::ind_grid ! ! integer::i,j,idim,ind_cell_son,iskip_son,np,ind_son,nx_loc,ind integer ,dimension(1:nvector),save::ind_cell,ind_cell_father integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids real(dp),dimension(1:nvector),save::new_rho ! Particle-based arrays logical ,dimension(1:nvector),save::ok real(dp),dimension(1:nvector),save::mmm,ttt real(dp),dimension(1:nvector),save::vol2 real(dp),dimension(1:nvector,1:ndim),save::x,dd,dg integer ,dimension(1:nvector,1:ndim),save::ig,id,igg,igd,icg,icd real(dp),dimension(1:nvector,1:twotondim),save::vol integer ,dimension(1:nvector,1:twotondim),save::igrid,icell,indp,kg real(dp),dimension(1:3)::skip_loc real(kind=8)::dx,dx_loc,scale,vol_loc logical::error ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim np=ngrid ! Compute father cell index do i=1,ngrid ind_cell(i)=father(ind_grid(i)) end do ! Gather 3x3x3 neighboring parent cells call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ngrid,ilevel) ! Loop over grid cells do ind_son=1,twotondim iskip_son=ncoarse+(ind_son-1)*ngridmax ! Compute pseudo particle (centre of mass) position do idim=1,ndim do j=1,np ind_cell_son=iskip_son+ind_grid(j) x(j,idim)=unew(ind_cell_son,idim+1)/unew(ind_cell_son,1) end do end do ! Compute total multipole if(ilevel==levelmin)then do idim=1,ndim+1 do j=1,np ind_cell_son=iskip_son+ind_grid(j) multipole(idim)=multipole(idim)+unew(ind_cell_son,idim) end do end do endif ! Rescale particle position at level ilevel do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/scale+skip_loc(idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)-(xg(ind_grid(j),idim)-3d0*dx) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/dx end do end do ! Gather particle mass do j=1,np ind_cell_son=iskip_son+ind_grid(j) mmm(j)=unew(ind_cell_son,1) end do ! CIC at level ilevel (dd: right cloud boundary; dg: left cloud boundary) do idim=1,ndim do j=1,np dd(j,idim)=x(j,idim)+0.5D0 id(j,idim)=dd(j,idim) dd(j,idim)=dd(j,idim)-id(j,idim) dg(j,idim)=1.0D0-dd(j,idim) ig(j,idim)=id(j,idim)-1 end do end do ! Check for illegal moves error=.false. do idim=1,ndim do j=1,np if(x(j,idim)<0.5D0.or.x(j,idim)>5.5D0)error=.true. end do end do if(error)then write(*,*)'problem in cic' do idim=1,ndim do j=1,np if(x(j,idim)<0.5D0.or.x(j,idim)>5.5D0)then write(*,*)x(j,1:ndim) endif end do end do stop end if ! Compute cloud volumes #if NDIM==1 do j=1,np vol(j,1)=dg(j,1) vol(j,2)=dd(j,1) end do #endif #if NDIM==2 do j=1,np vol(j,1)=dg(j,1)*dg(j,2) vol(j,2)=dd(j,1)*dg(j,2) vol(j,3)=dg(j,1)*dd(j,2) vol(j,4)=dd(j,1)*dd(j,2) end do #endif #if NDIM==3 do j=1,np vol(j,1)=dg(j,1)*dg(j,2)*dg(j,3) vol(j,2)=dd(j,1)*dg(j,2)*dg(j,3) vol(j,3)=dg(j,1)*dd(j,2)*dg(j,3) vol(j,4)=dd(j,1)*dd(j,2)*dg(j,3) vol(j,5)=dg(j,1)*dg(j,2)*dd(j,3) vol(j,6)=dd(j,1)*dg(j,2)*dd(j,3) vol(j,7)=dg(j,1)*dd(j,2)*dd(j,3) vol(j,8)=dd(j,1)*dd(j,2)*dd(j,3) end do #endif ! Compute parent grids do idim=1,ndim do j=1,np igg(j,idim)=ig(j,idim)/2 igd(j,idim)=id(j,idim)/2 end do end do #if NDIM==1 do j=1,np kg(j,1)=1+igg(j,1) kg(j,2)=1+igd(j,1) end do #endif #if NDIM==2 do j=1,np kg(j,1)=1+igg(j,1)+3*igg(j,2) kg(j,2)=1+igd(j,1)+3*igg(j,2) kg(j,3)=1+igg(j,1)+3*igd(j,2) kg(j,4)=1+igd(j,1)+3*igd(j,2) end do #endif #if NDIM==3 do j=1,np kg(j,1)=1+igg(j,1)+3*igg(j,2)+9*igg(j,3) kg(j,2)=1+igd(j,1)+3*igg(j,2)+9*igg(j,3) kg(j,3)=1+igg(j,1)+3*igd(j,2)+9*igg(j,3) kg(j,4)=1+igd(j,1)+3*igd(j,2)+9*igg(j,3) kg(j,5)=1+igg(j,1)+3*igg(j,2)+9*igd(j,3) kg(j,6)=1+igd(j,1)+3*igg(j,2)+9*igd(j,3) kg(j,7)=1+igg(j,1)+3*igd(j,2)+9*igd(j,3) kg(j,8)=1+igd(j,1)+3*igd(j,2)+9*igd(j,3) end do #endif do ind=1,twotondim do j=1,np igrid(j,ind)=son(nbors_father_cells(j,kg(j,ind))) end do end do ! Compute parent cell position do idim=1,ndim do j=1,np icg(j,idim)=ig(j,idim)-2*igg(j,idim) icd(j,idim)=id(j,idim)-2*igd(j,idim) end do end do #if NDIM==1 do j=1,np icell(j,1)=1+icg(j,1) icell(j,2)=1+icd(j,1) end do #endif #if NDIM==2 do j=1,np icell(j,1)=1+icg(j,1)+2*icg(j,2) icell(j,2)=1+icd(j,1)+2*icg(j,2) icell(j,3)=1+icg(j,1)+2*icd(j,2) icell(j,4)=1+icd(j,1)+2*icd(j,2) end do #endif #if NDIM==3 do j=1,np icell(j,1)=1+icg(j,1)+2*icg(j,2)+4*icg(j,3) icell(j,2)=1+icd(j,1)+2*icg(j,2)+4*icg(j,3) icell(j,3)=1+icg(j,1)+2*icd(j,2)+4*icg(j,3) icell(j,4)=1+icd(j,1)+2*icd(j,2)+4*icg(j,3) icell(j,5)=1+icg(j,1)+2*icg(j,2)+4*icd(j,3) icell(j,6)=1+icd(j,1)+2*icg(j,2)+4*icd(j,3) icell(j,7)=1+icg(j,1)+2*icd(j,2)+4*icd(j,3) icell(j,8)=1+icd(j,1)+2*icd(j,2)+4*icd(j,3) end do #endif ! Compute parent cell adress do ind=1,twotondim do j=1,np indp(j,ind)=ncoarse+(icell(j,ind)-1)*ngridmax+igrid(j,ind) end do end do ! Update mass density and number density fields do ind=1,twotondim do j=1,np ok(j)=igrid(j,ind)>0 end do do j=1,np vol2(j)=mmm(j)*vol(j,ind)/vol_loc end do do j=1,np if(ok(j))then rho(indp(j,ind))=rho(indp(j,ind))+vol2(j) end if end do end do end do ! End loop over grid cells end subroutine cic_cell !############################################################################## !############################################################################## !############################################################################## !############################################################################## subroutine tsc_amr(ind_cell,ind_part,ind_grid_part,x0,ng,np,ilevel) use amr_commons use amr_parameters use pm_commons use poisson_commons use hydro_commons, ONLY: mass_sph implicit none integer::ng,np,ilevel integer ,dimension(1:nvector)::ind_cell,ind_grid_part,ind_part real(dp),dimension(1:nvector,1:ndim)::x0 !------------------------------------------------------------------ ! This routine computes the density field at level ilevel using ! the TSC scheme. Only cells that are in level ilevel ! are updated by the input particle list. !------------------------------------------------------------------ integer::j,ind,idim,nx_loc real(dp)::dx,dx_loc,scale,vol_loc ! Grid-based arrays integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids ! Particle-based arrays logical ,dimension(1:nvector),save::ok,abandoned real(dp),dimension(1:nvector),save::mmm real(dp),dimension(1:nvector),save::ttt=0d0 real(dp),dimension(1:nvector),save::vol2 real(dp),dimension(1:nvector,1:ndim),save::x,cl,cr,cc,wl,wr,wc integer ,dimension(1:nvector,1:ndim),save::igl,igr,igc,icl,icr,icc real(dp),dimension(1:nvector,1:threetondim),save::vol integer ,dimension(1:nvector,1:threetondim),save::igrid,icell,indp,kg real(dp),dimension(1:3)::skip_loc if (ndim .ne. 3)then write(*,*)'TSC not supported for ndim neq 3' call clean_stop end if #if NDIM==3 ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim ! Gather neighboring father cells (should be present at anytime!) call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ng,ilevel) ! Rescale particle position at level ilevel do idim=1,ndim do j=1,np x(j,idim)=xp(ind_part(j),idim)/scale+skip_loc(idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)-x0(ind_grid_part(j),idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/dx end do end do ! Gather particle mass do j=1,np mmm(j)=mp(ind_part(j)) end do if(ilevel==levelmin)then do j=1,np multipole(1)=multipole(1)+mp(ind_part(j)) end do do idim=1,ndim do j=1,np multipole(idim+1)=multipole(idim+1)+mp(ind_part(j))*xp(ind_part(j),idim) end do end do end if ! Gather particle birth epoch if(star)then do j=1,np ttt(j)=tp(ind_part(j)) end do endif ! Check for illegal moves abandoned(1:np)=.false. do idim=1,ndim do j=1,np if(x(j,idim)<1.0D0.or.x(j,idim)>5.0D0) abandoned(j)=.true. end do end do ! TSC at level ilevel; a particle contributes ! to three cells in each dimension ! cl: position of leftmost cell centre ! cc: position of central cell centre ! cr: position of rightmost cell centre ! wl: weighting function for leftmost cell ! wc: weighting function for central cell ! wr: weighting function for rightmost cell do idim=1,ndim do j=1,np if(.not.abandoned(j)) then cl(j,idim)=dble(int(x(j,idim)))-0.5D0 cc(j,idim)=dble(int(x(j,idim)))+0.5D0 cr(j,idim)=dble(int(x(j,idim)))+1.5D0 wl(j,idim)=0.50D0*(1.5D0-abs(x(j,idim)-cl(j,idim)))**2 wc(j,idim)=0.75D0- (x(j,idim)-cc(j,idim)) **2 wr(j,idim)=0.50D0*(1.5D0-abs(x(j,idim)-cr(j,idim)))**2 end if end do end do ! Compute cloud volumes do j=1,np if(.not.abandoned(j)) then vol(j,1 )=wl(j,1)*wl(j,2)*wl(j,3) vol(j,2 )=wc(j,1)*wl(j,2)*wl(j,3) vol(j,3 )=wr(j,1)*wl(j,2)*wl(j,3) vol(j,4 )=wl(j,1)*wc(j,2)*wl(j,3) vol(j,5 )=wc(j,1)*wc(j,2)*wl(j,3) vol(j,6 )=wr(j,1)*wc(j,2)*wl(j,3) vol(j,7 )=wl(j,1)*wr(j,2)*wl(j,3) vol(j,8 )=wc(j,1)*wr(j,2)*wl(j,3) vol(j,9 )=wr(j,1)*wr(j,2)*wl(j,3) vol(j,10)=wl(j,1)*wl(j,2)*wc(j,3) vol(j,11)=wc(j,1)*wl(j,2)*wc(j,3) vol(j,12)=wr(j,1)*wl(j,2)*wc(j,3) vol(j,13)=wl(j,1)*wc(j,2)*wc(j,3) vol(j,14)=wc(j,1)*wc(j,2)*wc(j,3) vol(j,15)=wr(j,1)*wc(j,2)*wc(j,3) vol(j,16)=wl(j,1)*wr(j,2)*wc(j,3) vol(j,17)=wc(j,1)*wr(j,2)*wc(j,3) vol(j,18)=wr(j,1)*wr(j,2)*wc(j,3) vol(j,19)=wl(j,1)*wl(j,2)*wr(j,3) vol(j,20)=wc(j,1)*wl(j,2)*wr(j,3) vol(j,21)=wr(j,1)*wl(j,2)*wr(j,3) vol(j,22)=wl(j,1)*wc(j,2)*wr(j,3) vol(j,23)=wc(j,1)*wc(j,2)*wr(j,3) vol(j,24)=wr(j,1)*wc(j,2)*wr(j,3) vol(j,25)=wl(j,1)*wr(j,2)*wr(j,3) vol(j,26)=wc(j,1)*wr(j,2)*wr(j,3) vol(j,27)=wr(j,1)*wr(j,2)*wr(j,3) end if end do ! Compute parent grids do idim=1,ndim do j=1,np if(.not.abandoned(j)) then igl(j,idim)=(int(cl(j,idim)))/2 igc(j,idim)=(int(cc(j,idim)))/2 igr(j,idim)=(int(cr(j,idim)))/2 end if end do end do do j=1,np if(.not.abandoned(j)) then kg(j,1 )=1+igl(j,1)+3*igl(j,2)+9*igl(j,3) kg(j,2 )=1+igc(j,1)+3*igl(j,2)+9*igl(j,3) kg(j,3 )=1+igr(j,1)+3*igl(j,2)+9*igl(j,3) kg(j,4 )=1+igl(j,1)+3*igc(j,2)+9*igl(j,3) kg(j,5 )=1+igc(j,1)+3*igc(j,2)+9*igl(j,3) kg(j,6 )=1+igr(j,1)+3*igc(j,2)+9*igl(j,3) kg(j,7 )=1+igl(j,1)+3*igr(j,2)+9*igl(j,3) kg(j,8 )=1+igc(j,1)+3*igr(j,2)+9*igl(j,3) kg(j,9 )=1+igr(j,1)+3*igr(j,2)+9*igl(j,3) kg(j,10)=1+igl(j,1)+3*igl(j,2)+9*igc(j,3) kg(j,11)=1+igc(j,1)+3*igl(j,2)+9*igc(j,3) kg(j,12)=1+igr(j,1)+3*igl(j,2)+9*igc(j,3) kg(j,13)=1+igl(j,1)+3*igc(j,2)+9*igc(j,3) kg(j,14)=1+igc(j,1)+3*igc(j,2)+9*igc(j,3) kg(j,15)=1+igr(j,1)+3*igc(j,2)+9*igc(j,3) kg(j,16)=1+igl(j,1)+3*igr(j,2)+9*igc(j,3) kg(j,17)=1+igc(j,1)+3*igr(j,2)+9*igc(j,3) kg(j,18)=1+igr(j,1)+3*igr(j,2)+9*igc(j,3) kg(j,19)=1+igl(j,1)+3*igl(j,2)+9*igr(j,3) kg(j,20)=1+igc(j,1)+3*igl(j,2)+9*igr(j,3) kg(j,21)=1+igr(j,1)+3*igl(j,2)+9*igr(j,3) kg(j,22)=1+igl(j,1)+3*igc(j,2)+9*igr(j,3) kg(j,23)=1+igc(j,1)+3*igc(j,2)+9*igr(j,3) kg(j,24)=1+igr(j,1)+3*igc(j,2)+9*igr(j,3) kg(j,25)=1+igl(j,1)+3*igr(j,2)+9*igr(j,3) kg(j,26)=1+igc(j,1)+3*igr(j,2)+9*igr(j,3) kg(j,27)=1+igr(j,1)+3*igr(j,2)+9*igr(j,3) end if end do do ind=1,threetondim do j=1,np igrid(j,ind)=son(nbors_father_cells(ind_grid_part(j),kg(j,ind))) end do end do ! Compute parent cell position do idim=1,ndim do j=1,np if(.not.abandoned(j)) then icl(j,idim)=int(cl(j,idim))-2*igl(j,idim) icc(j,idim)=int(cc(j,idim))-2*igc(j,idim) icr(j,idim)=int(cr(j,idim))-2*igr(j,idim) end if end do end do do j=1,np if(.not.abandoned(j)) then icell(j,1 )=1+icl(j,1)+2*icl(j,2)+4*icl(j,3) icell(j,2 )=1+icc(j,1)+2*icl(j,2)+4*icl(j,3) icell(j,3 )=1+icr(j,1)+2*icl(j,2)+4*icl(j,3) icell(j,4 )=1+icl(j,1)+2*icc(j,2)+4*icl(j,3) icell(j,5 )=1+icc(j,1)+2*icc(j,2)+4*icl(j,3) icell(j,6 )=1+icr(j,1)+2*icc(j,2)+4*icl(j,3) icell(j,7 )=1+icl(j,1)+2*icr(j,2)+4*icl(j,3) icell(j,8 )=1+icc(j,1)+2*icr(j,2)+4*icl(j,3) icell(j,9 )=1+icr(j,1)+2*icr(j,2)+4*icl(j,3) icell(j,10)=1+icl(j,1)+2*icl(j,2)+4*icc(j,3) icell(j,11)=1+icc(j,1)+2*icl(j,2)+4*icc(j,3) icell(j,12)=1+icr(j,1)+2*icl(j,2)+4*icc(j,3) icell(j,13)=1+icl(j,1)+2*icc(j,2)+4*icc(j,3) icell(j,14)=1+icc(j,1)+2*icc(j,2)+4*icc(j,3) icell(j,15)=1+icr(j,1)+2*icc(j,2)+4*icc(j,3) icell(j,16)=1+icl(j,1)+2*icr(j,2)+4*icc(j,3) icell(j,17)=1+icc(j,1)+2*icr(j,2)+4*icc(j,3) icell(j,18)=1+icr(j,1)+2*icr(j,2)+4*icc(j,3) icell(j,19)=1+icl(j,1)+2*icl(j,2)+4*icr(j,3) icell(j,20)=1+icc(j,1)+2*icl(j,2)+4*icr(j,3) icell(j,21)=1+icr(j,1)+2*icl(j,2)+4*icr(j,3) icell(j,22)=1+icl(j,1)+2*icc(j,2)+4*icr(j,3) icell(j,23)=1+icc(j,1)+2*icc(j,2)+4*icr(j,3) icell(j,24)=1+icr(j,1)+2*icc(j,2)+4*icr(j,3) icell(j,25)=1+icl(j,1)+2*icr(j,2)+4*icr(j,3) icell(j,26)=1+icc(j,1)+2*icr(j,2)+4*icr(j,3) icell(j,27)=1+icr(j,1)+2*icr(j,2)+4*icr(j,3) end if end do ! Compute parent cell adress do ind=1,threetondim do j=1,np if(.not.abandoned(j)) then indp(j,ind)=ncoarse+(icell(j,ind)-1)*ngridmax+igrid(j,ind) end if end do end do ! Update mass density and number density fields do ind=1,threetondim do j=1,np if(.not.abandoned(j)) then ok(j)=igrid(j,ind)>0 end if end do do j=1,np if(.not.abandoned(j)) then vol2(j)=mmm(j)*vol(j,ind)/vol_loc end if end do if(cic_levelmax==0.or.ilevel<=cic_levelmax) then do j=1,np if(ok(j).and.(.not.abandoned(j))) then rho(indp(j,ind))=rho(indp(j,ind))+vol2(j) end if end do else if(ilevel>cic_levelmax) then do j=1,np if(ok(j).and.(ttt(j).ne.0d0).and.(.not.abandoned(j))) then rho(indp(j,ind))=rho(indp(j,ind))+vol2(j) end if end do endif if(ilevel==cic_levelmax)then do j=1,np if(ok(j).and.(ttt(j)==0d0).and.(.not.abandoned(j)))then rho_top(indp(j,ind))=rho_top(indp(j,ind))+vol2(j) end if end do endif do j=1,np if(.not.abandoned(j)) then vol2(j)=vol(j,ind) end if end do ! Remove test particles for static runs if(static) then do j=1,np if(.not.abandoned(j)) then ok(j)=ok(j).and.(mmm(j)>0.0) end if end do endif ! Remove massive dark matter particle if(mass_cut_refine>0.0) then do j=1,np if(ttt(j)==0d0.and.(.not.abandoned(j))) then ok(j)=ok(j).and.mmm(j)=cic_levelmax) then do j=1,np if(ok(j).and.(ttt(j).ne.0d0).and.(.not.abandoned(j))) then phi(indp(j,ind))=phi(indp(j,ind))+vol2(j) end if end do endif end do #endif end subroutine tsc_amr !########################################################### !########################################################### !########################################################### !########################################################### subroutine tsc_from_multipole(ilevel) use amr_commons use hydro_commons use poisson_commons implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel logical::multigrid !------------------------------------------------------------------- ! This routine compute array rho (source term for Poisson equation) ! by first reseting array rho to zero, then ! by affecting the gas density to leaf cells, and finally ! by performing a restriction operation for split cells. ! For pure particle runs, the restriction is not necessary and the ! routine only set rho to zero. On the other hand, for the Multigrid ! solver, the restriction is necessary in any case. !------------------------------------------------------------------- integer ::ind,i,j,icpu,ncache,ngrid,iskip,info,ibound,nx_loc integer ::idim,nleaf,ix,iy,iz,igrid integer,dimension(1:nvector),save::ind_grid #if NDIM==3 if(numbtot(1,ilevel)==0)return if(verbose)write(*,111)ilevel ! Initialize density field to zero do icpu=1,ncpu do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,reception(icpu,ilevel)%ngrid rho(reception(icpu,ilevel)%igrid(i)+iskip)=0.0D0 end do end do end do do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,active(ilevel)%ngrid rho(active(ilevel)%igrid(i)+iskip)=0.0D0 end do end do ! Reset rho in physical boundaries do ibound=1,nboundary do ind=1,twotondim iskip=ncoarse+(ind-1)*ngridmax do i=1,boundary(ibound,ilevel)%ngrid rho(boundary(ibound,ilevel)%igrid(i)+iskip)=0.0 end do end do end do if(hydro)then ! Perform a restriction over split cells (ilevel+1) ncache=active(ilevel)%ngrid do igrid=1,ncache,nvector ! Gather nvector grids ngrid=MIN(nvector,ncache-igrid+1) do i=1,ngrid ind_grid(i)=active(ilevel)%igrid(igrid+i-1) end do call tsc_cell(ind_grid,ngrid,ilevel) end do end if #endif 111 format(' Entering tsc_from_multipole for level',i2) end subroutine tsc_from_multipole !########################################################### !########################################################### !########################################################### !########################################################### subroutine tsc_cell(ind_grid,ngrid,ilevel) use amr_commons use poisson_commons use hydro_commons, ONLY: unew implicit none integer::ngrid,ilevel integer,dimension(1:nvector)::ind_grid ! ! integer::i,j,idim,ind_cell_son,iskip_son,np,ind_son,nx_loc,ind integer ,dimension(1:nvector),save::ind_cell,ind_cell_father integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids real(dp),dimension(1:nvector),save::new_rho ! Particle-based arrays logical ,dimension(1:nvector),save::ok real(dp),dimension(1:nvector),save::mmm,ttt real(dp),dimension(1:nvector),save::vol2 real(dp),dimension(1:nvector,1:ndim),save::x,cl,cr,cc,wl,wr,wc integer ,dimension(1:nvector,1:ndim),save::igl,igr,igc,icl,icr,icc real(dp),dimension(1:nvector,1:threetondim),save::vol integer ,dimension(1:nvector,1:threetondim),save::igrid,icell,indp,kg real(dp),dimension(1:3)::skip_loc real(kind=8)::dx,dx_loc,scale,vol_loc logical::error #if NDIM==3 ! Mesh spacing in that level dx=0.5D0**ilevel nx_loc=(icoarse_max-icoarse_min+1) skip_loc=(/0.0d0,0.0d0,0.0d0/) if(ndim>0)skip_loc(1)=dble(icoarse_min) if(ndim>1)skip_loc(2)=dble(jcoarse_min) if(ndim>2)skip_loc(3)=dble(kcoarse_min) scale=boxlen/dble(nx_loc) dx_loc=dx*scale vol_loc=dx_loc**ndim np=ngrid ! Compute father cell index do i=1,ngrid ind_cell(i)=father(ind_grid(i)) end do ! Gather 3x3x3 neighboring parent cells call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ngrid,ilevel) ! Loop over grid cells do ind_son=1,twotondim iskip_son=ncoarse+(ind_son-1)*ngridmax ! Compute pseudo particle (centre of mass) position do idim=1,ndim do j=1,np ind_cell_son=iskip_son+ind_grid(j) x(j,idim)=unew(ind_cell_son,idim+1)/unew(ind_cell_son,1) end do end do ! Compute total multipole if(ilevel==levelmin)then do idim=1,ndim+1 do j=1,np ind_cell_son=iskip_son+ind_grid(j) multipole(idim)=multipole(idim)+unew(ind_cell_son,idim) end do end do endif ! Rescale particle position at level ilevel do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/scale+skip_loc(idim) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)-(xg(ind_grid(j),idim)-3d0*dx) end do end do do idim=1,ndim do j=1,np x(j,idim)=x(j,idim)/dx end do end do ! Gather particle mass do j=1,np ind_cell_son=iskip_son+ind_grid(j) mmm(j)=unew(ind_cell_son,1) end do ! TSC at level ilevel; a particle contributes ! to three cells in each dimension ! cl: position of leftmost cell centre ! cc: position of central cell centre ! cr: position of rightmost cell centre ! wl: weighting function for leftmost cell ! wc: weighting function for central cell ! wr: weighting function for rightmost cell do idim=1,ndim do j=1,np cl(j,idim)=dble(int(x(j,idim)))-0.5D0 cc(j,idim)=dble(int(x(j,idim)))+0.5D0 cr(j,idim)=dble(int(x(j,idim)))+1.5D0 wl(j,idim)=0.50D0*(1.5D0-abs(x(j,idim)-cl(j,idim)))**2 wc(j,idim)=0.75D0- (x(j,idim)-cc(j,idim)) **2 wr(j,idim)=0.50D0*(1.5D0-abs(x(j,idim)-cr(j,idim)))**2 end do end do ! Check for illegal moves error=.false. do idim=1,ndim do j=1,np if(x(j,idim)<1.0D0.or.x(j,idim)>5.0D0)error=.true. end do end do if(error)then write(*,*)'problem in tsc_cell' do idim=1,ndim do j=1,np if(x(j,idim)<1.0D0.or.x(j,idim)>5.0D0)then write(*,*)x(j,1:ndim) endif end do end do stop end if ! Compute cloud volumes do j=1,np vol(j,1 )=wl(j,1)*wl(j,2)*wl(j,3) vol(j,2 )=wc(j,1)*wl(j,2)*wl(j,3) vol(j,3 )=wr(j,1)*wl(j,2)*wl(j,3) vol(j,4 )=wl(j,1)*wc(j,2)*wl(j,3) vol(j,5 )=wc(j,1)*wc(j,2)*wl(j,3) vol(j,6 )=wr(j,1)*wc(j,2)*wl(j,3) vol(j,7 )=wl(j,1)*wr(j,2)*wl(j,3) vol(j,8 )=wc(j,1)*wr(j,2)*wl(j,3) vol(j,9 )=wr(j,1)*wr(j,2)*wl(j,3) vol(j,10)=wl(j,1)*wl(j,2)*wc(j,3) vol(j,11)=wc(j,1)*wl(j,2)*wc(j,3) vol(j,12)=wr(j,1)*wl(j,2)*wc(j,3) vol(j,13)=wl(j,1)*wc(j,2)*wc(j,3) vol(j,14)=wc(j,1)*wc(j,2)*wc(j,3) vol(j,15)=wr(j,1)*wc(j,2)*wc(j,3) vol(j,16)=wl(j,1)*wr(j,2)*wc(j,3) vol(j,17)=wc(j,1)*wr(j,2)*wc(j,3) vol(j,18)=wr(j,1)*wr(j,2)*wc(j,3) vol(j,19)=wl(j,1)*wl(j,2)*wr(j,3) vol(j,20)=wc(j,1)*wl(j,2)*wr(j,3) vol(j,21)=wr(j,1)*wl(j,2)*wr(j,3) vol(j,22)=wl(j,1)*wc(j,2)*wr(j,3) vol(j,23)=wc(j,1)*wc(j,2)*wr(j,3) vol(j,24)=wr(j,1)*wc(j,2)*wr(j,3) vol(j,25)=wl(j,1)*wr(j,2)*wr(j,3) vol(j,26)=wc(j,1)*wr(j,2)*wr(j,3) vol(j,27)=wr(j,1)*wr(j,2)*wr(j,3) end do ! Compute parent grids do idim=1,ndim do j=1,np igl(j,idim)=(int(cl(j,idim)))/2 igc(j,idim)=(int(cc(j,idim)))/2 igr(j,idim)=(int(cr(j,idim)))/2 end do end do do j=1,np kg(j,1 )=1+igl(j,1)+3*igl(j,2)+9*igl(j,3) kg(j,2 )=1+igc(j,1)+3*igl(j,2)+9*igl(j,3) kg(j,3 )=1+igr(j,1)+3*igl(j,2)+9*igl(j,3) kg(j,4 )=1+igl(j,1)+3*igc(j,2)+9*igl(j,3) kg(j,5 )=1+igc(j,1)+3*igc(j,2)+9*igl(j,3) kg(j,6 )=1+igr(j,1)+3*igc(j,2)+9*igl(j,3) kg(j,7 )=1+igl(j,1)+3*igr(j,2)+9*igl(j,3) kg(j,8 )=1+igc(j,1)+3*igr(j,2)+9*igl(j,3) kg(j,9 )=1+igr(j,1)+3*igr(j,2)+9*igl(j,3) kg(j,10)=1+igl(j,1)+3*igl(j,2)+9*igc(j,3) kg(j,11)=1+igc(j,1)+3*igl(j,2)+9*igc(j,3) kg(j,12)=1+igr(j,1)+3*igl(j,2)+9*igc(j,3) kg(j,13)=1+igl(j,1)+3*igc(j,2)+9*igc(j,3) kg(j,14)=1+igc(j,1)+3*igc(j,2)+9*igc(j,3) kg(j,15)=1+igr(j,1)+3*igc(j,2)+9*igc(j,3) kg(j,16)=1+igl(j,1)+3*igr(j,2)+9*igc(j,3) kg(j,17)=1+igc(j,1)+3*igr(j,2)+9*igc(j,3) kg(j,18)=1+igr(j,1)+3*igr(j,2)+9*igc(j,3) kg(j,19)=1+igl(j,1)+3*igl(j,2)+9*igr(j,3) kg(j,20)=1+igc(j,1)+3*igl(j,2)+9*igr(j,3) kg(j,21)=1+igr(j,1)+3*igl(j,2)+9*igr(j,3) kg(j,22)=1+igl(j,1)+3*igc(j,2)+9*igr(j,3) kg(j,23)=1+igc(j,1)+3*igc(j,2)+9*igr(j,3) kg(j,24)=1+igr(j,1)+3*igc(j,2)+9*igr(j,3) kg(j,25)=1+igl(j,1)+3*igr(j,2)+9*igr(j,3) kg(j,26)=1+igc(j,1)+3*igr(j,2)+9*igr(j,3) kg(j,27)=1+igr(j,1)+3*igr(j,2)+9*igr(j,3) end do do ind=1,threetondim do j=1,np igrid(j,ind)=son(nbors_father_cells(j,kg(j,ind))) end do end do ! Compute parent cell position do idim=1,ndim do j=1,np icl(j,idim)=int(cl(j,idim))-2*igl(j,idim) icc(j,idim)=int(cc(j,idim))-2*igc(j,idim) icr(j,idim)=int(cr(j,idim))-2*igr(j,idim) end do end do do j=1,np icell(j,1 )=1+icl(j,1)+2*icl(j,2)+4*icl(j,3) icell(j,2 )=1+icc(j,1)+2*icl(j,2)+4*icl(j,3) icell(j,3 )=1+icr(j,1)+2*icl(j,2)+4*icl(j,3) icell(j,4 )=1+icl(j,1)+2*icc(j,2)+4*icl(j,3) icell(j,5 )=1+icc(j,1)+2*icc(j,2)+4*icl(j,3) icell(j,6 )=1+icr(j,1)+2*icc(j,2)+4*icl(j,3) icell(j,7 )=1+icl(j,1)+2*icr(j,2)+4*icl(j,3) icell(j,8 )=1+icc(j,1)+2*icr(j,2)+4*icl(j,3) icell(j,9 )=1+icr(j,1)+2*icr(j,2)+4*icl(j,3) icell(j,10)=1+icl(j,1)+2*icl(j,2)+4*icc(j,3) icell(j,11)=1+icc(j,1)+2*icl(j,2)+4*icc(j,3) icell(j,12)=1+icr(j,1)+2*icl(j,2)+4*icc(j,3) icell(j,13)=1+icl(j,1)+2*icc(j,2)+4*icc(j,3) icell(j,14)=1+icc(j,1)+2*icc(j,2)+4*icc(j,3) icell(j,15)=1+icr(j,1)+2*icc(j,2)+4*icc(j,3) icell(j,16)=1+icl(j,1)+2*icr(j,2)+4*icc(j,3) icell(j,17)=1+icc(j,1)+2*icr(j,2)+4*icc(j,3) icell(j,18)=1+icr(j,1)+2*icr(j,2)+4*icc(j,3) icell(j,19)=1+icl(j,1)+2*icl(j,2)+4*icr(j,3) icell(j,20)=1+icc(j,1)+2*icl(j,2)+4*icr(j,3) icell(j,21)=1+icr(j,1)+2*icl(j,2)+4*icr(j,3) icell(j,22)=1+icl(j,1)+2*icc(j,2)+4*icr(j,3) icell(j,23)=1+icc(j,1)+2*icc(j,2)+4*icr(j,3) icell(j,24)=1+icr(j,1)+2*icc(j,2)+4*icr(j,3) icell(j,25)=1+icl(j,1)+2*icr(j,2)+4*icr(j,3) icell(j,26)=1+icc(j,1)+2*icr(j,2)+4*icr(j,3) icell(j,27)=1+icr(j,1)+2*icr(j,2)+4*icr(j,3) end do ! Compute parent cell adress do ind=1,threetondim do j=1,np indp(j,ind)=ncoarse+(icell(j,ind)-1)*ngridmax+igrid(j,ind) end do end do ! Update mass density and number density fields do ind=1,twotondim do j=1,np ok(j)=igrid(j,ind)>0 end do do j=1,np vol2(j)=mmm(j)*vol(j,ind)/vol_loc end do do j=1,np if(ok(j))then rho(indp(j,ind))=rho(indp(j,ind))+vol2(j) end if end do end do end do ! End loop over grid cells #endif end subroutine tsc_cell !########################################################### !########################################################### !########################################################### !########################################################### ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/units.f90 subroutine units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) use amr_commons use hydro_commons use cooling_module ! ADDED by TTG (Feb 2017) use hydro_parameters, only: mass_sph real(dp)::scale_nH,scale_T2,scale_t,scale_v,scale_d,scale_l ! ADDED by TTG (Feb 2017) real(dp)::scale_prs,scale_m,scale_phi real(dp)::grav_const=6.6738d-8 ! cm^3/s^2/g real(dp)::msol=1.989d33,kpc=3.086d21,myr=3.154d13 ! g, cm, s logical,save::first_call=.true. !----------------------------------------------------------------------- ! Conversion factors from user units into cgs units ! For gravity runs, make sure that G=1 in user units. !----------------------------------------------------------------------- ! scale_d converts mass density from user units into g/cc scale_d = units_density if(cosmo) scale_d = omega_m * rhoc *(h0/100.)**2 / aexp**3 ! scale_t converts time from user units into seconds scale_t = units_time if(cosmo) scale_t = aexp**2 / (h0*1d5/3.08d24) ! ADDED BY TTG (FEB 2017) G = 1 in code units; therefore: if(poisson) scale_t = 1.0/sqrt(grav_const * scale_d) ! scale_l converts distance from user units into cm scale_l = units_length if(cosmo) scale_l = aexp * boxlen_ini * 3.08d24 / (h0/100) ! scale_v converts velocity in user units into cm/s scale_v = scale_l / scale_t ! scale_T2 converts (P/rho) in user unit into (T/mu) in Kelvin scale_T2 = mH/kB * scale_v**2 ! scale_nH converts rho in user units into nH in H/cc scale_nH = X/mH * scale_d ! ADDED BY TTG (FEB 2017; used only for info purposes) ! scale_prs converts pressure in user units into dyne/cm^2 scale_prs = scale_d * scale_v**2 ! ADDED BY TTG (FEB 2017; used only for info purposes) ! mass conversion factor scale_m = scale_d * scale_l**3 ! ADDED BY TTG (FEB 2017; used only for info purposes) ! potential conversion factor scale_phi = boxlen * scale_v**2 ! output unit information; only main process !NOTE: add pressure unit if ((first_call).and.(myid==1)) then first_call = .false. write(*,*) write(*,*) write(*,*) 'Physical Units:' write(*,*) '---------------' write(*,'(a32,1pe10.2)') 'Unit density [g/cm^3]: ', scale_d write(*,'(a32,1pe10.2)') 'Unit mass [Msun]: ', scale_m / msol write(*,'(a32,1pe10.2)') 'Unit time [Myr]: ', scale_t / myr write(*,'(a32,1pe10.2)') 'Unit length [kpc]: ', scale_l / kpc write(*,'(a32,1pe10.2)') 'Unit velocity [cm/s]: ', scale_v write(*,'(a32,1pe10.2)') 'Unit temperature/mu [K]: ', scale_T2 write(*,'(a32,1pe10.2)') 'Unit hydrogen density [cm^-3]: ', scale_nH write(*,'(a32,1pe10.2)') 'Unit pressure [dyne/cm^2]: ', scale_prs write(*,'(a32,1pe10.2)') 'Unit potential [cm^2/s^2]: ', scale_phi ! ADDED BY TTG (APR 2017) write(*,*) write(*,'(a32,1pe10.2)') 'Refinement > gas mass [Msun]: ',& & m_refine(levelmin+1) * mass_sph * scale_m / msol write(*,*) write(*,*) end if end subroutine units ../patch/mySIMS/Nbody+HD/dice/myics/dice_MW_MCs_restart/src/update_time.f90 !======================================================================= real(kind=8) function wallclock() implicit none #ifdef WITHOUTMPI integer, save :: tstart integer :: tcur integer :: count_rate #else integer :: info real(kind=8), save :: tstart real(kind=8) :: tcur #endif logical, save :: first_call=.true. real(kind=8), save :: norm, offset=0. #ifndef WITHOUTMPI include 'mpif.h' #endif !--------------------------------------------------------------------- if (first_call) then #ifdef WITHOUTMPI call system_clock(count=tstart, count_rate=count_rate) norm=1d0/count_rate #else norm = 1d0 tstart = MPI_Wtime() #endif first_call=.false. end if #ifdef WITHOUTMPI call system_clock(count=tcur) #else tcur = MPI_Wtime() #endif wallclock = (tcur-tstart)*norm + offset if (wallclock < 0.) then offset = offset + 24d0*3600d0 wallclock = wallclock + 24d0*3600d0 end if end function wallclock !======================================================================= module timer_m implicit none integer, parameter :: mtimer=200 ! max nr of timers real(kind=8), dimension(mtimer) :: start, time integer :: ntimer=0, itimer character(len=72), dimension(mtimer) :: labels contains !----------------------------------------------------------------------- subroutine findit (label) implicit none character(len=*) label do itimer=1,ntimer if (trim(label) == trim(labels(itimer))) return end do ntimer = ntimer+1 itimer = ntimer labels(itimer) = label time(itimer) = 0. end subroutine end module !======================================================================= subroutine timer (label, cmd) use timer_m implicit none character(len=*) label, cmd real(kind=8) wallclock, current integer ierr !----------------------------------------------------------------------- current = wallclock() ! current time if (itimer > 0) then ! if timer is active .. time(itimer) = time(itimer) + current - start(itimer) ! add to it end if call findit (label) ! locate timer slot if (cmd == 'start') then ! start command start(itimer) = current ! register start time else if (cmd == 'stop') then ! stop command itimer = 0 ! turn off timer end if end subroutine !======================================================================= subroutine finalize_timer use amr_parameters use amr_commons use timer_m implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif real(kind=8) :: total, gtotal, avtime, rmstime real(kind=8), dimension(ncpu) :: vtime integer, dimension(ncpu) :: all_ntimer logical, dimension(ncpu) :: gprint_timer integer :: imn, imx, mpi_err, icpu logical :: o, print_timer !----------------------------------------------------------------------- o = myid == 1 total = 1e-9 if (o .and. ncpu==1) write (*,'(/a,i7,a)') ' seconds % STEP (rank=',myid,')' do itimer = 1,ntimer total = total + time(itimer) end do if (ncpu==1) then do itimer = 1,ntimer if (o .and. time(itimer)/total > 0.001) write (*,'(f12.3,4x,f6.1,4x,a24)') & time(itimer), 100.*time(itimer)/total,labels(itimer) end do if (o) write (*,'(f12.3,4x,f6.1,4x,a)') total, 100., 'TOTAL' end if #ifndef WITHOUTMPI if (ncpu > 1) then ! Check that timers are consistent across ranks call MPI_BARRIER(MPI_COMM_WORLD,mpi_err) call MPI_GATHER(ntimer,1,MPI_INTEGER,all_ntimer,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpi_err) if (o) then if (maxval(all_ntimer) .ne. minval(all_ntimer)) then write (*,*) write (*,*) '--------------------------------------------------------------------' write (*,*) 'Error: Inconsistent number of timers on each rank. Min, max nr:', minval(all_ntimer), maxval(all_ntimer) write (*,*) 'Timing summary below can be misleading' write (*,*) 'Labels of timer on rank==1 :' write (*,*) '--------------------------------------------------------------------' do itimer=1,ntimer write(*,'(i3,1x,a)') itimer, labels(itimer) enddo endif ! Find first occurence of a rank with a different number of timers -- if it exists gprint_timer=.false. do icpu=1,ncpu if (all_ntimer(icpu) .ne. ntimer) then gprint_timer(icpu) = .true. exit endif enddo if (any(gprint_timer)) call sleep(1) ! Make sure that master rank finished, before we print from other rank. endif call MPI_SCATTER(gprint_timer,1,MPI_LOGICAL,print_timer,1,MPI_LOGICAL,0,MPI_COMM_WORLD,mpi_err) if (print_timer) then write (*,*) write (*,*) 'Labels of timer on rank==',myid write (*,*) '--------------------------------------------------------------------' do itimer=1,ntimer write(*,'(i3,1x,a)') itimer, labels(itimer) enddo write (*,*) endif call MPI_BARRIER(MPI_COMM_WORLD,mpi_err) call MPI_ALLREDUCE(total,gtotal,1,MPI_REAL8,MPI_SUM,MPI_COMM_WORLD,mpi_err) gtotal = gtotal / ncpu if (o) write (*,*) '--------------------------------------------------------------------' if (o) write (*,'(/a)') ' minimum average maximum' // & ' standard dev std/av % rmn rmx TIMER' do itimer = 1,ntimer call MPI_GATHER(real(time(itimer),kind=8),1,MPI_REAL8,vtime,1,MPI_REAL8,0,MPI_COMM_WORLD,mpi_err) if (o) then if (maxval(vtime)/gtotal > 0.001) then avtime = sum(vtime) / ncpu ! average time used imn = minloc(vtime,1) imx = maxloc(vtime,1) rmstime = sqrt(sum((vtime - avtime)**2)/ncpu) write (*,'(5(f12.3,2x),f6.1,2x,2i4,4x,a24)') & vtime(imn), avtime, vtime(imx), rmstime, rmstime/avtime, 100.*avtime/gtotal, imn, imx, labels(itimer) endif endif end do if (o) write (*,'(f12.3,4x,f6.1,4x,a)') total, 100., 'TOTAL' endif #endif end subroutine !======================================================================= subroutine reset_timer use timer_m implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif !----------------------------------------------------------------------- do itimer = 1,ntimer time(itimer)=0.0 end do end subroutine !======================================================================= subroutine update_time(ilevel) use amr_commons use pm_commons use hydro_commons use cooling_module implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif integer::ilevel real(dp)::dt,econs,mcons real(kind=8)::ttend real(kind=8),save::ttstart=0 integer::i,itest,info ! Local constants dt=dtnew(ilevel) itest=0 #ifndef WITHOUTMPI if(myid==1)then if(ttstart.eq.0.0)ttstart=MPI_WTIME() endif #endif !------------------------------------------------------------- ! At this point, IF nstep_coarse has JUST changed, all levels ! are synchronised, and all new refinements have been done. !------------------------------------------------------------- if(nstep_coarse .ne. nstep_coarse_old)then !-------------------------- ! Check mass conservation !-------------------------- if(mass_tot_0==0.0D0)then mass_tot_0=mass_tot mcons=0.0D0 else mcons=(mass_tot-mass_tot_0)/mass_tot_0 end if !---------------------------- ! Check energy conservation !---------------------------- if(epot_tot_old.ne.0)then epot_tot_int=epot_tot_int + & & 0.5D0*(epot_tot_old+epot_tot)*log(aexp/aexp_old) end if epot_tot_old=epot_tot aexp_old=aexp if(einit==0.0D0)then einit=epot_tot+ekin_tot ! initial total energy econs=0.0D0 else econs=(ekin_tot+epot_tot-epot_tot_int-einit) / & &(-(epot_tot-epot_tot_int-einit)+ekin_tot) end if if(mod(nstep_coarse,ncontrol)==0.or.output_done)then if(myid==1)then !------------------------------- ! Output AMR structure to screen !------------------------------- write(*,*)'Mesh structure' do i=1,nlevelmax if(numbtot(1,i)>0)write(*,999)i,numbtot(1:4,i) end do !---------------------------------------------- ! Output mass and energy conservation to screen !---------------------------------------------- if(cooling.or.pressure_fix)then write(*,778)nstep_coarse,mcons,econs,epot_tot,ekin_tot,eint_tot else write(*,777)nstep_coarse,mcons,econs,epot_tot,ekin_tot end if #ifdef SOLVERmhd write(*,'(' emag=',ES9.2)') emag_tot #endif if(pic)then write(*,888)nstep,t,dt,aexp,& & real(100.0D0*dble(used_mem_tot)/dble(ngridmax+1)),& & real(100.0D0*dble(npartmax-numbp_free_tot)/dble(npartmax+1)) else write(*,888)nstep,t,dt,aexp,& & real(100.0D0*dble(used_mem_tot)/dble(ngridmax+1)) endif itest=1 end if output_done=.false. end if !--------------- ! Exit program !--------------- if(t>=tout(noutput).or.aexp>=aout(noutput).or. & & nstep_coarse>=nstepmax)then if(myid==1)then write(*,*)'Run completed' #ifndef WITHOUTMPI ttend=MPI_WTIME() ! CHANGED BY TTG (FEB 2017) ! write(*,*)'Total elapsed time:',ttend-ttstart call TotalRunTime(ttend-ttstart) #endif endif call clean_stop end if end if nstep_coarse_old=nstep_coarse !---------------------------- ! Output controls to screen !---------------------------- if(mod(nstep,ncontrol)==0)then if(myid==1.and.itest==0)then if(pic)then write(*,888)nstep,t,dt,aexp,& & real(100.0D0*dble(used_mem_tot)/dble(ngridmax+1)),& & real(100.0D0*dble(npartmax-numbp_free_tot)/dble(npartmax+1)) else write(*,888)nstep,t,dt,aexp,& & real(100.0D0*dble(used_mem_tot)/dble(ngridmax+1)) endif end if end if !------------------------ ! Update time variables !------------------------ t=t+dt nstep=nstep+1 if(cosmo)then ! Find neighboring times i=1 do while(tau_frw(i)>t.and.i1024.**3.)then write(*,999)usedmem/1024.**3. else if (usedmem>1024.**2.) then write(*,998)usedmem/1024.**2 else if (usedmem>1024.) then write(*,997)usedmem/1024. endif 997 format(' Used memory:',F9.1,' kb') 998 format(' Used memory:',F9.1,' Mb') 999 format(' Used memory:',F9.3,' Gb') end subroutine writemem subroutine getmem(outmem) use amr_commons,only:myid,IOGROUPSIZE,ncpu implicit none #ifndef WITHOUTMPI include 'mpif.h' #endif real(kind=4)::outmem character(len=300) :: dir, dir2, cmd, file integer::read_status integer,parameter::tag=1134 integer::dummy_io,info2 integer::nmem,ind,j logical::file_exists file='/proc/self/stat' #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if (mod(myid-1,IOGROUPSIZE)/=0) then call MPI_RECV(dummy_io,1,MPI_INTEGER,myid-1-1,tag,& & MPI_COMM_WORLD,MPI_STATUS_IGNORE,info2) end if endif #endif inquire(file=file, exist=file_exists) if (file_exists) then open(unit=1,file=file,form='formatted') read(1,'(A300)',IOSTAT=read_status)dir close(1) else read_status=-1000 endif ! Send the token #ifndef WITHOUTMPI if(IOGROUPSIZE>0) then if(mod(myid,IOGROUPSIZE)/=0 .and.(myid.lt.ncpu))then dummy_io=1 call MPI_SEND(dummy_io,1,MPI_INTEGER,myid-1+1,tag, & & MPI_COMM_WORLD,info2) end if endif #endif if (read_status < 0)then outmem=0. if (myid==1 .and. read_status .ne. -1000)write(*,*)'Problem in checking free memory' else ind=300 j=0 do while (j<23) ind=index(dir,' ') dir2=dir(ind+1:300) j=j+1 dir=dir2 end do ind=index(dir,' ') dir2=dir(1:ind) read(dir2,'(I12)')nmem outmem=real(nmem,kind=4) end if end subroutine getmem subroutine cmpmem(outmem) use amr_commons use hydro_commons implicit none real::outmem,outmem_int,outmem_dp,outmem_qdp outmem_int=0.0 outmem_dp=0.0 outmem_qdp=0.0 outmem_dp =outmem_dp +ngridmax*ndim ! xg outmem_int=outmem_int+ngridmax*twondim ! nbor outmem_int=outmem_int+ngridmax ! father outmem_int=outmem_int+ngridmax ! next outmem_int=outmem_int+ngridmax ! prev outmem_int=outmem_int+ngridmax*twotondim ! son outmem_int=outmem_int+ngridmax*twotondim ! flag1 outmem_int=outmem_int+ngridmax*twotondim ! flag2 outmem_int=outmem_int+ngridmax*twotondim ! cpu_map1 outmem_int=outmem_int+ngridmax*twotondim ! cpu_map2 outmem_qdp=outmem_qdp+ngridmax*twotondim ! hilbert_key ! Add communicator variable here if(hydro)then outmem_dp =outmem_dp +ngridmax*twotondim*nvar ! uold outmem_dp =outmem_dp +ngridmax*twotondim*nvar ! unew if(pressure_fix)then outmem_dp =outmem_dp +ngridmax*twotondim ! uold outmem_dp =outmem_dp +ngridmax*twotondim ! uold endif endif write(*,*)'Estimated memory=',(outmem_dp*8.+outmem_int*4.+outmem_qdp*8.)/1024./1024. end subroutine cmpmem !------------------------------------------------------------------------ SUBROUTINE getProperTime(tau,tproper) ! Calculate proper time tproper corresponding to conformal time tau (both ! in code units). !------------------------------------------------------------------------ use amr_commons implicit none real(dp)::tau, tproper integer::i if(.not. cosmo .or. tau .eq. 0.d0) then ! this might happen quite often tproper = tau return endif i = 1 do while( tau_frw(i) > tau .and. i < n_frw ) i = i+1 end do tproper = t_frw(i )*(tau-tau_frw(i-1))/(tau_frw(i )-tau_frw(i-1))+ & & t_frw(i-1)*(tau-tau_frw(i ))/(tau_frw(i-1)-tau_frw(i )) END SUBROUTINE getProperTime !------------------------------------------------------------------------ SUBROUTINE getAgeGyr(t_birth_proper, age) ! Calculate proper time passed, in Gyrs, since proper time t_birth_proper ! (given in code units) until the current time. !------------------------------------------------------------------------ use amr_commons use pm_commons implicit none real(dp):: t_birth_proper, age real(dp), parameter:: yr = 3.15569d+07 real(dp),save:: scale_t_Gyr logical,save::scale_init=.false. real(dp):: scale_nH, scale_T2, scale_l, scale_d, scale_t, scale_v if( .not. scale_init) then ! The timescale has not been initialized call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) scale_t_Gyr = (scale_t/aexp**2)/yr/1.e9 scale_init=.true. endif age = (texp - t_birth_proper) * scale_t_Gyr END SUBROUTINE getAgeGyr !------------------------------------------------------------------------ SUBROUTINE getAgeSec(t_birth_proper, age) ! Calculate proper time passed, in sec, since proper time t_birth_proper ! (given in code units) until the current time. !------------------------------------------------------------------------ use amr_commons use pm_commons implicit none real(dp):: t_birth_proper, age real(dp),save:: scale_t_sec logical::scale_init=.false. real(dp):: scale_nH, scale_T2, scale_l, scale_d, scale_t, scale_v if( .not. scale_init) then ! The timescale has not been initialized call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2) scale_t_sec = (scale_t/aexp**2) scale_init=.true. endif age = (texp - t_birth_proper) * scale_t_sec END SUBROUTINE getAgeSec !------------------------------------------------------------------------ !------------------------------------------------------------------------ subroutine TotalRunTime(deltaTime) ! ! ! convert a floating-point variable (deltaTime, in seconds) to a string ! displaying days:hours:minutes:seconds ! ! NOTE: This routine has been adapted from PLUTO v4.1 by TTG (FEB 2017) ! !------------------------------------------------------------------------ integer::days,hours,mins,secs real(kind=8)::deltaTime days = floor(deltaTime/86400.0) hours = floor((deltaTime - 86400.0*days)/3600.0) mins = floor((deltaTime - 86400.0*days - 3600.0*hours)/60.) secs = ceiling(deltaTime - 86400.0*days - 3600.0*hours - 60.0*mins) write(*,123) days,hours,mins,secs write(*,*) 123 format(' Total elapsed time: ',i3,'d:',i3,'h:',i3,'m:',i3,'s') end subroutine TotalRunTime !------------------------------------------------------------------------