diff --git a/examples/Basic_Simulation/initial_conditions.py b/examples/Basic_Simulation/initial_conditions.py index 861556958..b58522824 100644 --- a/examples/Basic_Simulation/initial_conditions.py +++ b/examples/Basic_Simulation/initial_conditions.py @@ -20,7 +20,7 @@ Output ------ -bin.nc : A NetCDF file containing the simulation output. +data.nc : A NetCDF file containing the simulation output. dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. diff --git a/examples/Basic_Simulation/output_reader.py b/examples/Basic_Simulation/output_reader.py index a41103ccd..977c2a393 100644 --- a/examples/Basic_Simulation/output_reader.py +++ b/examples/Basic_Simulation/output_reader.py @@ -15,7 +15,7 @@ Input ------ -bin.nc : A NetCDF file containing the simulation output. +data.nc : A NetCDF file containing the simulation output. Output ------ @@ -28,7 +28,7 @@ import matplotlib.pyplot as plt # Read in the simulation output and store it as an Xarray dataset. -sim = swiftest.Simulation(read_old_output_file=True) +sim = swiftest.Simulation(read_old_output=True) # Plot of the data and save the output plot. colors = ['white' if x == 'Massive Body' else 'black' for x in sim.data['particle_type']] diff --git a/examples/Fragmentation/Fragmentation_Movie.py b/examples/Fragmentation/Fragmentation_Movie.py index a664ef49e..4a0d3b80d 100644 --- a/examples/Fragmentation/Fragmentation_Movie.py +++ b/examples/Fragmentation/Fragmentation_Movie.py @@ -90,7 +90,7 @@ def encounter_combiner(sim): # Only keep a minimal subset of necessary data from the simulation and encounter datasets keep_vars = ['rh','Gmass','radius'] data = sim.data[keep_vars] - enc = sim.enc[keep_vars].load() + enc = sim.encounters[keep_vars].load() # Remove any encounter data at the same time steps that appear in the data to prevent duplicates t_not_duplicate = ~enc['time'].isin(data['time']) @@ -148,7 +148,7 @@ def setup_plot(self): ax.set_title(self.title) fig.add_axes(ax) - self.scatter_artist = ax.scatter([], [], animated=True) + self.scatter_artist = ax.scatter([], [], animated=True, c='k', edgecolors='face') return fig, ax def update_plot(self, frame): @@ -174,7 +174,7 @@ def data_stream(self, frame=0): radius = ds['radius'].values Gmass = ds['Gmass'].values rh = ds['rh'].values - point_rad = 2 * radius * self.ax_pt_size + point_rad = radius * self.ax_pt_size yield Gmass, rh, point_rad if __name__ == "__main__": @@ -202,8 +202,8 @@ def data_stream(self, frame=0): # Set fragmentation parameters minimum_fragment_gmass = 0.2 * body_Gmass[style][1] # Make the minimum fragment mass a fraction of the smallest body gmtiny = 0.99 * body_Gmass[style][1] # Make GMTINY just smaller than the smallest original body. This will prevent runaway collisional cascades - sim.set_parameter(fragmentation=True, fragmentation_save="TRAJECTORY", gmtiny=gmtiny, minimum_fragment_gmass=minimum_fragment_gmass, verbose=False) - sim.run(dt=1e-4, tstop=1.0e-3, istep_out=1, dump_cadence=0) + sim.set_parameter(fragmentation=True, encounter_save="trajectory", gmtiny=gmtiny, minimum_fragment_gmass=minimum_fragment_gmass, verbose=False) + sim.run(dt=1e-4, tstop=1.0e-3, istep_out=1, dump_cadence=1) print("Generating animation") anim = AnimatedScatter(sim,movie_filename,movie_titles[style],style,nskip=1) \ No newline at end of file diff --git a/examples/Fragmentation/swiftest_fragmentation.py b/examples/Fragmentation/swiftest_fragmentation.py index 067c53710..3ee13cb2a 100644 --- a/examples/Fragmentation/swiftest_fragmentation.py +++ b/examples/Fragmentation/swiftest_fragmentation.py @@ -21,7 +21,7 @@ Output ------ -disruption/bin.nc : A NetCDF file containing the simulation output. +disruption/data.nc : A NetCDF file containing the simulation output. disruption/dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. disruption/dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. disruption/dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. @@ -30,7 +30,7 @@ disruption/init_cond.nc : A NetCDF file containing the initial conditions for the simulation. disruption/param.in : An ASCII file containing the parameters for the simulation. disruption/swiftest.log : An ASCII file containing the information on the status of the simulation as it runs. -hitandrun/bin.nc : A NetCDF file containing the simulation output. +hitandrun/data.nc : A NetCDF file containing the simulation output. hitandrun/dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. hitandrun/dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. hitandrun/dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. @@ -39,7 +39,7 @@ hitandrun/init_cond.nc : A NetCDF file containing the initial conditions for the simulation. hitandrun/param.in : An ASCII file containing the parameters for the simulation. hitandrun/swiftest.log : An ASCII file containing the information on the status of the simulation as it runs. -supercat/bin.nc : A NetCDF file containing the simulation output. +supercat/data.nc : A NetCDF file containing the simulation output. supercat/dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. supercat/dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. supercat/dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. diff --git a/examples/helio_gr_test/helio_gr_test.py b/examples/helio_gr_test/helio_gr_test.py index c627be7f4..77ae66740 100644 --- a/examples/helio_gr_test/helio_gr_test.py +++ b/examples/helio_gr_test/helio_gr_test.py @@ -24,7 +24,7 @@ helio_gr_mercury_precession.png : Portable Network Graphic file depicting the precession of Mercury's perihelion over time with data sourced from the JPL Horizons database, Swiftest run with general relativity, and Swiftest run without general relativity. -gr/bin.nc : A NetCDF file containing the simulation output. +gr/data.nc : A NetCDF file containing the simulation output. gr/dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. gr/dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. gr/dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. @@ -32,7 +32,7 @@ gr/init_cond.nc : A NetCDF file containing the initial conditions for the simulation. gr/param.in : An ASCII file containing the parameters for the simulation. gr/swiftest.log : An ASCII file containing the information on the status of the simulation as it runs. -nogr/bin.nc : A NetCDF file containing the simulation output. +nogr/data.nc : A NetCDF file containing the simulation output. nogr/dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. nogr/dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. nogr/dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. diff --git a/examples/whm_gr_test/whm_gr_test.py b/examples/whm_gr_test/whm_gr_test.py index d0d2ade69..f4dc185ab 100644 --- a/examples/whm_gr_test/whm_gr_test.py +++ b/examples/whm_gr_test/whm_gr_test.py @@ -24,7 +24,7 @@ whm_gr_mercury_precession.png : Portable Network Graphic file depicting the precession of Mercury's perihelion over time with data sourced from the JPL Horizons database, Swiftest run with general relativity, and Swiftest run without general relativity. -gr/bin.nc : A NetCDF file containing the simulation output. +gr/data.nc : A NetCDF file containing the simulation output. gr/dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. gr/dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. gr/dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. @@ -32,7 +32,7 @@ gr/init_cond.nc : A NetCDF file containing the initial conditions for the simulation. gr/param.in : An ASCII file containing the parameters for the simulation. gr/swiftest.log : An ASCII file containing the information on the status of the simulation as it runs. -nogr/bin.nc : A NetCDF file containing the simulation output. +nogr/data.nc : A NetCDF file containing the simulation output. nogr/dump_bin1.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. nogr/dump_bin2.nc : A NetCDF file containing the necessary inputs to restart a simulation from t!=0. nogr/dump_param1.in : An ASCII file containing the necessary parameters to restart a simulation. diff --git a/python/swiftest/swiftest/io.py b/python/swiftest/swiftest/io.py index a4f370773..c002978b9 100644 --- a/python/swiftest/swiftest/io.py +++ b/python/swiftest/swiftest/io.py @@ -32,8 +32,7 @@ "ENCOUNTER_CHECK", "TSTART", "DUMP_CADENCE", - "ENCOUNTER_SAVE", - "FRAGMENTATION_SAVE") + "ENCOUNTER_SAVE") @@ -55,16 +54,16 @@ float_param = ["T0", "TSTART", "TSTOP", "DT", "CHK_RMIN", "CHK_RMAX", "CHK_EJECT", "CHK_QMIN", "DU2M", "MU2KG", "TU2S", "MIN_GMFRAG", "GMTINY"] -upper_str_param = ["OUT_TYPE","OUT_FORM","OUT_STAT","IN_TYPE","IN_FORM","ENCOUNTER_SAVE","FRAGMENTATION_SAVE", "CHK_QMIN_COORD"] +upper_str_param = ["OUT_TYPE","OUT_FORM","OUT_STAT","IN_TYPE","IN_FORM","ENCOUNTER_SAVE", "CHK_QMIN_COORD"] lower_str_param = ["NC_IN", "PL_IN", "TP_IN", "CB_IN", "CHK_QMIN_RANGE"] param_keys = ['! VERSION'] + int_param + float_param + upper_str_param + lower_str_param+ bool_param # This defines Xarray Dataset variables that are strings, which must be processed due to quirks in how NetCDF-Fortran # handles strings differently than Python's Xarray. -string_varnames = ["name", "particle_type", "status", "origin_type"] +string_varnames = ["name", "particle_type", "status", "origin_type", "stage", "regime"] char_varnames = ["space"] -int_varnames = ["id", "ntp", "npl", "nplm", "discard_body_id", "collision_id"] +int_varnames = ["id", "ntp", "npl", "nplm", "discard_body_id", "collision_id", "loopnum"] def bool2yesno(boolval): """ @@ -816,18 +815,19 @@ def process_netcdf_input(ds, param): ------- ds : xarray dataset """ - - ds = ds.where(~np.isnan(ds.id) ,drop=True) + # + #ds = ds.where(ds.id >=0,drop=True) if param['OUT_TYPE'] == "NETCDF_DOUBLE": ds = fix_types(ds,ftype=np.float64) elif param['OUT_TYPE'] == "NETCDF_FLOAT": ds = fix_types(ds,ftype=np.float32) - # Check if the name variable contains unique values. If so, make name the dimension instead of id - if "id" in ds.dims: - if len(np.unique(ds['name'])) == len(ds['name']): - ds = ds.swap_dims({"id" : "name"}) - ds = ds.reset_coords("id") + # # Check if the name variable contains unique values. If so, make name the dimension instead of id + # if "id" in ds.dims: + # if len(np.unique(ds['name'])) == len(ds['name']): + # ds = ds.swap_dims({"id" : "name"}) + # if "id" in ds: + # ds = ds.reset_coords("id") return ds @@ -900,15 +900,14 @@ def string_converter(da): ------- da : xarray dataset with the strings cleaned up """ - if da.dtype == np.dtype(object): - da = da.astype(' 0, drop=True) + cb = frame.isel(name=0) + pl = frame.where(name != cb.name) pl = pl.where(np.invert(np.isnan(pl['Gmass'])), drop=True).drop_vars(['j2rp2', 'j2rp2'],errors="ignore") tp = frame.where(np.isnan(frame['Gmass']), drop=True).drop_vars(['Gmass', 'radius', 'j2rp2', 'j4rp4'],errors="ignore") diff --git a/python/swiftest/swiftest/simulation_class.py b/python/swiftest/swiftest/simulation_class.py index 2b9ede95b..eea75c1ed 100644 --- a/python/swiftest/swiftest/simulation_class.py +++ b/python/swiftest/swiftest/simulation_class.py @@ -43,7 +43,7 @@ class Simulation: This is a class that defines the basic Swift/Swifter/Swiftest simulation object """ - def __init__(self,read_param: bool = False, read_old_output_file: bool = False, simdir: os.PathLike | str = "simdata", **kwargs: Any): + def __init__(self,read_param: bool = False, read_old_output: bool = False, simdir: os.PathLike | str = "simdata", **kwargs: Any): """ Parameters @@ -65,7 +65,7 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, inside the current working directory, which can be changed by passing `param_file` as an argument. - The argument has an equivalent parameter or set of parameters in the parameter input file. 3. Default values (see below) - read_old_output_file : bool, default False + read_old_output : bool, default False If true, read in a pre-existing binary input file given by the argument `output_file_name` if it exists. Parameter input file equivalent: None simdir : PathLike, default `"simdir"` @@ -141,8 +141,7 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, Parameter input file equivalent: `OUT_TYPE` output_file_name : str or path-like, optional Name of output file to generate. If not supplied, then one of the default file names are used, depending on - the value passed to `output_file_type`. If one of the NetCDF types are used, the default is "bin.nc". - Otherwise, the default is "bin.dat". + the value passed to `output_file_type`. The default is "data.nc". Parameter input file equivalent: `BIN_OUT` output_format : {"XV","XVEL"}, default "XVEL" Specifies the format for the data saved to the output file. If "XV" then cartesian position and velocity @@ -215,10 +214,12 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, Check for close encounters between bodies. If set to True, then the radii of massive bodies must be included in initial conditions. Parameter input file equivalent: `CHK_CLOSE` - encounter_save : {"NONE","TRAJECTORY","CLOSEST"}, default "NONE" - Indicate if and how encounter data should be saved. If set to "TRAJECTORY" the full close encounter - trajectories are saved to file. If set to "CLOSEST" only the trajectories at the time of closest approach - are saved. If set to "NONE" no trajectory information is saved. + encounter_save : {"NONE","TRAJECTORY","CLOSEST", "BOTH"}, default "NONE" + Indicate if and how encounter data should be saved. If set to "TRAJECTORY", the position and velocity vectors + of all bodies undergoing close encounters are saved at each intermediate step to the encounter files. + If set to "CLOSEST", the position and velocities at the point of closest approach between pairs of bodies are + computed and stored to the encounter files. If set to "BOTH", then this stores the values that would be computed + in "TRAJECTORY" and "CLOSEST". If set to "NONE" no trajectory information is saved. *WARNING*: Enabling this feature could lead to very large files. general_relativity : bool, default True Include the post-Newtonian correction in acceleration calculations. @@ -227,12 +228,6 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, If set to True, this turns on the Fraggle fragment generation code and `rotation` must also be True. This argument only applies to Swiftest-SyMBA simulations. It will be ignored otherwise. Parameter input file equivalent: `FRAGMENTATION` - fragmentation_save : {"NONE","TRAJECTORY","CLOSEST"}, default "NONE" - Indicate if and how fragmentation data should be saved. If set to "TRAJECTORY" the full close encounter - trajectories associated with each collision are saved to file. If set to "CLOSEST" only the trajectories - at a the time the collision occurs are saved. If set to "NONE" no trajectory information is saved (collision - details are still logged fraggle.log). - *WARNING*: Enabling this feature could lead to very large files. minimum_fragment_gmass : float, optional If fragmentation is turned on, this sets the mimimum G*mass of a collisional fragment that can be generated. *Note.* Only set one of minimum_fragment_gmass or minimum_fragment_mass @@ -318,8 +313,9 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, self.param = {} self.data = xr.Dataset() - self.ic = xr.Dataset() - self.enc = xr.Dataset() + self.init_cond = xr.Dataset() + self.encounters = xr.Dataset() + self.collisions = xr.Dataset() self.simdir = Path(simdir) if self.simdir.exists(): @@ -328,7 +324,7 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, msg += "\nDelete the file or change the location of param_file" raise NotADirectoryError(msg) else: - if read_old_output_file or read_param: + if read_old_output or read_param: raise NotADirectoryError(f"Cannot find directory {self.simdir.resolve()} ") else: self.simdir.mkdir(parents=True, exist_ok=False) @@ -353,8 +349,8 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, # If the user asks to read in an old parameter file or output file, override any default parameters with values from the file # If the file doesn't exist, flag it for now so we know to create it param_file_found = False - if read_param or read_old_output_file: - if self.read_param(read_init_cond = not read_old_output_file): + if read_param or read_old_output: + if self.read_param(read_init_cond = not read_old_output): # We will add the parameter file to the kwarg list. This will keep the set_parameter method from # overriding everything with defaults when there are no arguments passed to Simulation() kwargs['param_file'] = self.param_file @@ -374,7 +370,7 @@ def __init__(self,read_param: bool = False, read_old_output_file: bool = False, self.write_param() # Read in an old simulation file if requested - if read_old_output_file: + if read_old_output: binpath = os.path.join(self.simdir, self.param['BIN_OUT']) if os.path.exists(binpath): self.read_output_file() @@ -761,7 +757,7 @@ def set_parameter(self, verbose: bool = True, **kwargs): "init_cond_file_type": "NETCDF_DOUBLE", "init_cond_file_name": None, "init_cond_format": "EL", - "read_old_output_file": False, + "read_old_output": False, "output_file_type": "NETCDF_DOUBLE", "output_file_name": None, "output_format": "XVEL", @@ -793,8 +789,7 @@ def set_parameter(self, verbose: bool = True, **kwargs): "encounter_check_loops": "TRIANGULAR", "ephemeris_date": "MBCL", "restart": False, - "encounter_save" : "NONE", - "fragmentation_save" : "NONE" + "encounter_save" : "NONE" } param_file = kwargs.pop("param_file",None) @@ -1030,8 +1025,7 @@ def set_feature(self, tides: bool | None = None, interaction_loops: Literal["TRIANGULAR", "FLAT", "ADAPTIVE"] | None = None, encounter_check_loops: Literal["TRIANGULAR", "SORTSWEEP", "ADAPTIVE"] | None = None, - encounter_save: Literal["NONE", "TRAJECTORY", "CLOSEST"] | None = None, - fragmentation_save: Literal["NONE", "TRAJECTORY", "CLOSEST"] | None = None, + encounter_save: Literal["NONE", "TRAJECTORY", "CLOSEST", "BOTH"] | None = None, verbose: bool | None = None, **kwargs: Any ): @@ -1043,22 +1037,18 @@ def set_feature(self, close_encounter_check : bool, optional Check for close encounters between bodies. If set to True, then the radii of massive bodies must be included in initial conditions. - encounter_save : {"NONE","TRAJECTORY","CLOSEST"}, default "NONE" - Indicate if and how encounter data should be saved. If set to "TRAJECTORY" the full close encounter - trajectories are saved to file. If set to "CLOSEST" only the trajectories at the time of closest approach - are saved. If set to "NONE" no trajectory information is saved. + encounter_save : {"NONE","TRAJECTORY","CLOSEST","BOTH"}, default "NONE" + Indicate if and how encounter data should be saved. If set to "TRAJECTORY", the position and velocity vectors + of all bodies undergoing close encounters are saved at each intermediate step to the encounter files. + If set to "CLOSEST", the position and velocities at the point of closest approach between pairs of bodies are + computed and stored to the encounter files. If set to "BOTH", then this stores the values that would be computed + in "TRAJECTORY" and "CLOSEST". If set to "NONE" no trajectory information is saved. *WARNING*: Enabling this feature could lead to very large files. general_relativity : bool, optional Include the post-Newtonian correction in acceleration calculations. fragmentation : bool, optional If set to True, this turns on the Fraggle fragment generation code and `rotation` must also be True. This argument only applies to Swiftest-SyMBA simulations. It will be ignored otherwise. - fragmentation_save : {"NONE","TRAJECTORY","CLOSEST"}, default "NONE" - Indicate if and how fragmentation data should be saved. If set to "TRAJECTORY" the full close encounter - trajectories associated with each collision are saved to file. If set to "CLOSEST" only the trajectories - at a the time the collision occurs are saved. If set to "NONE" no trajectory information is saved (collision - details are still logged fraggle.log). - *WARNING*: Enabling this feature could lead to very large files. minimum_fragment_gmass : float, optional If fragmentation is turned on, this sets the mimimum G*mass of a collisional fragment that can be generated. *Note.* Only set one of minimum_fragment_gmass or minimum_fragment_mass @@ -1213,7 +1203,7 @@ def set_feature(self, update_list.append("encounter_check_loops") if encounter_save is not None: - valid_vals = ["NONE", "TRAJECTORY", "CLOSEST"] + valid_vals = ["NONE", "TRAJECTORY", "CLOSEST", "BOTH"] encounter_save = encounter_save.upper() if encounter_save not in valid_vals: msg = f"{encounter_save} is not a valid option for encounter_save." @@ -1225,20 +1215,6 @@ def set_feature(self, self.param["ENCOUNTER_SAVE"] = encounter_save update_list.append("encounter_save") - - if fragmentation_save is not None: - fragmentation_save = fragmentation_save.upper() - valid_vals = ["NONE", "TRAJECTORY", "CLOSEST"] - if fragmentation_save not in valid_vals: - msg = f"{fragmentation_save} is not a valid option for fragmentation_save." - msg += f"\nMust be one of {valid_vals}" - warnings.warn(msg,stacklevel=2) - if "FRAGMENTATION_SAVE" not in self.param: - self.param["FRAGMENTATION_SAVE"] = valid_vals[0] - else: - self.param["FRAGMENTATION_SAVE"] = fragmentation_save - update_list.append("fragmentation_save") - self.param["TIDES"] = False feature_dict = self.get_feature(update_list, verbose) @@ -1271,7 +1247,6 @@ def get_feature(self, arg_list: str | List[str] | None = None, verbose: bool | N valid_var = {"close_encounter_check": "CHK_CLOSE", "fragmentation": "FRAGMENTATION", "encounter_save": "ENCOUNTER_SAVE", - "fragmentation_save": "FRAGMENTATION_SAVE", "minimum_fragment_gmass": "MIN_GMFRAG", "rotation": "ROTATION", "general_relativity": "GR", @@ -1536,7 +1511,7 @@ def set_output_files(self, * Swift: Only "REAL4" supported. output_file_name : str or path-like, optional Name of output file to generate. If not supplied, then one of the default file names are used, depending on - the value passed to `output_file_type`. If one of the NetCDF types are used, the default is "bin.nc". + the value passed to `output_file_type`. If one of the NetCDF types are used, the default is "data.nc". Otherwise, the default is "bin.dat". output_format : {"XV","XVEL"}, optional Specifies the format for the data saved to the output file. If "XV" then cartesian position and velocity @@ -1596,7 +1571,7 @@ def set_output_files(self, self.param['OUT_TYPE'] = output_file_type if output_file_name is None: if output_file_type in ["NETCDF_DOUBLE", "NETCDF_FLOAT"]: - self.param['BIN_OUT'] = "bin.nc" + self.param['BIN_OUT'] = "data.nc" else: self.param['BIN_OUT'] = "bin.dat" else: @@ -2185,7 +2160,7 @@ def add_solar_system_body(self, if dsnew['npl'] > 0 or dsnew['ntp'] > 0: self.save(verbose=False) - self.ic = self.data.copy(deep=True) + self.init_cond = self.data.copy(deep=True) return @@ -2484,7 +2459,7 @@ def input_to_array_3d(val,n=None): dsnew = self._combine_and_fix_dsnew(dsnew) self.save(verbose=False) - self.ic = self.data.copy(deep=True) + self.init_cond = self.data.copy(deep=True) return @@ -2505,7 +2480,8 @@ def _combine_and_fix_dsnew(self,dsnew): if "id" not in self.data.dims: if len(np.unique(dsnew['name'])) == len(dsnew['name']): dsnew = dsnew.swap_dims({"id" : "name"}) - dsnew = dsnew.reset_coords("id") + if "id" in dsnew: + dsnew = dsnew.reset_coords("id") else: msg = "Non-unique names detected for bodies. The Dataset will be dimensioned by integer id instead of name." msg +="\nConsider using unique names instead." @@ -2590,7 +2566,7 @@ def read_param(self, param_tmp = self.param.copy() param_tmp['BIN_OUT'] = init_cond_file self.data = io.swiftest2xr(param_tmp, verbose=self.verbose) - self.ic = self.data.copy(deep=True) + self.init_cond = self.data.copy(deep=True) else: warnings.warn(f"Initial conditions file file {init_cond_file} not found.", stacklevel=2) else: @@ -2733,10 +2709,6 @@ def read_output_file(self,read_init_cond : bool = True): # This is done to handle cases where the method is called from a different working directory than the simulation # results - if "ENCOUNTER_SAVE" in self.param or "FRAGMENTATION_SAVE" in self.param: - read_encounter = self.param["ENCOUNTER_SAVE"] != "NONE" or self.param["FRAGMENTATION_SAVE"] != "NONE" - else: - read_encounter = False param_tmp = self.param.copy() param_tmp['BIN_OUT'] = os.path.join(self.simdir, self.param['BIN_OUT']) if self.codename == "Swiftest": @@ -2744,15 +2716,15 @@ def read_output_file(self,read_init_cond : bool = True): if self.verbose: print('Swiftest simulation data stored as xarray DataSet .data') if read_init_cond: if self.verbose: - print("Reading initial conditions file as .ic") + print("Reading initial conditions file as .init_cond") if "NETCDF" in self.param['IN_TYPE']: param_tmp['BIN_OUT'] = self.simdir / self.param['NC_IN'] - - self.ic = io.swiftest2xr(param_tmp, verbose=self.verbose) + self.init_cond = io.swiftest2xr(param_tmp, verbose=False) else: - self.ic = self.data.isel(time=0) - if read_encounter: - self.read_encounter() + self.init_cond = self.data.isel(time=0) + + self.read_encounters() + self.read_collisions() elif self.codename == "Swifter": self.data = io.swifter2xr(param_tmp, verbose=self.verbose) @@ -2763,10 +2735,14 @@ def read_output_file(self,read_init_cond : bool = True): warnings.warn('Cannot process unknown code type. Call the read_param method with a valid code name. Valid options are "Swiftest", "Swifter", or "Swift".',stacklevel=2) return - def read_encounter(self): - if self.verbose: - print("Reading encounter history file as .enc") + def read_encounters(self): enc_files = glob(f"{self.simdir}{os.path.sep}encounter_*.nc") + if len(enc_files) == 0: + return + + if self.verbose: + print("Reading encounter history file as .encounters") + enc_files.sort() # This is needed in order to pass the param argument down to the io.process_netcdf_input function @@ -2774,11 +2750,31 @@ def _preprocess(ds, param): return io.process_netcdf_input(ds,param) partial_func = partial(_preprocess, param=self.param) - self.enc = xr.open_mfdataset(enc_files,parallel=True,combine="nested",concat_dim="time",join="left",preprocess=partial_func,mask_and_scale=True) - self.enc = io.process_netcdf_input(self.enc, self.param) + self.encounters = xr.open_mfdataset(enc_files,parallel=True,combine="nested",concat_dim="time",join="left",preprocess=partial_func,mask_and_scale=True) + self.encounters = io.process_netcdf_input(self.encounters, self.param) # Remove any overlapping time values - tgood,tid = np.unique(self.enc.time,return_index=True) - self.enc = self.enc.isel(time=tid) + tgood,tid = np.unique(self.encounters.time,return_index=True) + self.encounters = self.encounters.isel(time=tid) + + return + + + def read_collisions(self): + col_files = glob(f"{self.simdir}{os.path.sep}collision_*.nc") + if len(col_files) == 0: + return + + col_files.sort() + if self.verbose: + print("Reading collision history file as .collisions") + + # This is needed in order to pass the param argument down to the io.process_netcdf_input function + def _preprocess(ds, param): + return io.process_netcdf_input(ds,param) + partial_func = partial(_preprocess, param=self.param) + + self.collisions = xr.open_mfdataset(col_files,parallel=True, coords=["collision"], join="inner", preprocess=partial_func,mask_and_scale=True) + self.collisions = io.process_netcdf_input(self.collisions, self.param) return @@ -2952,8 +2948,8 @@ def clean(self): ] glob_files = [self.simdir.glob("**/dump_param?.in")] \ + [self.simdir.glob("**/dump_bin?.nc")] \ - + [self.simdir.glob("**/enc*.nc")] \ - + [self.simdir.glob("**/frag*.nc")] + + [self.simdir.glob("**/encounter_*.nc")] \ + + [self.simdir.glob("**/collision_*.nc")] for f in old_files: if f.exists(): diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index eb9fb20d5..594850a50 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -78,16 +78,18 @@ SET(FAST_MATH_FILES ${SRC}/util/util_final.f90 ${SRC}/util/util_flatten.f90 ${SRC}/util/util_get_energy_momentum.f90 - ${SRC}/util/util_index_array.f90 + ${SRC}/util/util_index.f90 ${SRC}/util/util_minimize_bfgs.f90 ${SRC}/util/util_peri.f90 ${SRC}/util/util_rescale.f90 ${SRC}/util/util_reset.f90 ${SRC}/util/util_resize.f90 ${SRC}/util/util_set.f90 + ${SRC}/util/util_snapshot.f90 ${SRC}/util/util_solve.f90 ${SRC}/util/util_sort.f90 ${SRC}/util/util_spill.f90 + ${SRC}/util/util_unique.f90 ${SRC}/util/util_valid.f90 ${SRC}/util/util_version.f90 ${SRC}/walltime/walltime.f90 diff --git a/src/discard/discard.f90 b/src/discard/discard.f90 index 1e0be68bd..fc5160fd7 100644 --- a/src/discard/discard.f90 +++ b/src/discard/discard.f90 @@ -38,8 +38,8 @@ module subroutine discard_system(self, param) call tp%discard(system, param) ltp_discards = (tp_discards%nbody > 0) end if - if (ltp_discards) call tp_discards%write_info(param%nc, param) - if (lpl_discards) call pl_discards%write_info(param%nc, param) + if (ltp_discards) call tp_discards%write_info(param%system_history%nc, param) + if (lpl_discards) call pl_discards%write_info(param%system_history%nc, param) if (lpl_discards .and. param%lenergy) call self%conservation_report(param, lterminal=.false.) if (lpl_check) call pl_discards%setup(0,param) if (ltp_check) call tp_discards%setup(0,param) @@ -153,7 +153,7 @@ subroutine discard_cb_tp(tp, system, param) call tp%info(i)%set_value(status="DISCARDED_RMIN", discard_time=system%t, discard_rh=tp%rh(:,i), & discard_vh=tp%vh(:,i), discard_body_id=cb%id) else if (param%rmaxu >= 0.0_DP) then - rb2 = dot_product(tp%xb(:, i), tp%xb(:, i)) + rb2 = dot_product(tp%rb(:, i), tp%rb(:, i)) vb2 = dot_product(tp%vb(:, i), tp%vb(:, i)) energy = 0.5_DP * vb2 - Gmtot / sqrt(rb2) if ((energy > 0.0_DP) .and. (rb2 > rmaxu2)) then diff --git a/src/encounter/encounter_check.f90 b/src/encounter/encounter_check.f90 index 6d866fb50..4e60ecf4f 100644 --- a/src/encounter/encounter_check.f90 +++ b/src/encounter/encounter_check.f90 @@ -891,7 +891,7 @@ pure module subroutine encounter_check_sort_aabb_1D(self, n, extent_arr) end subroutine encounter_check_sort_aabb_1D - module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, x1, v1, x2, v2, renc1, renc2, dt, & + module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, r1, v1, r2, v2, renc1, renc2, dt, & nenc, index1, index2, lvdotr) !! author: David A. Minton !! @@ -902,8 +902,8 @@ module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, x1, v1, x class(encounter_bounding_box), intent(inout) :: self !! Multi-dimensional bounding box structure integer(I4B), intent(in) :: n1 !! Number of bodies 1 integer(I4B), intent(in) :: n2 !! Number of bodies 2 - real(DP), dimension(:,:), intent(in) :: x1, v1 !! Array of position and velocity vectorrs for bodies 1 - real(DP), dimension(:,:), intent(in) :: x2, v2 !! Array of position and velocity vectorrs for bodies 2 + real(DP), dimension(:,:), intent(in) :: r1, v1 !! Array of position and velocity vectorrs for bodies 1 + real(DP), dimension(:,:), intent(in) :: r2, v2 !! Array of position and velocity vectorrs for bodies 2 real(DP), dimension(:), intent(in) :: renc1 !! Radius of encounter regions of bodies 1 real(DP), dimension(:), intent(in) :: renc2 !! Radius of encounter regions of bodies 2 real(DP), intent(in) :: dt !! Step size @@ -943,17 +943,17 @@ module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, x1, v1, x dim = 1 where(llist1(dim,:)) - xind(:) = x1(1,ext_ind(dim,:)) - yind(:) = x1(2,ext_ind(dim,:)) - zind(:) = x1(3,ext_ind(dim,:)) + xind(:) = r1(1,ext_ind(dim,:)) + yind(:) = r1(2,ext_ind(dim,:)) + zind(:) = r1(3,ext_ind(dim,:)) vxind(:) = v1(1,ext_ind(dim,:)) vyind(:) = v1(2,ext_ind(dim,:)) vzind(:) = v1(3,ext_ind(dim,:)) rencind(:) = renc1(ext_ind(dim,:)) elsewhere - xind(:) = x2(1,ext_ind(dim,:)) - yind(:) = x2(2,ext_ind(dim,:)) - zind(:) = x2(3,ext_ind(dim,:)) + xind(:) = r2(1,ext_ind(dim,:)) + yind(:) = r2(2,ext_ind(dim,:)) + zind(:) = r2(3,ext_ind(dim,:)) vxind(:) = v2(1,ext_ind(dim,:)) vyind(:) = v2(2,ext_ind(dim,:)) vzind(:) = v2(3,ext_ind(dim,:)) @@ -962,7 +962,7 @@ module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, x1, v1, x where(.not.loverlap(:)) lenc(:)%nenc = 0 !$omp parallel default(private) & - !$omp shared(self, ext_ind, lenc, loverlap, x1, v1, x2, v2, renc1, renc2, xind, yind, zind, vxind, vyind, vzind, rencind, llist1) & + !$omp shared(self, ext_ind, lenc, loverlap, r1, v1, r2, v2, renc1, renc2, xind, yind, zind, vxind, vyind, vzind, rencind, llist1) & !$omp firstprivate(ntot, n1, n2, dt, dim) ! Do the first group of bodies (i is in list 1, all the others are from list 2) @@ -972,7 +972,7 @@ module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, x1, v1, x ibeg = self%aabb(dim)%ibeg(i) + 1_I8B iend = self%aabb(dim)%iend(i) - 1_I8B nbox = iend - ibeg + 1 - call encounter_check_all_sweep_one(i, nbox, x1(1,i), x1(2,i), x1(3,i), v1(1,i), v1(2,i), v1(3,i), & + call encounter_check_all_sweep_one(i, nbox, r1(1,i), r1(2,i), r1(3,i), v1(1,i), v1(2,i), v1(3,i), & xind(ibeg:iend), yind(ibeg:iend), zind(ibeg:iend),& vxind(ibeg:iend), vyind(ibeg:iend), vzind(ibeg:iend), & renc1(i), rencind(ibeg:iend), dt, ext_ind(dim,ibeg:iend), & @@ -989,7 +989,7 @@ module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, x1, v1, x iend = self%aabb(dim)%iend(i) - 1_I8B nbox = iend - ibeg + 1 ii = i - n1 - call encounter_check_all_sweep_one(ii, nbox, x2(1,ii), x2(2,ii), x2(3,ii), v2(1,ii), v2(2,ii), v2(3,ii), & + call encounter_check_all_sweep_one(ii, nbox, r1(1,ii), r1(2,ii), r1(3,ii), v2(1,ii), v2(2,ii), v2(3,ii), & xind(ibeg:iend), yind(ibeg:iend), zind(ibeg:iend),& vxind(ibeg:iend), vyind(ibeg:iend), vzind(ibeg:iend), & renc2(ii), rencind(ibeg:iend), dt, ext_ind(dim,ibeg:iend), & diff --git a/src/encounter/encounter_io.f90 b/src/encounter/encounter_io.f90 index 0cc07b009..22827f611 100644 --- a/src/encounter/encounter_io.f90 +++ b/src/encounter/encounter_io.f90 @@ -12,34 +12,90 @@ contains - module subroutine encounter_io_dump(self, param) + module subroutine encounter_io_dump_collision(self, param) !! author: David A. Minton !! !! Dumps the time history of an encounter to file. implicit none ! Arguments + class(collision_storage(*)), intent(inout) :: self !! Encounter storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i + + select type(nc => self%nc) + class is (fraggle_io_parameters) + if (self%iframe > 0) then + nc%file_number = nc%file_number + 1 + call self%make_index_map() + nc%event_dimsize = self%nt + nc%name_dimsize = self%nid + + write(nc%file_name, '("collision_",I0.6,".nc")') nc%file_number + call nc%initialize(param) + + do i = 1, self%nframes + if (allocated(self%frame(i)%item)) then + select type(snapshot => self%frame(i)%item) + class is (fraggle_snapshot) + param%ioutput = i + call snapshot%write_frame(nc,param) + end select + else + exit + end if + end do + + call nc%close() + call self%reset() + end if + end select + + return + end subroutine encounter_io_dump_collision + + + module subroutine encounter_io_dump_encounter(self, param) + ! author: David A. Minton + !! + !! Dumps the time history of an encounter to file. + implicit none + ! Arguments class(encounter_storage(*)), intent(inout) :: self !! Encounter storage object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals integer(I4B) :: i - ! Most of this is just temporary test code just to get something working. Eventually this should get cleaned up. - - do i = 1, self%nframes - if (allocated(self%frame(i)%item)) then - select type(snapshot => self%frame(i)%item) - class is (encounter_snapshot) - param%ioutput = self%tslot(i) - call snapshot%write_frame(self%nc,param) - end select - else - exit + select type(nc => self%nc) + class is (encounter_io_parameters) + if (self%iframe > 0) then + ! Create and save the output files for this encounter and fragmentation + nc%file_number = nc%file_number + 1 + call self%make_index_map() + nc%time_dimsize = self%nt + nc%name_dimsize = self%nid + write(nc%file_name, '("encounter_",I0.6,".nc")') nc%file_number + call nc%initialize(param) + + do i = 1, self%nframes + if (allocated(self%frame(i)%item)) then + select type(snapshot => self%frame(i)%item) + class is (encounter_snapshot) + param%ioutput = self%tmap(i) + call snapshot%write_frame(nc,param) + end select + else + exit + end if + end do + + call nc%close() + call self%reset() end if - end do - + end select return - end subroutine encounter_io_dump + end subroutine encounter_io_dump_encounter module subroutine encounter_io_initialize(self, param) @@ -58,7 +114,7 @@ module subroutine encounter_io_initialize(self, param) real(SP) :: sfill logical :: fileExists character(len=STRMAX) :: errmsg - integer(I4B) :: ndims + integer(I4B) :: ndims, i associate(nc => self) dfill = ieee_value(dfill, IEEE_QUIET_NAN) @@ -72,38 +128,38 @@ module subroutine encounter_io_initialize(self, param) end select ! Check if the file exists, and if it does, delete it - inquire(file=nc%enc_file, exist=fileExists) + inquire(file=nc%file_name, exist=fileExists) if (fileExists) then - open(unit=LUN, file=nc%enc_file, status="old", err=667, iomsg=errmsg) + open(unit=LUN, file=nc%file_name, status="old", err=667, iomsg=errmsg) close(unit=LUN, status="delete") end if - call check( nf90_create(nc%enc_file, NF90_NETCDF4, nc%id), "encounter_io_initialize nf90_create" ) + call check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "encounter_io_initialize nf90_create" ) ! Dimensions call check( nf90_def_dim(nc%id, nc%time_dimname, nc%time_dimsize, nc%time_dimid), "encounter_io_initialize nf90_def_dim time_dimid" ) ! Simulation time dimension - call check( nf90_def_dim(nc%id, nc%space_dimname, NDIM , nc%space_dimid), "encounter_io_initialize nf90_def_dim space_dimid" ) ! 3D space dimension - call check( nf90_def_dim(nc%id, nc%id_dimname, param%maxid, nc%id_dimid), "encounter_io_initialize nf90_def_dim id_dimid" ) ! dimension to store particle id numbers + call check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "encounter_io_initialize nf90_def_dim space_dimid" ) ! 3D space dimension + call check( nf90_def_dim(nc%id, nc%name_dimname, nc%name_dimsize, nc%name_dimid), "encounter_io_initialize nf90_def_dim name_dimid" ) ! dimension to store particle id numbers call check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "encounter_io_initialize nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) ! Dimension coordinates call check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, nc%time_dimid, nc%time_varid), "encounter_io_initialize nf90_def_var time_varid" ) call check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "encounter_io_initialize nf90_def_var space_varid" ) - call check( nf90_def_var(nc%id, nc%id_dimname, NF90_INT, nc%id_dimid, nc%id_varid), "encounter_io_initialize nf90_def_var id_varid" ) + call check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "encounter_io_initialize nf90_def_var id_varid" ) ! Variables - call check( nf90_def_var(nc%id, nc%name_varname, NF90_CHAR, [nc%str_dimid, nc%id_dimid], nc%name_varid), "encounter_io_initialize nf90_def_var name_varid" ) - call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%id_dimid], nc%ptype_varid), "encounter_io_initialize nf90_def_var ptype_varid" ) - call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%rh_varid), "encounter_io_initialize nf90_def_var rh_varid" ) - call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%vh_varid), "encounter_io_initialize nf90_def_var vh_varid" ) - call check( nf90_def_var(nc%id, nc%Gmass_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%Gmass_varid), "encounter_io_initialize nf90_def_var Gmass_varid" ) - call check( nf90_def_var(nc%id, nc%level_varname, NF90_INT, [nc%id_dimid, nc%time_dimid], nc%level_varid), "encounter_io_initialize nf90_def_var level_varid" ) + call check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "encounter_io_initialize nf90_def_var id_varid" ) + call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%ptype_varid), "encounter_io_initialize nf90_def_var ptype_varid" ) + call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rh_varid), "encounter_io_initialize nf90_def_var rh_varid" ) + call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%vh_varid), "encounter_io_initialize nf90_def_var vh_varid" ) + call check( nf90_def_var(nc%id, nc%Gmass_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Gmass_varid), "encounter_io_initialize nf90_def_var Gmass_varid" ) + call check( nf90_def_var(nc%id, nc%loop_varname, NF90_INT, [nc%time_dimid], nc%loop_varid), "encounter_io_initialize nf90_def_var loop_varid" ) if (param%lclose) then - call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%radius_varid), "encounter_io_initialize nf90_def_var radius_varid" ) + call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%radius_varid), "encounter_io_initialize nf90_def_var radius_varid" ) end if if (param%lrotation) then - call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%Ip_varid), "encounter_io_initialize nf90_def_var Ip_varid" ) - call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%rot_varid), "encounter_io_initialize nf90_def_var rot_varid" ) + call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%Ip_varid), "encounter_io_initialize nf90_def_var Ip_varid" ) + call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rot_varid), "encounter_io_initialize nf90_def_var rot_varid" ) end if call check( nf90_inquire(nc%id, nVariables=nvar), "encounter_io_initialize nf90_inquire nVariables" ) @@ -126,6 +182,7 @@ module subroutine encounter_io_initialize(self, param) ! Add in the space dimension coordinates call check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "encounter_io_initialize nf90_put_var space" ) + end associate return @@ -143,60 +200,61 @@ module subroutine encounter_io_write_frame(self, nc, param) use netcdf implicit none ! Arguments - class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure - class(encounter_io_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset + class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure + class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals - integer(I4B) :: i, tslot, idslot, old_mode, npl, ntp - character(len=NAMELEN) :: charstring - - tslot = param%ioutput - - call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "encounter_io_write_frame nf90_set_fill" ) - - call check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[tslot]), "encounter_io_write_frame nf90_put_var time_varid" ) - - associate(pl => self%pl, tp => self%tp) - npl = pl%nbody - do i = 1, npl - idslot = pl%id(i) - call check( nf90_put_var(nc%id, nc%id_varid, pl%id(i), start=[idslot]), "encounter_io_write_frame nf90_put_var pl id_varid" ) - call check( nf90_put_var(nc%id, nc%rh_varid, pl%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl rh_varid" ) - call check( nf90_put_var(nc%id, nc%vh_varid, pl%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl vh_varid" ) - call check( nf90_put_var(nc%id, nc%Gmass_varid, pl%Gmass(i), start=[idslot, tslot]), "encounter_io_write_frame nf90_put_var pl Gmass_varid" ) - select type(pl) - class is (symba_pl) - call check( nf90_put_var(nc%id, nc%level_varid, pl%levelg(i), start=[idslot, tslot]), "encounter_io_write_frame nf90_put_var pl level_varid" ) - end select - - if (param%lclose) call check( nf90_put_var(nc%id, nc%radius_varid, pl%radius(i), start=[idslot, tslot]), "encounter_io_write_frame nf90_put_var pl radius_varid" ) - - if (param%lrotation) then - call check( nf90_put_var(nc%id, nc%Ip_varid, pl%Ip(:,i), start=[1, idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl Ip_varid" ) - call check( nf90_put_var(nc%id, nc%rot_varid, pl%rot(:,i), start=[1,idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl rotx_varid" ) - end if - - charstring = trim(adjustl(pl%info(i)%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "encounter_io_write_frame nf90_put_var pl name_varid" ) - charstring = trim(adjustl(pl%info(i)%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "encounter_io_write_frame nf90_put_var pl particle_type_varid" ) - end do - - ntp = tp%nbody - do i = 1, ntp - idslot = tp%id(i) - call check( nf90_put_var(nc%id, nc%id_varid, tp%id(i), start=[idslot]), "encounter_io_write_frame nf90_put_var tp id_varid" ) - call check( nf90_put_var(nc%id, nc%rh_varid, tp%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var tp rh_varid" ) - call check( nf90_put_var(nc%id, nc%vh_varid, tp%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var tp vh_varid" ) - - charstring = trim(adjustl(tp%info(i)%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "encounter_io_write_frame nf90_put_var tp name_varid" ) - charstring = trim(adjustl(tp%info(i)%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "encounter_io_write_frame nf90_put_var tp particle_type_varid" ) - end do - end associate - - call check( nf90_set_fill(nc%id, old_mode, old_mode) ) + integer(I4B) :: i, idslot, old_mode, npl, ntp + character(len=:), allocatable :: charstring + + select type (nc) + class is (encounter_io_parameters) + select type (param) + class is (symba_parameters) + associate(pl => self%pl, tp => self%tp, encounter_history => param%encounter_history, tslot => param%ioutput) + call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "encounter_io_write_frame nf90_set_fill" ) + + call check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[tslot]), "encounter_io_write_frame nf90_put_var time_varid" ) + call check( nf90_put_var(nc%id, nc%loop_varid, int(self%iloop,kind=I4B), start=[tslot]), "encounter_io_write_frame nf90_put_var pl loop_varid" ) + + npl = pl%nbody + do i = 1, npl + idslot = findloc(encounter_history%idvals,pl%id(i),dim=1) + call check( nf90_put_var(nc%id, nc%id_varid, pl%id(i), start=[idslot]), "encounter_io_write_frame nf90_put_var pl id_varid" ) + call check( nf90_put_var(nc%id, nc%rh_varid, pl%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl rh_varid" ) + call check( nf90_put_var(nc%id, nc%vh_varid, pl%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl vh_varid" ) + call check( nf90_put_var(nc%id, nc%Gmass_varid, pl%Gmass(i), start=[idslot, tslot]), "encounter_io_write_frame nf90_put_var pl Gmass_varid" ) + + if (param%lclose) call check( nf90_put_var(nc%id, nc%radius_varid, pl%radius(i), start=[idslot, tslot]), "encounter_io_write_frame nf90_put_var pl radius_varid" ) + + if (param%lrotation) then + call check( nf90_put_var(nc%id, nc%Ip_varid, pl%Ip(:,i), start=[1, idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl Ip_varid" ) + call check( nf90_put_var(nc%id, nc%rot_varid, pl%rot(:,i), start=[1,idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var pl rotx_varid" ) + end if + + charstring = trim(adjustl(pl%info(i)%name)) + call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame nf90_put_var pl name_varid" ) + charstring = trim(adjustl(pl%info(i)%particle_type)) + call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame nf90_put_var pl particle_type_varid" ) + end do + + ntp = tp%nbody + do i = 1, ntp + idslot = findloc(param%encounter_history%idvals,tp%id(i),dim=1) + call check( nf90_put_var(nc%id, nc%id_varid, tp%id(i), start=[idslot]), "encounter_io_write_frame nf90_put_var tp id_varid" ) + call check( nf90_put_var(nc%id, nc%rh_varid, tp%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var tp rh_varid" ) + call check( nf90_put_var(nc%id, nc%vh_varid, tp%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame nf90_put_var tp vh_varid" ) + + charstring = trim(adjustl(tp%info(i)%name)) + call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame nf90_put_var tp name_varid" ) + charstring = trim(adjustl(tp%info(i)%particle_type)) + call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame nf90_put_var tp particle_type_varid" ) + end do + + call check( nf90_set_fill(nc%id, old_mode, old_mode) ) + end associate + end select + end select return end subroutine encounter_io_write_frame diff --git a/src/encounter/encounter_setup.f90 b/src/encounter/encounter_setup.f90 index 22253b4e4..18b60d229 100644 --- a/src/encounter/encounter_setup.f90 +++ b/src/encounter/encounter_setup.f90 @@ -66,41 +66,33 @@ module subroutine encounter_setup_list(self, n) integer(I8B) :: i if (n < 0) return - - if (allocated(self%lvdotr)) deallocate(self%lvdotr) - if (allocated(self%status)) deallocate(self%status) - if (allocated(self%index1)) deallocate(self%index1) - if (allocated(self%index2)) deallocate(self%index2) - if (allocated(self%id1)) deallocate(self%id1) - if (allocated(self%id2)) deallocate(self%id2) - if (allocated(self%x1)) deallocate(self%x1) - if (allocated(self%x2)) deallocate(self%x2) - if (allocated(self%v1)) deallocate(self%v1) - if (allocated(self%v2)) deallocate(self%v2) + call self%dealloc() self%nenc = n if (n == 0_I8B) return self%t = 0.0_DP allocate(self%lvdotr(n)) + allocate(self%lclosest(n)) allocate(self%status(n)) allocate(self%index1(n)) allocate(self%index2(n)) allocate(self%id1(n)) allocate(self%id2(n)) - allocate(self%x1(NDIM,n)) - allocate(self%x2(NDIM,n)) + allocate(self%r1(NDIM,n)) + allocate(self%r2(NDIM,n)) allocate(self%v1(NDIM,n)) allocate(self%v2(NDIM,n)) self%lvdotr(:) = .false. + self%lclosest(:) = .false. self%status(:) = INACTIVE self%index1(:) = 0 self%index2(:) = 0 self%id1(:) = 0 self%id2(:) = 0 - self%x1(:,:) = 0.0_DP - self%x2(:,:) = 0.0_DP + self%r1(:,:) = 0.0_DP + self%r2(:,:) = 0.0_DP self%v1(:,:) = 0.0_DP self%v2(:,:) = 0.0_DP diff --git a/src/encounter/encounter_util.f90 b/src/encounter/encounter_util.f90 index 0d3a66d62..e4f0c1fbc 100644 --- a/src/encounter/encounter_util.f90 +++ b/src/encounter/encounter_util.f90 @@ -27,13 +27,14 @@ module subroutine encounter_util_append_list(self, source, lsource_mask) nold = self%nenc nsrc = source%nenc call util_append(self%lvdotr, source%lvdotr, nold, nsrc, lsource_mask) + call util_append(self%lclosest, source%lclosest, nold, nsrc, lsource_mask) call util_append(self%status, source%status, nold, nsrc, lsource_mask) call util_append(self%index1, source%index1, nold, nsrc, lsource_mask) call util_append(self%index2, source%index2, nold, nsrc, lsource_mask) call util_append(self%id1, source%id1, nold, nsrc, lsource_mask) call util_append(self%id2, source%id2, nold, nsrc, lsource_mask) - call util_append(self%x1, source%x1, nold, nsrc, lsource_mask) - call util_append(self%x2, source%x2, nold, nsrc, lsource_mask) + call util_append(self%r1, source%r1, nold, nsrc, lsource_mask) + call util_append(self%r2, source%r2, nold, nsrc, lsource_mask) call util_append(self%v1, source%v1, nold, nsrc, lsource_mask) call util_append(self%v2, source%v2, nold, nsrc, lsource_mask) self%nenc = nold + count(lsource_mask(1:nsrc)) @@ -55,13 +56,14 @@ module subroutine encounter_util_copy_list(self, source) self%nenc = n self%t = source%t self%lvdotr(1:n) = source%lvdotr(1:n) + self%lclosest(1:n) = source%lclosest(1:n) self%status(1:n) = source%status(1:n) self%index1(1:n) = source%index1(1:n) self%index2(1:n) = source%index2(1:n) self%id1(1:n) = source%id1(1:n) self%id2(1:n) = source%id2(1:n) - self%x1(:,1:n) = source%x1(:,1:n) - self%x2(:,1:n) = source%x2(:,1:n) + self%r1(:,1:n) = source%r1(:,1:n) + self%r2(:,1:n) = source%r2(:,1:n) self%v1(:,1:n) = source%v1(:,1:n) self%v2(:,1:n) = source%v2(:,1:n) end associate @@ -69,6 +71,7 @@ module subroutine encounter_util_copy_list(self, source) return end subroutine encounter_util_copy_list + module subroutine encounter_util_dealloc_aabb(self) !! author: David A. Minton !! @@ -94,13 +97,14 @@ module subroutine encounter_util_dealloc_list(self) class(encounter_list), intent(inout) :: self if (allocated(self%lvdotr)) deallocate(self%lvdotr) + if (allocated(self%lclosest)) deallocate(self%lclosest) if (allocated(self%status)) deallocate(self%status) if (allocated(self%index1)) deallocate(self%index1) if (allocated(self%index2)) deallocate(self%index2) if (allocated(self%id1)) deallocate(self%id1) if (allocated(self%id2)) deallocate(self%id2) - if (allocated(self%x1)) deallocate(self%x1) - if (allocated(self%x2)) deallocate(self%x2) + if (allocated(self%r1)) deallocate(self%r1) + if (allocated(self%r2)) deallocate(self%r2) if (allocated(self%v1)) deallocate(self%v1) if (allocated(self%v2)) deallocate(self%v2) @@ -152,6 +156,20 @@ module subroutine encounter_util_final_snapshot(self) end subroutine encounter_util_final_snapshot + module subroutine encounter_util_final_collision_storage(self) + !! author: David A. Minton + !! + !! Finalizer will deallocate all allocatables + implicit none + ! Arguments + type(collision_storage(*)), intent(inout) :: self !! SyMBA nbody system object + + call util_final_storage(self%swiftest_storage) + + return + end subroutine encounter_util_final_collision_storage + + module subroutine encounter_util_final_storage(self) !! author: David A. Minton !! @@ -166,6 +184,148 @@ module subroutine encounter_util_final_storage(self) end subroutine encounter_util_final_storage + module subroutine encounter_util_get_idvalues_snapshot(self, idvals) + !! author: David A. Minton + !! + !! Returns an array of all id values saved in this snapshot + implicit none + ! Arguments + class(encounter_snapshot), intent(in) :: self !! Encounter snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + ! Internals + integer(I4B) :: npl, ntp + + if (allocated(self%pl)) then + npl = self%pl%nbody + else + npl = 0 + end if + if (allocated(self%tp)) then + ntp = self%tp%nbody + else + ntp = 0 + end if + + if (npl + ntp == 0) return + allocate(idvals(npl+ntp)) + + if (npl > 0) idvals(1:npl) = self%pl%id(:) + if (ntp >0) idvals(npl+1:npl+ntp) = self%tp%id(:) + + return + + end subroutine encounter_util_get_idvalues_snapshot + + + subroutine encounter_util_get_vals_storage(storage, idvals, tvals) + !! author: David A. Minton + !! + !! Gets the id values in a storage object, regardless of whether it is encounter of collision + ! Argument + class(swiftest_storage(*)), intent(in) :: storage !! Swiftest storage object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values in all snapshots + real(DP), dimension(:), allocatable, intent(out) :: tvals !! Array of all time values in all snapshots + ! Internals + integer(I4B) :: i, n, nlo, nhi, ntotal + integer(I4B), dimension(:), allocatable :: itmp + + associate(nsnaps => storage%iframe) + + allocate(tvals(nsnaps)) + + tvals(:) = 0.0_DP + + ! First pass to get total number of ids + ntotal = 0 + do i = 1, nsnaps + if (allocated(storage%frame(i)%item)) then + select type(snapshot => storage%frame(i)%item) + class is (encounter_snapshot) + tvals(i) = snapshot%t + call snapshot%get_idvals(itmp) + if (allocated(itmp)) then + n = size(itmp) + ntotal = ntotal + n + end if + end select + end if + end do + + allocate(idvals(ntotal)) + nlo = 1 + ! Second pass to store all ids get all of the ids stored + do i = 1, nsnaps + if (allocated(storage%frame(i)%item)) then + select type(snapshot => storage%frame(i)%item) + class is (encounter_snapshot) + tvals(i) = snapshot%t + call snapshot%get_idvals(itmp) + if (allocated(itmp)) then + n = size(itmp) + nhi = nlo + n - 1 + idvals(nlo:nhi) = itmp(1:n) + nlo = nhi + 1 + end if + end select + end if + end do + + end associate + return + end subroutine encounter_util_get_vals_storage + + + module subroutine encounter_util_index_map_encounter(self) + !! author: David A. Minton + !! + !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id. + !! Basically this will make a unique list of ids that exist in all of the saved snapshots + implicit none + ! Arguments + class(encounter_storage(*)), intent(inout) :: self !! Swiftest storage object + ! Internals + integer(I4B), dimension(:), allocatable :: idvals + real(DP), dimension(:), allocatable :: tvals + + call encounter_util_get_vals_storage(self, idvals, tvals) + + ! Consolidate ids to only unique values + call util_unique(idvals,self%idvals,self%idmap) + self%nid = size(self%idvals) + + ! Consolidate time values to only unique values + call util_unique(tvals,self%tvals,self%tmap) + self%nt = size(self%tvals) + + return + end subroutine encounter_util_index_map_encounter + + + + module subroutine encounter_util_index_map_collision(self) + !! author: David A. Minton + !! + !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + implicit none + ! Arguments + class(collision_storage(*)), intent(inout) :: self !! Swiftest storage object + ! Internals + integer(I4B), dimension(:), allocatable :: idvals + real(DP), dimension(:), allocatable :: tvals + + call encounter_util_get_vals_storage(self, idvals, tvals) + + ! Consolidate ids to only unique values + call util_unique(idvals,self%idvals,self%idmap) + self%nid = size(self%idvals) + + ! Don't consolidate time values (multiple collisions can happen in a single time step) + self%nt = size(self%tvals) + + return + end subroutine encounter_util_index_map_collision + + module subroutine encounter_util_resize_list(self, nnew) !! author: David A. Minton !! @@ -219,13 +379,14 @@ module subroutine encounter_util_spill_list(self, discards, lspill_list, ldestru associate(keeps => self) call util_spill(keeps%lvdotr, discards%lvdotr, lspill_list, ldestructive) + call util_spill(keeps%lclosest, discards%lclosest, lspill_list, ldestructive) call util_spill(keeps%status, discards%status, lspill_list, ldestructive) call util_spill(keeps%index1, discards%index1, lspill_list, ldestructive) call util_spill(keeps%index2, discards%index2, lspill_list, ldestructive) call util_spill(keeps%id1, discards%id1, lspill_list, ldestructive) call util_spill(keeps%id2, discards%id2, lspill_list, ldestructive) - call util_spill(keeps%x1, discards%x1, lspill_list, ldestructive) - call util_spill(keeps%x2, discards%x2, lspill_list, ldestructive) + call util_spill(keeps%r1, discards%r1, lspill_list, ldestructive) + call util_spill(keeps%r2, discards%r2, lspill_list, ldestructive) call util_spill(keeps%v1, discards%v1, lspill_list, ldestructive) call util_spill(keeps%v2, discards%v2, lspill_list, ldestructive) @@ -240,4 +401,350 @@ module subroutine encounter_util_spill_list(self, discards, lspill_list, ldestru return end subroutine encounter_util_spill_list + + + subroutine encounter_util_save_collision(collision_history, snapshot) + !! author: David A. Minton + !! + !! Checks the current size of the encounter storage against the required size and extends it by a factor of 2 more than requested if it is too small. + !! Note: The reason to extend it by a factor of 2 is for performance. When there are many enounters per step, resizing every time you want to add an + !! encounter takes significant computational effort. Resizing by a factor of 2 is a tradeoff between performance (fewer resize calls) and memory managment + !! Memory usage grows by a factor of 2 each time it fills up, but no more. + implicit none + ! Arguments + type(collision_storage(*)), allocatable, intent(inout) :: collision_history !! Collision history object + class(encounter_snapshot), intent(in) :: snapshot !! Encounter snapshot object + ! Internals + type(collision_storage(nframes=:)), allocatable :: tmp + integer(I4B) :: i, nnew, nold, nbig + + ! Advance the snapshot frame counter + collision_history%iframe = collision_history%iframe + 1 + + ! Check to make sure the current encounter_history object is big enough. If not, grow it by a factor of 2 + nnew = collision_history%iframe + nold = collision_history%nframes + + if (nnew > nold) then + nbig = nold + do while (nbig < nnew) + nbig = nbig * 2 + end do + allocate(collision_storage(nbig) :: tmp) + tmp%iframe = collision_history%iframe + call move_alloc(collision_history%nc, tmp%nc) + + do i = 1, nold + if (allocated(collision_history%frame(i)%item)) call move_alloc(collision_history%frame(i)%item, tmp%frame(i)%item) + end do + deallocate(collision_history) + call move_alloc(tmp,collision_history) + nnew = nbig + end if + + collision_history%frame(nnew) = snapshot + + return + end subroutine encounter_util_save_collision + + + subroutine encounter_util_save_encounter(encounter_history, snapshot, t) + !! author: David A. Minton + !! + !! Checks the current size of the encounter storage against the required size and extends it by a factor of 2 more than requested if it is too small. + !! Note: The reason to extend it by a factor of 2 is for performance. When there are many enounters per step, resizing every time you want to add an + !! encounter takes significant computational effort. Resizing by a factor of 2 is a tradeoff between performance (fewer resize calls) and memory managment + !! Memory usage grows by a factor of 2 each time it fills up, but no more. + implicit none + ! Arguments + type(encounter_storage(*)), allocatable, intent(inout) :: encounter_history !! SyMBA encounter storage object + class(encounter_snapshot), intent(in) :: snapshot !! Encounter snapshot object + real(DP), intent(in) :: t !! The time of the snapshot + ! Internals + type(encounter_storage(nframes=:)), allocatable :: tmp + integer(I4B) :: i, nnew, nold, nbig + + ! Advance the snapshot frame counter + encounter_history%iframe = encounter_history%iframe + 1 + + ! Check to make sure the current encounter_history object is big enough. If not, grow it by a factor of 2 + nnew = encounter_history%iframe + nold = encounter_history%nframes + + if (nnew > nold) then + nbig = nold + do while (nbig < nnew) + nbig = nbig * 2 + end do + allocate(encounter_storage(nbig) :: tmp) + tmp%iframe = encounter_history%iframe + call move_alloc(encounter_history%nc, tmp%nc) + + do i = 1, nold + if (allocated(encounter_history%frame(i)%item)) call move_alloc(encounter_history%frame(i)%item, tmp%frame(i)%item) + end do + deallocate(encounter_history) + call move_alloc(tmp,encounter_history) + nnew = nbig + end if + + ! Find out which time slot this belongs in by searching for an existing slot + ! with the same value of time or the first available one + encounter_history%frame(nnew) = snapshot + + return + end subroutine encounter_util_save_encounter + + + module subroutine encounter_util_snapshot_collision(self, param, system, t, arg) + !! author: David A. Minton + !! + !! Takes a minimal snapshot of the state of the system during an encounter so that the trajectories + !! can be played back through the encounter + implicit none + ! Internals + class(collision_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! "before": takes a snapshot just before the collision. "after" takes the snapshot just after the collision. + ! Arguments + class(fraggle_snapshot), allocatable :: snapshot + type(symba_pl) :: pl + character(len=:), allocatable :: stage + + if (present(arg)) then + stage = arg + else + stage = "" + end if + + select type (system) + class is (symba_nbody_system) + + select case(stage) + case("before") + ! Saves the states of the bodies involved in the collision before the collision is resolved + associate (idx => system%colliders%idx, ncoll => system%colliders%ncoll) + call pl%setup(ncoll, param) + pl%id(:) = system%pl%id(idx(:)) + pl%Gmass(:) = system%pl%Gmass(idx(:)) + pl%radius(:) = system%pl%radius(idx(:)) + pl%rot(:,:) = system%pl%rot(:,idx(:)) + pl%Ip(:,:) = system%pl%Ip(:,idx(:)) + pl%rh(:,:) = system%pl%rh(:,idx(:)) + pl%vh(:,:) = system%pl%vh(:,idx(:)) + pl%info(:) = system%pl%info(idx(:)) + !end select + allocate(system%colliders%pl, source=pl) + end associate + case("after") + allocate(fraggle_snapshot :: snapshot) + allocate(snapshot%colliders, source=system%colliders) + allocate(snapshot%fragments, source=system%fragments) + select type(param) + class is (symba_parameters) + call encounter_util_save_collision(param%collision_history,snapshot) + end select + case default + write(*,*) "encounter_util_snapshot_collision requies either 'before' or 'after' passed to 'arg'" + end select + + end select + + return + end subroutine encounter_util_snapshot_collision + + + module subroutine encounter_util_snapshot_encounter(self, param, system, t, arg) + !! author: David A. Minton + !! + !! Takes a minimal snapshot of the state of the system during an encounter so that the trajectories + !! can be played back through the encounter + implicit none + ! Internals + class(encounter_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) + ! Arguments + class(encounter_snapshot), allocatable :: snapshot + integer(I4B) :: i, pi, pj, k, npl_snap, ntp_snap, iflag + real(DP), dimension(NDIM) :: rrel, vrel, rcom, vcom + real(DP) :: Gmtot, a, q, capm, tperi + real(DP), dimension(NDIM,2) :: rb,vb + + if (.not.present(t)) then + write(*,*) "encounter_util_snapshot_encounter requires `t` to be passed" + return + end if + + if (.not.present(arg)) then + write(*,*) "encounter_util_snapshot_encounter requires `arg` to be passed" + return + end if + + select type(param) + class is (symba_parameters) + select type (system) + class is (symba_nbody_system) + select type(pl => system%pl) + class is (symba_pl) + select type (tp => system%tp) + class is (symba_tp) + associate(npl => pl%nbody, ntp => tp%nbody) + if (npl + ntp == 0) return + allocate(encounter_snapshot :: snapshot) + allocate(snapshot%pl, mold=pl) + allocate(snapshot%tp, mold=tp) + snapshot%iloop = param%iloop + + select type(pl_snap => snapshot%pl) + class is (symba_pl) + select type(tp_snap => snapshot%tp) + class is (symba_tp) + + select case(arg) + case("trajectory") + snapshot%t = t + + npl_snap = npl + ntp_snap = ntp + + if (npl > 0) then + pl%lmask(1:npl) = pl%status(1:npl) /= INACTIVE .and. pl%levelg(1:npl) == system%irec + npl_snap = count(pl%lmask(1:npl)) + end if + if (ntp > 0) then + tp%lmask(1:ntp) = tp%status(1:ntp) /= INACTIVE .and. tp%levelg(1:ntp) == system%irec + ntp_snap = count(tp%lmask(1:ntp)) + end if + + if (npl_snap + ntp_snap == 0) return ! Nothing to snapshot + + pl_snap%nbody = npl_snap + + ! Take snapshot of the currently encountering massive bodies + if (npl_snap > 0) then + call pl_snap%setup(npl_snap, param) + pl_snap%levelg(:) = pack(pl%levelg(1:npl), pl%lmask(1:npl)) + pl_snap%id(:) = pack(pl%id(1:npl), pl%lmask(1:npl)) + pl_snap%info(:) = pack(pl%info(1:npl), pl%lmask(1:npl)) + pl_snap%Gmass(:) = pack(pl%Gmass(1:npl), pl%lmask(1:npl)) + do i = 1, NDIM + pl_snap%rh(i,:) = pack(pl%rh(i,1:npl), pl%lmask(1:npl)) + pl_snap%vh(i,:) = pack(pl%vb(i,1:npl), pl%lmask(1:npl)) + end do + if (param%lclose) then + pl_snap%radius(:) = pack(pl%radius(1:npl), pl%lmask(1:npl)) + end if + + if (param%lrotation) then + do i = 1, NDIM + pl_snap%Ip(i,:) = pack(pl%Ip(i,1:npl), pl%lmask(1:npl)) + pl_snap%rot(i,:) = pack(pl%rot(i,1:npl), pl%lmask(1:npl)) + end do + end if + call pl_snap%sort("id", ascending=.true.) + end if + + ! Take snapshot of the currently encountering test particles + tp_snap%nbody = ntp_snap + if (ntp_snap > 0) then + call tp_snap%setup(ntp_snap, param) + tp_snap%id(:) = pack(tp%id(1:ntp), tp%lmask(1:ntp)) + tp_snap%info(:) = pack(tp%info(1:ntp), tp%lmask(1:ntp)) + do i = 1, NDIM + tp_snap%rh(i,:) = pack(tp%rh(i,1:ntp), tp%lmask(1:ntp)) + tp_snap%vh(i,:) = pack(tp%vh(i,1:ntp), tp%lmask(1:ntp)) + end do + end if + + ! Save the snapshot + param%encounter_history%nid = param%encounter_history%nid + ntp_snap + npl_snap + call encounter_util_save_encounter(param%encounter_history,snapshot,t) + case("closest") + associate(plplenc_list => system%plplenc_list, pltpenc_list => system%pltpenc_list) + if (any(plplenc_list%lclosest(:))) then + call pl_snap%setup(2, param) + do k = 1, plplenc_list%nenc + if (plplenc_list%lclosest(k)) then + pi = plplenc_list%index1(k) + pj = plplenc_list%index2(k) + pl_snap%levelg(:) = pl%levelg([pi,pj]) + pl_snap%id(:) = pl%id([pi,pj]) + pl_snap%info(:) = pl%info([pi,pj]) + pl_snap%Gmass(:) = pl%Gmass([pi,pj]) + Gmtot = sum(pl_snap%Gmass(:)) + if (param%lclose) pl_snap%radius(:) = pl%radius([pi,pj]) + if (param%lrotation) then + do i = 1, NDIM + pl_snap%Ip(i,:) = pl%Ip(i,[pi,pj]) + pl_snap%rot(i,:) = pl%rot(i,[pi,pj]) + end do + end if + + ! Compute pericenter passage time to get the closest approach parameters + rrel(:) = plplenc_list%r2(:,k) - plplenc_list%r1(:,k) + vrel(:) = plplenc_list%v2(:,k) - plplenc_list%v1(:,k) + call orbel_xv2aqt(Gmtot, rrel(1), rrel(2), rrel(3), vrel(1), vrel(2), vrel(3), a, q, capm, tperi) + snapshot%t = t + tperi + + ! Computer the center mass of the pair + rcom(:) = (plplenc_list%r1(:,k) * pl_snap%Gmass(1) + plplenc_list%r2(:,k) * pl_snap%Gmass(2)) / Gmtot + vcom(:) = (plplenc_list%v1(:,k) * pl_snap%Gmass(1) + plplenc_list%v2(:,k) * pl_snap%Gmass(2)) / Gmtot + rb(:,1) = plplenc_list%r1(:,k) - rcom(:) + rb(:,2) = plplenc_list%r2(:,k) - rcom(:) + vb(:,1) = plplenc_list%v1(:,k) - vcom(:) + vb(:,2) = plplenc_list%v2(:,k) - vcom(:) + + ! Drift the relative orbit to get the new relative position and velocity + call drift_one(Gmtot, rrel(1), rrel(2), rrel(3), vrel(1), vrel(2), vrel(3), tperi, iflag) + if (iflag /= 0) write(*,*) "Danby error in encounter_util_snapshot_encounter. Closest approach positions and vectors may not be accurate." + + ! Get the new position and velocity vectors + rb(:,1) = -(pl_snap%Gmass(2) / Gmtot) * rrel(:) + rb(:,2) = (pl_snap%Gmass(1)) / Gmtot * rrel(:) + + vb(:,1) = -(pl_snap%Gmass(2) / Gmtot) * vrel(:) + vb(:,2) = (pl_snap%Gmass(1)) / Gmtot * vrel(:) + + ! Move the CoM assuming constant velocity over the time it takes to reach periapsis + rcom(:) = rcom(:) + vcom(:) * tperi + + ! Compute the heliocentric position and velocity vector at periapsis + pl_snap%rh(:,1) = rb(:,1) + rcom(:) + pl_snap%rh(:,2) = rb(:,2) + rcom(:) + pl_snap%vh(:,1) = vb(:,1) + vcom(:) + pl_snap%vh(:,2) = vb(:,2) + vcom(:) + + call pl_snap%sort("id", ascending=.true.) + call encounter_util_save_encounter(param%encounter_history,snapshot,snapshot%t) + end if + end do + + plplenc_list%lclosest(:) = .false. + end if + + if (any(pltpenc_list%lclosest(:))) then + do k = 1, pltpenc_list%nenc + end do + pltpenc_list%lclosest(:) = .false. + end if + end associate + case default + write(*,*) "encounter_util_snapshot_encounter requires `arg` to be either `trajectory` or `closest`" + end select + end select + end select + end associate + end select + end select + end select + end select + + return + end subroutine encounter_util_snapshot_encounter + end submodule s_encounter_util \ No newline at end of file diff --git a/src/fraggle/fraggle_generate.f90 b/src/fraggle/fraggle_generate.f90 index 3ec23ef99..8253fb12a 100644 --- a/src/fraggle/fraggle_generate.f90 +++ b/src/fraggle/fraggle_generate.f90 @@ -72,7 +72,7 @@ module subroutine fraggle_generate_fragments(self, colliders, system, param, lfa call frag%get_energy_and_momentum(colliders, system, param, lbefore=.true.) ! Start out the fragments close to the initial separation distance. This will be increased if there is any overlap or we fail to find a solution - r_max_start = 1 * norm2(colliders%xb(:,2) - colliders%xb(:,1)) + r_max_start = 1 * norm2(colliders%rb(:,2) - colliders%rb(:,1)) lfailure = .false. try = 1 do while (try < MAXTRY) @@ -151,7 +151,6 @@ module subroutine fraggle_generate_fragments(self, colliders, system, param, lfa else call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle fragment generation succeeded after " // & trim(adjustl(message)) // " tries") - call fraggle_io_log_generate(frag) end if call frag%set_original_scale(colliders) @@ -195,8 +194,8 @@ subroutine fraggle_generate_pos_vec(frag, colliders, r_max_start) call random_number(frag%x_coll(:,3:nfrag)) loverlap(:) = .true. do while (any(loverlap(3:nfrag))) - frag%x_coll(:, 1) = colliders%xb(:, 1) - frag%xbcom(:) - frag%x_coll(:, 2) = colliders%xb(:, 2) - frag%xbcom(:) + frag%x_coll(:, 1) = colliders%rb(:, 1) - frag%rbcom(:) + frag%x_coll(:, 2) = colliders%rb(:, 2) - frag%rbcom(:) r_max = r_max + 0.1_DP * rad do i = 3, nfrag if (loverlap(i)) then @@ -216,14 +215,14 @@ subroutine fraggle_generate_pos_vec(frag, colliders, r_max_start) call frag%set_coordinate_system(colliders) do i = 1, nfrag - frag%xb(:,i) = frag%x_coll(:,i) + frag%xbcom(:) + frag%rb(:,i) = frag%x_coll(:,i) + frag%rbcom(:) end do - frag%xbcom(:) = 0.0_DP + frag%rbcom(:) = 0.0_DP do i = 1, nfrag - frag%xbcom(:) = frag%xbcom(:) + frag%mass(i) * frag%xb(:,i) + frag%rbcom(:) = frag%rbcom(:) + frag%mass(i) * frag%rb(:,i) end do - frag%xbcom(:) = frag%xbcom(:) / frag%mtot + frag%rbcom(:) = frag%rbcom(:) / frag%mtot end associate return diff --git a/src/fraggle/fraggle_io.f90 b/src/fraggle/fraggle_io.f90 index 9d00bfb0f..f47a64047 100644 --- a/src/fraggle/fraggle_io.f90 +++ b/src/fraggle/fraggle_io.f90 @@ -12,57 +12,210 @@ contains - - module subroutine fraggle_io_encounter_dump(self, param) + module subroutine fraggle_io_initialize_output(self, param) + !! author: David A. Minton + !! + !! Initialize a NetCDF fragment history file system. This is a simplified version of the main simulation output NetCDF file, but with fewer variables. + use, intrinsic :: ieee_arithmetic + use netcdf implicit none - class(fraggle_storage(*)), intent(inout) :: self !! Encounter storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine fraggle_io_encounter_dump + ! Arguments + class(fraggle_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(swiftest_parameters), intent(in) :: param + ! Internals + integer(I4B) :: nvar, varid, vartype + real(DP) :: dfill + real(SP) :: sfill + logical :: fileExists + character(len=STRMAX) :: errmsg + integer(I4B) :: i, ndims - module subroutine fraggle_io_encounter_initialize_output(self, param) - implicit none - class(fraggle_io_encounter_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param - end subroutine fraggle_io_encounter_initialize_output + select type(param) + class is (symba_parameters) + associate(nc => self, collision_history => param%collision_history) + dfill = ieee_value(dfill, IEEE_QUIET_NAN) + sfill = ieee_value(sfill, IEEE_QUIET_NAN) - module subroutine fraggle_io_encounter_write_frame(self, nc, param) - implicit none - class(fraggle_encounter_snapshot), intent(in) :: self !! Swiftest encounter structure - class(encounter_io_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine fraggle_io_encounter_write_frame + select case (param%out_type) + case("NETCDF_FLOAT") + self%out_type = NF90_FLOAT + case("NETCDF_DOUBLE") + self%out_type = NF90_DOUBLE + end select + + ! Check if the file exists, and if it does, delete it + inquire(file=nc%file_name, exist=fileExists) + if (fileExists) then + open(unit=LUN, file=nc%file_name, status="old", err=667, iomsg=errmsg) + close(unit=LUN, status="delete") + end if + + call check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "fraggle_io_initialize nf90_create" ) + + ! Dimensions + call check( nf90_def_dim(nc%id, nc%event_dimname, nc%event_dimsize, nc%event_dimid), "fraggle_io_initialize nf90_def_dim event_dimid" ) ! Dimension to store individual collision events + call check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "fraggle_io_initialize nf90_def_dim space_dimid" ) ! 3D space dimension + call check( nf90_def_dim(nc%id, nc%name_dimname, nc%name_dimsize, nc%name_dimid), "fraggle_io_initialize nf90_def_dim name_dimid" ) ! Dimension to store particle id numbers + call check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "fraggle_io_initialize nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) + call check( nf90_def_dim(nc%id, nc%stage_dimname, 2, nc%stage_dimid), "fraggle_io_initialize nf90_def_dim stage_dimid" ) ! Dimension for stage variables (aka "before" vs. "after" + + ! Dimension coordinates + call check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "fraggle_io_initialize nf90_def_var space_varid" ) + call check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "fraggle_io_initialize nf90_def_var name_varid") + call check( nf90_def_var(nc%id, nc%stage_dimname, NF90_CHAR, [nc%str_dimid, nc%stage_dimid], nc%stage_varid), "fraggle_io_initialize nf90_def_var stage_varid" ) + + ! Variables + call check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "fraggle_io_initialize nf90_def_var id_varid" ) + call check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, & + nc%event_dimid, nc%time_varid), "fraggle_io_initialize nf90_def_var time_varid" ) + call check( nf90_def_var(nc%id, nc%regime_varname, NF90_CHAR, & + [nc%str_dimid, nc%event_dimid], nc%regime_varid), "fraggle_io_initialize nf90_def_var regime_varid") + call check( nf90_def_var(nc%id, nc%Qloss_varname, nc%out_type, & + [ nc%event_dimid], nc%Qloss_varid), "fraggle_io_initialize nf90_def_var Qloss_varid") + + call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, & + [nc%str_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%ptype_varid), "fraggle_io_initialize nf90_def_var ptype_varid") + + call check( nf90_def_var(nc%id, nc%loop_varname, NF90_INT, & + [ nc%event_dimid], nc%loop_varid), "fraggle_io_initialize nf90_def_var loop_varid") + + call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type,& + [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%rh_varid), "fraggle_io_initialize nf90_def_var rh_varid") + + call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type,& + [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%vh_varid), "fraggle_io_initialize nf90_def_var vh_varid") + + call check( nf90_def_var(nc%id, nc%Gmass_varname, nc%out_type,& + [ nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%Gmass_varid), "fraggle_io_initialize nf90_def_var Gmass_varid") + + + call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type,& + [ nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%radius_varid), "fraggle_io_initialize nf90_def_var radius_varid") + + call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type,& + [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%Ip_varid), "fraggle_io_initialize nf90_def_var Ip_varid") + + call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type,& + [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%rot_varid), "fraggle_io_initialize nf90_def_var rot_varid") + + call check( nf90_def_var(nc%id, nc%ke_orb_varname, nc%out_type,& + [ nc%stage_dimid, nc%event_dimid], nc%KE_orb_varid), "fraggle_io_initialize_output nf90_def_var KE_orb_varid") + + call check( nf90_def_var(nc%id, nc%ke_spin_varname, nc%out_type,& + [ nc%stage_dimid, nc%event_dimid], nc%KE_spin_varid), "fraggle_io_initialize_output nf90_def_var KE_spin_varid" ) + + call check( nf90_def_var(nc%id, nc%pe_varname, nc%out_type,& + [ nc%stage_dimid, nc%event_dimid], nc%PE_varid), "fraggle_io_initialize_output nf90_def_var PE_varid" ) + + call check( nf90_def_var(nc%id, nc%L_orb_varname, nc%out_type, & + [ nc%space_dimid, nc%stage_dimid, nc%event_dimid], nc%L_orb_varid), "fraggle_io_initialize_output nf90_def_var L_orb_varid" ) - module subroutine fraggle_io_log_generate(frag) + call check( nf90_def_var(nc%id, nc%L_spin_varname, nc%out_type,& + [ nc%space_dimid, nc%stage_dimid, nc%event_dimid], nc%L_spin_varid), "fraggle_io_initialize_output nf90_def_var L_spin_varid" ) + + + + call check( nf90_inquire(nc%id, nVariables=nvar), "fraggle_io_initialize nf90_inquire nVariables" ) + do varid = 1, nvar + call check( nf90_inquire_variable(nc%id, varid, xtype=vartype, ndims=ndims), "fraggle_io_initialize nf90_inquire_variable" ) + select case(vartype) + case(NF90_INT) + call check( nf90_def_var_fill(nc%id, varid, 0, NF90_FILL_INT), "fraggle_io_initialize nf90_def_var_fill NF90_INT" ) + case(NF90_FLOAT) + call check( nf90_def_var_fill(nc%id, varid, 0, sfill), "fraggle_io_initialize nf90_def_var_fill NF90_FLOAT" ) + case(NF90_DOUBLE) + call check( nf90_def_var_fill(nc%id, varid, 0, dfill), "fraggle_io_initialize nf90_def_var_fill NF90_DOUBLE" ) + case(NF90_CHAR) + call check( nf90_def_var_fill(nc%id, varid, 0, 0), "fraggle_io_initialize nf90_def_var_fill NF90_CHAR" ) + end select + end do + ! Take the file out of define mode + call check( nf90_enddef(nc%id), "fraggle_io_initialize nf90_enddef" ) + + ! Add in the space and stage dimension coordinates + call check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "fraggle_io_initialize nf90_put_var space" ) + call check( nf90_put_var(nc%id, nc%stage_varid, nc%stage_coords(1), start=[1,1], count=[len(nc%stage_coords(1)),1]), "fraggle_io_initialize nf90_put_var stage 1" ) + call check( nf90_put_var(nc%id, nc%stage_varid, nc%stage_coords(2), start=[1,2], count=[len(nc%stage_coords(2)),1]), "fraggle_io_initialize nf90_put_var stage 2" ) + + end associate + end select + + return + + 667 continue + write(*,*) "Error creating fragmentation output file. " // trim(adjustl(errmsg)) + call util_exit(FAILURE) + end subroutine fraggle_io_initialize_output + + + module subroutine fraggle_io_write_frame(self, nc, param) !! author: David A. Minton !! - !! Writes a log of the results of the fragment generation + !! Write a frame of output of a collision result + use netcdf implicit none ! Arguments - class(fraggle_fragments), intent(in) :: frag + class(fraggle_snapshot), intent(in) :: self !! Swiftest encounter structure + class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals - integer(I4B) :: i - character(STRMAX) :: errmsg - character(len=*), parameter :: fmtlabel = "(A14,10(ES11.4,1X,:))" + integer(I4B) :: i, idslot, old_mode, npl, stage + character(len=:), allocatable :: charstring + class(swiftest_pl), allocatable :: pl - open(unit=LUN, file=FRAGGLE_LOG_OUT, status = 'OLD', position = 'APPEND', form = 'FORMATTED', err = 667, iomsg = errmsg) - write(LUN, *, err = 667, iomsg = errmsg) - write(LUN, *) "--------------------------------------------------------------------" - write(LUN, *) " Fraggle fragment generation results" - write(LUN, *) "--------------------------------------------------------------------" - write(LUN, "(' dL_tot should be very small' )") - write(LUN,fmtlabel) ' dL_tot |', (.mag.(frag%Ltot_after(:) - frag%Ltot_before(:))) / (.mag.frag%Ltot_before(:)) - write(LUN, "(' dE_tot should be negative and equal to Qloss' )") - write(LUN,fmtlabel) ' dE_tot |', (frag%Etot_after - frag%Etot_before) / abs(frag%Etot_before) - write(LUN,fmtlabel) ' Qloss |', -frag%Qloss / abs(frag%Etot_before) - write(LUN,fmtlabel) ' dE - Qloss |', (frag%Etot_after - frag%Etot_before + frag%Qloss) / abs(frag%Etot_before) - write(LUN, "(' -------------------------------------------------------------------------------------')") + select type(nc) + class is (fraggle_io_parameters) + select type (param) + class is (symba_parameters) + associate(colliders => self%colliders, fragments => self%fragments, collision_history => param%collision_history, eslot => param%ioutput) + call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "fraggle_io_write_frame nf90_set_fill" ) - close(LUN) + call check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[eslot]), "fraggle_io_write_frame nf90_put_var time_varid" ) + call check( nf90_put_var(nc%id, nc%loop_varid, int(self%iloop,kind=I4B), start=[eslot]), "fraggle_io_write_frame nf90_put_varloop_varid" ) + + charstring = trim(adjustl(REGIME_NAMES(fragments%regime))) + call check( nf90_put_var(nc%id, nc%regime_varid, charstring, start=[1, eslot], count=[len(charstring), 1]), "fraggle_io_write_frame nf90_put_var regime_varid" ) + call check( nf90_put_var(nc%id, nc%Qloss_varid, fragments%Qloss, start=[eslot] ), "fraggle_io_write_frame nf90_put_var Qloss_varid" ) + do stage = 1,2 + if (allocated(pl)) deallocate(pl) + select case(stage) + case(1) + allocate(pl, source=colliders%pl) + case(2) + allocate(pl, source=fragments%pl) + end select + npl = pl%nbody + do i = 1, npl + idslot = findloc(collision_history%idvals,pl%id(i),dim=1) + call check( nf90_put_var(nc%id, nc%id_varid, pl%id(i), start=[ idslot ]), "fraggle_io_write_frame nf90_put_var id_varid" ) + charstring = trim(adjustl(pl%info(i)%name)) + call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot ], count=[len(charstring), 1]), "fraggle_io_write_frame nf90_put_var name_varid" ) + charstring = trim(adjustl(pl%info(i)%particle_type)) + call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot, stage, eslot], count=[len(charstring), 1, 1]), "fraggle_io_write_frame nf90_put_var particle_type_varid" ) + call check( nf90_put_var(nc%id, nc%rh_varid, pl%rh(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "fraggle_io_write_frame nf90_put_var rh_varid" ) + call check( nf90_put_var(nc%id, nc%vh_varid, pl%vh(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "fraggle_io_write_frame nf90_put_var vh_varid" ) + call check( nf90_put_var(nc%id, nc%Gmass_varid, pl%Gmass(i), start=[ idslot, stage, eslot]), "fraggle_io_write_frame nf90_put_var Gmass_varid" ) + call check( nf90_put_var(nc%id, nc%radius_varid, pl%radius(i), start=[ idslot, stage, eslot]), "fraggle_io_write_frame nf90_put_var radius_varid" ) + call check( nf90_put_var(nc%id, nc%Ip_varid, pl%Ip(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "fraggle_io_write_frame nf90_put_var Ip_varid" ) + call check( nf90_put_var(nc%id, nc%rot_varid, pl%rot(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "fraggle_io_write_frame nf90_put_var rotx_varid" ) + end do + end do + call check( nf90_put_var(nc%id, nc%ke_orb_varid, fragments%ke_orbit_before, start=[ 1, eslot]), "fraggle_io_write_frame nf90_put_var ke_orb_varid before" ) + call check( nf90_put_var(nc%id, nc%ke_orb_varid, fragments%ke_orbit_after, start=[ 2, eslot]), "fraggle_io_write_frame nf90_put_var ke_orb_varid after" ) + call check( nf90_put_var(nc%id, nc%pe_varid, fragments%pe_before, start=[ 1, eslot]), "fraggle_io_write_frame nf90_put_var pe_varid before" ) + call check( nf90_put_var(nc%id, nc%pe_varid, fragments%pe_after, start=[ 2, eslot]), "fraggle_io_write_frame nf90_put_var pe_varid after" ) + call check( nf90_put_var(nc%id, nc%L_orb_varid, fragments%Lorbit_before(:), start=[1, 1, eslot], count=[NDIM, 1, 1]), "fraggle_io_write_frame nf90_put_var L_orb_varid before" ) + call check( nf90_put_var(nc%id, nc%L_orb_varid, fragments%Lorbit_after(:), start=[1, 2, eslot], count=[NDIM, 1, 1]), "fraggle_io_write_frame nf90_put_var L_orb_varid after" ) + call check( nf90_put_var(nc%id, nc%L_spin_varid, fragments%Lspin_before(:), start=[1, 1, eslot], count=[NDIM, 1, 1]), "fraggle_io_write_frame nf90_put_var L_spin_varid before" ) + call check( nf90_put_var(nc%id, nc%L_spin_varid, fragments%Lspin_after(:), start=[1, 2, eslot], count=[NDIM, 1, 1]), "fraggle_io_write_frame nf90_put_var L_spin_varid after" ) + + call check( nf90_set_fill(nc%id, old_mode, old_mode) ) + end associate + end select + end select return - 667 continue - write(*,*) "Error writing Fraggle message to log file: " // trim(adjustl(errmsg)) - end subroutine fraggle_io_log_generate + end subroutine fraggle_io_write_frame module subroutine fraggle_io_log_pl(pl, param) @@ -71,7 +224,7 @@ module subroutine fraggle_io_log_pl(pl, param) !! Writes a single message to the fraggle log file implicit none ! Arguments - class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object (only the new bodies generated in a collision) + class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object (only the new bodies generated in a collision) class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters ! Internals integer(I4B) :: i diff --git a/src/fraggle/fraggle_regime.f90 b/src/fraggle/fraggle_regime.f90 index cf8d5891c..7b3191149 100644 --- a/src/fraggle/fraggle_regime.f90 +++ b/src/fraggle/fraggle_regime.f90 @@ -42,9 +42,9 @@ module subroutine fraggle_regime_colliders(self, frag, system, param) mass_si(:) = colliders%mass([jtarg, jproj]) * param%MU2KG !! The two-body equivalent masses of the collider system radius_si(:) = colliders%radius([jtarg, jproj]) * param%DU2M !! The two-body equivalent radii of the collider system density_si(:) = mass_si(:) / (4.0_DP / 3._DP * PI * radius_si(:)**3) !! The two-body equivalent density of the collider system - x1_si(:) = colliders%xb(:,jtarg) * param%DU2M !! The first body of the two-body equivalent position vector the collider system + x1_si(:) = colliders%rb(:,jtarg) * param%DU2M !! The first body of the two-body equivalent position vector the collider system v1_si(:) = colliders%vb(:,jtarg) * param%DU2M / param%TU2S !! The first body of the two-body equivalent velocity vector the collider system - x2_si(:) = colliders%xb(:,jproj) * param%DU2M !! The second body of the two-body equivalent position vector the collider system + x2_si(:) = colliders%rb(:,jproj) * param%DU2M !! The second body of the two-body equivalent position vector the collider system v2_si(:) = colliders%vb(:,jproj) * param%DU2M / param%TU2S !! The second body of the two-body equivalent velocity vector the collider system Mcb_si = system%cb%mass * param%MU2KG !! The central body mass of the system select type(param) @@ -68,7 +68,7 @@ module subroutine fraggle_regime_colliders(self, frag, system, param) ! Find the center of mass of the collisional system frag%mtot = sum(colliders%mass(:)) - frag%xbcom(:) = (colliders%mass(1) * colliders%xb(:,1) + colliders%mass(2) * colliders%xb(:,2)) / frag%mtot + frag%rbcom(:) = (colliders%mass(1) * colliders%rb(:,1) + colliders%mass(2) * colliders%rb(:,2)) / frag%mtot frag%vbcom(:) = (colliders%mass(1) * colliders%vb(:,1) + colliders%mass(2) * colliders%vb(:,2)) / frag%mtot ! Convert quantities back to the system units and save them into the fragment system @@ -82,7 +82,7 @@ module subroutine fraggle_regime_colliders(self, frag, system, param) end subroutine fraggle_regime_colliders - subroutine fraggle_regime_collresolve(Mcb, m1, m2, rad1, rad2, xh1, xh2, vb1, vb2, den1, den2, min_mfrag, & + subroutine fraggle_regime_collresolve(Mcb, m1, m2, rad1, rad2, rh1, rh2, vb1, vb2, den1, den2, min_mfrag, & regime, Mlr, Mslr, Qloss) !! Author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton !! @@ -103,7 +103,7 @@ subroutine fraggle_regime_collresolve(Mcb, m1, m2, rad1, rad2, xh1, xh2, vb1, vb implicit none ! Arguments real(DP), intent(in) :: Mcb, m1, m2, rad1, rad2, den1, den2, min_mfrag - real(DP), dimension(:), intent(in) :: xh1, xh2, vb1, vb2 + real(DP), dimension(:), intent(in) :: rh1, rh2, vb1, vb2 integer(I4B), intent(out) :: regime real(DP), intent(out) :: Mlr, Mslr real(DP), intent(out) :: Qloss !! The residual energy after the collision @@ -130,9 +130,9 @@ subroutine fraggle_regime_collresolve(Mcb, m1, m2, rad1, rad2, xh1, xh2, vb1, vb real(DP) :: U_binding Vimp = norm2(vb2(:) - vb1(:)) - b = calc_b(xh2, vb2, xh1, vb1) + b = calc_b(rh2, vb2, rh1, vb1) l = (rad1 + rad2) * (1 - b) - egy = 0.5_DP * dot_product(vb1, vb1) - GC * Mcb / norm2(xh1) + egy = 0.5_DP * dot_product(vb1, vb1) - GC * Mcb / norm2(rh1) a1 = - GC * Mcb / 2.0_DP / egy Mtot = m1 + m2 mu = (m1 * m2) / Mtot diff --git a/src/fraggle/fraggle_set.f90 b/src/fraggle/fraggle_set.f90 index 6f61b989c..4a70130b6 100644 --- a/src/fraggle/fraggle_set.f90 +++ b/src/fraggle/fraggle_set.f90 @@ -177,7 +177,7 @@ module subroutine fraggle_set_coordinate_system(self, colliders) associate(frag => self, nfrag => self%nbody) delta_v(:) = colliders%vb(:, 2) - colliders%vb(:, 1) v_col_norm = .mag. delta_v(:) - delta_r(:) = colliders%xb(:, 2) - colliders%xb(:, 1) + delta_r(:) = colliders%rb(:, 2) - colliders%rb(:, 1) r_col_norm = .mag. delta_r(:) ! We will initialize fragments on a plane defined by the pre-impact system, with the z-axis aligned with the angular momentum vector @@ -234,9 +234,9 @@ module subroutine fraggle_set_natural_scale_factors(self, colliders) frag%Lscale = frag%mscale * frag%dscale * frag%vscale ! Scale all dimensioned quantities of colliders and fragments - frag%xbcom(:) = frag%xbcom(:) / frag%dscale + frag%rbcom(:) = frag%rbcom(:) / frag%dscale frag%vbcom(:) = frag%vbcom(:) / frag%vscale - colliders%xb(:,:) = colliders%xb(:,:) / frag%dscale + colliders%rb(:,:) = colliders%rb(:,:) / frag%dscale colliders%vb(:,:) = colliders%vb(:,:) / frag%vscale colliders%mass(:) = colliders%mass(:) / frag%mscale colliders%radius(:) = colliders%radius(:) / frag%dscale @@ -276,12 +276,12 @@ module subroutine fraggle_set_original_scale_factors(self, colliders) associate(frag => self) ! Restore scale factors - frag%xbcom(:) = frag%xbcom(:) * frag%dscale + frag%rbcom(:) = frag%rbcom(:) * frag%dscale frag%vbcom(:) = frag%vbcom(:) * frag%vscale colliders%mass = colliders%mass * frag%mscale colliders%radius = colliders%radius * frag%dscale - colliders%xb = colliders%xb * frag%dscale + colliders%rb = colliders%rb * frag%dscale colliders%vb = colliders%vb * frag%vscale colliders%L_spin = colliders%L_spin * frag%Lscale do i = 1, 2 @@ -297,7 +297,7 @@ module subroutine fraggle_set_original_scale_factors(self, colliders) frag%v_coll = frag%v_coll * frag%vscale do i = 1, frag%nbody - frag%xb(:, i) = frag%x_coll(:, i) + frag%xbcom(:) + frag%rb(:, i) = frag%x_coll(:, i) + frag%rbcom(:) frag%vb(:, i) = frag%v_coll(:, i) + frag%vbcom(:) end do diff --git a/src/fraggle/fraggle_setup.f90 b/src/fraggle/fraggle_setup.f90 index 2eff96c29..ab31af995 100644 --- a/src/fraggle/fraggle_setup.f90 +++ b/src/fraggle/fraggle_setup.f90 @@ -19,7 +19,7 @@ module subroutine fraggle_setup_reset_fragments(self) ! Arguments class(fraggle_fragments), intent(inout) :: self - self%xb(:,:) = 0.0_DP + self%rb(:,:) = 0.0_DP self%vb(:,:) = 0.0_DP self%rot(:,:) = 0.0_DP self%x_coll(:,:) = 0.0_DP diff --git a/src/fraggle/fraggle_util.f90 b/src/fraggle/fraggle_util.f90 index 8688ec2d9..038b3c1a5 100644 --- a/src/fraggle/fraggle_util.f90 +++ b/src/fraggle/fraggle_util.f90 @@ -35,9 +35,9 @@ module subroutine fraggle_util_add_fragments_to_system(frag, colliders, system, pl%Gmass(npl_before+1:npl_after) = frag%mass(1:nfrag) * param%GU pl%radius(npl_before+1:npl_after) = frag%radius(1:nfrag) do concurrent (i = 1:nfrag) - pl%xb(:,npl_before+i) = frag%xb(:,i) + pl%rb(:,npl_before+i) = frag%rb(:,i) pl%vb(:,npl_before+i) = frag%vb(:,i) - pl%rh(:,npl_before+i) = frag%xb(:,i) - cb%xb(:) + pl%rh(:,npl_before+i) = frag%rb(:,i) - cb%rb(:) pl%vh(:,npl_before+i) = frag%vb(:,i) - cb%vb(:) end do if (param%lrotation) then @@ -168,26 +168,13 @@ module subroutine fraggle_util_final_fragments(self) end subroutine fraggle_util_final_fragments - module subroutine fraggle_util_final_storage(self) - !! author: David A. Minton - !! - !! Finalizer will deallocate all allocatables - implicit none - ! Arguments - type(fraggle_storage(*)), intent(inout) :: self !! Fraggle encountar storage object - - call util_final_storage(self%swiftest_storage) - - return - end subroutine fraggle_util_final_storage - module subroutine fraggle_util_final_snapshot(self) !! author: David A. Minton !! !! Finalizer will deallocate all allocatables implicit none ! Arguments - type(fraggle_encounter_snapshot), intent(inout) :: self !! Fraggle encountar storage object + type(fraggle_snapshot), intent(inout) :: self !! Fraggle encountar storage object call encounter_util_final_snapshot(self%encounter_snapshot) @@ -270,6 +257,40 @@ module subroutine fraggle_util_get_energy_momentum(self, colliders, system, para end subroutine fraggle_util_get_energy_momentum + module subroutine fraggle_util_get_idvalues_snapshot(self, idvals) + !! author: David A. Minton + !! + !! Returns an array of all id values saved in this snapshot + implicit none + ! Arguments + class(fraggle_snapshot), intent(in) :: self !! Fraggle snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + ! Internals + integer(I4B) :: ncoll, nfrag + + if (allocated(self%colliders)) then + ncoll = self%colliders%pl%nbody + else + ncoll = 0 + end if + + if (allocated(self%fragments)) then + nfrag = self%fragments%pl%nbody + else + nfrag = 0 + end if + + if (ncoll + nfrag == 0) return + allocate(idvals(ncoll+nfrag)) + + if (ncoll > 0) idvals(1:ncoll) = self%colliders%pl%id(:) + if (nfrag > 0) idvals(ncoll+1:ncoll+nfrag) = self%fragments%pl%id(:) + + return + + end subroutine fraggle_util_get_idvalues_snapshot + + module subroutine fraggle_util_restructure(self, colliders, try, f_spin, r_max_start) !! Author: David A. Minton !! diff --git a/src/helio/helio_kick.f90 b/src/helio/helio_kick.f90 index b5161b405..03bc688b5 100644 --- a/src/helio/helio_kick.f90 +++ b/src/helio/helio_kick.f90 @@ -75,7 +75,7 @@ module subroutine helio_kick_getacch_tp(self, system, param, t, lbeg) associate(tp => self, cb => system%cb, pl => system%pl, npl => system%pl%nbody) system%lbeg = lbeg if (system%lbeg) then - call tp%accel_int(param, pl%Gmass(1:npl), pl%xbeg(:,1:npl), npl) + call tp%accel_int(param, pl%Gmass(1:npl), pl%rbeg(:,1:npl), npl) else call tp%accel_int(param, pl%Gmass(1:npl), pl%xend(:,1:npl), npl) end if @@ -112,7 +112,7 @@ module subroutine helio_kick_vb_pl(self, system, param, t, dt, lbeg) pl%ah(:, 1:npl) = 0.0_DP call pl%accel(system, param, t, lbeg) if (lbeg) then - call pl%set_beg_end(xbeg = pl%rh) + call pl%set_beg_end(rbeg = pl%rh) else call pl%set_beg_end(xend = pl%rh) end if diff --git a/src/io/io.f90 b/src/io/io.f90 index d14f0a694..f159e6ac7 100644 --- a/src/io/io.f90 +++ b/src/io/io.f90 @@ -130,10 +130,10 @@ module subroutine io_conservation_report(self, param, lterminal) "; D(Eorbit+Ecollisions)/|E0| = ", ES12.5, & "; DM/M0 = ", ES12.5)' - associate(system => self, pl => self%pl, cb => self%cb, npl => self%pl%nbody, display_unit => param%display_unit) + associate(system => self, pl => self%pl, cb => self%cb, npl => self%pl%nbody, display_unit => param%display_unit, nc => param%system_history%nc) call pl%vb2vh(cb) - call pl%xh2xb(cb) + call pl%rh2rb(cb) call system%get_energy_and_momentum(param) ke_orbit_now = system%ke_orbit @@ -177,8 +177,8 @@ module subroutine io_conservation_report(self, param, lterminal) write(*,*) "Severe error! Mass not conserved! Halting!" ! Save the frame of data to the bin file in the slot just after the present one for diagnostics param%ioutput = param%ioutput + 1 - call self%write_frame(param%nc, param) - call param%nc%close() + call self%write_frame(nc, param) + call nc%close() call util_exit(FAILURE) end if end if @@ -246,24 +246,34 @@ module subroutine io_dump_system(self, param) dump_param%out_stat = 'APPEND' dump_param%in_type = "NETCDF_DOUBLE" dump_param%in_netcdf = trim(adjustl(DUMP_NC_FILE(idx))) - dump_param%nc%id_chunk = self%pl%nbody + self%tp%nbody - dump_param%nc%time_chunk = 1 - dump_param%tstart = self%t - - call dump_param%dump(param_file_name) - - dump_param%out_form = "XV" - dump_param%outfile = trim(adjustl(DUMP_NC_FILE(idx))) - dump_param%ioutput = 1 - call dump_param%nc%initialize(dump_param) - call self%write_frame(dump_param%nc, dump_param) - call dump_param%nc%close() - ! Syncrhonize the disk and memory buffer of the NetCDF file (e.g. commit the frame files stored in memory to disk) - call param%nc%flush(param) + associate(nc => dump_param%system_history%nc) + nc%id_chunk = self%pl%nbody + self%tp%nbody + nc%time_chunk = 1 + dump_param%tstart = self%t + + call dump_param%dump(param_file_name) + + dump_param%out_form = "XV" + nc%file_name = trim(adjustl(DUMP_NC_FILE(idx))) + dump_param%ioutput = 1 + call nc%initialize(dump_param) + call self%write_frame(nc, dump_param) + call nc%close() + end associate idx = idx + 1 if (idx > NDUMPFILES) idx = 1 + ! Dump the encounter history if necessary + select type(param) + class is (symba_parameters) + call param%encounter_history%dump(param) + call param%collision_history%dump(param) + end select + + ! Dump the system history to file + call param%system_history%dump(param) + return end subroutine io_dump_system @@ -283,9 +293,11 @@ module subroutine io_dump_storage(self, param) integer(I4B) :: i integer(I8B) :: iloop_start - iloop_start = max(param%iloop - int(param%istep_out * param%dump_cadence, kind=I8B),1) + if (self%iframe == 0) return + iloop_start = param%iloop - int(param%istep_out * param%dump_cadence, kind=I8B) + 1 + call self%make_index_map() do i = 1, param%dump_cadence - param%ioutput = max(int(iloop_start / param%istep_out, kind=I4B),1) + i + param%ioutput = iloop_start + self%tmap(i) if (allocated(self%frame(i)%item)) then select type(system => self%frame(i)%item) class is (swiftest_nbody_system) @@ -294,7 +306,7 @@ module subroutine io_dump_storage(self, param) deallocate(self%frame(i)%item) end if end do - + call self%reset() return end subroutine io_dump_storage @@ -670,7 +682,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%lrestart = .true. end if ! Ignore SyMBA-specific, not-yet-implemented, or obsolete input parameters - case ("NPLMAX", "NTPMAX", "GMTINY", "MIN_GMFRAG", "FRAGMENTATION", "SEED", "YARKOVSKY", "YORP", "ENCOUNTER_SAVE", "FRAGMENTATION_SAVE") + case ("NPLMAX", "NTPMAX", "GMTINY", "MIN_GMFRAG", "FRAGMENTATION", "SEED", "YARKOVSKY", "YORP", "ENCOUNTER_SAVE") case default write(*,*) "Ignoring unknown parameter -> ",param_name end select @@ -1301,13 +1313,13 @@ module subroutine io_read_in_system(self, param) self%Euntracked = param%Euntracked else allocate(tmp_param, source=param) - tmp_param%outfile = param%in_netcdf + tmp_param%system_history%nc%file_name = param%in_netcdf tmp_param%out_form = param%in_form if (.not. param%lrestart) then ! Turn off energy computation so we don't have to feed it into the initial conditions tmp_param%lenergy = .false. end if - ierr = self%read_frame(tmp_param%nc, tmp_param) + ierr = self%read_frame(tmp_param%system_history%nc, tmp_param) deallocate(tmp_param) if (ierr /=0) call util_exit(FAILURE) end if @@ -1536,31 +1548,34 @@ module subroutine io_write_frame_system(self, param) character(len=STRMAX) :: errmsg logical :: fileExists - param%nc%id_chunk = self%pl%nbody + self%tp%nbody - param%nc%time_chunk = max(param%dump_cadence / param%istep_out, 1) - if (lfirst) then - inquire(file=param%outfile, exist=fileExists) - - select case(param%out_stat) - case('APPEND') - if (.not.fileExists) then - errmsg = param%outfile // " not found! You must specify OUT_STAT = NEW, REPLACE, or UNKNOWN" - goto 667 - end if - case('NEW') - if (fileExists) then - errmsg = param%outfile // " Alread Exists! You must specify OUT_STAT = APPEND, REPLACE, or UNKNOWN" - goto 667 - end if - call param%nc%initialize(param) - case('REPLACE', 'UNKNOWN') - call param%nc%initialize(param) - end select + associate (nc => param%system_history%nc, pl => self%pl, tp => self%tp, npl => self%pl%nbody, ntp => self%tp%nbody) + nc%id_chunk = npl + ntp + nc%time_chunk = max(param%dump_cadence / param%istep_out, 1) + nc%file_name = param%outfile + if (lfirst) then + inquire(file=param%outfile, exist=fileExists) + + select case(param%out_stat) + case('APPEND') + if (.not.fileExists) then + errmsg = param%outfile // " not found! You must specify OUT_STAT = NEW, REPLACE, or UNKNOWN" + goto 667 + end if + case('NEW') + if (fileExists) then + errmsg = param%outfile // " Alread Exists! You must specify OUT_STAT = APPEND, REPLACE, or UNKNOWN" + goto 667 + end if + call nc%initialize(param) + case('REPLACE', 'UNKNOWN') + call nc%initialize(param) + end select - lfirst = .false. - end if + lfirst = .false. + end if - call self%write_frame(param%nc, param) + call self%write_frame(nc, param) + end associate return diff --git a/src/kick/kick.f90 b/src/kick/kick.f90 index 40b238fec..8f1ae7e08 100644 --- a/src/kick/kick.f90 +++ b/src/kick/kick.f90 @@ -63,7 +63,7 @@ module subroutine kick_getacch_int_pl(self, param) end subroutine kick_getacch_int_pl - module subroutine kick_getacch_int_tp(self, param, GMpl, xhp, npl) + module subroutine kick_getacch_int_tp(self, param, GMpl, rhp, npl) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations of test particles by massive bodies @@ -75,12 +75,12 @@ module subroutine kick_getacch_int_tp(self, param, GMpl, xhp, npl) class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters real(DP), dimension(:), intent(in) :: GMpl !! Massive body masses - real(DP), dimension(:,:), intent(in) :: xhp !! Massive body position vectors + real(DP), dimension(:,:), intent(in) :: rhp !! Massive body position vectors integer(I4B), intent(in) :: npl !! Number of active massive bodies if ((self%nbody == 0) .or. (npl == 0)) return - call kick_getacch_int_all_tp(self%nbody, npl, self%rh, xhp, GMpl, self%lmask, self%ah) + call kick_getacch_int_all_tp(self%nbody, npl, self%rh, rhp, GMpl, self%lmask, self%ah) return end subroutine kick_getacch_int_tp diff --git a/src/main/swiftest_driver.f90 b/src/main/swiftest_driver.f90 index 6d5abce79..ebd207e54 100644 --- a/src/main/swiftest_driver.f90 +++ b/src/main/swiftest_driver.f90 @@ -18,10 +18,10 @@ program swiftest_driver use swiftest implicit none - class(swiftest_nbody_system), allocatable :: nbody_system !! Polymorphic object containing the nbody system to be integrated + class(swiftest_nbody_system), allocatable :: system !! Polymorphic object containing the nbody system to be integrated class(swiftest_parameters), allocatable :: param !! Run configuration parameters character(len=:), allocatable :: integrator !! Integrator type code (see swiftest_globals for symbolic names) - character(len=:),allocatable :: param_file_name !! Name of the file containing user-defined parameters + character(len=:), allocatable :: param_file_name !! Name of the file containing user-defined parameters character(len=:), allocatable :: display_style !! Style of the output display {"STANDARD", "COMPACT", "PROGRESS"}). Default is "STANDARD" integer(I8B) :: istart !! Starting index for loop counter integer(I8B) :: nloops !! Number of steps to take in the simulation @@ -38,7 +38,7 @@ program swiftest_driver character(len=64) :: pbarmessage character(*), parameter :: symbacompactfmt = '(";NPLM",ES22.15,$)' - type(swiftest_storage(nframes=:)), allocatable :: system_history + !type(swiftest_storage(nframes=:)), allocatable :: system_history call io_get_args(integrator, param_file_name, display_style) @@ -51,117 +51,123 @@ program swiftest_driver end select param%integrator = trim(adjustl(integrator)) call param%set_display(display_style) - - !> Define the maximum number of threads - nthreads = 1 ! In the *serial* case - !$ nthreads = omp_get_max_threads() ! In the *parallel* case - !$ write(param%display_unit,'(a)') ' OpenMP parameters:' - !$ write(param%display_unit,'(a)') ' ------------------' - !$ write(param%display_unit,'(a,i3,/)') ' Number of threads = ', nthreads - !$ if (param%log_output) write(*,'(a,i3)') ' OpenMP: Number of threads = ',nthreads - - call setup_construct_system(nbody_system, param) call param%read_in(param_file_name) - associate(t => nbody_system%t, & - t0 => param%t0, & - tstart => param%tstart, & - dt => param%dt, & - tstop => param%tstop, & - iloop => param%iloop, & - istep_out => param%istep_out, & - dump_cadence => param%dump_cadence, & - ioutput => param%ioutput, & - display_style => param%display_style, & - display_unit => param%display_unit) - call nbody_system%initialize(param) + associate(t0 => param%t0, & + tstart => param%tstart, & + dt => param%dt, & + tstop => param%tstop, & + iloop => param%iloop, & + istep_out => param%istep_out, & + dump_cadence => param%dump_cadence, & + ioutput => param%ioutput, & + display_style => param%display_style, & + display_unit => param%display_unit) + ! Set up loop and output cadence variables - t = tstart nloops = ceiling((tstop - t0) / dt, kind=I8B) istart = ceiling((tstart - t0) / dt + 1.0_DP, kind=I8B) ioutput = max(int(istart / istep_out, kind=I4B),1) ! Set up system storage for intermittent file dumps if (dump_cadence == 0) dump_cadence = ceiling(nloops / (1.0_DP * istep_out), kind=I8B) - allocate(swiftest_storage(dump_cadence) :: system_history) - - ! If this is a new run, compute energy initial conditions (if energy tracking is turned on) and write the initial conditions to file. - if (param%lrestart) then - if (param%lenergy) call nbody_system%conservation_report(param, lterminal=.true.) - else - if (param%lenergy) call nbody_system%conservation_report(param, lterminal=.false.) ! This will save the initial values of energy and momentum - call nbody_system%write_frame(param) - call nbody_system%dump(param) - end if - - write(display_unit, *) " *************** Main Loop *************** " - - if (display_style == "PROGRESS") then - call pbar%reset(nloops) - write(pbarmessage,fmt=pbarfmt) t0, tstop - call pbar%update(1,message=pbarmessage) - else if (display_style == "COMPACT") then - write(*,*) "SWIFTEST START " // param%integrator - call nbody_system%compact_output(param,integration_timer) - end if - - iout = 0 - idump = 0 - do iloop = istart, nloops - !> Step the system forward in time - call integration_timer%start() - call nbody_system%step(param, t, dt) - call integration_timer%stop() - - t = t0 + iloop * dt - - !> Evaluate any discards or collisional outcomes - call nbody_system%discard(param) - if (display_style == "PROGRESS") call pbar%update(iloop) - - !> If the loop counter is at the output cadence value, append the data file with a single frame - if (istep_out > 0) then - iout = iout + 1 - if (iout == istep_out) then - iout = 0 - idump = idump + 1 - system_history%frame(idump) = nbody_system ! Store a snapshot of the system for posterity - - if (idump == dump_cadence) then - idump = 0 - call nbody_system%dump(param) - call system_history%dump(param) - end if - tfrac = (t - t0) / (tstop - t0) - - select type(pl => nbody_system%pl) - class is (symba_pl) - write(display_unit, symbastatfmt) t, tfrac, pl%nplm, pl%nbody, nbody_system%tp%nbody - class default - write(display_unit, statusfmt) t, tfrac, pl%nbody, nbody_system%tp%nbody - end select - if (param%lenergy) call nbody_system%conservation_report(param, lterminal=.true.) - call integration_timer%report(message="Integration steps:", unit=display_unit, nsubsteps=istep_out) - - if (display_style == "PROGRESS") then - write(pbarmessage,fmt=pbarfmt) t, tstop - call pbar%update(1,message=pbarmessage) - else if (display_style == "COMPACT") then - call nbody_system%compact_output(param,integration_timer) - end if + ! Construct the main n-body system using the user-input integrator to choose the type of system + call setup_construct_system(system, param) + + !> Define the maximum number of threads + nthreads = 1 ! In the *serial* case + !$ nthreads = omp_get_max_threads() ! In the *parallel* case + !$ write(param%display_unit,'(a)') ' OpenMP parameters:' + !$ write(param%display_unit,'(a)') ' ------------------' + !$ write(param%display_unit,'(a,i3,/)') ' Number of threads = ', nthreads + !$ if (param%log_output) write(*,'(a,i3)') ' OpenMP: Number of threads = ',nthreads + + call system%initialize(param) + + associate (system_history => param%system_history) + ! If this is a new run, compute energy initial conditions (if energy tracking is turned on) and write the initial conditions to file. + if (param%lenergy) then + if (param%lrestart) then + call system%conservation_report(param, lterminal=.true.) + else + call system%conservation_report(param, lterminal=.false.) ! This will save the initial values of energy and momentum + end if + end if + call system_history%take_snapshot(param,system) + call system%dump(param) + + write(display_unit, *) " *************** Main Loop *************** " + + if (display_style == "PROGRESS") then + call pbar%reset(nloops) + write(pbarmessage,fmt=pbarfmt) t0, tstop + call pbar%update(1,message=pbarmessage) + else if (display_style == "COMPACT") then + write(*,*) "SWIFTEST START " // param%integrator + call system%compact_output(param,integration_timer) + end if - call integration_timer%reset() + iout = 0 + idump = 0 + system%t = tstart + do iloop = istart, nloops + !> Step the system forward in time + call integration_timer%start() + call system%step(param, system%t, dt) + call integration_timer%stop() + + system%t = t0 + iloop * dt + + !> Evaluate any discards or collisional outcomes + call system%discard(param) + if (display_style == "PROGRESS") call pbar%update(iloop) + + !> If the loop counter is at the output cadence value, append the data file with a single frame + if (istep_out > 0) then + iout = iout + 1 + if (iout == istep_out) then + iout = 0 + idump = idump + 1 + call system_history%take_snapshot(param,system) + + if (idump == dump_cadence) then + idump = 0 + call system%dump(param) + + end if + + tfrac = (system%t - t0) / (tstop - t0) + + select type(pl => system%pl) + class is (symba_pl) + write(display_unit, symbastatfmt) system%t, tfrac, pl%nplm, pl%nbody, system%tp%nbody + class default + write(display_unit, statusfmt) system%t, tfrac, pl%nbody, system%tp%nbody + end select + if (param%lenergy) call system%conservation_report(param, lterminal=.true.) + call integration_timer%report(message="Integration steps:", unit=display_unit, nsubsteps=istep_out) + + if (display_style == "PROGRESS") then + write(pbarmessage,fmt=pbarfmt) system%t, tstop + call pbar%update(1,message=pbarmessage) + else if (display_style == "COMPACT") then + call system%compact_output(param,integration_timer) + end if + + call integration_timer%reset() + end if end if - end if - end do - ! Dump any remaining history if it exists - call system_history%dump(param) - if (display_style == "COMPACT") write(*,*) "SWIFTEST STOP" // param%integrator + end do + ! Dump any remaining history if it exists + call system%dump(param) + call system_history%dump(param) + if (display_style == "COMPACT") write(*,*) "SWIFTEST STOP" // param%integrator + end associate end associate call util_exit(SUCCESS) diff --git a/src/modules/encounter_classes.f90 b/src/modules/encounter_classes.f90 index c7edc5e8a..2b313eeb5 100644 --- a/src/modules/encounter_classes.f90 +++ b/src/modules/encounter_classes.f90 @@ -19,18 +19,20 @@ module encounter_classes integer(I4B), parameter :: SWEEPDIM = 3 type :: encounter_list - integer(I8B) :: nenc = 0 !! Total number of encounters - real(DP) :: t !! Time of encounter - logical, dimension(:), allocatable :: lvdotr !! relative vdotr flag - integer(I4B), dimension(:), allocatable :: status !! status of the interaction - integer(I4B), dimension(:), allocatable :: index1 !! position of the first body in the encounter - integer(I4B), dimension(:), allocatable :: index2 !! position of the second body in the encounter - integer(I4B), dimension(:), allocatable :: id1 !! id of the first body in the encounter - integer(I4B), dimension(:), allocatable :: id2 !! id of the second body in the encounter - real(DP), dimension(:,:), allocatable :: x1 !! the position of body 1 in the encounter - real(DP), dimension(:,:), allocatable :: x2 !! the position of body 2 in the encounter - real(DP), dimension(:,:), allocatable :: v1 !! the velocity of body 1 in the encounter - real(DP), dimension(:,:), allocatable :: v2 !! the velocity of body 2 in the encounter + integer(I8B) :: nenc = 0 !! Total number of encounters + logical :: lcollision !! Indicates if the encounter resulted in at least one collision + real(DP) :: t !! Time of encounter + logical, dimension(:), allocatable :: lclosest !! indicates that thie pair of bodies is in currently at its closest approach point + logical, dimension(:), allocatable :: lvdotr !! relative vdotr flag + integer(I4B), dimension(:), allocatable :: status !! status of the interaction + integer(I4B), dimension(:), allocatable :: index1 !! position of the first body in the encounter + integer(I4B), dimension(:), allocatable :: index2 !! position of the second body in the encounter + integer(I4B), dimension(:), allocatable :: id1 !! id of the first body in the encounter + integer(I4B), dimension(:), allocatable :: id2 !! id of the second body in the encounter + real(DP), dimension(:,:), allocatable :: r1 !! the position of body 1 in the encounter + real(DP), dimension(:,:), allocatable :: r2 !! the position of body 2 in the encounter + real(DP), dimension(:,:), allocatable :: v1 !! the velocity of body 1 in the encounter + real(DP), dimension(:,:), allocatable :: v2 !! the velocity of body 2 in the encounter contains procedure :: setup => encounter_setup_list !! A constructor that sets the number of encounters and allocates and initializes all arrays procedure :: append => encounter_util_append_list !! Appends elements from one structure to another @@ -43,32 +45,43 @@ module encounter_classes type :: encounter_snapshot !! A simplified version of a SyMBA nbody system object for storing minimal snapshots of the system state during encounters - class(swiftest_pl), allocatable :: pl !! Massive body data structure - class(swiftest_tp), allocatable :: tp !! Test particle data structure - real(DP) :: t !! Simulation time when snapshot was taken + class(swiftest_pl), allocatable :: pl !! Massive body data structure + class(swiftest_tp), allocatable :: tp !! Test particle data structure + real(DP) :: t !! Simulation time when snapshot was taken + integer(I8B) :: iloop !! Loop number at time of snapshot contains - procedure :: write_frame => encounter_io_write_frame !! Writes a frame of encounter data to file + procedure :: write_frame => encounter_io_write_frame !! Writes a frame of encounter data to file + procedure :: get_idvals => encounter_util_get_idvalues_snapshot !! Gets an array of all id values saved in this snapshot final :: encounter_util_final_snapshot end type encounter_snapshot !> NetCDF dimension and variable names for the enounter save object type, extends(netcdf_parameters) :: encounter_io_parameters - integer(I4B) :: ienc_frame = 1 !! Current frame number for the encounter history - character(STRMAX) :: enc_file !! Encounter output file name - character(NAMELEN) :: level_varname = "level" !! Recursion depth - integer(I4B) :: level_varid !! ID for the recursion level variable - integer(I4B) :: time_dimsize = 0 !! Number of time values in snapshot - integer(I4B) :: id_dimsize = 0 !! Number of potential id values in snapshot + character(NAMELEN) :: loop_varname = "loopnum" !! Loop number for encounter + integer(I4B) :: loop_varid !! ID for the recursion level variable + integer(I4B) :: time_dimsize = 0 !! Number of time values in snapshot + integer(I4B) :: name_dimsize = 0 !! Number of potential id values in snapshot + integer(I4B) :: file_number = 1 !! The number to append on the output file contains procedure :: initialize => encounter_io_initialize !! Initialize a set of parameters used to identify a NetCDF output object end type encounter_io_parameters + !> A class that that is used to store simulation history data between file output + type, extends(swiftest_storage) :: collision_storage + contains + procedure :: dump => encounter_io_dump_collision !! Dumps contents of encounter history to file + procedure :: take_snapshot => encounter_util_snapshot_collision !! Take a minimal snapshot of the system through an encounter + procedure :: make_index_map => encounter_util_index_map_collision !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + final :: encounter_util_final_collision_storage + end type collision_storage + !> A class that that is used to store simulation history data between file output type, extends(swiftest_storage) :: encounter_storage - type(encounter_io_parameters) :: nc !! NetCDF parameter object containing the details about the file attached to this storage object contains - procedure :: dump => encounter_io_dump !! Dumps contents of encounter history to file - final :: encounter_util_final_storage + procedure :: dump => encounter_io_dump_encounter !! Dumps contents of encounter history to file + procedure :: make_index_map => encounter_util_index_map_encounter !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + procedure :: take_snapshot => encounter_util_snapshot_encounter !! Take a minimal snapshot of the system through an encounter + final :: encounter_util_final_storage end type encounter_storage type encounter_bounding_box_1D @@ -173,14 +186,14 @@ pure module subroutine encounter_check_sort_aabb_1D(self, n, extent_arr) real(DP), dimension(:), intent(in) :: extent_arr !! Array of extents of size 2*n end subroutine encounter_check_sort_aabb_1D - module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, x1, v1, x2, v2, renc1, renc2, dt, & + module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, r1, v1, r2, v2, renc1, renc2, dt, & nenc, index1, index2, lvdotr) implicit none class(encounter_bounding_box), intent(inout) :: self !! Multi-dimensional bounding box structure integer(I4B), intent(in) :: n1 !! Number of bodies 1 integer(I4B), intent(in) :: n2 !! Number of bodies 2 - real(DP), dimension(:,:), intent(in) :: x1, v1 !! Array of indices of bodies 1 - real(DP), dimension(:,:), intent(in) :: x2, v2 !! Array of indices of bodies 2 + real(DP), dimension(:,:), intent(in) :: r1, v1 !! Array of indices of bodies 1 + real(DP), dimension(:,:), intent(in) :: r2, v2 !! Array of indices of bodies 2 real(DP), dimension(:), intent(in) :: renc1 !! Radius of encounter regions of bodies 1 real(DP), dimension(:), intent(in) :: renc2 !! Radius of encounter regions of bodies 2 real(DP), intent(in) :: dt !! Step size @@ -203,11 +216,17 @@ module subroutine encounter_check_sweep_aabb_single_list(self, n, x, v, renc, dt logical, dimension(:), allocatable, intent(out) :: lvdotr !! Logical array indicating which pairs are approaching end subroutine encounter_check_sweep_aabb_single_list - module subroutine encounter_io_dump(self, param) + module subroutine encounter_io_dump_collision(self, param) + implicit none + class(collision_storage(*)), intent(inout) :: self !! Collision storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine encounter_io_dump_collision + + module subroutine encounter_io_dump_encounter(self, param) implicit none class(encounter_storage(*)), intent(inout) :: self !! Encounter storage object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine encounter_io_dump + end subroutine encounter_io_dump_encounter module subroutine encounter_io_initialize(self, param) implicit none @@ -217,9 +236,9 @@ end subroutine encounter_io_initialize module subroutine encounter_io_write_frame(self, nc, param) implicit none - class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure - class(encounter_io_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure + class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine encounter_io_write_frame module subroutine encounter_setup_aabb(self, n, n_last) @@ -263,6 +282,11 @@ module subroutine encounter_util_final_aabb(self) type(encounter_bounding_box_1D), intent(inout) :: self !!Bounding box structure along a single dimension end subroutine encounter_util_final_aabb + module subroutine encounter_util_final_collision_storage(self) + implicit none + type(collision_storage(*)), intent(inout) :: self !! SyMBA nbody system object + end subroutine encounter_util_final_collision_storage + module subroutine encounter_util_final_list(self) implicit none type(encounter_list), intent(inout) :: self !! Swiftest encounter list object @@ -278,12 +302,47 @@ module subroutine encounter_util_final_storage(self) type(encounter_storage(*)), intent(inout) :: self !! SyMBA nbody system object end subroutine encounter_util_final_storage + module subroutine encounter_util_get_idvalues_snapshot(self, idvals) + implicit none + class(encounter_snapshot), intent(in) :: self !! Encounter snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + end subroutine encounter_util_get_idvalues_snapshot + + module subroutine encounter_util_index_map_collision(self) + implicit none + class(collision_storage(*)), intent(inout) :: self !! Collision storage object + end subroutine encounter_util_index_map_collision + + module subroutine encounter_util_index_map_encounter(self) + implicit none + class(encounter_storage(*)), intent(inout) :: self !! Encounter storage object + end subroutine encounter_util_index_map_encounter + module subroutine encounter_util_resize_list(self, nnew) implicit none class(encounter_list), intent(inout) :: self !! Swiftest encounter list integer(I8B), intent(in) :: nnew !! New size of list needed end subroutine encounter_util_resize_list + module subroutine encounter_util_snapshot_collision(self, param, system, t, arg) + implicit none + class(collision_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! "before": takes a snapshot just before the collision. "after" takes the snapshot just after the collision. + end subroutine encounter_util_snapshot_collision + + module subroutine encounter_util_snapshot_encounter(self, param, system, t, arg) + implicit none + class(encounter_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) + end subroutine encounter_util_snapshot_encounter + + module subroutine encounter_util_spill_list(self, discards, lspill_list, ldestructive) implicit none class(encounter_list), intent(inout) :: self !! Swiftest encounter list diff --git a/src/modules/fraggle_classes.f90 b/src/modules/fraggle_classes.f90 index e4a458a3b..8c75a3fc6 100644 --- a/src/modules/fraggle_classes.f90 +++ b/src/modules/fraggle_classes.f90 @@ -10,10 +10,10 @@ module fraggle_classes !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! - !! Definition of classes and methods specific to Fraggel: The Fragment Generation Model + !! Definition of classes and methods specific to Fraggle: *Frag*ment *g*eneration that conserves angular momentum (*L*) and energy (*E*) use swiftest_globals use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system, swiftest_cb, swiftest_pl, swiftest_storage, netcdf_parameters - use encounter_classes, only : encounter_snapshot, encounter_io_parameters + use encounter_classes, only : encounter_snapshot, encounter_io_parameters, encounter_storage implicit none public @@ -27,7 +27,7 @@ module fraggle_classes type :: fraggle_colliders integer(I4B) :: ncoll !! Number of bodies involved in the collision integer(I4B), dimension(:), allocatable :: idx !! Index of bodies involved in the collision - real(DP), dimension(NDIM,2) :: xb !! Two-body equivalent position vectors of the collider bodies prior to collision + real(DP), dimension(NDIM,2) :: rb !! Two-body equivalent position vectors of the collider bodies prior to collision real(DP), dimension(NDIM,2) :: vb !! Two-body equivalent velocity vectors of the collider bodies prior to collision real(DP), dimension(NDIM,2) :: rot !! Two-body equivalent principal axes moments of inertia the collider bodies prior to collision real(DP), dimension(NDIM,2) :: L_spin !! Two-body equivalent spin angular momentum vectors of the collider bodies prior to collision @@ -35,6 +35,7 @@ module fraggle_classes real(DP), dimension(NDIM,2) :: Ip !! Two-body equivalent principal axes moments of inertia the collider bodies prior to collision real(DP), dimension(2) :: mass !! Two-body equivalent mass of the collider bodies prior to the collision real(DP), dimension(2) :: radius !! Two-body equivalent radii of the collider bodies prior to the collision + class(swiftest_pl), allocatable :: pl !! A snapshot of the planets involved in the collision contains procedure :: regime => fraggle_regime_colliders !! Determine which fragmentation regime the set of colliders will be final :: fraggle_util_final_colliders !! Finalizer will deallocate all allocatables @@ -51,7 +52,7 @@ module fraggle_classes integer(I4B) :: regime !! Collresolve regime code for this collision ! Values in a coordinate frame centered on the collider barycenter and collisional system unit vectors (these are used internally by the fragment generation subroutine) - real(DP), dimension(NDIM) :: xbcom !! Center of mass position vector of the collider system in system barycentric coordinates + real(DP), dimension(NDIM) :: rbcom !! Center of mass position vector of the collider system in system barycentric coordinates real(DP), dimension(NDIM) :: vbcom !! Velocity vector of the center of mass of the collider system in system barycentric coordinates real(DP), dimension(NDIM) :: x_coll_unit !! x-direction unit vector of collisional system real(DP), dimension(NDIM) :: y_coll_unit !! y-direction unit vector of collisional system @@ -65,6 +66,7 @@ module fraggle_classes real(DP), dimension(:), allocatable :: rotmag !! Array of rotation magnitudes of individual fragments real(DP), dimension(:), allocatable :: v_r_mag !! Array of radial direction velocity magnitudes of individual fragments real(DP), dimension(:), allocatable :: v_t_mag !! Array of tangential direction velocity magnitudes of individual fragments + class(swiftest_pl), allocatable :: pl !! A snapshot of the fragments created in the collision ! Energy and momentum book-keeping variables that characterize the whole system of fragments real(DP) :: ke_orbit !! Current orbital kinetic energy of the system of fragments in the collisional frame @@ -110,23 +112,35 @@ module fraggle_classes end type fraggle_fragments !! NetCDF dimension and variable names for the enounter save object - type, extends(encounter_io_parameters) :: fraggle_io_encounter_parameters - contains - procedure :: initialize => fraggle_io_encounter_initialize_output !! Initialize a set of parameters used to identify a NetCDF output object - end type fraggle_io_encounter_parameters + type, extends(encounter_io_parameters) :: fraggle_io_parameters + integer(I4B) :: stage_dimid !! ID for the stage dimension + integer(I4B) :: stage_varid !! ID for the stage variable + character(NAMELEN) :: stage_dimname = "stage" !! name of the stage dimension (before/after) + character(len=6), dimension(2) :: stage_coords = ["before", "after"] !! The stage coordinate labels + + character(NAMELEN) :: event_dimname = "collision" !! Name of collision event dimension + integer(I4B) :: event_dimid !! ID for the collision event dimension + integer(I4B) :: event_varid !! ID for the collision event variable + integer(I4B) :: event_dimsize = 0 !! Number of events + + character(NAMELEN) :: Qloss_varname = "Qloss" !! name of the energy loss variable + integer(I4B) :: Qloss_varid !! ID for the energy loss variable + character(NAMELEN) :: regime_varname = "regime" !! name of the collision regime variable + integer(I4B) :: regime_varid !! ID for the collision regime variable - !> A class that that is used to store fragmentation data between file output - type, extends(swiftest_storage) :: fraggle_storage contains - procedure :: dump => fraggle_io_encounter_dump !! Dumps contents of encounter history to file - final :: fraggle_util_final_storage - end type fraggle_storage + procedure :: initialize => fraggle_io_initialize_output !! Initialize a set of parameters used to identify a NetCDF output object + end type fraggle_io_parameters - type, extends(encounter_snapshot) :: fraggle_encounter_snapshot + type, extends(encounter_snapshot) :: fraggle_snapshot + logical :: lcollision !! Indicates that this snapshot contains at least one collision + class(fraggle_colliders), allocatable :: colliders !! Colliders object at this snapshot + class(fraggle_fragments), allocatable :: fragments !! Fragments object at this snapshot contains - procedure :: write_frame => fraggle_io_encounter_write_frame !! Writes a frame of encounter data to file + procedure :: write_frame => fraggle_io_write_frame !! Writes a frame of encounter data to file + procedure :: get_idvals => fraggle_util_get_idvalues_snapshot !! Gets an array of all id values saved in this snapshot final :: fraggle_util_final_snapshot - end type fraggle_encounter_snapshot + end type fraggle_snapshot interface module subroutine fraggle_generate_fragments(self, colliders, system, param, lfailure) @@ -139,29 +153,18 @@ module subroutine fraggle_generate_fragments(self, colliders, system, param, lfa logical, intent(out) :: lfailure !! Answers the question: Should this have been a merger instead? end subroutine fraggle_generate_fragments - module subroutine fraggle_io_encounter_dump(self, param) - implicit none - class(fraggle_storage(*)), intent(inout) :: self !! Encounter storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine fraggle_io_encounter_dump - - module subroutine fraggle_io_encounter_initialize_output(self, param) + module subroutine fraggle_io_initialize_output(self, param) implicit none - class(fraggle_io_encounter_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(fraggle_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset class(swiftest_parameters), intent(in) :: param - end subroutine fraggle_io_encounter_initialize_output + end subroutine fraggle_io_initialize_output - module subroutine fraggle_io_encounter_write_frame(self, nc, param) - implicit none - class(fraggle_encounter_snapshot), intent(in) :: self !! Swiftest encounter structure - class(encounter_io_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine fraggle_io_encounter_write_frame - - module subroutine fraggle_io_log_generate(frag) + module subroutine fraggle_io_write_frame(self, nc, param) implicit none - class(fraggle_fragments), intent(in) :: frag - end subroutine fraggle_io_log_generate + class(fraggle_snapshot), intent(in) :: self !! Swiftest encounter structure + class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine fraggle_io_write_frame module subroutine fraggle_io_log_pl(pl, param) implicit none @@ -283,22 +286,17 @@ end subroutine fraggle_util_construct_temporary_system module subroutine fraggle_util_final_colliders(self) implicit none - type(fraggle_colliders), intent(inout) :: self !! Fraggle encountar storage object + type(fraggle_colliders), intent(inout) :: self !! Fraggle colliders object end subroutine fraggle_util_final_colliders module subroutine fraggle_util_final_fragments(self) implicit none - type(fraggle_fragments), intent(inout) :: self !! Fraggle encountar storage object + type(fraggle_fragments), intent(inout) :: self !! Fraggle frgments object end subroutine fraggle_util_final_fragments - module subroutine fraggle_util_final_storage(self) - implicit none - type(fraggle_storage(*)), intent(inout) :: self !! Fraggle encountar storage object - end subroutine fraggle_util_final_storage - module subroutine fraggle_util_final_snapshot(self) implicit none - type(fraggle_encounter_snapshot), intent(inout) :: self !! Fraggle encountar storage object + type(fraggle_snapshot), intent(inout) :: self !! Fraggle storage snapshot object end subroutine fraggle_util_final_snapshot module subroutine fraggle_util_get_energy_momentum(self, colliders, system, param, lbefore) @@ -311,6 +309,12 @@ module subroutine fraggle_util_get_energy_momentum(self, colliders, system, para logical, intent(in) :: lbefore !! Flag indicating that this the "before" state of the system, with colliders included and fragments excluded or vice versa end subroutine fraggle_util_get_energy_momentum + module subroutine fraggle_util_get_idvalues_snapshot(self, idvals) + implicit none + class(fraggle_snapshot), intent(in) :: self !! Fraggle snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + end subroutine fraggle_util_get_idvalues_snapshot + module subroutine fraggle_util_restructure(self, colliders, try, f_spin, r_max_start) implicit none class(fraggle_fragments), intent(inout) :: self !! Fraggle fragment system object diff --git a/src/modules/rmvs_classes.f90 b/src/modules/rmvs_classes.f90 index ec7dfcf16..f8add18eb 100644 --- a/src/modules/rmvs_classes.f90 +++ b/src/modules/rmvs_classes.f90 @@ -77,7 +77,7 @@ module rmvs_classes ! The following are used to correctly set the oblateness values of the acceleration during an inner encounter with a planet type(rmvs_cb) :: cb_heliocentric !! Copy of original central body object passed to close encounter (used for oblateness acceleration during planetocentric encoountters) - real(DP), dimension(:,:), allocatable :: xheliocentric !! original heliocentric position (used for oblateness calculation during close encounters) + real(DP), dimension(:,:), allocatable :: rheliocentric !! original heliocentric position (used for oblateness calculation during close encounters) integer(I4B) :: index !! inner substep number within current set integer(I4B) :: ipleP !! index value of encountering planet logical :: lplanetocentric = .false. !! Flag that indicates that the object is a planetocentric set of masive bodies used for close encounter calculations diff --git a/src/modules/swiftest_classes.f90 b/src/modules/swiftest_classes.f90 index abda5adc2..2e32f8c1d 100644 --- a/src/modules/swiftest_classes.f90 +++ b/src/modules/swiftest_classes.f90 @@ -20,6 +20,7 @@ module swiftest_classes !! This derived datatype stores the NetCDF ID values for each of the variables included in the NetCDF data file. This is used as the base class defined in swiftest_classes type :: netcdf_variables + character(STRMAX) :: file_name !! Name of the output file integer(I4B) :: out_type !! output type (will be assigned either NF90_DOUBLE or NF90_FLOAT, depending on the user parameter) integer(I4B) :: id !! ID for the output file integer(I4B) :: discard_body_id_varid !! ID for the id of the other body involved in the discard @@ -33,9 +34,9 @@ module swiftest_classes character(NAMELEN) :: time_dimname = "time" !! name of the time dimension integer(I4B) :: time_dimid !! ID for the time dimension integer(I4B) :: time_varid !! ID for the time variable - character(NAMELEN) :: id_dimname = "id" !! name of the particle id dimension - integer(I4B) :: id_dimid !! ID for the particle id dimension - integer(I4B) :: id_varid !! ID for the particle name variable + character(NAMELEN) :: name_dimname = "name" !! name of the particle name dimension + integer(I4B) :: name_dimid !! ID for the particle name dimension + integer(I4B) :: name_varid !! ID for the particle name variable character(NAMELEN) :: space_dimname = "space" !! name of the space dimension integer(I4B) :: space_dimid !! ID for the space dimension integer(I4B) :: space_varid !! ID for the space variable @@ -44,8 +45,8 @@ module swiftest_classes ! Non-dimension ids and variable names character(NAMELEN) :: ptype_varname = "particle_type" !! name of the particle type variable integer(I4B) :: ptype_varid !! ID for the particle type variable - character(NAMELEN) :: name_varname = "name" !! name of the particle name variable - integer(I4B) :: name_varid !! ID for the namevariable + character(NAMELEN) :: id_varname = "id" !! name of the particle id variable + integer(I4B) :: id_varid !! ID for the id variable character(NAMELEN) :: npl_varname = "npl" !! name of the number of active massive bodies variable integer(I4B) :: npl_varid !! ID for the number of active massive bodies variable character(NAMELEN) :: ntp_varname = "ntp" !! name of the number of active test particles variable @@ -147,20 +148,27 @@ module swiftest_classes contains procedure :: store => util_copy_store !! Stores a snapshot of the nbody system so that later it can be retrieved for saving to file. generic :: assignment(=) => store - final :: util_final_storage_frame + final :: util_final_storage_frame end type type :: swiftest_storage(nframes) !! An class that establishes the pattern for various storage objects - integer(I4B), len :: nframes = 4096 !! Total number of frames that can be stored - type(swiftest_storage_frame), dimension(nframes) :: frame !! Array of stored frames - integer(I4B) :: iframe = 0 !! Index of the last frame stored in the system - integer(I4B), dimension(nframes) :: tslot !! The value of the time dimension index associated with each frame - real(DP), dimension(nframes) :: tvals !! Stored time values for snapshots + integer(I4B), len :: nframes = 4096 !! Total number of frames that can be stored + type(swiftest_storage_frame), dimension(nframes) :: frame !! Array of stored frames + integer(I4B) :: iframe = 0 !! Index of the last frame stored in the system + integer(I4B) :: nid !! Number of unique id values in all saved snapshots + integer(I4B), dimension(:), allocatable :: idvals !! The set of unique id values contained in the snapshots + integer(I4B), dimension(:), allocatable :: idmap !! The id value -> index map + integer(I4B) :: nt !! Number of unique time values in all saved snapshots + real(DP), dimension(:), allocatable :: tvals !! The set of unique time values contained in the snapshots + integer(I4B), dimension(:), allocatable :: tmap !! The t value -> index map + class(netcdf_parameters), allocatable :: nc !! NetCDF object attached to this storage object contains - procedure :: dump => io_dump_storage !! Dumps storage object contents to file - procedure :: reset => util_reset_storage !! Resets a storage object by deallocating all items and resetting the frame counter to 0 - final :: util_final_storage + procedure :: dump => io_dump_storage !! Dumps storage object contents to file + procedure :: make_index_map => util_index_map_storage !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + procedure :: reset => util_reset_storage !! Resets a storage object by deallocating all items and resetting the frame counter to 0 + procedure :: take_snapshot => util_snapshot_system !! Takes a snapshot of the system for later file storage + final :: util_final_storage end type swiftest_storage !******************************************************************************************************************************** @@ -248,8 +256,7 @@ module swiftest_classes logical :: lgr = .false. !! Turn on GR logical :: lyarkovsky = .false. !! Turn on Yarkovsky effect logical :: lyorp = .false. !! Turn on YORP effect - - type(netcdf_parameters) :: nc !! Object containing NetCDF parameters + type(swiftest_storage(nframes=:)), allocatable :: system_history contains procedure :: reader => io_param_reader procedure :: writer => io_param_writer @@ -313,7 +320,7 @@ module swiftest_classes real(DP), dimension(NDIM) :: aoblend = 0.0_DP !! Barycentric acceleration due to central body oblatenes at end of step real(DP), dimension(NDIM) :: atidebeg = 0.0_DP !! Barycentric acceleration due to central body oblatenes at beginning of step real(DP), dimension(NDIM) :: atideend = 0.0_DP !! Barycentric acceleration due to central body oblatenes at end of step - real(DP), dimension(NDIM) :: xb = 0.0_DP !! Barycentric position (units DU) + real(DP), dimension(NDIM) :: rb = 0.0_DP !! Barycentric position (units DU) real(DP), dimension(NDIM) :: vb = 0.0_DP !! Barycentric velocity (units DU / TU) real(DP), dimension(NDIM) :: agr = 0.0_DP !! Acceleration due to post-Newtonian correction real(DP), dimension(NDIM) :: Ip = 0.0_DP !! Unitless principal moments of inertia (I1, I2, I3) / (MR**2). Principal axis rotation assumed. @@ -342,7 +349,7 @@ module swiftest_classes real(DP), dimension(:), allocatable :: mu !! G * (Mcb + [m]) real(DP), dimension(:,:), allocatable :: rh !! Swiftestcentric position real(DP), dimension(:,:), allocatable :: vh !! Swiftestcentric velocity - real(DP), dimension(:,:), allocatable :: xb !! Barycentric position + real(DP), dimension(:,:), allocatable :: rb !! Barycentric position real(DP), dimension(:,:), allocatable :: vb !! Barycentric velocity real(DP), dimension(:,:), allocatable :: ah !! Total heliocentric acceleration real(DP), dimension(:,:), allocatable :: aobl !! Barycentric accelerations of bodies due to central body oblatenes @@ -395,7 +402,7 @@ module swiftest_classes real(DP), dimension(:), allocatable :: rhill !! Body mass (units MU) real(DP), dimension(:), allocatable :: renc !! Critical radius for close encounters real(DP), dimension(:), allocatable :: radius !! Body radius (units DU) - real(DP), dimension(:,:), allocatable :: xbeg !! Position at beginning of step + real(DP), dimension(:,:), allocatable :: rbeg !! Position at beginning of step real(DP), dimension(:,:), allocatable :: xend !! Position at end of step real(DP), dimension(:,:), allocatable :: vbeg !! Velocity at beginning of step real(DP), dimension(:), allocatable :: density !! Body mass density - calculated internally (units MU / DU**3) @@ -422,7 +429,7 @@ module swiftest_classes procedure :: b2h => util_coord_b2h_pl !! Convert massive bodies from barycentric to heliocentric coordinates (position and velocity) procedure :: vh2vb => util_coord_vh2vb_pl !! Convert massive bodies from heliocentric to barycentric coordinates (velocity only) procedure :: vb2vh => util_coord_vb2vh_pl !! Convert massive bodies from barycentric to heliocentric coordinates (velocity only) - procedure :: xh2xb => util_coord_rh2xb_pl !! Convert massive bodies from heliocentric to barycentric coordinates (position only) + procedure :: rh2rb => util_coord_rh2rb_pl !! Convert massive bodies from heliocentric to barycentric coordinates (position only) procedure :: dealloc => util_dealloc_pl !! Deallocates all allocatable arrays procedure :: fill => util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: resize => util_resize_pl !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. @@ -462,7 +469,7 @@ module swiftest_classes procedure :: b2h => util_coord_b2h_tp !! Convert test particles from barycentric to heliocentric coordinates (position and velocity) procedure :: vb2vh => util_coord_vb2vh_tp !! Convert test particles from barycentric to heliocentric coordinates (velocity only) procedure :: vh2vb => util_coord_vh2vb_tp !! Convert test particles from heliocentric to barycentric coordinates (velocity only) - procedure :: xh2xb => util_coord_rh2xb_tp !! Convert test particles from heliocentric to barycentric coordinates (position only) + procedure :: rh2rb => util_coord_rh2rb_tp !! Convert test particles from heliocentric to barycentric coordinates (position only) procedure :: dealloc => util_dealloc_tp !! Deallocates all allocatable arrays procedure :: fill => util_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: get_peri => util_peri_tp !! Determine system pericenter passages for test particles @@ -546,9 +553,10 @@ module swiftest_classes procedure :: finalize => setup_finalize_system !! Runs any finalization subroutines when ending the simulation. procedure :: initialize => setup_initialize_system !! Initialize the system from input files procedure :: init_particle_info => setup_initialize_particle_info_system !! Initialize the system from input files - ! procedure :: step_spin => tides_step_spin_system !! Steps the spins of the massive & central bodies due to tides. + ! procedure :: step_spin => tides_step_spin_system !! Steps the spins of the massive & central bodies due to tides. procedure :: set_msys => util_set_msys !! Sets the value of msys from the masses of system bodies. procedure :: get_energy_and_momentum => util_get_energy_momentum_system !! Calculates the total system energy and momentum + procedure :: get_idvals => util_get_idvalues_system !! Returns an array of all id values in use in the system procedure :: rescale => util_rescale_system !! Rescales the system into a new set of units procedure :: validate_ids => util_valid_id_system !! Validate the numerical ids passed to the system and save the maximum value generic :: write_frame => write_frame_system, write_frame_netcdf !! Generic method call for reading a frame of output data @@ -607,11 +615,9 @@ subroutine abstract_step_system(self, param, t, dt) real(DP), intent(in) :: t !! Simulation time real(DP), intent(in) :: dt !! Current stepsize end subroutine abstract_step_system - end interface interface - module subroutine check(status, call_identifier) implicit none integer, intent (in) :: status !! The status code returned by a NetCDF function @@ -922,12 +928,12 @@ module subroutine kick_getacch_int_pl(self, param) class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters end subroutine kick_getacch_int_pl - module subroutine kick_getacch_int_tp(self, param, GMpl, xhp, npl) + module subroutine kick_getacch_int_tp(self, param, GMpl, rhp, npl) implicit none class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters real(DP), dimension(:), intent(in) :: GMpl !! Massive body masses - real(DP), dimension(:,:), intent(in) :: xhp !! Massive body position vectors + real(DP), dimension(:,:), intent(in) :: rhp !! Massive body position vectors integer(I4B), intent(in) :: npl !! Number of active massive bodies end subroutine kick_getacch_int_tp @@ -1344,17 +1350,17 @@ module subroutine util_coord_vh2vb_tp(self, vbcb) real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body end subroutine util_coord_vh2vb_tp - module subroutine util_coord_rh2xb_pl(self, cb) + module subroutine util_coord_rh2rb_pl(self, cb) implicit none class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_coord_rh2xb_pl + end subroutine util_coord_rh2rb_pl - module subroutine util_coord_rh2xb_tp(self, cb) + module subroutine util_coord_rh2rb_tp(self, cb) implicit none class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object class(swiftest_cb), intent(in) :: cb !! Swiftest central body object - end subroutine util_coord_rh2xb_tp + end subroutine util_coord_rh2rb_tp module subroutine util_copy_particle_info(self, source) implicit none @@ -1514,6 +1520,11 @@ module subroutine util_index_array(ind_arr, n) integer(I4B), intent(in) :: n !! The new size of the index array end subroutine util_index_array + module subroutine util_index_map_storage(self) + implicit none + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + end subroutine util_index_map_storage + module function util_minimize_bfgs(f, N, x0, eps, maxloop, lerr) result(x1) use lambda_function implicit none @@ -1610,10 +1621,16 @@ module subroutine util_get_energy_momentum_system(self, param) class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine util_get_energy_momentum_system - module subroutine util_set_beg_end_pl(self, xbeg, xend, vbeg) + module subroutine util_get_idvalues_system(self, idvals) + implicit none + class(swiftest_nbody_system), intent(in) :: self !! Encounter snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + end subroutine util_get_idvalues_system + + module subroutine util_set_beg_end_pl(self, rbeg, xend, vbeg) implicit none class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - real(DP), dimension(:,:), intent(in), optional :: xbeg !! Position vectors at beginning of step + real(DP), dimension(:,:), intent(in), optional :: rbeg !! Position vectors at beginning of step real(DP), dimension(:,:), intent(in), optional :: xend !! Positions vectors at end of step real(DP), dimension(:,:), intent(in), optional :: vbeg !! vbeg is an unused variable to keep this method forward compatible with RMVS end subroutine util_set_beg_end_pl @@ -1681,6 +1698,15 @@ module subroutine util_set_rhill_approximate(self,cb) class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object end subroutine util_set_rhill_approximate + + module subroutine util_snapshot_system(self, param, system, t, arg) + implicit none + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in encounter snapshots) + end subroutine util_snapshot_system end interface interface util_solve_linear_system @@ -1948,6 +1974,25 @@ module subroutine util_spill_tp(self, discards, lspill_list, ldestructive) logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not end subroutine util_spill_tp + end interface + + interface util_unique + module subroutine util_unique_DP(input_array, output_array, index_map) + implicit none + real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array + real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + end subroutine util_unique_DP + + module subroutine util_unique_I4B(input_array, output_array, index_map) + implicit none + integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array + integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + end subroutine util_unique_I4B + end interface util_unique + + interface module subroutine util_valid_id_system(self, param) implicit none class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object diff --git a/src/modules/swiftest_globals.f90 b/src/modules/swiftest_globals.f90 index 4c8c21693..d9590b59e 100644 --- a/src/modules/swiftest_globals.f90 +++ b/src/modules/swiftest_globals.f90 @@ -101,6 +101,7 @@ module swiftest_globals integer(I4B), parameter :: COLLRESOLVE_REGIME_SUPERCATASTROPHIC = 3 integer(I4B), parameter :: COLLRESOLVE_REGIME_GRAZE_AND_MERGE = 4 integer(I4B), parameter :: COLLRESOLVE_REGIME_HIT_AND_RUN = 5 + character(len=*),dimension(5), parameter :: REGIME_NAMES = ["Merge", "Disruption", "Supercatastrophic", "Graze and Merge", "Hit and Run"] !> String labels for body/particle addition/subtraction in discard file character(*), parameter :: ADD = '+1' @@ -121,7 +122,7 @@ module swiftest_globals character(*), parameter :: PL_INFILE = 'pl.in' character(*), parameter :: TP_INFILE = 'tp.in' character(*), parameter :: NC_INFILE = 'in.nc' - character(*), parameter :: BIN_OUTFILE = 'bin.nc' + character(*), parameter :: BIN_OUTFILE = 'data.nc' integer(I4B), parameter :: BINUNIT = 20 !! File unit number for the binary output file integer(I4B), parameter :: PARTICLEUNIT = 44 !! File unit number for the binary particle info output file integer(I4B), parameter :: LUN = 42 !! File unit number for files that are opened and closed within a single subroutine call, and therefore should not collide diff --git a/src/modules/symba_classes.f90 b/src/modules/symba_classes.f90 index faa1e2e80..1d5a708b3 100644 --- a/src/modules/symba_classes.f90 +++ b/src/modules/symba_classes.f90 @@ -16,7 +16,7 @@ module symba_classes use swiftest_classes, only : swiftest_parameters, swiftest_base, swiftest_particle_info, swiftest_storage, netcdf_parameters use helio_classes, only : helio_cb, helio_pl, helio_tp, helio_nbody_system use fraggle_classes, only : fraggle_colliders, fraggle_fragments - use encounter_classes, only : encounter_list, encounter_storage, encounter_snapshot + use encounter_classes, only : encounter_list, encounter_storage, collision_storage implicit none public @@ -26,13 +26,15 @@ module symba_classes real(DP), private, parameter :: RSHELL = 0.48075_DP type, extends(swiftest_parameters) :: symba_parameters - real(DP) :: GMTINY = -1.0_DP !! Smallest G*mass that is fully gravitating - real(DP) :: min_GMfrag = -1.0_DP !! Smallest G*mass that can be produced in a fragmentation event - integer(I4B), dimension(:), allocatable :: seed !! Random seeds - logical :: lfragmentation = .false. !! Do fragmentation modeling instead of simple merger. - character(STRMAX) :: encounter_save = "NONE" !! Indicate if and how encounter data should be saved - character(STRMAX) :: fragmentation_save = "NONE" !! Indicate if and how fragmentation data should be saved - logical :: lencounter_save = .false. !! Turns on encounter saving + real(DP) :: GMTINY = -1.0_DP !! Smallest G*mass that is fully gravitating + real(DP) :: min_GMfrag = -1.0_DP !! Smallest G*mass that can be produced in a fragmentation event + integer(I4B), dimension(:), allocatable :: seed !! Random seeds for fragmentation modeling + logical :: lfragmentation = .false. !! Do fragmentation modeling instead of simple merger. + character(STRMAX) :: encounter_save = "NONE" !! Indicate if and how encounter data should be saved + logical :: lenc_save_trajectory = .false. !! Indicates that when encounters are saved, the full trajectory through recursion steps are saved + logical :: lenc_save_closest = .false. !! Indicates that when encounters are saved, the closest approach distance between pairs of bodies is saved + type(encounter_storage(nframes=:)), allocatable :: encounter_history !! Stores encounter history for later retrieval and saving to file + type(collision_storage(nframes=:)), allocatable :: collision_history !! Stores encounter history for later retrieval and saving to file contains procedure :: reader => symba_io_param_reader procedure :: writer => symba_io_param_writer @@ -164,7 +166,7 @@ module symba_classes !> SyMBA class for tracking pl-tp close encounters in a step type, extends(symba_encounter) :: symba_pltpenc contains - procedure :: resolve_collision => symba_collision_resolve_pltpenc !! Process the pl-tp collision list, then modifiy the massive bodies based on the outcome of the c + procedure :: resolve_collision => symba_resolve_collision_pltpenc !! Process the pl-tp collision list, then modifiy the massive bodies based on the outcome of the c end type symba_pltpenc !******************************************************************************************************************************** @@ -173,10 +175,10 @@ module symba_classes !> SyMBA class for tracking pl-pl close encounters in a step type, extends(symba_encounter) :: symba_plplenc contains - procedure :: extract_collisions => symba_collision_encounter_extract_collisions !! Processes the pl-pl encounter list remove only those encounters that led to a collision - procedure :: resolve_fragmentations => symba_collision_resolve_fragmentations !! Process list of collisions, determine the collisional regime, and then create fragments - procedure :: resolve_mergers => symba_collision_resolve_mergers !! Process list of collisions and merge colliding bodies together - procedure :: resolve_collision => symba_collision_resolve_plplenc !! Process the pl-pl collision list, then modifiy the massive bodies based on the outcome of the c + procedure :: extract_collisions => symba_collision_extract_collisions_from_encounters !! Processes the pl-pl encounter list remove only those encounters that led to a collision + procedure :: resolve_fragmentations => symba_resolve_collision_fragmentations !! Process list of collisions, determine the collisional regime, and then create fragments + procedure :: resolve_mergers => symba_resolve_collision_mergers !! Process list of collisions and merge colliding bodies together + procedure :: resolve_collision => symba_resolve_collision_plplenc !! Process the pl-pl collision list, then modifiy the massive bodies based on the outcome of the c end type symba_plplenc @@ -184,12 +186,13 @@ module symba_classes ! symba_nbody_system class definitions and method interfaces !******************************************************************************************************************************** type, extends(helio_nbody_system) :: symba_nbody_system - class(symba_merger), allocatable :: pl_adds !! List of added bodies in mergers or collisions - class(symba_pltpenc), allocatable :: pltpenc_list !! List of massive body-test particle encounters in a single step - class(symba_plplenc), allocatable :: plplenc_list !! List of massive body-massive body encounters in a single step - class(symba_plplenc), allocatable :: plplcollision_list !! List of massive body-massive body collisions in a single step - integer(I4B) :: irec !! System recursion level - type(encounter_storage(nframes=:)), allocatable :: encounter_history !! Stores encounter history for later retrieval and saving to file + class(symba_merger), allocatable :: pl_adds !! List of added bodies in mergers or collisions + class(symba_pltpenc), allocatable :: pltpenc_list !! List of massive body-test particle encounters in a single step + class(symba_plplenc), allocatable :: plplenc_list !! List of massive body-massive body encounters in a single step + class(symba_plplenc), allocatable :: plplcollision_list !! List of massive body-massive body collisions in a single step + integer(I4B) :: irec !! System recursion level + class(fraggle_colliders), allocatable :: colliders !! Fraggle colliders object + class(fraggle_fragments), allocatable :: fragments !! Fraggle fragmentation system object contains procedure :: write_discard => symba_io_write_discard !! Write out information about discarded and merged planets and test particles in SyMBA procedure :: initialize => symba_setup_initialize_system !! Performs SyMBA-specific initilization steps @@ -198,28 +201,25 @@ module symba_classes procedure :: set_recur_levels => symba_step_set_recur_levels_system !! Sets recursion levels of bodies and encounter lists to the current system level procedure :: recursive_step => symba_step_recur_system !! Step interacting planets and active test particles ahead in democratic heliocentric coordinates at the current recursion level, if applicable, and descend to the next deeper level if necessary procedure :: reset => symba_step_reset_system !! Resets pl, tp,and encounter structures at the start of a new step - procedure :: snapshot => symba_util_take_encounter_snapshot !! Take a minimal snapshot of the system through an encounter - procedure :: start_encounter => symba_io_start_encounter !! Initializes the new encounter history - procedure :: stop_encounter => symba_io_stop_encounter !! Saves the encounter and/or fragmentation data to file(s) final :: symba_util_final_system !! Finalizes the SyMBA nbody system object - deallocates all allocatables end type symba_nbody_system interface - module function symba_collision_check_encounter(self, system, param, t, dt, irec) result(lany_collision) + module subroutine symba_collision_check_encounter(self, system, param, t, dt, irec, lany_collision) use swiftest_classes, only : swiftest_parameters implicit none class(symba_encounter), intent(inout) :: self !! SyMBA pl-tp encounter list object class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters real(DP), intent(in) :: t !! current time real(DP), intent(in) :: dt !! step size integer(I4B), intent(in) :: irec !! Current recursion level - logical :: lany_collision !! Returns true if cany pair of encounters resulted in a collision n - end function symba_collision_check_encounter + logical, intent(out) :: lany_collision !! Returns true if any pair of encounters resulted in a collision + end subroutine symba_collision_check_encounter - module subroutine symba_collision_encounter_extract_collisions(self, system, param) + module subroutine symba_collision_extract_collisions_from_encounters(self, system, param) implicit none class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object @@ -232,21 +232,21 @@ module subroutine symba_collision_make_colliders_pl(self,idx) integer(I4B), dimension(2), intent(in) :: idx !! Array holding the indices of the two bodies involved in the collision end subroutine symba_collision_make_colliders_pl - module subroutine symba_collision_resolve_fragmentations(self, system, param) + module subroutine symba_resolve_collision_fragmentations(self, system, param) implicit none class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - end subroutine symba_collision_resolve_fragmentations + end subroutine symba_resolve_collision_fragmentations - module subroutine symba_collision_resolve_mergers(self, system, param) + module subroutine symba_resolve_collision_mergers(self, system, param) implicit none class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - end subroutine symba_collision_resolve_mergers + end subroutine symba_resolve_collision_mergers - module subroutine symba_collision_resolve_plplenc(self, system, param, t, dt, irec) + module subroutine symba_resolve_collision_plplenc(self, system, param, t, dt, irec) implicit none class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object @@ -254,9 +254,9 @@ module subroutine symba_collision_resolve_plplenc(self, system, param, t, dt, ir real(DP), intent(in) :: t !! Current simulation time real(DP), intent(in) :: dt !! Current simulation step size integer(I4B), intent(in) :: irec !! Current recursion level - end subroutine symba_collision_resolve_plplenc + end subroutine symba_resolve_collision_plplenc - module subroutine symba_collision_resolve_pltpenc(self, system, param, t, dt, irec) + module subroutine symba_resolve_collision_pltpenc(self, system, param, t, dt, irec) implicit none class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-tp encounter list class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object @@ -264,7 +264,7 @@ module subroutine symba_collision_resolve_pltpenc(self, system, param, t, dt, ir real(DP), intent(in) :: t !! Current simulation time real(DP), intent(in) :: dt !! Current simulation step size integer(I4B), intent(in) :: irec !! Current recursion level - end subroutine symba_collision_resolve_pltpenc + end subroutine symba_resolve_collision_pltpenc module subroutine symba_discard_pl(self, system, param) use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters @@ -343,33 +343,24 @@ pure module subroutine symba_gr_p4_tp(self, system, param, dt) real(DP), intent(in) :: dt !! Step size end subroutine symba_gr_p4_tp - module function symba_collision_casedisruption(system, param, colliders, frag) result(status) - use fraggle_classes, only : fraggle_colliders, fraggle_fragments + module function symba_collision_casedisruption(system, param) result(status) implicit none class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - class(fraggle_colliders), intent(inout) :: colliders !! Fraggle colliders object - class(fraggle_fragments), intent(inout) :: frag !! Fraggle fragmentation system object integer(I4B) :: status !! Status flag assigned to this outcome end function symba_collision_casedisruption - module function symba_collision_casehitandrun(system, param, colliders, frag) result(status) - use fraggle_classes, only : fraggle_colliders, fraggle_fragments + module function symba_collision_casehitandrun(system, param) result(status) implicit none class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - class(fraggle_colliders), intent(inout) :: colliders !! Fraggle colliders object - class(fraggle_fragments), intent(inout) :: frag !! Fraggle fragmentation system object integer(I4B) :: status !! Status flag assigned to this outcome end function symba_collision_casehitandrun - module function symba_collision_casemerge(system, param, colliders, frag) result(status) - use fraggle_classes, only : fraggle_colliders, fraggle_fragments + module function symba_collision_casemerge(system, param) result(status) implicit none class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - class(fraggle_colliders), intent(inout) :: colliders !! Fraggle colliders object - class(fraggle_fragments), intent(inout) :: frag !! Fraggle fragmentation system object integer(I4B) :: status !! Status flag assigned to this outcome end function symba_collision_casemerge @@ -379,14 +370,6 @@ module subroutine symba_util_set_renc(self, scale) integer(I4B), intent(in) :: scale !! Current recursion depth end subroutine symba_util_set_renc - module subroutine symba_util_take_encounter_snapshot(self, param, t) - use swiftest_classes, only : swiftest_parameters - implicit none - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! current time - end subroutine symba_util_take_encounter_snapshot - module subroutine symba_io_param_reader(self, unit, iotype, v_list, iostat, iomsg) implicit none class(symba_parameters), intent(inout) :: self !! Current run configuration parameters with SyMBA additionss @@ -409,20 +392,6 @@ module subroutine symba_io_param_writer(self, unit, iotype, v_list, iostat, ioms character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 end subroutine symba_io_param_writer - module subroutine symba_io_start_encounter(self, param, t) - implicit none - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - end subroutine symba_io_start_encounter - - module subroutine symba_io_stop_encounter(self, param, t) - implicit none - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - end subroutine symba_io_stop_encounter - module subroutine symba_io_write_discard(self, param) use swiftest_classes, only : swiftest_parameters implicit none diff --git a/src/netcdf/netcdf.f90 b/src/netcdf/netcdf.f90 index ad5d7bbeb..588a138d6 100644 --- a/src/netcdf/netcdf.f90 +++ b/src/netcdf/netcdf.f90 @@ -80,63 +80,65 @@ module function netcdf_get_old_t_final_system(self, param) result(old_t_final) real(DP), dimension(NDIM) :: rot0, Ip0, Lnow real(DP) :: KE_orb_orig, KE_spin_orig, PE_orig - call param%nc%open(param) - call check( nf90_inquire_dimension(param%nc%id, param%nc%time_dimid, len=itmax), "netcdf_get_old_t_final_system time_dimid" ) - call check( nf90_inquire_dimension(param%nc%id, param%nc%id_dimid, len=idmax), "netcdf_get_old_t_final_system id_dimid" ) - allocate(vals(idmax)) - call check( nf90_get_var(param%nc%id, param%nc%time_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system time_varid" ) + associate (nc => param%system_history%nc) + call nc%open(param) + call check( nf90_inquire_dimension(nc%id, nc%time_dimid, len=itmax), "netcdf_get_old_t_final_system time_dimid" ) + call check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "netcdf_get_old_t_final_system name_dimid" ) + allocate(vals(idmax)) + call check( nf90_get_var(nc%id, nc%time_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system time_varid" ) - !old_t_final = rtemp(1) - old_t_final = param%t0 ! For NetCDF it is safe to overwrite the final t value on a restart + !old_t_final = rtemp(1) + old_t_final = param%t0 ! For NetCDF it is safe to overwrite the final t value on a restart - if (param%lenergy) then - call check( nf90_get_var(param%nc%id, param%nc%KE_orb_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system KE_orb_varid" ) - KE_orb_orig = rtemp(1) + if (param%lenergy) then + call check( nf90_get_var(nc%id, nc%KE_orb_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system KE_orb_varid" ) + KE_orb_orig = rtemp(1) - call check( nf90_get_var(param%nc%id, param%nc%KE_spin_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system KE_spin_varid" ) - KE_spin_orig = rtemp(1) + call check( nf90_get_var(nc%id, nc%KE_spin_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system KE_spin_varid" ) + KE_spin_orig = rtemp(1) - call check( nf90_get_var(param%nc%id, param%nc%PE_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system PE_varid" ) - PE_orig = rtemp(1) + call check( nf90_get_var(nc%id, nc%PE_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system PE_varid" ) + PE_orig = rtemp(1) - call check( nf90_get_var(param%nc%id, param%nc%Ecollisions_varid, self%Ecollisions, start=[1]), "netcdf_get_old_t_final_system Ecollisions_varid" ) - call check( nf90_get_var(param%nc%id, param%nc%Euntracked_varid, self%Euntracked, start=[1]), "netcdf_get_old_t_final_system Euntracked_varid" ) + call check( nf90_get_var(nc%id, nc%Ecollisions_varid, self%Ecollisions, start=[1]), "netcdf_get_old_t_final_system Ecollisions_varid" ) + call check( nf90_get_var(nc%id, nc%Euntracked_varid, self%Euntracked, start=[1]), "netcdf_get_old_t_final_system Euntracked_varid" ) - self%Eorbit_orig = KE_orb_orig + KE_spin_orig + PE_orig + self%Ecollisions + self%Euntracked + self%Eorbit_orig = KE_orb_orig + KE_spin_orig + PE_orig + self%Ecollisions + self%Euntracked - call check( nf90_get_var(param%nc%id, param%nc%L_orb_varid, self%Lorbit_orig(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_orb_varid" ) - call check( nf90_get_var(param%nc%id, param%nc%L_spin_varid, self%Lspin_orig(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_spin_varid" ) - call check( nf90_get_var(param%nc%id, param%nc%L_escape_varid, self%Lescape(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_escape_varid" ) + call check( nf90_get_var(nc%id, nc%L_orb_varid, self%Lorbit_orig(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_orb_varid" ) + call check( nf90_get_var(nc%id, nc%L_spin_varid, self%Lspin_orig(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_spin_varid" ) + call check( nf90_get_var(nc%id, nc%L_escape_varid, self%Lescape(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_escape_varid" ) - self%Ltot_orig(:) = self%Lorbit_orig(:) + self%Lspin_orig(:) + self%Lescape(:) + self%Ltot_orig(:) = self%Lorbit_orig(:) + self%Lspin_orig(:) + self%Lescape(:) - call check( nf90_get_var(param%nc%id, param%nc%Gmass_varid, vals, start=[1,1], count=[idmax,1]), "netcdf_get_old_t_final_system Gmass_varid" ) - call check( nf90_get_var(param%nc%id, param%nc%GMescape_varid, self%GMescape, start=[1]), "netcdf_get_old_t_final_system GMescape_varid" ) - self%GMtot_orig = vals(1) + sum(vals(2:idmax), vals(2:idmax) == vals(2:idmax)) + self%GMescape + call check( nf90_get_var(nc%id, nc%Gmass_varid, vals, start=[1,1], count=[idmax,1]), "netcdf_get_old_t_final_system Gmass_varid" ) + call check( nf90_get_var(nc%id, nc%GMescape_varid, self%GMescape, start=[1]), "netcdf_get_old_t_final_system GMescape_varid" ) + self%GMtot_orig = vals(1) + sum(vals(2:idmax), vals(2:idmax) == vals(2:idmax)) + self%GMescape - select type(cb => self%cb) - class is (symba_cb) - cb%GM0 = vals(1) - cb%dGM = cb%Gmass - cb%GM0 + select type(cb => self%cb) + class is (symba_cb) + cb%GM0 = vals(1) + cb%dGM = cb%Gmass - cb%GM0 - call check( nf90_get_var(param%nc%id, param%nc%radius_varid, rtemp, start=[1,1], count=[1,1]), "netcdf_get_old_t_final_system radius_varid" ) - cb%R0 = rtemp(1) + call check( nf90_get_var(nc%id, nc%radius_varid, rtemp, start=[1,1], count=[1,1]), "netcdf_get_old_t_final_system radius_varid" ) + cb%R0 = rtemp(1) - if (param%lrotation) then + if (param%lrotation) then - call check( nf90_get_var(param%nc%id, param%nc%rot_varid, rot0, start=[1,1,1], count=[NDIM,1,1]), "netcdf_get_old_t_final_system rot_varid" ) - call check( nf90_get_var(param%nc%id, param%nc%Ip_varid, Ip0, start=[1,1,1], count=[NDIM,1,1]), "netcdf_get_old_t_final_system Ip_varid" ) + call check( nf90_get_var(nc%id, nc%rot_varid, rot0, start=[1,1,1], count=[NDIM,1,1]), "netcdf_get_old_t_final_system rot_varid" ) + call check( nf90_get_var(nc%id, nc%Ip_varid, Ip0, start=[1,1,1], count=[NDIM,1,1]), "netcdf_get_old_t_final_system Ip_varid" ) - cb%L0(:) = Ip0(3) * cb%GM0 * cb%R0**2 * rot0(:) + cb%L0(:) = Ip0(3) * cb%GM0 * cb%R0**2 * rot0(:) - Lnow(:) = cb%Ip(3) * cb%Gmass * cb%radius**2 * cb%rot(:) - cb%dL(:) = Lnow(:) - cb%L0(:) - end if - end select + Lnow(:) = cb%Ip(3) * cb%Gmass * cb%radius**2 * cb%rot(:) + cb%dL(:) = Lnow(:) - cb%L0(:) + end if + end select - end if + end if - deallocate(vals) + deallocate(vals) + end associate return end function netcdf_get_old_t_final_system @@ -172,89 +174,89 @@ module subroutine netcdf_initialize_output(self, param) end select ! Check if the file exists, and if it does, delete it - inquire(file=param%outfile, exist=fileExists) + inquire(file=nc%file_name, exist=fileExists) if (fileExists) then - open(unit=LUN, file=param%outfile, status="old", err=667, iomsg=errmsg) + open(unit=LUN, file=nc%file_name, status="old", err=667, iomsg=errmsg) close(unit=LUN, status="delete") end if ! Create the file - call check( nf90_create(param%outfile, NF90_NETCDF4, nc%id), "netcdf_initialize_output nf90_create" ) + call check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "netcdf_initialize_output nf90_create" ) ! Dimensions call check( nf90_def_dim(nc%id, nc%time_dimname, NF90_UNLIMITED, nc%time_dimid), "netcdf_initialize_output nf90_def_dim time_dimid" ) ! Simulation time dimension call check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "netcdf_initialize_output nf90_def_dim space_dimid" ) ! 3D space dimension - call check( nf90_def_dim(nc%id, nc%id_dimname, NF90_UNLIMITED, nc%id_dimid), "netcdf_initialize_output nf90_def_dim id_dimid" ) ! dimension to store particle id numbers + call check( nf90_def_dim(nc%id, nc%name_dimname, NF90_UNLIMITED, nc%name_dimid), "netcdf_initialize_output nf90_def_dim name_dimid" ) ! dimension to store particle id numbers call check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "netcdf_initialize_output nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) ! Dimension coordinates call check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, nc%time_dimid, nc%time_varid), "netcdf_initialize_output nf90_def_var time_varid" ) call check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "netcdf_initialize_output nf90_def_var space_varid" ) - call check( nf90_def_var(nc%id, nc%id_dimname, NF90_INT, nc%id_dimid, nc%id_varid), "netcdf_initialize_output nf90_def_var id_varid" ) + call check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "netcdf_initialize_output nf90_def_var name_varid" ) ! Variables + call check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "netcdf_initialize_output nf90_def_var id_varid" ) call check( nf90_def_var(nc%id, nc%npl_varname, NF90_INT, nc%time_dimid, nc%npl_varid), "netcdf_initialize_output nf90_def_var npl_varid" ) call check( nf90_def_var(nc%id, nc%ntp_varname, NF90_INT, nc%time_dimid, nc%ntp_varid), "netcdf_initialize_output nf90_def_var ntp_varid" ) if (param%integrator == SYMBA) call check( nf90_def_var(nc%id, nc%nplm_varname, NF90_INT, nc%time_dimid, nc%nplm_varid), "netcdf_initialize_output nf90_def_var nplm_varid" ) - call check( nf90_def_var(nc%id, nc%name_varname, NF90_CHAR, [nc%str_dimid, nc%id_dimid], nc%name_varid), "netcdf_initialize_output nf90_def_var name_varid" ) - call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%id_dimid], nc%ptype_varid), "netcdf_initialize_output nf90_def_var ptype_varid" ) + call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%ptype_varid), "netcdf_initialize_output nf90_def_var ptype_varid" ) if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then - call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%rh_varid), "netcdf_initialize_output nf90_def_var rh_varid" ) - call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%vh_varid), "netcdf_initialize_output nf90_def_var vh_varid" ) + call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rh_varid), "netcdf_initialize_output nf90_def_var rh_varid" ) + call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%vh_varid), "netcdf_initialize_output nf90_def_var vh_varid" ) !! When GR is enabled, we need to save the pseudovelocity vectors in addition to the true heliocentric velocity vectors, otherwise !! we cannnot expect bit-identical runs from restarted runs with GR enabled due to floating point errors during the conversion. if (param%lgr) then - call check( nf90_def_var(nc%id, nc%gr_pseudo_vh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%gr_pseudo_vh_varid), "netcdf_initialize_output nf90_def_var gr_psuedo_vh_varid" ) + call check( nf90_def_var(nc%id, nc%gr_pseudo_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%gr_pseudo_vh_varid), "netcdf_initialize_output nf90_def_var gr_psuedo_vh_varid" ) nc%lpseudo_vel_exists = .true. end if end if if ((param%out_form == "EL") .or. (param%out_form == "XVEL")) then - call check( nf90_def_var(nc%id, nc%a_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%a_varid), "netcdf_initialize_output nf90_def_var a_varid" ) - call check( nf90_def_var(nc%id, nc%e_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%e_varid), "netcdf_initialize_output nf90_def_var e_varid" ) - call check( nf90_def_var(nc%id, nc%inc_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%inc_varid), "netcdf_initialize_output nf90_def_var inc_varid" ) - call check( nf90_def_var(nc%id, nc%capom_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%capom_varid), "netcdf_initialize_output nf90_def_var capom_varid" ) - call check( nf90_def_var(nc%id, nc%omega_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%omega_varid), "netcdf_initialize_output nf90_def_var omega_varid" ) - call check( nf90_def_var(nc%id, nc%capm_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%capm_varid), "netcdf_initialize_output nf90_def_var capm_varid" ) - call check( nf90_def_var(nc%id, nc%varpi_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%varpi_varid), "netcdf_initialize_output nf90_def_var varpi_varid" ) - call check( nf90_def_var(nc%id, nc%lam_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%lam_varid), "netcdf_initialize_output nf90_def_var lam_varid" ) - call check( nf90_def_var(nc%id, nc%f_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%f_varid), "netcdf_initialize_output nf90_def_var f_varid" ) - call check( nf90_def_var(nc%id, nc%cape_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%cape_varid), "netcdf_initialize_output nf90_def_var cape_varid" ) + call check( nf90_def_var(nc%id, nc%a_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%a_varid), "netcdf_initialize_output nf90_def_var a_varid" ) + call check( nf90_def_var(nc%id, nc%e_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%e_varid), "netcdf_initialize_output nf90_def_var e_varid" ) + call check( nf90_def_var(nc%id, nc%inc_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%inc_varid), "netcdf_initialize_output nf90_def_var inc_varid" ) + call check( nf90_def_var(nc%id, nc%capom_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%capom_varid), "netcdf_initialize_output nf90_def_var capom_varid" ) + call check( nf90_def_var(nc%id, nc%omega_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%omega_varid), "netcdf_initialize_output nf90_def_var omega_varid" ) + call check( nf90_def_var(nc%id, nc%capm_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%capm_varid), "netcdf_initialize_output nf90_def_var capm_varid" ) + call check( nf90_def_var(nc%id, nc%varpi_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%varpi_varid), "netcdf_initialize_output nf90_def_var varpi_varid" ) + call check( nf90_def_var(nc%id, nc%lam_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%lam_varid), "netcdf_initialize_output nf90_def_var lam_varid" ) + call check( nf90_def_var(nc%id, nc%f_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%f_varid), "netcdf_initialize_output nf90_def_var f_varid" ) + call check( nf90_def_var(nc%id, nc%cape_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%cape_varid), "netcdf_initialize_output nf90_def_var cape_varid" ) end if - call check( nf90_def_var(nc%id, nc%gmass_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%Gmass_varid), "netcdf_initialize_output nf90_def_var Gmass_varid" ) + call check( nf90_def_var(nc%id, nc%gmass_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Gmass_varid), "netcdf_initialize_output nf90_def_var Gmass_varid" ) if (param%lrhill_present) then - call check( nf90_def_var(nc%id, nc%rhill_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%rhill_varid), "netcdf_initialize_output nf90_def_var rhill_varid" ) + call check( nf90_def_var(nc%id, nc%rhill_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%rhill_varid), "netcdf_initialize_output nf90_def_var rhill_varid" ) end if if (param%lclose) then - call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%radius_varid), "netcdf_initialize_output nf90_def_var radius_varid" ) + call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%radius_varid), "netcdf_initialize_output nf90_def_var radius_varid" ) - call check( nf90_def_var(nc%id, nc%origin_time_varname, nc%out_type, nc%id_dimid, nc%origin_time_varid), "netcdf_initialize_output nf90_def_var origin_time_varid" ) - call check( nf90_def_var(nc%id, nc%origin_type_varname, NF90_CHAR, [nc%str_dimid, nc%id_dimid], & + call check( nf90_def_var(nc%id, nc%origin_time_varname, nc%out_type, nc%name_dimid, nc%origin_time_varid), "netcdf_initialize_output nf90_def_var origin_time_varid" ) + call check( nf90_def_var(nc%id, nc%origin_type_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], & nc%origin_type_varid), "netcdf_initialize_output nf90_create" ) - call check( nf90_def_var(nc%id, nc%origin_rh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid], nc%origin_rh_varid), "netcdf_initialize_output nf90_def_var origin_rh_varid" ) - call check( nf90_def_var(nc%id, nc%origin_vh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid], nc%origin_vh_varid), "netcdf_initialize_output nf90_def_var origin_vh_varid" ) - - call check( nf90_def_var(nc%id, nc%collision_id_varname, NF90_INT, nc%id_dimid, nc%collision_id_varid), "netcdf_initialize_output nf90_def_var collision_id_varid" ) - call check( nf90_def_var(nc%id, nc%discard_time_varname, nc%out_type, nc%id_dimid, nc%discard_time_varid), "netcdf_initialize_output nf90_def_var discard_time_varid" ) - call check( nf90_def_var(nc%id, nc%discard_rh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid], nc%discard_rh_varid), "netcdf_initialize_output nf90_def_var discard_rh_varid" ) - call check( nf90_def_var(nc%id, nc%discard_vh_varname, nc%out_type, [nc%space_dimid, nc%id_dimid], nc%discard_vh_varid), "netcdf_initialize_output nf90_def_var discard_vh_varid" ) - call check( nf90_def_var(nc%id, nc%discard_body_id_varname, NF90_INT, nc%id_dimid, nc%discard_body_id_varid), "netcdf_initialize_output nf90_def_var discard_body_id_varid" ) + call check( nf90_def_var(nc%id, nc%origin_rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%origin_rh_varid), "netcdf_initialize_output nf90_def_var origin_rh_varid" ) + call check( nf90_def_var(nc%id, nc%origin_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%origin_vh_varid), "netcdf_initialize_output nf90_def_var origin_vh_varid" ) + + call check( nf90_def_var(nc%id, nc%collision_id_varname, NF90_INT, nc%name_dimid, nc%collision_id_varid), "netcdf_initialize_output nf90_def_var collision_id_varid" ) + call check( nf90_def_var(nc%id, nc%discard_time_varname, nc%out_type, nc%name_dimid, nc%discard_time_varid), "netcdf_initialize_output nf90_def_var discard_time_varid" ) + call check( nf90_def_var(nc%id, nc%discard_rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%discard_rh_varid), "netcdf_initialize_output nf90_def_var discard_rh_varid" ) + call check( nf90_def_var(nc%id, nc%discard_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%discard_vh_varid), "netcdf_initialize_output nf90_def_var discard_vh_varid" ) + call check( nf90_def_var(nc%id, nc%discard_body_id_varname, NF90_INT, nc%name_dimid, nc%discard_body_id_varid), "netcdf_initialize_output nf90_def_var discard_body_id_varid" ) end if if (param%lrotation) then - call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%Ip_varid), "netcdf_initialize_output nf90_def_var Ip_varid" ) - call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%id_dimid, nc%time_dimid], nc%rot_varid), "netcdf_initialize_output nf90_def_var rot_varid" ) + call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%Ip_varid), "netcdf_initialize_output nf90_def_var Ip_varid" ) + call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rot_varid), "netcdf_initialize_output nf90_def_var rot_varid" ) end if ! if (param%ltides) then - ! call check( nf90_def_var(nc%id, nc%k2_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%k2_varid), "netcdf_initialize_output nf90_def_var k2_varid" ) - ! call check( nf90_def_var(nc%id, nc%q_varname, nc%out_type, [nc%id_dimid, nc%time_dimid], nc%Q_varid), "netcdf_initialize_output nf90_def_var Q_varid" ) + ! call check( nf90_def_var(nc%id, nc%k2_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%k2_varid), "netcdf_initialize_output nf90_def_var k2_varid" ) + ! call check( nf90_def_var(nc%id, nc%q_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Q_varid), "netcdf_initialize_output nf90_def_var Q_varid" ) ! end if if (param%lenergy) then @@ -324,22 +326,22 @@ module subroutine netcdf_open(self, param, readonly) associate(nc => self) - write(errmsg,*) "netcdf_open nf90_open ",trim(adjustl(param%outfile)) - call check( nf90_open(param%outfile, mode, nc%id), errmsg) + write(errmsg,*) "netcdf_open nf90_open ",trim(adjustl(nc%file_name)) + call check( nf90_open(nc%file_name, mode, nc%id), errmsg) ! Dimensions call check( nf90_inq_dimid(nc%id, nc%time_dimname, nc%time_dimid), "netcdf_open nf90_inq_dimid time_dimid" ) call check( nf90_inq_dimid(nc%id, nc%space_dimname, nc%space_dimid), "netcdf_open nf90_inq_dimid space_dimid" ) - call check( nf90_inq_dimid(nc%id, nc%id_dimname, nc%id_dimid), "netcdf_open nf90_inq_dimid id_dimid" ) + call check( nf90_inq_dimid(nc%id, nc%name_dimname, nc%name_dimid), "netcdf_open nf90_inq_dimid name_dimid" ) call check( nf90_inq_dimid(nc%id, nc%str_dimname, nc%str_dimid), "netcdf_open nf90_inq_dimid str_dimid" ) ! Dimension coordinates call check( nf90_inq_varid(nc%id, nc%time_dimname, nc%time_varid), "netcdf_open nf90_inq_varid time_varid" ) call check( nf90_inq_varid(nc%id, nc%space_dimname, nc%space_varid), "netcdf_open nf90_inq_varid space_varid" ) - call check( nf90_inq_varid(nc%id, nc%id_dimname, nc%id_varid), "netcdf_open nf90_inq_varid id_varid" ) + call check( nf90_inq_varid(nc%id, nc%name_dimname, nc%name_varid), "netcdf_open nf90_inq_varid name_varid" ) ! Required Variables - call check( nf90_inq_varid(nc%id, nc%name_varname, nc%name_varid), "netcdf_open nf90_inq_varid name_varid" ) + call check( nf90_inq_varid(nc%id, nc%id_varname, nc%id_varid), "netcdf_open nf90_inq_varid name_varid" ) call check( nf90_inq_varid(nc%id, nc%gmass_varname, nc%Gmass_varid), "netcdf_open nf90_inq_varid Gmass_varid" ) if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then @@ -459,7 +461,7 @@ module function netcdf_read_frame_system(self, nc, param) result(ierr) call pl%setup(npl, param) call tp%setup(ntp, param) - call check( nf90_inquire_dimension(nc%id, nc%id_dimid, len=idmax), "netcdf_read_frame_system nf90_inquire_dimension id_dimid" ) + call check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "netcdf_read_frame_system nf90_inquire_dimension name_dimid" ) allocate(rtemp(idmax)) allocate(vectemp(NDIM,idmax)) allocate(itemp(idmax)) @@ -701,7 +703,7 @@ module subroutine netcdf_read_hdr_system(self, nc, param) tslot = param%ioutput - call check( nf90_inquire_dimension(nc%id, nc%id_dimid, len=idmax), "netcdf_read_hdr_system nf90_inquire_dimension id_dimid" ) + call check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "netcdf_read_hdr_system nf90_inquire_dimension name_dimid" ) call check( nf90_get_var(nc%id, nc%time_varid, self%t, start=[tslot]), "netcdf_read_hdr_system nf90_getvar time_varid" ) allocate(gmtemp(idmax)) @@ -824,6 +826,9 @@ module subroutine netcdf_read_particle_info_system(self, nc, param, plmask, tpma cb%id = itemp(1) pl%id(:) = pack(itemp, plmask) tp%id(:) = pack(itemp, tpmask) + cb%id = 0 + pl%id(:) = pack([(i,i=0,idmax-1)],plmask) + tp%id(:) = pack([(i,i=0,idmax-1)],tpmask) call check( nf90_get_var(nc%id, nc%name_varid, ctemp, count=[NAMELEN, idmax]), "netcdf_read_particle_info_system nf90_getvar name_varid" ) call cb%info%set_value(name=ctemp(1)) @@ -1160,7 +1165,7 @@ module subroutine netcdf_write_info_base(self, nc, param) ! Internals integer(I4B) :: i, j, idslot, old_mode integer(I4B), dimension(:), allocatable :: ind - character(len=NAMELEN) :: charstring + character(len=:), allocatable :: charstring ! This string of spaces of length NAMELEN is used to clear out any old data left behind inside the string variables call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "netcdf_write_info_base nf90_set_fill nf90_nofill" ) @@ -1177,14 +1182,14 @@ module subroutine netcdf_write_info_base(self, nc, param) call check( nf90_put_var(nc%id, nc%id_varid, self%id(j), start=[idslot]), "netcdf_write_info_base nf90_put_var id_varid" ) charstring = trim(adjustl(self%info(j)%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "netcdf_write_info_base nf90_put_var name_varid" ) + call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var name_varid" ) charstring = trim(adjustl(self%info(j)%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "netcdf_write_info_base nf90_put_var particle_type_varid" ) + call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var particle_type_varid" ) if (param%lclose) then charstring = trim(adjustl(self%info(j)%origin_type)) - call check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "netcdf_write_info_base nf90_put_var origin_type_varid" ) + call check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var origin_type_varid" ) call check( nf90_put_var(nc%id, nc%origin_time_varid, self%info(j)%origin_time, start=[idslot]), "netcdf_write_info_base nf90_put_var origin_time_varid" ) call check( nf90_put_var(nc%id, nc%origin_rh_varid, self%info(j)%origin_rh(:), start=[1,idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var origin_rh_varid" ) call check( nf90_put_var(nc%id, nc%origin_vh_varid, self%info(j)%origin_vh(:), start=[1,idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var origin_vh_varid" ) @@ -1203,14 +1208,14 @@ module subroutine netcdf_write_info_base(self, nc, param) call check( nf90_put_var(nc%id, nc%id_varid, self%id, start=[idslot]), "netcdf_write_info_base nf90_put_var cb id_varid" ) charstring = trim(adjustl(self%info%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "netcdf_write_info_base nf90_put_var cb name_varid" ) + call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var cb name_varid" ) charstring = trim(adjustl(self%info%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "netcdf_write_info_base nf90_put_var cb ptype_varid" ) + call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var cb ptype_varid" ) if (param%lclose) then charstring = trim(adjustl(self%info%origin_type)) - call check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[NAMELEN, 1]), "netcdf_write_info_base nf90_put_var cb origin_type_varid" ) + call check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var cb origin_type_varid" ) call check( nf90_put_var(nc%id, nc%origin_time_varid, self%info%origin_time, start=[idslot]), "netcdf_write_info_base nf90_put_var cb origin_time_varid" ) call check( nf90_put_var(nc%id, nc%origin_rh_varid, self%info%origin_rh(:), start=[1, idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var cb origin_rh_varid" ) diff --git a/src/rmvs/rmvs_encounter_check.f90 b/src/rmvs/rmvs_encounter_check.f90 index 860bcacfb..be0c8ba62 100644 --- a/src/rmvs/rmvs_encounter_check.f90 +++ b/src/rmvs/rmvs_encounter_check.f90 @@ -42,7 +42,7 @@ module function rmvs_encounter_check_tp(self, param, system, dt) result(lencount class is (rmvs_pl) associate(tp => self, ntp => self%nbody, npl => pl%nbody) tp%plencP(1:ntp) = 0 - call encounter_check_all_pltp(param, npl, ntp, pl%xbeg, pl%vbeg, tp%rh, tp%vh, pl%renc, dt, & + call encounter_check_all_pltp(param, npl, ntp, pl%rbeg, pl%vbeg, tp%rh, tp%vh, pl%renc, dt, & nenc, index1, index2, lvdotr) lencounter = (nenc > 0_I8B) diff --git a/src/rmvs/rmvs_kick.f90 b/src/rmvs/rmvs_kick.f90 index bb43aba94..88b71d0a9 100644 --- a/src/rmvs/rmvs_kick.f90 +++ b/src/rmvs/rmvs_kick.f90 @@ -27,7 +27,7 @@ module subroutine rmvs_kick_getacch_tp(self, system, param, t, lbeg) logical, intent(in) :: lbeg !! Logical flag that determines whether or not this is the beginning or end of the step ! Internals class(swiftest_parameters), allocatable :: param_planetocen - real(DP), dimension(:, :), allocatable :: xh_original + real(DP), dimension(:, :), allocatable :: rh_original real(DP) :: GMcb_original integer(I4B) :: i @@ -46,7 +46,7 @@ module subroutine rmvs_kick_getacch_tp(self, system, param, t, lbeg) system_planetocen%lbeg = lbeg ! Save the original heliocentric position for later - allocate(xh_original, source=tp%rh) + allocate(rh_original, source=tp%rh) ! Temporarily turn off the heliocentric-dependent acceleration terms during an inner encounter using a copy of the parameter list with all of the heliocentric-specific acceleration terms turned off allocate(param_planetocen, source=param) @@ -60,17 +60,17 @@ module subroutine rmvs_kick_getacch_tp(self, system, param, t, lbeg) ! Now compute any heliocentric values of acceleration if (tp%lfirst) then do concurrent(i = 1:ntp, tp%lmask(i)) - tp%xheliocentric(:,i) = tp%rh(:,i) + cb%inner(inner_index - 1)%x(:,1) + tp%rheliocentric(:,i) = tp%rh(:,i) + cb%inner(inner_index - 1)%x(:,1) end do else do concurrent(i = 1:ntp, tp%lmask(i)) - tp%xheliocentric(:,i) = tp%rh(:,i) + cb%inner(inner_index )%x(:,1) + tp%rheliocentric(:,i) = tp%rh(:,i) + cb%inner(inner_index )%x(:,1) end do end if ! Swap the planetocentric and heliocentric position vectors and central body masses do concurrent(i = 1:ntp, tp%lmask(i)) - tp%rh(:, i) = tp%xheliocentric(:, i) + tp%rh(:, i) = tp%rheliocentric(:, i) end do GMcb_original = cb%Gmass cb%Gmass = tp%cb_heliocentric%Gmass @@ -81,7 +81,7 @@ module subroutine rmvs_kick_getacch_tp(self, system, param, t, lbeg) if (param%lgr) call tp%accel_gr(param) ! Put everything back the way we found it - call move_alloc(xh_original, tp%rh) + call move_alloc(rh_original, tp%rh) cb%Gmass = GMcb_original end associate diff --git a/src/rmvs/rmvs_setup.f90 b/src/rmvs/rmvs_setup.f90 index 2c5a0faea..9c0b88876 100644 --- a/src/rmvs/rmvs_setup.f90 +++ b/src/rmvs/rmvs_setup.f90 @@ -156,7 +156,7 @@ module subroutine rmvs_setup_tp(self, n, param) allocate(self%plperP(n)) allocate(self%plencP(n)) - if (self%lplanetocentric) allocate(self%xheliocentric(NDIM, n)) + if (self%lplanetocentric) allocate(self%rheliocentric(NDIM, n)) self%lperi(:) = .false. diff --git a/src/rmvs/rmvs_step.f90 b/src/rmvs/rmvs_step.f90 index 132139e33..ab39e6f31 100644 --- a/src/rmvs/rmvs_step.f90 +++ b/src/rmvs/rmvs_step.f90 @@ -26,7 +26,7 @@ module subroutine rmvs_step_system(self, param, t, dt) real(DP), intent(in) :: dt !! Current stepsiz ! Internals logical :: lencounter, lfirstpl - real(DP), dimension(:,:), allocatable :: xbeg, xend, vbeg + real(DP), dimension(:,:), allocatable :: rbeg, xend, vbeg if (self%tp%nbody == 0) then call whm_step_system(self, param, t, dt) @@ -38,15 +38,15 @@ module subroutine rmvs_step_system(self, param, t, dt) select type(tp => self%tp) class is (rmvs_tp) associate(system => self, ntp => tp%nbody, npl => pl%nbody) - allocate(xbeg, source=pl%rh) + allocate(rbeg, source=pl%rh) allocate(vbeg, source=pl%vh) - call pl%set_beg_end(xbeg = xbeg, vbeg = vbeg) + call pl%set_beg_end(rbeg = rbeg, vbeg = vbeg) ! ****** Check for close encounters ***** ! call pl%set_renc(RHSCALE) lencounter = tp%encounter_check(param, system, dt) if (lencounter) then lfirstpl = pl%lfirst - pl%outer(0)%x(:, 1:npl) = xbeg(:, 1:npl) + pl%outer(0)%x(:, 1:npl) = rbeg(:, 1:npl) pl%outer(0)%v(:, 1:npl) = vbeg(:, 1:npl) call pl%step(system, param, t, dt) pl%outer(NTENC)%x(:, 1:npl) = pl%rh(:, 1:npl) @@ -54,7 +54,7 @@ module subroutine rmvs_step_system(self, param, t, dt) call rmvs_interp_out(cb, pl, dt) call rmvs_step_out(cb, pl, tp, system, param, t, dt) tp%lmask(1:ntp) = .not. tp%lmask(1:ntp) - call pl%set_beg_end(xbeg = xbeg, xend = xend) + call pl%set_beg_end(rbeg = rbeg, xend = xend) tp%lfirst = .true. call tp%step(system, param, t, dt) tp%lmask(1:ntp) = .true. @@ -185,7 +185,7 @@ subroutine rmvs_step_out(cb, pl, tp, system, param, t, dt) call pl%set_renc(RHPSCALE) do outer_index = 1, NTENC outer_time = t + (outer_index - 1) * dto - call pl%set_beg_end(xbeg = pl%outer(outer_index - 1)%x(:, 1:npl), & + call pl%set_beg_end(rbeg = pl%outer(outer_index - 1)%x(:, 1:npl), & vbeg = pl%outer(outer_index - 1)%v(:, 1:npl), & xend = pl%outer(outer_index )%x(:, 1:npl)) lencounter = tp%encounter_check(param, system, dto) @@ -234,7 +234,7 @@ subroutine rmvs_interp_in(cb, pl, system, param, dt, outer_index) ! Internals integer(I4B) :: i, inner_index real(DP) :: frac, dntphenc - real(DP), dimension(:,:), allocatable :: xtmp, vtmp, xh_original, ah_original + real(DP), dimension(:,:), allocatable :: xtmp, vtmp, rh_original, ah_original real(DP), dimension(:), allocatable :: GMcb, dti integer(I4B), dimension(:), allocatable :: iflag @@ -258,7 +258,7 @@ subroutine rmvs_interp_in(cb, pl, system, param, dt, outer_index) vtmp(:, 1:npl) = pl%inner(0)%v(:, 1:npl) if ((param%loblatecb) .or. (param%ltides)) then - allocate(xh_original, source=pl%rh) + allocate(rh_original, source=pl%rh) allocate(ah_original, source=pl%ah) pl%rh(:, 1:npl) = xtmp(:, 1:npl) ! Temporarily replace heliocentric position with inner substep values to calculate the oblateness terms end if @@ -339,7 +339,7 @@ subroutine rmvs_interp_in(cb, pl, system, param, dt, outer_index) ! pl%inner(NTPHENC)%atide(:, 1:npl) = pl%atide(:, 1:npl) ! end if ! Put the planet positions and accelerations back into place - if (allocated(xh_original)) call move_alloc(xh_original, pl%rh) + if (allocated(rh_original)) call move_alloc(rh_original, pl%rh) if (allocated(ah_original)) call move_alloc(ah_original, pl%ah) end associate return @@ -389,7 +389,7 @@ subroutine rmvs_step_in(cb, pl, tp, param, outer_time, dto) lfirsttp = .true. do inner_index = 1, NTPHENC ! Integrate over the encounter region, using the "substitute" planetocentric systems at each level plenci%rh(:, 1:npl) = plenci%inner(inner_index - 1)%x(:, 1:npl) - call plenci%set_beg_end(xbeg = plenci%inner(inner_index - 1)%x, & + call plenci%set_beg_end(rbeg = plenci%inner(inner_index - 1)%x, & xend = plenci%inner(inner_index)%x) if (param%loblatecb) then @@ -403,7 +403,7 @@ subroutine rmvs_step_in(cb, pl, tp, param, outer_time, dto) call tpenci%step(planetocen_system, param, inner_time, dti) do j = 1, pl%nenc(i) - tpenci%xheliocentric(:, j) = tpenci%rh(:, j) + pl%inner(inner_index)%x(:,i) + tpenci%rheliocentric(:, j) = tpenci%rh(:, j) + pl%inner(inner_index)%x(:,i) end do inner_time = outer_time + j * dti call rmvs_peri_tp(tpenci, pl, inner_time, dti, .false., inner_index, i, param) @@ -464,8 +464,8 @@ subroutine rmvs_make_planetocentric(param, cb, pl, tp) ! Grab all the encountering test particles and convert them to a planetocentric frame tpenci%id(1:nenci) = pack(tp%id(1:ntp), encmask(1:ntp)) do j = 1, NDIM - tpenci%xheliocentric(j, 1:nenci) = pack(tp%rh(j,1:ntp), encmask(:)) - tpenci%rh(j, 1:nenci) = tpenci%xheliocentric(j, 1:nenci) - pl%inner(0)%x(j, i) + tpenci%rheliocentric(j, 1:nenci) = pack(tp%rh(j,1:ntp), encmask(:)) + tpenci%rh(j, 1:nenci) = tpenci%rheliocentric(j, 1:nenci) - pl%inner(0)%x(j, i) tpenci%vh(j, 1:nenci) = pack(tp%vh(j, 1:ntp), encmask(1:ntp)) - pl%inner(0)%v(j, i) end do tpenci%lperi(1:nenci) = pack(tp%lperi(1:ntp), encmask(1:ntp)) @@ -534,7 +534,7 @@ subroutine rmvs_peri_tp(tp, pl, t, dt, lfirst, inner_index, ipleP, param) ! Internals integer(I4B) :: i, id1, id2 real(DP) :: r2, mu, rhill2, vdotr, a, peri, capm, tperi, rpl - real(DP), dimension(NDIM) :: xh1, xh2, vh1, vh2 + real(DP), dimension(NDIM) :: rh1, rh2, vh1, vh2 rhill2 = pl%rhill(ipleP)**2 mu = pl%Gmass(ipleP) diff --git a/src/rmvs/rmvs_util.f90 b/src/rmvs/rmvs_util.f90 index eb31db53d..b62c3ad88 100644 --- a/src/rmvs/rmvs_util.f90 +++ b/src/rmvs/rmvs_util.f90 @@ -137,7 +137,7 @@ module subroutine rmvs_util_dealloc_tp(self) if (allocated(self%lperi)) deallocate(self%lperi) if (allocated(self%plperP)) deallocate(self%plperP) if (allocated(self%plencP)) deallocate(self%plencP) - if (allocated(self%xheliocentric)) deallocate(self%xheliocentric) + if (allocated(self%rheliocentric)) deallocate(self%rheliocentric) call self%cb_heliocentric%dealloc() call util_dealloc_tp(self) @@ -319,7 +319,7 @@ module subroutine rmvs_util_resize_tp(self, nnew) call util_resize(self%lperi, nnew) call util_resize(self%plperP, nnew) call util_resize(self%plencP, nnew) - call util_resize(self%xheliocentric, nnew) + call util_resize(self%rheliocentric, nnew) call util_resize_tp(self, nnew) @@ -399,7 +399,7 @@ module subroutine rmvs_util_sort_tp(self, sortby, ascending) call util_sort(direction * tp%plperP(1:ntp), ind) case("plencP") call util_sort(direction * tp%plencP(1:ntp), ind) - case("lperi", "cb_heliocentric", "xheliocentric", "index", "ipleP", "lplanetocentric") + case("lperi", "cb_heliocentric", "rheliocentric", "index", "ipleP", "lplanetocentric") write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' case default ! Look for components in the parent class (*NOTE whm_tp does not need its own sort method, so we go straight to the swiftest_tp method) call util_sort_tp(tp, sortby, ascending) @@ -451,7 +451,7 @@ module subroutine rmvs_util_sort_rearrange_tp(self, ind) call util_sort_rearrange(tp%lperi, ind, ntp) call util_sort_rearrange(tp%plperP, ind, ntp) call util_sort_rearrange(tp%plencP, ind, ntp) - call util_sort_rearrange(tp%xheliocentric, ind, ntp) + call util_sort_rearrange(tp%rheliocentric, ind, ntp) call util_sort_rearrange_tp(tp,ind) end associate diff --git a/src/setup/setup.f90 b/src/setup/setup.f90 index e95505b9b..ef8558aef 100644 --- a/src/setup/setup.f90 +++ b/src/setup/setup.f90 @@ -21,6 +21,10 @@ module subroutine setup_construct_system(system, param) class(swiftest_nbody_system), allocatable, intent(inout) :: system !! Swiftest system object class(swiftest_parameters), intent(inout) :: param !! Swiftest parameters + allocate(swiftest_storage(param%dump_cadence) :: param%system_history) + allocate(netcdf_parameters :: param%system_history%nc) + call param%system_history%reset() + select case(param%integrator) case (BS) write(*,*) 'Bulirsch-Stoer integrator not yet enabled' @@ -68,6 +72,34 @@ module subroutine setup_construct_system(system, param) allocate(symba_pltpenc :: system%pltpenc_list) allocate(symba_plplenc :: system%plplenc_list) allocate(symba_plplenc :: system%plplcollision_list) + + select type(param) + class is (symba_parameters) + if (param%lenc_save_trajectory .or. param%lenc_save_closest) then + allocate(encounter_storage :: param%encounter_history) + associate (encounter_history => param%encounter_history) + allocate(encounter_io_parameters :: encounter_history%nc) + call encounter_history%reset() + select type(nc => encounter_history%nc) + class is (encounter_io_parameters) + nc%file_number = param%iloop / param%dump_cadence + end select + end associate + end if + + if (param%lclose) then + allocate(collision_storage :: param%collision_history) + associate (collision_history => param%collision_history) + allocate(fraggle_io_parameters :: collision_history%nc) + call collision_history%reset() + select type(nc => collision_history%nc) + class is (fraggle_io_parameters) + nc%file_number = param%iloop / param%dump_cadence + end select + end associate + end if + end select + end select case (RINGMOONS) write(*,*) 'RINGMOONS-SyMBA integrator not yet enabled' @@ -76,6 +108,10 @@ module subroutine setup_construct_system(system, param) call util_exit(FAILURE) end select + + + + return end subroutine setup_construct_system @@ -91,7 +127,7 @@ module subroutine setup_finalize_system(self, param) class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters associate(system => self) - call param%nc%close() + call param%system_history%nc%close() end associate return @@ -195,7 +231,7 @@ module subroutine setup_body(self, n, param) allocate(self%mu(n)) allocate(self%rh(NDIM, n)) allocate(self%vh(NDIM, n)) - allocate(self%xb(NDIM, n)) + allocate(self%rb(NDIM, n)) allocate(self%vb(NDIM, n)) allocate(self%ah(NDIM, n)) allocate(self%ir3h(n)) @@ -225,7 +261,7 @@ module subroutine setup_body(self, n, param) self%mu(:) = 0.0_DP self%rh(:,:) = 0.0_DP self%vh(:,:) = 0.0_DP - self%xb(:,:) = 0.0_DP + self%rb(:,:) = 0.0_DP self%vb(:,:) = 0.0_DP self%ah(:,:) = 0.0_DP self%ir3h(:) = 0.0_DP diff --git a/src/symba/symba_collision.f90 b/src/symba/symba_collision.f90 index eb891eb23..67540bfa3 100644 --- a/src/symba/symba_collision.f90 +++ b/src/symba/symba_collision.f90 @@ -12,7 +12,7 @@ contains - module function symba_collision_casedisruption(system, param, colliders, frag) result(status) + module function symba_collision_casedisruption(system, param) result(status) !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton !! !! Create the fragments resulting from a non-catastrophic disruption collision @@ -21,8 +21,6 @@ module function symba_collision_casedisruption(system, param, colliders, frag) ! Arguments class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - class(fraggle_colliders), intent(inout) :: colliders !! Fraggle colliders object - class(fraggle_fragments), intent(inout) :: frag !! Fraggle fragmentation system object ! Result integer(I4B) :: status !! Status flag assigned to this outcome ! Internals @@ -30,57 +28,60 @@ module function symba_collision_casedisruption(system, param, colliders, frag) logical :: lfailure character(len=STRMAX) :: message - select case(frag%regime) - case(COLLRESOLVE_REGIME_DISRUPTION) - message = "Disruption between" - case(COLLRESOLVE_REGIME_SUPERCATASTROPHIC) - message = "Supercatastrophic disruption between" - end select - call symba_collision_collider_message(system%pl, colliders%idx, message) - call io_log_one_message(FRAGGLE_LOG_OUT, message) - - ! Collisional fragments will be uniformly distributed around the pre-impact barycenter - call frag%set_mass_dist(colliders, param) + associate(colliders => system%colliders, fragments => system%fragments) - ! Generate the position and velocity distributions of the fragments - call frag%generate_fragments(colliders, system, param, lfailure) - - if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "No fragment solution found, so treat as a pure hit-and-run") - status = ACTIVE - nfrag = 0 - select type(pl => system%pl) - class is (symba_pl) - pl%status(colliders%idx(:)) = status - pl%ldiscard(colliders%idx(:)) = .false. - pl%lcollision(colliders%idx(:)) = .false. - end select - else - ! Populate the list of new bodies - nfrag = frag%nbody - write(message, *) nfrag - call io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") - select case(frag%regime) + select case(fragments%regime) case(COLLRESOLVE_REGIME_DISRUPTION) - status = DISRUPTION - ibiggest = colliders%idx(maxloc(system%pl%Gmass(colliders%idx(:)), dim=1)) - frag%id(1) = system%pl%id(ibiggest) - frag%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] - param%maxid = frag%id(nfrag) + message = "Disruption between" case(COLLRESOLVE_REGIME_SUPERCATASTROPHIC) - status = SUPERCATASTROPHIC - frag%id(1:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag)] - param%maxid = frag%id(nfrag) + message = "Supercatastrophic disruption between" end select + call symba_collision_collider_message(system%pl, colliders%idx, message) + call io_log_one_message(FRAGGLE_LOG_OUT, message) - call symba_collision_mergeaddsub(system, param, colliders, frag, status) - end if + ! Collisional fragments will be uniformly distributed around the pre-impact barycenter + call fragments%set_mass_dist(colliders, param) + + ! Generate the position and velocity distributions of the fragments + call fragments%generate_fragments(colliders, system, param, lfailure) + + if (lfailure) then + call io_log_one_message(FRAGGLE_LOG_OUT, "No fragment solution found, so treat as a pure hit-and-run") + status = ACTIVE + nfrag = 0 + select type(pl => system%pl) + class is (symba_pl) + pl%status(colliders%idx(:)) = status + pl%ldiscard(colliders%idx(:)) = .false. + pl%lcollision(colliders%idx(:)) = .false. + end select + else + ! Populate the list of new bodies + nfrag = fragments%nbody + write(message, *) nfrag + call io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") + select case(fragments%regime) + case(COLLRESOLVE_REGIME_DISRUPTION) + status = DISRUPTION + ibiggest = colliders%idx(maxloc(system%pl%Gmass(colliders%idx(:)), dim=1)) + fragments%id(1) = system%pl%id(ibiggest) + fragments%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] + param%maxid = fragments%id(nfrag) + case(COLLRESOLVE_REGIME_SUPERCATASTROPHIC) + status = SUPERCATASTROPHIC + fragments%id(1:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag)] + param%maxid = fragments%id(nfrag) + end select + + call symba_collision_mergeaddsub(system, param, status) + end if + end associate return end function symba_collision_casedisruption - module function symba_collision_casehitandrun(system, param, colliders, frag) result(status) + module function symba_collision_casehitandrun(system, param) result(status) !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton !! !! Create the fragments resulting from a non-catastrophic hit-and-run collision @@ -89,8 +90,6 @@ module function symba_collision_casehitandrun(system, param, colliders, frag) r ! Arguments class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - class(fraggle_colliders), intent(inout) :: colliders !! Fraggle colliders object - class(fraggle_fragments), intent(inout) :: frag !! Fraggle fragmentation system object ! Result integer(I4B) :: status !! Status flag assigned to this outcom ! Internals @@ -98,60 +97,63 @@ module function symba_collision_casehitandrun(system, param, colliders, frag) r logical :: lpure character(len=STRMAX) :: message - message = "Hit and run between" - call symba_collision_collider_message(system%pl, colliders%idx, message) - call io_log_one_message(FRAGGLE_LOG_OUT, trim(adjustl(message))) + associate(colliders => system%colliders, fragments => system%fragments) + message = "Hit and run between" + call symba_collision_collider_message(system%pl, colliders%idx, message) + call io_log_one_message(FRAGGLE_LOG_OUT, trim(adjustl(message))) - if (colliders%mass(1) > colliders%mass(2)) then - jtarg = 1 - jproj = 2 - else - jtarg = 2 - jproj = 1 - end if + if (colliders%mass(1) > colliders%mass(2)) then + jtarg = 1 + jproj = 2 + else + jtarg = 2 + jproj = 1 + end if - if (frag%mass_dist(2) > 0.9_DP * colliders%mass(jproj)) then ! Pure hit and run, so we'll just keep the two bodies untouched - call io_log_one_message(FRAGGLE_LOG_OUT, "Pure hit and run. No new fragments generated.") - nfrag = 0 - lpure = .true. - else ! Imperfect hit and run, so we'll keep the largest body and destroy the other - lpure = .false. - call frag%set_mass_dist(colliders, param) + if (fragments%mass_dist(2) > 0.9_DP * colliders%mass(jproj)) then ! Pure hit and run, so we'll just keep the two bodies untouched + call io_log_one_message(FRAGGLE_LOG_OUT, "Pure hit and run. No new fragments generated.") + nfrag = 0 + lpure = .true. + else ! Imperfect hit and run, so we'll keep the largest body and destroy the other + lpure = .false. + call fragments%set_mass_dist(colliders, param) - ! Generate the position and velocity distributions of the fragments - call frag%generate_fragments(colliders, system, param, lpure) + ! Generate the position and velocity distributions of the fragments + call fragments%generate_fragments(colliders, system, param, lpure) - if (lpure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "Should have been a pure hit and run instead") - nfrag = 0 + if (lpure) then + call io_log_one_message(FRAGGLE_LOG_OUT, "Should have been a pure hit and run instead") + nfrag = 0 + else + nfrag = fragments%nbody + write(message, *) nfrag + call io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") + end if + end if + if (lpure) then ! Reset these bodies back to being active so that nothing further is done to them + status = HIT_AND_RUN_PURE + select type(pl => system%pl) + class is (symba_pl) + pl%status(colliders%idx(:)) = ACTIVE + pl%ldiscard(colliders%idx(:)) = .false. + pl%lcollision(colliders%idx(:)) = .false. + end select else - nfrag = frag%nbody - write(message, *) nfrag - call io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") + ibiggest = colliders%idx(maxloc(system%pl%Gmass(colliders%idx(:)), dim=1)) + fragments%id(1) = system%pl%id(ibiggest) + fragments%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] + param%maxid = fragments%id(nfrag) + status = HIT_AND_RUN_DISRUPT + call symba_collision_mergeaddsub(system, param, status) end if - end if - if (lpure) then ! Reset these bodies back to being active so that nothing further is done to them - status = HIT_AND_RUN_PURE - select type(pl => system%pl) - class is (symba_pl) - pl%status(colliders%idx(:)) = ACTIVE - pl%ldiscard(colliders%idx(:)) = .false. - pl%lcollision(colliders%idx(:)) = .false. - end select - else - ibiggest = colliders%idx(maxloc(system%pl%Gmass(colliders%idx(:)), dim=1)) - frag%id(1) = system%pl%id(ibiggest) - frag%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] - param%maxid = frag%id(nfrag) - status = HIT_AND_RUN_DISRUPT - call symba_collision_mergeaddsub(system, param, colliders, frag, status) - end if + + end associate return end function symba_collision_casehitandrun - module function symba_collision_casemerge(system, param, colliders, frag) result(status) + module function symba_collision_casemerge(system, param) result(status) !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton !! !! Merge massive bodies. @@ -163,8 +165,6 @@ module function symba_collision_casemerge(system, param, colliders, frag) resul ! Arguments class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - class(fraggle_colliders), intent(inout) :: colliders !! Fraggle colliders object - class(fraggle_fragments), intent(inout) :: frag !! Fraggle fragmentation system object ! Result integer(I4B) :: status !! Status flag assigned to this outcome ! Internals @@ -173,62 +173,63 @@ module function symba_collision_casemerge(system, param, colliders, frag) resul real(DP), dimension(NDIM) :: L_spin_new character(len=STRMAX) :: message - message = "Merging" - call symba_collision_collider_message(system%pl, colliders%idx, message) - call io_log_one_message(FRAGGLE_LOG_OUT, message) - - select type(pl => system%pl) - class is (symba_pl) + associate(colliders => system%colliders, fragments => system%fragments) + message = "Merging" + call symba_collision_collider_message(system%pl, colliders%idx, message) + call io_log_one_message(FRAGGLE_LOG_OUT, message) - call frag%set_mass_dist(colliders, param) - ibiggest = colliders%idx(maxloc(pl%Gmass(colliders%idx(:)), dim=1)) - frag%id(1) = pl%id(ibiggest) - frag%xb(:,1) = frag%xbcom(:) - frag%vb(:,1) = frag%vbcom(:) + select type(pl => system%pl) + class is (symba_pl) - if (param%lrotation) then - ! Conserve angular momentum by putting pre-impact orbital momentum into spin of the new body - L_spin_new(:) = colliders%L_orbit(:,1) + colliders%L_orbit(:,2) + colliders%L_spin(:,1) + colliders%L_spin(:,2) + call fragments%set_mass_dist(colliders, param) + ibiggest = colliders%idx(maxloc(pl%Gmass(colliders%idx(:)), dim=1)) + fragments%id(1) = pl%id(ibiggest) + fragments%rb(:,1) = fragments%rbcom(:) + fragments%vb(:,1) = fragments%vbcom(:) - ! Assume prinicpal axis rotation on 3rd Ip axis - frag%rot(:,1) = L_spin_new(:) / (frag%Ip(3,1) * frag%mass(1) * frag%radius(1)**2) - else ! If spin is not enabled, we will consider the lost pre-collision angular momentum as "escaped" and add it to our bookkeeping variable - param%Lescape(:) = param%Lescape(:) + colliders%L_orbit(:,1) + colliders%L_orbit(:,2) - end if + if (param%lrotation) then + ! Conserve angular momentum by putting pre-impact orbital momentum into spin of the new body + L_spin_new(:) = colliders%L_orbit(:,1) + colliders%L_orbit(:,2) + colliders%L_spin(:,1) + colliders%L_spin(:,2) - ! Keep track of the component of potential energy due to the pre-impact colliders%idx for book-keeping - pe = 0.0_DP - do j = 1, colliders%ncoll - do i = j + 1, colliders%ncoll - pe = pe - pl%Gmass(i) * pl%mass(j) / norm2(pl%xb(:, i) - pl%xb(:, j)) - end do - end do - system%Ecollisions = system%Ecollisions + pe - system%Euntracked = system%Euntracked - pe + ! Assume prinicpal axis rotation on 3rd Ip axis + fragments%rot(:,1) = L_spin_new(:) / (fragments%Ip(3,1) * fragments%mass(1) * fragments%radius(1)**2) + else ! If spin is not enabled, we will consider the lost pre-collision angular momentum as "escaped" and add it to our bookkeeping variable + param%Lescape(:) = param%Lescape(:) + colliders%L_orbit(:,1) + colliders%L_orbit(:,2) + end if - ! Update any encounter lists that have the removed bodies in them so that they instead point to the new - do k = 1, system%plplenc_list%nenc + ! Keep track of the component of potential energy due to the pre-impact colliders%idx for book-keeping + pe = 0.0_DP do j = 1, colliders%ncoll - i = colliders%idx(j) - if (i == ibiggest) cycle - if (system%plplenc_list%id1(k) == pl%id(i)) then - system%plplenc_list%id1(k) = pl%id(ibiggest) - system%plplenc_list%index1(k) = i - end if - if (system%plplenc_list%id2(k) == pl%id(i)) then - system%plplenc_list%id2(k) = pl%id(ibiggest) - system%plplenc_list%index2(k) = i - end if - if (system%plplenc_list%id1(k) == system%plplenc_list%id2(k)) system%plplenc_list%status(k) = INACTIVE + do i = j + 1, colliders%ncoll + pe = pe - pl%Gmass(i) * pl%mass(j) / norm2(pl%rb(:, i) - pl%rb(:, j)) + end do + end do + system%Ecollisions = system%Ecollisions + pe + system%Euntracked = system%Euntracked - pe + + ! Update any encounter lists that have the removed bodies in them so that they instead point to the new + do k = 1, system%plplenc_list%nenc + do j = 1, colliders%ncoll + i = colliders%idx(j) + if (i == ibiggest) cycle + if (system%plplenc_list%id1(k) == pl%id(i)) then + system%plplenc_list%id1(k) = pl%id(ibiggest) + system%plplenc_list%index1(k) = i + end if + if (system%plplenc_list%id2(k) == pl%id(i)) then + system%plplenc_list%id2(k) = pl%id(ibiggest) + system%plplenc_list%index2(k) = i + end if + if (system%plplenc_list%id1(k) == system%plplenc_list%id2(k)) system%plplenc_list%status(k) = INACTIVE + end do end do - end do - - status = MERGED - - call symba_collision_mergeaddsub(system, param, colliders, frag, status) - end select + status = MERGED + + call symba_collision_mergeaddsub(system, param, status) + end select + end associate return end function symba_collision_casemerge @@ -261,7 +262,7 @@ subroutine symba_collision_collider_message(pl, collidx, collider_message) end subroutine symba_collision_collider_message - module function symba_collision_check_encounter(self, system, param, t, dt, irec) result(lany_collision) + module subroutine symba_collision_check_encounter(self, system, param, t, dt, irec, lany_collision) !! author: David A. Minton !! !! Check for merger between massive bodies and test particles in SyMBA @@ -273,18 +274,17 @@ module function symba_collision_check_encounter(self, system, param, t, dt, irec ! Arguments class(symba_encounter), intent(inout) :: self !! SyMBA pl-tp encounter list object class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters real(DP), intent(in) :: t !! current time real(DP), intent(in) :: dt !! step size integer(I4B), intent(in) :: irec !! Current recursion level - ! Result - logical :: lany_collision !! Returns true if cany pair of encounters resulted in a collision + logical, intent(out) :: lany_collision !! Returns true if cany pair of encounters resulted in a collision ! Internals logical, dimension(:), allocatable :: lcollision, lmask real(DP), dimension(NDIM) :: xr, vr integer(I4B) :: i, j, k, nenc real(DP) :: rlim, Gmtot - logical :: isplpl + logical :: isplpl, lany_closest character(len=STRMAX) :: timestr, idstri, idstrj, message class(symba_encounter), allocatable :: tmp @@ -302,101 +302,112 @@ module function symba_collision_check_encounter(self, system, param, t, dt, irec class is (symba_pl) select type(tp => system%tp) class is (symba_tp) - nenc = self%nenc - allocate(lmask(nenc)) - lmask(:) = ((self%status(1:nenc) == ACTIVE) .and. (pl%levelg(self%index1(1:nenc)) >= irec)) - if (isplpl) then - lmask(:) = lmask(:) .and. (pl%levelg(self%index2(1:nenc)) >= irec) - else - lmask(:) = lmask(:) .and. (tp%levelg(self%index2(1:nenc)) >= irec) - end if - if (.not.any(lmask(:))) return - - allocate(lcollision(nenc)) - lcollision(:) = .false. - - if (isplpl) then - do concurrent(k = 1:nenc, lmask(k)) - i = self%index1(k) - j = self%index2(k) - xr(:) = pl%rh(:, i) - pl%rh(:, j) - vr(:) = pl%vb(:, i) - pl%vb(:, j) - rlim = pl%radius(i) + pl%radius(j) - Gmtot = pl%Gmass(i) + pl%Gmass(j) - lcollision(k) = symba_collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), & - Gmtot, rlim, dt, self%lvdotr(k)) - end do - else - do concurrent(k = 1:nenc, lmask(k)) - i = self%index1(k) - j = self%index2(k) - xr(:) = pl%rh(:, i) - tp%rh(:, j) - vr(:) = pl%vb(:, i) - tp%vb(:, j) - lcollision(k) = symba_collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), & - pl%Gmass(i), pl%radius(i), dt, self%lvdotr(k)) - end do - end if + select type (param) + class is (symba_parameters) + nenc = self%nenc + allocate(lmask(nenc)) + lmask(:) = ((self%status(1:nenc) == ACTIVE) .and. (pl%levelg(self%index1(1:nenc)) >= irec)) + if (isplpl) then + lmask(:) = lmask(:) .and. (pl%levelg(self%index2(1:nenc)) >= irec) + else + lmask(:) = lmask(:) .and. (tp%levelg(self%index2(1:nenc)) >= irec) + end if + if (.not.any(lmask(:))) return + + allocate(lcollision(nenc)) + lcollision(:) = .false. + self%lclosest(:) = .false. + + if (isplpl) then + do concurrent(k = 1:nenc, lmask(k)) + i = self%index1(k) + j = self%index2(k) + xr(:) = pl%rh(:, i) - pl%rh(:, j) + vr(:) = pl%vb(:, i) - pl%vb(:, j) + rlim = pl%radius(i) + pl%radius(j) + Gmtot = pl%Gmass(i) + pl%Gmass(j) + call symba_collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), Gmtot, rlim, dt, self%lvdotr(k), lcollision(k), self%lclosest(k)) + end do + else + do concurrent(k = 1:nenc, lmask(k)) + i = self%index1(k) + j = self%index2(k) + xr(:) = pl%rh(:, i) - tp%rh(:, j) + vr(:) = pl%vb(:, i) - tp%vb(:, j) + call symba_collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), pl%Gmass(i), pl%radius(i), dt, self%lvdotr(k), lcollision(k), self%lclosest(k)) + end do + end if + + lany_collision = any(lcollision(:)) + lany_closest = (param%lenc_save_closest .and. any(self%lclosest(:))) + - lany_collision = any(lcollision(:)) - if (lany_collision) then - call pl%xh2xb(system%cb) ! Update the central body barycenteric position vector to get us out of DH and into bary - do k = 1, nenc - i = self%index1(k) - j = self%index2(k) - if (lcollision(k)) self%status(k) = COLLISION - self%tcollision(k) = t - self%x1(:,k) = pl%rh(:,i) + system%cb%xb(:) - self%v1(:,k) = pl%vb(:,i) - if (isplpl) then - self%x2(:,k) = pl%rh(:,j) + system%cb%xb(:) - self%v2(:,k) = pl%vb(:,j) + if (lany_collision .or. lany_closest) then + call pl%rh2rb(system%cb) ! Update the central body barycenteric position vector to get us out of DH and into bary + do k = 1, nenc + if (.not.lcollision(k) .and. .not. self%lclosest(k)) cycle + i = self%index1(k) + j = self%index2(k) + self%r1(:,k) = pl%rh(:,i) + system%cb%rb(:) + self%v1(:,k) = pl%vb(:,i) if (lcollision(k)) then - ! Check to see if either of these bodies has been involved with a collision before, and if so, make this a collisional colliders%idx - if (pl%lcollision(i) .or. pl%lcollision(j)) call pl%make_colliders([i,j]) - - ! Set the collision flag for these to bodies to true in case they become involved in another collision later in the step - pl%lcollision([i, j]) = .true. - pl%status([i, j]) = COLLISION - call pl%info(i)%set_value(status="COLLISION", discard_time=t, discard_rh=pl%rh(:,i), discard_vh=pl%vh(:,i)) - call pl%info(j)%set_value(status="COLLISION", discard_time=t, discard_rh=pl%rh(:,j), discard_vh=pl%vh(:,j)) + self%status(k) = COLLISION + self%tcollision(k) = t end if - else - self%x2(:,k) = tp%rh(:,j) + system%cb%xb(:) - self%v2(:,k) = tp%vb(:,j) - if (lcollision(k)) then - tp%status(j) = DISCARDED_PLR - tp%ldiscard(j) = .true. - write(idstri, *) pl%id(i) - write(idstrj, *) tp%id(j) - write(timestr, *) t - call tp%info(j)%set_value(status="DISCARDED_PLR", discard_time=t, discard_rh=tp%rh(:,j), discard_vh=tp%vh(:,j)) - write(message, *) "Particle " // trim(adjustl(tp%info(j)%name)) // " (" // trim(adjustl(idstrj)) // ")" & - // " collided with massive body " // trim(adjustl(pl%info(i)%name)) // " (" // trim(adjustl(idstri)) // ")" & - // " at t = " // trim(adjustl(timestr)) - call io_log_one_message(FRAGGLE_LOG_OUT, message) + if (isplpl) then + self%r2(:,k) = pl%rh(:,j) + system%cb%rb(:) + self%v2(:,k) = pl%vb(:,j) + if (lcollision(k)) then + ! Check to see if either of these bodies has been involved with a collision before, and if so, make this a collider pair + if (pl%lcollision(i) .or. pl%lcollision(j)) call pl%make_colliders([i,j]) + + ! Set the collision flag for these to bodies to true in case they become involved in another collision later in the step + pl%lcollision([i, j]) = .true. + pl%status([i, j]) = COLLISION + call pl%info(i)%set_value(status="COLLISION", discard_time=t, discard_rh=pl%rh(:,i), discard_vh=pl%vh(:,i)) + call pl%info(j)%set_value(status="COLLISION", discard_time=t, discard_rh=pl%rh(:,j), discard_vh=pl%vh(:,j)) + end if + else + self%r2(:,k) = tp%rh(:,j) + system%cb%rb(:) + self%v2(:,k) = tp%vb(:,j) + if (lcollision(k)) then + tp%status(j) = DISCARDED_PLR + tp%ldiscard(j) = .true. + write(idstri, *) pl%id(i) + write(idstrj, *) tp%id(j) + write(timestr, *) t + call tp%info(j)%set_value(status="DISCARDED_PLR", discard_time=t, discard_rh=tp%rh(:,j), discard_vh=tp%vh(:,j)) + write(message, *) "Particle " // trim(adjustl(tp%info(j)%name)) // " (" // trim(adjustl(idstrj)) // ")" & + // " collided with massive body " // trim(adjustl(pl%info(i)%name)) // " (" // trim(adjustl(idstri)) // ")" & + // " at t = " // trim(adjustl(timestr)) + call io_log_one_message(FRAGGLE_LOG_OUT, message) + end if end if - end if - end do - end if - end select - end select + end do + + ! Extract the pl-pl or pl-tp encounter list and return the pl-pl or pl-tp collision_list + select type(self) + class is (symba_plplenc) + call self%extract_collisions(system, param) + class is (symba_pltpenc) + allocate(tmp, mold=self) + call self%spill(tmp, lcollision, ldestructive=.true.) ! Remove this encounter pair from the encounter list + end select + end if + + ! Take snapshots of pairs of bodies at close approach (but not collision) if requested + if (lany_closest) call param%encounter_history%take_snapshot(param, system, t, "closest") + + end select - ! Extract the pl-pl or pl-tp encounter list and return the pl-pl or pl-tp collision_list - if (lany_collision) then - select type(self) - class is (symba_plplenc) - call self%extract_collisions(system, param) - class default - allocate(tmp, mold=self) - call self%spill(tmp, lcollision, ldestructive=.true.) ! Remove this encounter pair from the encounter list end select - end if + end select return - end function symba_collision_check_encounter + end subroutine symba_collision_check_encounter - pure elemental function symba_collision_check_one(xr, yr, zr, vxr, vyr, vzr, Gmtot, rlim, dt, lvdotr) result(lcollision) + pure elemental subroutine symba_collision_check_one(xr, yr, zr, vxr, vyr, vzr, Gmtot, rlim, dt, lvdotr, lcollision, lclosest) !! author: David A. Minton !! !! Check for a merger between a single pair of particles @@ -412,14 +423,14 @@ pure elemental function symba_collision_check_one(xr, yr, zr, vxr, vyr, vzr, Gmt real(DP), intent(in) :: rlim !! Collision limit - Typically the sum of the radii of colliding bodies real(DP), intent(in) :: dt !! Step size logical, intent(in) :: lvdotr !! Logical flag indicating that these two bodies are approaching in the current substep - ! Result - logical :: lcollision !! Logical flag indicating whether these two bodies will collide or not + logical, intent(out) :: lcollision !! Logical flag indicating whether these two bodies will collide or not + logical, intent(out) :: lclosest !! Logical flag indicating that, while not a collision, this is the closest approach for this pair of bodies ! Internals real(DP) :: r2, rlim2, a, e, q, vdotr, tcr2, dt2 r2 = xr**2 + yr**2 + zr**2 rlim2 = rlim**2 - + lclosest = .false. if (r2 <= rlim2) then ! checks if bodies are actively colliding in this time step lcollision = .true. else ! if they are not actively colliding in this time step, checks if they are going to collide next time step based on velocities and q @@ -432,11 +443,12 @@ pure elemental function symba_collision_check_one(xr, yr, zr, vxr, vyr, vzr, Gmt call orbel_xv2aeq(Gmtot, xr, yr, zr, vxr, vyr, vzr, a, e, q) lcollision = (q < rlim) end if + lclosest = .not. lcollision end if end if return - end function symba_collision_check_one + end subroutine symba_collision_check_one function symba_collision_consolidate_colliders(pl, cb, param, idx_parent, colliders) result(lflag) @@ -493,7 +505,6 @@ function symba_collision_consolidate_colliders(pl, cb, param, idx_parent, collid associate(idx_arr => parent_child_index_array(j)%idx, & id_arr => parent_child_index_array(j)%id, & ncj => nchild(j), & - pl => pl, & plkinj => pl%kin(idx_parent(j))) idx_arr(1) = idx_parent(j) if (ncj > 0) idx_arr(2:ncj + 1) = plkinj%child(1:ncj) @@ -513,7 +524,7 @@ function symba_collision_consolidate_colliders(pl, cb, param, idx_parent, collid ! Find the barycenter of each body along with its children, if it has any do j = 1, 2 - colliders%xb(:, j) = pl%rh(:, idx_parent(j)) + cb%xb(:) + colliders%rb(:, j) = pl%rh(:, idx_parent(j)) + cb%rb(:) colliders%vb(:, j) = pl%vb(:, idx_parent(j)) ! Assume principal axis rotation about axis corresponding to highest moment of inertia (3rd Ip) if (param%lrotation) then @@ -526,16 +537,16 @@ function symba_collision_consolidate_colliders(pl, cb, param, idx_parent, collid idx_child = parent_child_index_array(j)%idx(i + 1) if (.not. pl%lcollision(idx_child)) cycle mchild = pl%mass(idx_child) - xchild(:) = pl%rh(:, idx_child) + cb%xb(:) + xchild(:) = pl%rh(:, idx_child) + cb%rb(:) vchild(:) = pl%vb(:, idx_child) volchild = (4.0_DP / 3.0_DP) * PI * pl%radius(idx_child)**3 volume(j) = volume(j) + volchild ! Get angular momentum of the child-parent pair and add that to the spin ! Add the child's spin if (param%lrotation) then - xcom(:) = (colliders%mass(j) * colliders%xb(:,j) + mchild * xchild(:)) / (colliders%mass(j) + mchild) + xcom(:) = (colliders%mass(j) * colliders%rb(:,j) + mchild * xchild(:)) / (colliders%mass(j) + mchild) vcom(:) = (colliders%mass(j) * colliders%vb(:,j) + mchild * vchild(:)) / (colliders%mass(j) + mchild) - xc(:) = colliders%xb(:, j) - xcom(:) + xc(:) = colliders%rb(:, j) - xcom(:) vc(:) = colliders%vb(:, j) - vcom(:) xcrossv(:) = xc(:) .cross. vc(:) colliders%L_spin(:, j) = colliders%L_spin(:, j) + colliders%mass(j) * xcrossv(:) @@ -553,7 +564,7 @@ function symba_collision_consolidate_colliders(pl, cb, param, idx_parent, collid ! Merge the child and parent colliders%mass(j) = colliders%mass(j) + mchild - colliders%xb(:, j) = xcom(:) + colliders%rb(:, j) = xcom(:) colliders%vb(:, j) = vcom(:) end do end if @@ -563,10 +574,10 @@ function symba_collision_consolidate_colliders(pl, cb, param, idx_parent, collid end do lflag = .true. - xcom(:) = (colliders%mass(1) * colliders%xb(:, 1) + colliders%mass(2) * colliders%xb(:, 2)) / sum(colliders%mass(:)) + xcom(:) = (colliders%mass(1) * colliders%rb(:, 1) + colliders%mass(2) * colliders%rb(:, 2)) / sum(colliders%mass(:)) vcom(:) = (colliders%mass(1) * colliders%vb(:, 1) + colliders%mass(2) * colliders%vb(:, 2)) / sum(colliders%mass(:)) - mxc(:, 1) = colliders%mass(1) * (colliders%xb(:, 1) - xcom(:)) - mxc(:, 2) = colliders%mass(2) * (colliders%xb(:, 2) - xcom(:)) + mxc(:, 1) = colliders%mass(1) * (colliders%rb(:, 1) - xcom(:)) + mxc(:, 2) = colliders%mass(2) * (colliders%rb(:, 2) - xcom(:)) vcc(:, 1) = colliders%vb(:, 1) - vcom(:) vcc(:, 2) = colliders%vb(:, 2) - vcom(:) colliders%L_orbit(:,:) = mxc(:,:) .cross. vcc(:,:) @@ -578,7 +589,7 @@ function symba_collision_consolidate_colliders(pl, cb, param, idx_parent, collid end function symba_collision_consolidate_colliders - module subroutine symba_collision_encounter_extract_collisions(self, system, param) + module subroutine symba_collision_extract_collisions_from_encounters(self, system, param) !! author: David A. Minton !! !! Processes the pl-pl encounter list remove only those encounters that led to a collision @@ -644,7 +655,7 @@ module subroutine symba_collision_encounter_extract_collisions(self, system, par end select return - end subroutine symba_collision_encounter_extract_collisions + end subroutine symba_collision_extract_collisions_from_encounters module subroutine symba_collision_make_colliders_pl(self, idx) @@ -708,7 +719,7 @@ module subroutine symba_collision_make_colliders_pl(self, idx) end subroutine symba_collision_make_colliders_pl - subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) + subroutine symba_collision_mergeaddsub(system, param, status) !! author: David A. Minton !! !! Fills the pl_discards and pl_adds with removed and added bodies @@ -717,8 +728,6 @@ subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) ! Arguments class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - class(fraggle_colliders), intent(inout) :: colliders !! Fraggle colliders object - class(fraggle_fragments), intent(inout) :: frag !! Fraggle fragmentation system object integer(I4B), intent(in) :: status !! Status flag to assign to adds ! Internals integer(I4B) :: i, ibiggest, ismallest, iother, nstart, nend, ncolliders, nfrag @@ -731,10 +740,10 @@ subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) class is (symba_pl) select type(pl_discards => system%pl_discards) class is (symba_merger) - associate(info => pl%info, pl_adds => system%pl_adds, cb => system%cb, npl => pl%nbody) + associate(info => pl%info, pl_adds => system%pl_adds, cb => system%cb, npl => pl%nbody, colliders => system%colliders, fragments => system%fragments) ! Add the colliders%idx bodies to the subtraction list ncolliders = colliders%ncoll - nfrag = frag%nbody + nfrag = fragments%nbody param%maxid_collision = max(param%maxid_collision, maxval(system%pl%info(:)%collision_id)) param%maxid_collision = param%maxid_collision + 1 @@ -746,26 +755,26 @@ subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) ismallest = colliders%idx(minloc(pl%Gmass(colliders%idx(:)), dim=1)) ! Copy over identification, information, and physical properties of the new bodies from the fragment list - plnew%id(1:nfrag) = frag%id(1:nfrag) - plnew%xb(:, 1:nfrag) = frag%xb(:, 1:nfrag) - plnew%vb(:, 1:nfrag) = frag%vb(:, 1:nfrag) + plnew%id(1:nfrag) = fragments%id(1:nfrag) + plnew%rb(:, 1:nfrag) = fragments%rb(:, 1:nfrag) + plnew%vb(:, 1:nfrag) = fragments%vb(:, 1:nfrag) call pl%vb2vh(cb) - call pl%xh2xb(cb) + call pl%rh2rb(cb) do i = 1, nfrag - plnew%rh(:,i) = frag%xb(:, i) - cb%xb(:) - plnew%vh(:,i) = frag%vb(:, i) - cb%vb(:) + plnew%rh(:,i) = fragments%rb(:, i) - cb%rb(:) + plnew%vh(:,i) = fragments%vb(:, i) - cb%vb(:) end do - plnew%mass(1:nfrag) = frag%mass(1:nfrag) - plnew%Gmass(1:nfrag) = param%GU * frag%mass(1:nfrag) - plnew%radius(1:nfrag) = frag%radius(1:nfrag) - plnew%density(1:nfrag) = frag%mass(1:nfrag) / frag%radius(1:nfrag) + plnew%mass(1:nfrag) = fragments%mass(1:nfrag) + plnew%Gmass(1:nfrag) = param%GU * fragments%mass(1:nfrag) + plnew%radius(1:nfrag) = fragments%radius(1:nfrag) + plnew%density(1:nfrag) = fragments%mass(1:nfrag) / fragments%radius(1:nfrag) call plnew%set_rhill(cb) select case(status) case(SUPERCATASTROPHIC) plnew%status(1:nfrag) = NEW_PARTICLE do i = 1, nfrag - write(newname, FRAGFMT) frag%id(i) + write(newname, FRAGFMT) fragments%id(i) call plnew%info(i)%set_value(origin_type="Supercatastrophic", origin_time=system%t, name=newname, & origin_rh=plnew%rh(:,i), origin_vh=plnew%vh(:,i), & collision_id=param%maxid_collision) @@ -789,7 +798,7 @@ subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) call plnew%info(1)%copy(pl%info(ibiggest)) plnew%status(1) = OLD_PARTICLE do i = 2, nfrag - write(newname, FRAGFMT) frag%id(i) + write(newname, FRAGFMT) fragments%id(i) call plnew%info(i)%set_value(origin_type=origin_type, origin_time=system%t, name=newname, & origin_rh=plnew%rh(:,i), origin_vh=plnew%vh(:,i), & collision_id=param%maxid_collision) @@ -814,8 +823,8 @@ subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) end select if (param%lrotation) then - plnew%Ip(:, 1:nfrag) = frag%Ip(:, 1:nfrag) - plnew%rot(:, 1:nfrag) = frag%rot(:, 1:nfrag) + plnew%Ip(:, 1:nfrag) = fragments%Ip(:, 1:nfrag) + plnew%rot(:, 1:nfrag) = fragments%rot(:, 1:nfrag) end if ! if (param%ltides) then @@ -832,6 +841,7 @@ subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) ! Log the properties of the new bodies call fraggle_io_log_pl(plnew, param) + allocate(system%fragments%pl, source=plnew) ! Append the new merged body to the list nstart = pl_adds%nbody + 1 @@ -870,7 +880,7 @@ subroutine symba_collision_mergeaddsub(system, param, colliders, frag, status) end subroutine symba_collision_mergeaddsub - module subroutine symba_collision_resolve_fragmentations(self, system, param) + module subroutine symba_resolve_collision_fragmentations(self, system, param) !! author: David A. Minton !! !! Process list of collisions, determine the collisional regime, and then create fragments. @@ -885,43 +895,46 @@ module subroutine symba_collision_resolve_fragmentations(self, system, param) integer(I4B), dimension(2) :: idx_parent !! Index of the two bodies considered the "parents" of the collision logical :: lgoodcollision integer(I4B) :: i - type(fraggle_colliders) :: colliders !! Fraggle colliders object - type(fraggle_fragments) :: frag !! Fraggle fragmentation system object - associate(plplcollision_list => self, ncollisions => self%nenc, idx1 => self%index1, idx2 => self%index2) + associate(plplcollision_list => self, ncollisions => self%nenc, idx1 => self%index1, idx2 => self%index2, t => system%t, collision_history => param%collision_history) select type(pl => system%pl) class is (symba_pl) select type (cb => system%cb) class is (symba_cb) do i = 1, ncollisions + allocate(fraggle_colliders :: system%colliders) + allocate(fraggle_fragments :: system%fragments) idx_parent(1) = pl%kin(idx1(i))%parent idx_parent(2) = pl%kin(idx2(i))%parent - lgoodcollision = symba_collision_consolidate_colliders(pl, cb, param, idx_parent, colliders) + lgoodcollision = symba_collision_consolidate_colliders(pl, cb, param, idx_parent, system%colliders) if ((.not. lgoodcollision) .or. any(pl%status(idx_parent(:)) /= COLLISION)) cycle - call colliders%regime(frag, system, param) - - select case (frag%regime) + call system%colliders%regime(system%fragments, system, param) + + if (param%lenc_save_trajectory) call collision_history%take_snapshot(param,system, t, "before") + select case (system%fragments%regime) case (COLLRESOLVE_REGIME_DISRUPTION, COLLRESOLVE_REGIME_SUPERCATASTROPHIC) - plplcollision_list%status(i) = symba_collision_casedisruption(system, param, colliders, frag) + plplcollision_list%status(i) = symba_collision_casedisruption(system, param) case (COLLRESOLVE_REGIME_HIT_AND_RUN) - plplcollision_list%status(i) = symba_collision_casehitandrun(system, param, colliders, frag) + plplcollision_list%status(i) = symba_collision_casehitandrun(system, param) case (COLLRESOLVE_REGIME_MERGE, COLLRESOLVE_REGIME_GRAZE_AND_MERGE) - plplcollision_list%status(i) = symba_collision_casemerge(system, param, colliders, frag) + plplcollision_list%status(i) = symba_collision_casemerge(system, param) case default write(*,*) "Error in symba_collision, unrecognized collision regime" call util_exit(FAILURE) end select + if (param%lenc_save_trajectory) call collision_history%take_snapshot(param,system, t, "after") + deallocate(system%colliders,system%fragments) end do end select end select end associate return - end subroutine symba_collision_resolve_fragmentations + end subroutine symba_resolve_collision_fragmentations - module subroutine symba_collision_resolve_mergers(self, system, param) + module subroutine symba_resolve_collision_mergers(self, system, param) !! author: David A. Minton !! !! Process list of collisions and merge colliding bodies together. @@ -935,10 +948,8 @@ module subroutine symba_collision_resolve_mergers(self, system, param) integer(I4B), dimension(2) :: idx_parent !! Index of the two bodies considered the "parents" of the collision logical :: lgoodcollision integer(I4B) :: i - type(fraggle_colliders) :: colliders !! Fraggle colliders object - type(fraggle_fragments) :: frag !! Fraggle fragmentation system object - associate(plplcollision_list => self, ncollisions => self%nenc, idx1 => self%index1, idx2 => self%index2) + associate(plplcollision_list => self, ncollisions => self%nenc, idx1 => self%index1, idx2 => self%index2, fragments => system%fragments, colliders => system%colliders) select type(pl => system%pl) class is (symba_pl) select type(cb => system%cb) @@ -950,24 +961,24 @@ module subroutine symba_collision_resolve_mergers(self, system, param) if (.not. lgoodcollision) cycle if (any(pl%status(idx_parent(:)) /= COLLISION)) cycle ! One of these two bodies has already been resolved - frag%regime = COLLRESOLVE_REGIME_MERGE - frag%mtot = sum(colliders%mass(:)) - frag%mass_dist(1) = frag%mtot - frag%mass_dist(2) = 0.0_DP - frag%mass_dist(3) = 0.0_DP - frag%xbcom(:) = (colliders%mass(1) * colliders%xb(:,1) + colliders%mass(2) * colliders%xb(:,2)) / frag%mtot - frag%vbcom(:) = (colliders%mass(1) * colliders%vb(:,1) + colliders%mass(2) * colliders%vb(:,2)) / frag%mtot - plplcollision_list%status(i) = symba_collision_casemerge(system, param, colliders, frag) + fragments%regime = COLLRESOLVE_REGIME_MERGE + fragments%mtot = sum(colliders%mass(:)) + fragments%mass_dist(1) = fragments%mtot + fragments%mass_dist(2) = 0.0_DP + fragments%mass_dist(3) = 0.0_DP + fragments%rbcom(:) = (colliders%mass(1) * colliders%rb(:,1) + colliders%mass(2) * colliders%rb(:,2)) / fragments%mtot + fragments%vbcom(:) = (colliders%mass(1) * colliders%vb(:,1) + colliders%mass(2) * colliders%vb(:,2)) / fragments%mtot + plplcollision_list%status(i) = symba_collision_casemerge(system, param) end do end select end select end associate return - end subroutine symba_collision_resolve_mergers + end subroutine symba_resolve_collision_mergers - module subroutine symba_collision_resolve_plplenc(self, system, param, t, dt, irec) + module subroutine symba_resolve_collision_plplenc(self, system, param, t, dt, irec) !! author: David A. Minton !! !! Process the pl-pl collision list, then modifiy the massive bodies based on the outcome of the collision @@ -994,7 +1005,7 @@ module subroutine symba_collision_resolve_plplenc(self, system, param, t, dt, ir if (plplcollision_list%nenc == 0) return ! No collisions to resolve ! Make sure that the heliocentric and barycentric coordinates are consistent with each other call pl%vb2vh(system%cb) - call pl%xh2xb(system%cb) + call pl%rh2rb(system%cb) ! Get the energy before the collision is resolved if (param%lenergy) then @@ -1035,7 +1046,7 @@ module subroutine symba_collision_resolve_plplenc(self, system, param, t, dt, ir deallocate(tmp_param) ! Check whether or not any of the particles that were just added are themselves in a collision state. This will generate a new plplcollision_list - lplpl_collision = plplenc_list%collision_check(system, param, t, dt, irec) + call plplenc_list%collision_check(system, param, t, dt, irec, lplpl_collision) if (.not.lplpl_collision) exit end do @@ -1051,10 +1062,10 @@ module subroutine symba_collision_resolve_plplenc(self, system, param, t, dt, ir end associate return - end subroutine symba_collision_resolve_plplenc + end subroutine symba_resolve_collision_plplenc - module subroutine symba_collision_resolve_pltpenc(self, system, param, t, dt, irec) + module subroutine symba_resolve_collision_pltpenc(self, system, param, t, dt, irec) !! author: David A. Minton !! !! Process the pl-tp collision list, then modifiy the massive bodies based on the outcome of the collision @@ -1078,6 +1089,6 @@ module subroutine symba_collision_resolve_pltpenc(self, system, param, t, dt, ir call system%tp%discard(system, param) return - end subroutine symba_collision_resolve_pltpenc + end subroutine symba_resolve_collision_pltpenc end submodule s_symba_collision \ No newline at end of file diff --git a/src/symba/symba_discard.f90 b/src/symba/symba_discard.f90 index a380487f7..82741d695 100644 --- a/src/symba/symba_discard.f90 +++ b/src/symba/symba_discard.f90 @@ -74,7 +74,7 @@ subroutine symba_discard_cb_pl(pl, system, param) call pl%info(i)%set_value(status="DISCARDED_RMIN", discard_time=system%t, discard_rh=pl%rh(:,i), & discard_vh=pl%vh(:,i), discard_body_id=cb%id) else if (param%rmaxu >= 0.0_DP) then - rb2 = dot_product(pl%xb(:,i), pl%xb(:,i)) + rb2 = dot_product(pl%rb(:,i), pl%rb(:,i)) vb2 = dot_product(pl%vb(:,i), pl%vb(:,i)) energy = 0.5_DP * vb2 - system%Gmtot / sqrt(rb2) if ((energy > 0.0_DP) .and. (rb2 > rmaxu2)) then @@ -124,7 +124,7 @@ subroutine symba_discard_conserve_mtm(pl, system, param, ipl, lescape_body) class is (symba_cb) ! Add the potential and kinetic energy of the lost body to the records - pe = -cb%Gmass * pl%mass(ipl) / norm2(pl%xb(:, ipl) - cb%xb(:)) + pe = -cb%Gmass * pl%mass(ipl) / norm2(pl%rb(:, ipl) - cb%rb(:)) ke_orbit = 0.5_DP * pl%mass(ipl) * dot_product(pl%vb(:, ipl), pl%vb(:, ipl)) if (param%lrotation) then ke_spin = 0.5_DP * pl%mass(ipl) * pl%radius(ipl)**2 * pl%Ip(3, ipl) * dot_product(pl%rot(:, ipl), pl%rot(:, ipl)) @@ -138,15 +138,15 @@ subroutine symba_discard_conserve_mtm(pl, system, param, ipl, lescape_body) system%GMescape = system%GMescape + pl%Gmass(ipl) do i = 1, pl%nbody if (i == ipl) cycle - pe = pe - pl%Gmass(i) * pl%mass(ipl) / norm2(pl%xb(:, ipl) - pl%xb(:, i)) + pe = pe - pl%Gmass(i) * pl%mass(ipl) / norm2(pl%rb(:, ipl) - pl%rb(:, i)) end do Ltot(:) = 0.0_DP do i = 1, pl%nbody - Lpl(:) = pL%mass(i) * (pl%xb(:,i) .cross. pl%vb(:, i)) + Lpl(:) = pL%mass(i) * (pl%rb(:,i) .cross. pl%vb(:, i)) Ltot(:) = Ltot(:) + Lpl(:) end do - Ltot(:) = Ltot(:) + cb%mass * (cb%xb(:) .cross. cb%vb(:)) + Ltot(:) = Ltot(:) + cb%mass * (cb%rb(:) .cross. cb%vb(:)) call pl%b2h(cb) oldstat = pl%status(ipl) pl%status(ipl) = INACTIVE @@ -154,21 +154,21 @@ subroutine symba_discard_conserve_mtm(pl, system, param, ipl, lescape_body) pl%status(ipl) = oldstat do i = 1, pl%nbody if (i == ipl) cycle - Lpl(:) = pl%mass(i) * (pl%xb(:,i) .cross. pl%vb(:, i)) + Lpl(:) = pl%mass(i) * (pl%rb(:,i) .cross. pl%vb(:, i)) Ltot(:) = Ltot(:) - Lpl(:) end do - Ltot(:) = Ltot(:) - cb%mass * (cb%xb(:) .cross. cb%vb(:)) + Ltot(:) = Ltot(:) - cb%mass * (cb%rb(:) .cross. cb%vb(:)) system%Lescape(:) = system%Lescape(:) + Ltot(:) if (param%lrotation) system%Lescape(:) = system%Lescape + pl%mass(ipl) * pl%radius(ipl)**2 & * pl%Ip(3, ipl) * pl%rot(:, ipl) else - xcom(:) = (pl%mass(ipl) * pl%xb(:, ipl) + cb%mass * cb%xb(:)) / (cb%mass + pl%mass(ipl)) + xcom(:) = (pl%mass(ipl) * pl%rb(:, ipl) + cb%mass * cb%rb(:)) / (cb%mass + pl%mass(ipl)) vcom(:) = (pl%mass(ipl) * pl%vb(:, ipl) + cb%mass * cb%vb(:)) / (cb%mass + pl%mass(ipl)) - Lpl(:) = (pl%xb(:,ipl) - xcom(:)) .cross. (pL%vb(:,ipl) - vcom(:)) + Lpl(:) = (pl%rb(:,ipl) - xcom(:)) .cross. (pL%vb(:,ipl) - vcom(:)) if (param%lrotation) Lpl(:) = pl%mass(ipl) * (Lpl(:) + pl%radius(ipl)**2 * pl%Ip(3,ipl) * pl%rot(:, ipl)) - Lcb(:) = cb%mass * ((cb%xb(:) - xcom(:)) .cross. (cb%vb(:) - vcom(:))) + Lcb(:) = cb%mass * ((cb%rb(:) - xcom(:)) .cross. (cb%vb(:) - vcom(:))) ke_orbit = ke_orbit + 0.5_DP * cb%mass * dot_product(cb%vb(:), cb%vb(:)) if (param%lrotation) ke_spin = ke_spin + 0.5_DP * cb%mass * cb%radius**2 * cb%Ip(3) * dot_product(cb%rot(:), cb%rot(:)) @@ -186,7 +186,7 @@ subroutine symba_discard_conserve_mtm(pl, system, param, ipl, lescape_body) cb%rot(:) = (cb%L0(:) + cb%dL(:)) / (cb%Ip(3) * cb%mass * cb%radius**2) ke_spin = ke_spin - 0.5_DP * cb%mass * cb%radius**2 * cb%Ip(3) * dot_product(cb%rot(:), cb%rot(:)) end if - cb%xb(:) = xcom(:) + cb%rb(:) = xcom(:) cb%vb(:) = vcom(:) ke_orbit = ke_orbit - 0.5_DP * cb%mass * dot_product(cb%vb(:), cb%vb(:)) end if @@ -360,7 +360,7 @@ module subroutine symba_discard_pl(self, system, param) class is (symba_parameters) associate(pl => self, plplenc_list => system%plplenc_list, plplcollision_list => system%plplcollision_list) call pl%vb2vh(system%cb) - call pl%xh2xb(system%cb) + call pl%rh2rb(system%cb) !call plplenc_list%write(pl, pl, param) TODO: write the encounter list writer for NetCDF call symba_discard_nonplpl(self, system, param) diff --git a/src/symba/symba_encounter_check.f90 b/src/symba/symba_encounter_check.f90 index dd60f2e00..f53061b93 100644 --- a/src/symba/symba_encounter_check.f90 +++ b/src/symba/symba_encounter_check.f90 @@ -59,14 +59,15 @@ module function symba_encounter_check_pl(self, param, system, dt, irec) result(l if (lany_encounter) then do k = 1_I8B, nenc + plplenc_list%t = system%t i = plplenc_list%index1(k) j = plplenc_list%index2(k) plplenc_list%id1(k) = pl%id(i) plplenc_list%id2(k) = pl%id(j) plplenc_list%status(k) = ACTIVE plplenc_list%level(k) = irec - plplenc_list%x1(:,k) = pl%rh(:,i) - plplenc_list%x2(:,k) = pl%rh(:,j) + plplenc_list%r1(:,k) = pl%rh(:,i) + plplenc_list%r2(:,k) = pl%rh(:,j) plplenc_list%v1(:,k) = pl%vb(:,i) - cb%vb(:) plplenc_list%v2(:,k) = pl%vb(:,j) - cb%vb(:) pl%lencounter(i) = .true. diff --git a/src/symba/symba_io.f90 b/src/symba/symba_io.f90 index e790e1685..29f1c1fbe 100644 --- a/src/symba/symba_io.f90 +++ b/src/symba/symba_io.f90 @@ -11,6 +11,8 @@ use swiftest contains + + module subroutine symba_io_param_reader(self, unit, iotype, v_list, iostat, iomsg) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! @@ -66,9 +68,6 @@ module subroutine symba_io_param_reader(self, unit, iotype, v_list, iostat, ioms case ("ENCOUNTER_SAVE") call io_toupper(param_value) read(param_value, *) param%encounter_save - case ("FRAGMENTATION_SAVE") - call io_toupper(param_value) - read(param_value, *) param%fragmentation_save case("SEED") read(param_value, *) nseeds_from_file ! Because the number of seeds can vary between compilers/systems, we need to make sure we can handle cases in which the input file has a different @@ -119,21 +118,18 @@ module subroutine symba_io_param_reader(self, unit, iotype, v_list, iostat, ioms ! All reporting of collision information in SyMBA (including mergers) is now recorded in the Fraggle logfile call io_log_start(param, FRAGGLE_LOG_OUT, "Fraggle logfile") - if ((param%encounter_save /= "NONE") .and. (param%encounter_save /= "TRAJECTORY") .and. (param%encounter_save /= "CLOSEST")) then + if ((param%encounter_save /= "NONE") .and. & + (param%encounter_save /= "TRAJECTORY") .and. & + (param%encounter_save /= "CLOSEST") .and. & + (param%encounter_save /= "BOTH")) then write(iomsg,*) 'Invalid encounter_save parameter: ',trim(adjustl(param%out_type)) - write(iomsg,*) 'Valid options are NONE, TRAJECTORY, or CLOSEST' + write(iomsg,*) 'Valid options are NONE, TRAJECTORY, CLOSEST, or BOTH' iostat = -1 return end if - if ((param%fragmentation_save /= "NONE") .and. (param%fragmentation_save /= "TRAJECTORY") .and. (param%fragmentation_save /= "CLOSEST")) then - write(iomsg,*) 'Invalid fragmentation_save parameter: ',trim(adjustl(param%out_type)) - write(iomsg,*) 'Valid options are NONE, TRAJECTORY, or CLOSEST' - iostat = -1 - return - end if - param%lencounter_save = (param%encounter_save == "TRAJECTORY") .or. (param%encounter_save == "CLOSEST") .or. & - (param%fragmentation_save == "TRAJECTORY") .or. (param%fragmentation_save == "CLOSEST") + param%lenc_save_trajectory = (param%encounter_save == "TRAJECTORY") .or. (param%encounter_save == "BOTH") + param%lenc_save_closest = (param%encounter_save == "CLOSEST") .or. (param%encounter_save == "BOTH") ! Call the base method (which also prints the contents to screen) call io_param_reader(param, unit, iotype, v_list, iostat, iomsg) @@ -188,55 +184,6 @@ module subroutine symba_io_param_writer(self, unit, iotype, v_list, iostat, ioms end subroutine symba_io_param_writer - module subroutine symba_io_start_encounter(self, param, t) - !! author: David A. Minton - !! - !! Initializes the new encounter and/or fragmentation history - implicit none - ! Arguments - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - - if (.not. allocated(self%encounter_history)) then - allocate(encounter_storage :: self%encounter_history) - end if - call self%encounter_history%reset() - - ! Take the snapshot at the start of the encounter - call self%snapshot(param, t) - - return - end subroutine symba_io_start_encounter - - - module subroutine symba_io_stop_encounter(self, param, t) - !! author: David A. Minton - !! - !! Saves the encounter and/or fragmentation data to file(s) - implicit none - ! Arguments - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - ! Internals - integer(I4B) :: i - - ! Create and save the output file for this encounter - - self%encounter_history%nc%time_dimsize = maxval(self%encounter_history%tslot(:)) - - write(self%encounter_history%nc%enc_file, '("encounter_",I0.6,".nc")') param%iloop - - call self%encounter_history%nc%initialize(param) - call self%encounter_history%dump(param) - call self%encounter_history%nc%close() - call self%encounter_history%reset() - - return - end subroutine symba_io_stop_encounter - - module subroutine symba_io_write_discard(self, param) !! author: David A. Minton !! @@ -248,12 +195,12 @@ module subroutine symba_io_write_discard(self, param) associate(pl => self%pl, npl => self%pl%nbody, pl_adds => self%pl_adds) - if (self%tp_discards%nbody > 0) call self%tp_discards%write_info(param%nc, param) + if (self%tp_discards%nbody > 0) call self%tp_discards%write_info(param%system_history%nc, param) select type(pl_discards => self%pl_discards) class is (symba_merger) if (pl_discards%nbody == 0) return - call pl_discards%write_info(param%nc, param) + call pl_discards%write_info(param%system_history%nc, param) end select end associate diff --git a/src/symba/symba_kick.f90 b/src/symba/symba_kick.f90 index 114160f9a..cdad09045 100644 --- a/src/symba/symba_kick.f90 +++ b/src/symba/symba_kick.f90 @@ -129,7 +129,7 @@ module subroutine symba_kick_getacch_tp(self, system, param, t, lbeg) j = pltpenc_list%index2(k) if (tp%lmask(j)) then if (lbeg) then - dx(:) = tp%rh(:,j) - pl%xbeg(:,i) + dx(:) = tp%rh(:,j) - pl%rbeg(:,i) else dx(:) = tp%rh(:,j) - pl%xend(:,i) end if diff --git a/src/symba/symba_step.f90 b/src/symba/symba_step.f90 index e727ed9f3..68645d7b8 100644 --- a/src/symba/symba_step.f90 +++ b/src/symba/symba_step.f90 @@ -34,17 +34,19 @@ module subroutine symba_step_system(self, param, t, dt) class is (symba_tp) select type(param) class is (symba_parameters) - call self%reset(param) - lencounter = pl%encounter_check(param, self, dt, 0) .or. tp%encounter_check(param, self, dt, 0) - if (lencounter) then - if (param%lencounter_save) call self%start_encounter(param, t) - call self%interp(param, t, dt) - if (param%lencounter_save) call self%stop_encounter(param, t+dt) - else - self%irec = -1 - call helio_step_system(self, param, t, dt) - end if - param%lfirstkick = pl%lfirst + associate(encounter_history => param%encounter_history) + call self%reset(param) + lencounter = pl%encounter_check(param, self, dt, 0) .or. tp%encounter_check(param, self, dt, 0) + if (lencounter) then + if (param%lenc_save_trajectory) call encounter_history%take_snapshot(param, self, t, "trajectory") + call self%interp(param, t, dt) + if (param%lenc_save_trajectory) call encounter_history%take_snapshot(param, self, t+dt, "trajectory") + else + self%irec = -1 + call helio_step_system(self, param, t, dt) + end if + param%lfirstkick = pl%lfirst + end associate end select end select end select @@ -178,15 +180,17 @@ recursive module subroutine symba_step_recur_system(self, param, t, ireci) ! Internals integer(I4B) :: j, irecp, nloops real(DP) :: dtl, dth - logical :: lencounter, lplpl_collision, lpltp_collision - - associate(system => self, plplenc_list => self%plplenc_list, pltpenc_list => self%pltpenc_list) - select type(param) - class is (symba_parameters) - select type(pl => self%pl) - class is (symba_pl) - select type(tp => self%tp) - class is (symba_tp) + logical :: lencounter + + select type(param) + class is (symba_parameters) + select type(pl => self%pl) + class is (symba_pl) + select type(tp => self%tp) + class is (symba_tp) + associate(system => self, plplenc_list => self%plplenc_list, pltpenc_list => self%pltpenc_list, & + lplpl_collision => self%plplenc_list%lcollision, lpltp_collision => self%pltpenc_list%lcollision, & + encounter_history => param%encounter_history) system%irec = ireci dtl = param%dt / (NTENC**ireci) dth = 0.5_DP * dtl @@ -221,7 +225,7 @@ recursive module subroutine symba_step_recur_system(self, param, t, ireci) call pl%drift(system, param, dtl) call tp%drift(system, param, dtl) - if (lencounter) call system%recursive_step(param, t+dth,irecp) + if (lencounter) call system%recursive_step(param, t+(j-1)*dtl, irecp) system%irec = ireci if (param%lgr) then @@ -237,21 +241,21 @@ recursive module subroutine symba_step_recur_system(self, param, t, ireci) end if if (param%lclose) then - lplpl_collision = plplenc_list%collision_check(system, param, t+dtl, dtl, ireci) - lpltp_collision = pltpenc_list%collision_check(system, param, t+dtl, dtl, ireci) + call plplenc_list%collision_check(system, param, t+j*dtl, dtl, ireci, lplpl_collision) + call pltpenc_list%collision_check(system, param, t+j*dtl, dtl, ireci, lpltp_collision) - if (lplpl_collision) call plplenc_list%resolve_collision(system, param, t+dtl, dtl, ireci) - if (lpltp_collision) call pltpenc_list%resolve_collision(system, param, t+dtl, dtl, ireci) + if (lplpl_collision) call plplenc_list%resolve_collision(system, param, t+j*dtl, dtl, ireci) + if (lpltp_collision) call pltpenc_list%resolve_collision(system, param, t+j*dtl, dtl, ireci) end if - if (param%lencounter_save) call system%snapshot(param, t+dtl) + if (param%lenc_save_trajectory) call encounter_history%take_snapshot(param, self, t+j*dtl, "trajectory") call self%set_recur_levels(ireci) end do - end select + end associate end select end select - end associate + end select return end subroutine symba_step_recur_system @@ -295,6 +299,7 @@ module subroutine symba_step_reset_system(self, param) call pl%set_renc(0) call system%plplenc_list%setup(nenc_old) ! This resizes the pl-pl encounter list to be the same size as it was the last step, to decrease the number of potential resize operations that have to be one inside the step system%plplenc_list%nenc = 0 ! Sets the true number of encounters back to 0 after resizing + system%plplenc_list%lcollision = .false. end if nenc_old = system%pltpenc_list%nenc @@ -307,6 +312,7 @@ module subroutine symba_step_reset_system(self, param) tp%ldiscard(1:ntp) = .false. call system%pltpenc_list%setup(nenc_old)! This resizes the pl-tp encounter list to be the same size as it was the last step, to decrease the number of potential resize operations that have to be one inside the step system%pltpenc_list%nenc = 0 ! Sets the true number of encounters back to 0 after resizing + system%pltpenc_list%lcollision = .false. end if call system%pl_adds%setup(0, param) diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index d53bd442b..06d75bac8 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -204,6 +204,8 @@ module subroutine symba_util_dealloc_encounter_list(self) if (allocated(self%level)) deallocate(self%level) if (allocated(self%tcollision)) deallocate(self%tcollision) + call self%encounter_list%dealloc() + return end subroutine symba_util_dealloc_encounter_list @@ -232,7 +234,7 @@ module subroutine symba_util_dealloc_merger(self) if (allocated(self%ncomp)) deallocate(self%ncomp) - call symba_util_dealloc_pl(self) + call self%symba_pl%dealloc() return end subroutine symba_util_dealloc_merger @@ -266,7 +268,7 @@ module subroutine symba_util_dealloc_pl(self) deallocate(self%kin) end if - call util_dealloc_pl(self) + call self%helio_pl%dealloc() return end subroutine symba_util_dealloc_pl @@ -284,7 +286,7 @@ module subroutine symba_util_dealloc_tp(self) if (allocated(self%levelg)) deallocate(self%levelg) if (allocated(self%levelm)) deallocate(self%levelm) - call util_dealloc_tp(self) + call self%helio_tp%dealloc() return end subroutine symba_util_dealloc_tp @@ -532,7 +534,7 @@ module subroutine symba_util_peri_pl(self, system, param) else do i = 1, npl if (pl%status(i) == ACTIVE) then - vdotr = dot_product(pl%xb(:,i), pl%vb(:,i)) + vdotr = dot_product(pl%rb(:,i), pl%vb(:,i)) if (vdotr > 0.0_DP) then pl%isperi(i) = 1 else @@ -564,11 +566,11 @@ module subroutine symba_util_peri_pl(self, system, param) else do i = 1, npl if (pl%status(i) == ACTIVE) then - vdotr = dot_product(pl%xb(:,i), pl%vb(:,i)) + vdotr = dot_product(pl%rb(:,i), pl%vb(:,i)) if (pl%isperi(i) == -1) then if (vdotr >= 0.0_DP) then pl%isperi(i) = 0 - CALL orbel_xv2aeq(system%Gmtot, pl%xb(1,i), pl%xb(2,i), pl%xb(3,i), pl%vb(1,i), pl%vb(2,i), pl%vb(3,i),& + CALL orbel_xv2aeq(system%Gmtot, pl%rb(1,i), pl%rb(2,i), pl%rb(3,i), pl%vb(1,i), pl%vb(2,i), pl%vb(3,i),& pl%atp(i), e, pl%peri(i)) end if else @@ -612,7 +614,7 @@ module subroutine symba_util_rearray_pl(self, system, param) nadd = pl_adds%nbody if (npl == 0) return ! Deallocate any temporary variables - if (allocated(pl%xbeg)) deallocate(pl%xbeg) + if (allocated(pl%rbeg)) deallocate(pl%rbeg) if (allocated(pl%xend)) deallocate(pl%xend) ! Remove the discards and destroy the list, as the system already tracks pl_discards elsewhere @@ -667,7 +669,7 @@ module subroutine symba_util_rearray_pl(self, system, param) end where end select - call pl%write_info(param%nc, param) + call pl%write_info(param%system_history%nc, param) deallocate(ldump_mask) ! Reindex the new list of bodies @@ -712,9 +714,10 @@ module subroutine symba_util_rearray_pl(self, system, param) if ((idnew1 == idold1) .and. (idnew2 == idold2)) then ! This is an encounter we already know about, so save the old information system%plplenc_list%lvdotr(k) = plplenc_old%lvdotr(k) + system%plplenc_list%lclosest(k) = plplenc_old%lclosest(k) system%plplenc_list%status(k) = plplenc_old%status(k) - system%plplenc_list%x1(:,k) = plplenc_old%x1(:,k) - system%plplenc_list%x2(:,k) = plplenc_old%x2(:,k) + system%plplenc_list%r1(:,k) = plplenc_old%r1(:,k) + system%plplenc_list%r2(:,k) = plplenc_old%r2(:,k) system%plplenc_list%v1(:,k) = plplenc_old%v1(:,k) system%plplenc_list%v2(:,k) = plplenc_old%v2(:,k) system%plplenc_list%tcollision(k) = plplenc_old%tcollision(k) @@ -722,9 +725,10 @@ module subroutine symba_util_rearray_pl(self, system, param) else if (((idnew1 == idold2) .and. (idnew2 == idold1))) then ! This is an encounter we already know about, but with the order reversed, so save the old information system%plplenc_list%lvdotr(k) = plplenc_old%lvdotr(k) + system%plplenc_list%lclosest(k) = plplenc_old%lclosest(k) system%plplenc_list%status(k) = plplenc_old%status(k) - system%plplenc_list%x1(:,k) = plplenc_old%x2(:,k) - system%plplenc_list%x2(:,k) = plplenc_old%x1(:,k) + system%plplenc_list%r1(:,k) = plplenc_old%r2(:,k) + system%plplenc_list%r2(:,k) = plplenc_old%r1(:,k) system%plplenc_list%v1(:,k) = plplenc_old%v2(:,k) system%plplenc_list%v2(:,k) = plplenc_old%v1(:,k) system%plplenc_list%tcollision(k) = plplenc_old%tcollision(k) @@ -749,12 +753,13 @@ module subroutine symba_util_rearray_pl(self, system, param) system%plplenc_list%id1(1:nencmin) = pack(system%plplenc_list%id1(1:nenc_old), lmask(1:nenc_old)) system%plplenc_list%id2(1:nencmin) = pack(system%plplenc_list%id2(1:nenc_old), lmask(1:nenc_old)) system%plplenc_list%lvdotr(1:nencmin) = pack(system%plplenc_list%lvdotr(1:nenc_old), lmask(1:nenc_old)) + system%plplenc_list%lclosest(1:nencmin) = pack(system%plplenc_list%lclosest(1:nenc_old), lmask(1:nenc_old)) system%plplenc_list%status(1:nencmin) = pack(system%plplenc_list%status(1:nenc_old), lmask(1:nenc_old)) system%plplenc_list%tcollision(1:nencmin) = pack(system%plplenc_list%tcollision(1:nenc_old), lmask(1:nenc_old)) system%plplenc_list%level(1:nencmin) = pack(system%plplenc_list%level(1:nenc_old), lmask(1:nenc_old)) do i = 1, NDIM - system%plplenc_list%x1(i, 1:nencmin) = pack(system%plplenc_list%x1(i, 1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%x2(i, 1:nencmin) = pack(system%plplenc_list%x2(i, 1:nenc_old), lmask(1:nenc_old)) + system%plplenc_list%r1(i, 1:nencmin) = pack(system%plplenc_list%r1(i, 1:nenc_old), lmask(1:nenc_old)) + system%plplenc_list%r2(i, 1:nencmin) = pack(system%plplenc_list%r2(i, 1:nenc_old), lmask(1:nenc_old)) system%plplenc_list%v1(i, 1:nencmin) = pack(system%plplenc_list%v1(i, 1:nenc_old), lmask(1:nenc_old)) system%plplenc_list%v2(i, 1:nencmin) = pack(system%plplenc_list%v2(i, 1:nenc_old), lmask(1:nenc_old)) end do @@ -868,65 +873,6 @@ module subroutine symba_util_resize_pl(self, nnew) return end subroutine symba_util_resize_pl - - subroutine symba_util_save_storage(system, snapshot, t) - !! author: David A. Minton - !! - !! Checks the current size of the encounter storage against the required size and extends it by a factor of 2 more than requested if it is too small. - !! Note: The reason to extend it by a factor of 2 is for performance. When there are many enounters per step, resizing every time you want to add an - !! encounter takes significant computational effort. Resizing by a factor of 2 is a tradeoff between performance (fewer resize calls) and memory managment - !! Memory usage grows by a factor of 2 each time it fills up, but no more. - implicit none - ! Arguments - type(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(encounter_snapshot), intent(in) :: snapshot !! Encounter snapshot object - real(DP), intent(in) :: t !! The time of the snapshot - ! Internals - type(encounter_storage(nframes=:)), allocatable :: tmp - integer(I4B) :: i, nnew, nold, nbig - - ! Advance the snapshot frame counter - system%encounter_history%iframe = system%encounter_history%iframe + 1 - - ! Check to make sure the current encounter_history object is big enough. If not, grow it by a factor of 2 - nnew = system%encounter_history%iframe - nold = system%encounter_history%nframes - - if (nnew > nold) then - nbig = nold - do while (nbig < nnew) - nbig = nbig * 2 - end do - allocate(encounter_storage(nbig) :: tmp) - tmp%tvals(1:nold) = system%encounter_history%tvals(1:nold) - tmp%tvals(nold+1:nbig) = huge(1.0_DP) - tmp%tslot(1:nold) = system%encounter_history%tslot(1:nold) - tmp%tslot(nold+1:nbig) = 0 - tmp%iframe = system%encounter_history%iframe - - do i = 1, nold - if (allocated(system%encounter_history%frame(i)%item)) call move_alloc(system%encounter_history%frame(i)%item, tmp%frame(i)%item) - end do - deallocate(system%encounter_history) - call move_alloc(tmp,system%encounter_history) - nnew = nbig - end if - - ! Find out which time slot this belongs in by searching for an existing slot - ! with the same value of time or the first available one - do i = 1, nnew - if (t <= system%encounter_history%tvals(i)) then - system%encounter_history%tvals(i) = t - system%encounter_history%tslot(nnew) = i - system%encounter_history%frame(nnew) = snapshot - exit - end if - end do - - return - end subroutine symba_util_save_storage - - module subroutine symba_util_resize_tp(self, nnew) !! author: David A. Minton !! @@ -1285,108 +1231,5 @@ module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) end subroutine symba_util_spill_tp - module subroutine symba_util_take_encounter_snapshot(self, param, t) - !! author: David A. Minton - !! - !! Takes a minimal snapshot of the state of the system during an encounter so that the trajectories - !! can be played back through the encounter - implicit none - ! Internals - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! current time - ! Arguments - type(encounter_snapshot) :: snapshot - integer(I4B) :: i, npl_snap, ntp_snap - - associate(npl => self%pl%nbody, ntp => self%tp%nbody) - - snapshot%t = t - - if (npl + ntp == 0) return - npl_snap = npl - ntp_snap = ntp - - select type (pl => self%pl) - class is (symba_pl) - select type (tp => self%tp) - class is (symba_tp) - allocate(symba_pl :: snapshot%pl) - allocate(symba_tp :: snapshot%tp) - - select type(pl_snap => snapshot%pl) - class is (symba_pl) - select type(tp_snap => snapshot%tp) - class is (symba_tp) - - if (npl > 0) then - pl%lmask(1:npl) = pl%status(1:npl) /= INACTIVE .and. pl%levelg(1:npl) == self%irec - npl_snap = count(pl%lmask(1:npl)) - end if - if (ntp > 0) then - tp%lmask(1:ntp) = tp%status(1:ntp) /= INACTIVE .and. tp%levelg(1:ntp) == self%irec - ntp_snap = count(tp%lmask(1:ntp)) - end if - pl_snap%nbody = npl_snap - - ! Take snapshot of the currently encountering massive bodies - if (npl_snap > 0) then - allocate(pl_snap%id(npl_snap)) - allocate(pl_snap%info(npl_snap)) - allocate(pl_snap%Gmass(npl_snap)) - - allocate(pl_snap%levelg(npl_snap)) - pl_snap%levelg(:) = pack(pl%levelg(1:npl), pl%lmask(1:npl)) - pl_snap%id(:) = pack(pl%id(1:npl), pl%lmask(1:npl)) - pl_snap%info(:) = pack(pl%info(1:npl), pl%lmask(1:npl)) - pl_snap%Gmass(:) = pack(pl%Gmass(1:npl), pl%lmask(1:npl)) - allocate(pl_snap%rh(NDIM,npl_snap)) - allocate(pl_snap%vh(NDIM,npl_snap)) - do i = 1, NDIM - pl_snap%rh(i,:) = pack(pl%rh(i,1:npl), pl%lmask(1:npl)) - pl_snap%vh(i,:) = pack(pl%vb(i,1:npl), pl%lmask(1:npl)) - end do - if (param%lclose) then - allocate(pl_snap%radius(npl_snap)) - pl_snap%radius(:) = pack(pl%radius(1:npl), pl%lmask(1:npl)) - end if - - if (param%lrotation) then - allocate(pl_snap%Ip(NDIM,npl_snap)) - allocate(pl_snap%rot(NDIM,npl_snap)) - do i = 1, NDIM - pl_snap%Ip(i,:) = pack(pl%Ip(i,1:npl), pl%lmask(1:npl)) - pl_snap%rot(i,:) = pack(pl%rot(i,1:npl), pl%lmask(1:npl)) - end do - end if - call pl_snap%sort("id", ascending=.true.) - end if - - ! Take snapshot of the currently encountering test particles - tp_snap%nbody = ntp_snap - if (ntp_snap > 0) then - allocate(tp_snap%id(ntp_snap)) - allocate(tp_snap%info(ntp_snap)) - tp_snap%id(:) = pack(tp%id(1:ntp), tp%lmask(1:ntp)) - tp_snap%info(:) = pack(tp%info(1:ntp), tp%lmask(1:ntp)) - allocate(tp_snap%rh(NDIM,ntp_snap)) - allocate(tp_snap%vh(NDIM,ntp_snap)) - do i = 1, NDIM - tp_snap%rh(i,:) = pack(tp%rh(i,1:ntp), tp%lmask(1:ntp)) - tp_snap%vh(i,:) = pack(tp%vh(i,1:ntp), tp%lmask(1:ntp)) - end do - end if - end select - end select - - - ! Save the snapshot - call symba_util_save_storage(self,snapshot,t) - end select - end select - end associate - - return - end subroutine symba_util_take_encounter_snapshot end submodule s_symba_util diff --git a/src/tides/tides_spin_step.f90 b/src/tides/tides_spin_step.f90 index 576aff8d7..ee4309eb6 100644 --- a/src/tides/tides_spin_step.f90 +++ b/src/tides/tides_spin_step.f90 @@ -4,7 +4,7 @@ type, extends(lambda_obj_tvar) :: tides_derivs_func !! Base class for an lambda function object. This object takes no additional arguments other than the dependent variable x, an array of real numbers procedure(tidederiv), pointer, nopass :: lambdaptr_tides_deriv - real(DP), dimension(:,:), allocatable :: xbeg + real(DP), dimension(:,:), allocatable :: rbeg real(DP), dimension(:,:), allocatable :: xend real(DP) :: dt contains @@ -16,13 +16,13 @@ module procedure tides_derivs_init end interface abstract interface - function tidederiv(x, t, dt, xbeg, xend) result(y) + function tidederiv(x, t, dt, rbeg, xend) result(y) ! Template for a 0 argument function import DP, swiftest_nbody_system real(DP), dimension(:), intent(in) :: x real(DP), intent(in) :: t real(DP), intent(in) :: dt - real(DP), dimension(:,:), intent(in) :: xbeg + real(DP), dimension(:,:), intent(in) :: rbeg real(DP), dimension(:,:), intent(in) :: xend real(DP), dimension(:), allocatable :: y end function @@ -51,7 +51,7 @@ module subroutine tides_step_spin_system(self, param, t, dt) rot0 = [pack(pl%rot(:,1:npl),.true.), pack(cb%rot(:),.true.)] ! Use this space call the ode_solver, passing tides_spin_derivs as the function: subdt = dt / 20._DP - !rot1(:) = util_solve_rkf45(lambda_obj(tides_spin_derivs, subdt, pl%xbeg, pl%xend), rot0, dt, subdt tol) + !rot1(:) = util_solve_rkf45(lambda_obj(tides_spin_derivs, subdt, pl%rbeg, pl%xend), rot0, dt, subdt tol) ! Recover with unpack !pl%rot(:,1:npl) = unpack(rot1... !cb%rot(:) = unpack(rot1... @@ -61,7 +61,7 @@ module subroutine tides_step_spin_system(self, param, t, dt) end subroutine tides_step_spin_system - function tides_spin_derivs(rot_pl_cb, t, dt, xbeg, xend) result(drot) !! Need to add more arguments so we can pull in mass, radius, Ip, J2, etc... + function tides_spin_derivs(rot_pl_cb, t, dt, rbeg, xend) result(drot) !! Need to add more arguments so we can pull in mass, radius, Ip, J2, etc... !! author: Jennifer L.L. Pouplin and David A. Minton !! !! function used to calculate the derivatives that are fed to the ODE solver @@ -70,7 +70,7 @@ function tides_spin_derivs(rot_pl_cb, t, dt, xbeg, xend) result(drot) !! Need to real(DP), dimension(:,:), intent(in) :: rot_pl_cb !! Array of rotations. The last element is the central body, and all others are massive bodies real(DP), intent(in) :: t !! Current time, which is used to interpolate the massive body positions real(DP), intent(in) :: dt !! Total step size - real(DP), dimension(:,:), intent(in) :: xbeg + real(DP), dimension(:,:), intent(in) :: rbeg real(DP), dimension(:,:), intent(in) :: xend ! Internals real(DP), dimension(:,:), allocatable :: drot @@ -85,7 +85,7 @@ function tides_spin_derivs(rot_pl_cb, t, dt, xbeg, xend) result(drot) !! Need to allocate(drot, mold=rot_pl_cb) drot(:,:) = 0.0_DP do i = 1,n-1 - xinterp(:) = xbeg(:,i) + t / dt * (xend(:,i) - xbeg(:,i)) + xinterp(:) = rbeg(:,i) + t / dt * (xend(:,i) - rbeg(:,i)) ! Calculate Ncb and Npl as a function of xinterp !drot(:,i) = -Mcb / (Mcb + Mpl(i)) * (N_Tpl + N_Rpl) !drot(:,n) = drot(:,n) - Mcb / (Mcb + Mpl(i) * (N_Tcb + N_Rcb) @@ -104,7 +104,7 @@ function tides_derivs_eval(self, x, t) result(y) ! Result real(DP), dimension(:), allocatable :: y if (associated(self%lambdaptr_tides_deriv)) then - y = self%lambdaptr_tides_deriv(x, t, self%dt, self%xbeg, self%xend) + y = self%lambdaptr_tides_deriv(x, t, self%dt, self%rbeg, self%xend) else error stop "Lambda function was not initialized" end if @@ -112,18 +112,18 @@ function tides_derivs_eval(self, x, t) result(y) return end function tides_derivs_eval - function tides_derivs_init(lambda, dt, xbeg, xend) result(f) + function tides_derivs_init(lambda, dt, rbeg, xend) result(f) implicit none ! Arguments procedure(tidederiv) :: lambda real(DP), intent(in) :: dt - real(DP), dimension(:,:), intent(in) :: xbeg + real(DP), dimension(:,:), intent(in) :: rbeg real(DP), dimension(:,:), intent(in) :: xend ! Result type(tides_derivs_func) :: f f%lambdaptr_tides_deriv => lambda f%dt = dt - allocate(f%xbeg, source = xbeg) + allocate(f%rbeg, source = rbeg) allocate(f%xend, source = xend) return diff --git a/src/util/util_append.f90 b/src/util/util_append.f90 index a02b28f2b..7470bace4 100644 --- a/src/util/util_append.f90 +++ b/src/util/util_append.f90 @@ -211,7 +211,7 @@ module subroutine util_append_body(self, source, lsource_mask) call util_append(self%mu, source%mu, nold, nsrc, lsource_mask) call util_append(self%rh, source%rh, nold, nsrc, lsource_mask) call util_append(self%vh, source%vh, nold, nsrc, lsource_mask) - call util_append(self%xb, source%xb, nold, nsrc, lsource_mask) + call util_append(self%rb, source%rb, nold, nsrc, lsource_mask) call util_append(self%vb, source%vb, nold, nsrc, lsource_mask) call util_append(self%ah, source%ah, nold, nsrc, lsource_mask) call util_append(self%aobl, source%aobl, nold, nsrc, lsource_mask) @@ -250,7 +250,7 @@ module subroutine util_append_pl(self, source, lsource_mask) call util_append(self%rhill, source%rhill, nold, nsrc, lsource_mask) call util_append(self%renc, source%renc, nold, nsrc, lsource_mask) call util_append(self%radius, source%radius, nold, nsrc, lsource_mask) - call util_append(self%xbeg, source%xbeg, nold, nsrc, lsource_mask) + call util_append(self%rbeg, source%rbeg, nold, nsrc, lsource_mask) call util_append(self%xend, source%xend, nold, nsrc, lsource_mask) call util_append(self%vbeg, source%vbeg, nold, nsrc, lsource_mask) call util_append(self%density, source%density, nold, nsrc, lsource_mask) diff --git a/src/util/util_coord.f90 b/src/util/util_coord.f90 index 98a5549ac..78c2eca83 100644 --- a/src/util/util_coord.f90 +++ b/src/util/util_coord.f90 @@ -38,11 +38,11 @@ module subroutine util_coord_h2b_pl(self, cb) xtmp(:) = xtmp(:) + pl%Gmass(i) * pl%rh(:,i) vtmp(:) = vtmp(:) + pl%Gmass(i) * pl%vh(:,i) end do - cb%xb(:) = -xtmp(:) / Gmtot + cb%rb(:) = -xtmp(:) / Gmtot cb%vb(:) = -vtmp(:) / Gmtot do i = 1, npl if (pl%status(i) == INACTIVE) cycle - pl%xb(:,i) = pl%rh(:,i) + cb%xb(:) + pl%rb(:,i) = pl%rh(:,i) + cb%rb(:) pl%vb(:,i) = pl%vh(:,i) + cb%vb(:) end do end associate @@ -68,7 +68,7 @@ module subroutine util_coord_h2b_tp(self, cb) if (self%nbody == 0) return associate(tp => self, ntp => self%nbody) do concurrent (i = 1:ntp, tp%status(i) /= INACTIVE) - tp%xb(:, i) = tp%rh(:, i) + cb%xb(:) + tp%rb(:, i) = tp%rh(:, i) + cb%rb(:) tp%vb(:, i) = tp%vh(:, i) + cb%vb(:) end do end associate @@ -95,7 +95,7 @@ module subroutine util_coord_b2h_pl(self, cb) associate(pl => self, npl => self%nbody) do concurrent (i = 1:npl, pl%status(i) /= INACTIVE) - pl%rh(:, i) = pl%xb(:, i) - cb%xb(:) + pl%rh(:, i) = pl%rb(:, i) - cb%rb(:) pl%vh(:, i) = pl%vb(:, i) - cb%vb(:) end do end associate @@ -122,7 +122,7 @@ module subroutine util_coord_b2h_tp(self, cb) associate(tp => self, ntp => self%nbody) do concurrent(i = 1:ntp, tp%status(i) /= INACTIVE) - tp%rh(:, i) = tp%xb(:, i) - cb%xb(:) + tp%rh(:, i) = tp%rb(:, i) - cb%rb(:) tp%vh(:, i) = tp%vb(:, i) - cb%vb(:) end do end associate @@ -246,7 +246,7 @@ module subroutine util_coord_vh2vb_tp(self, vbcb) end subroutine util_coord_vh2vb_tp - module subroutine util_coord_rh2xb_pl(self, cb) + module subroutine util_coord_rh2rb_pl(self, cb) !! author: David A. Minton !! !! Convert position vectors of massive bodies from heliocentric to barycentric coordinates (position only) @@ -271,18 +271,18 @@ module subroutine util_coord_rh2xb_pl(self, cb) Gmtot = Gmtot + pl%Gmass(i) xtmp(:) = xtmp(:) + pl%Gmass(i) * pl%rh(:,i) end do - cb%xb(:) = -xtmp(:) / Gmtot + cb%rb(:) = -xtmp(:) / Gmtot do i = 1, npl if (pl%status(i) == INACTIVE) cycle - pl%xb(:,i) = pl%rh(:,i) + cb%xb(:) + pl%rb(:,i) = pl%rh(:,i) + cb%rb(:) end do end associate return - end subroutine util_coord_rh2xb_pl + end subroutine util_coord_rh2rb_pl - module subroutine util_coord_rh2xb_tp(self, cb) + module subroutine util_coord_rh2rb_tp(self, cb) !! author: David A. Minton !! !! Convert test particles from heliocentric to barycentric coordinates (position only) @@ -299,11 +299,11 @@ module subroutine util_coord_rh2xb_tp(self, cb) if (self%nbody == 0) return associate(tp => self, ntp => self%nbody) do concurrent (i = 1:ntp, tp%status(i) /= INACTIVE) - tp%xb(:, i) = tp%rh(:, i) + cb%xb(:) + tp%rb(:, i) = tp%rh(:, i) + cb%rb(:) end do end associate return - end subroutine util_coord_rh2xb_tp + end subroutine util_coord_rh2rb_tp end submodule s_util_coord \ No newline at end of file diff --git a/src/util/util_dealloc.f90 b/src/util/util_dealloc.f90 index 54151f567..14309d2a6 100644 --- a/src/util/util_dealloc.f90 +++ b/src/util/util_dealloc.f90 @@ -27,7 +27,7 @@ module subroutine util_dealloc_body(self) if (allocated(self%mu)) deallocate(self%mu) if (allocated(self%rh)) deallocate(self%rh) if (allocated(self%vh)) deallocate(self%vh) - if (allocated(self%xb)) deallocate(self%xb) + if (allocated(self%rb)) deallocate(self%rb) if (allocated(self%vb)) deallocate(self%vb) if (allocated(self%ah)) deallocate(self%ah) if (allocated(self%aobl)) deallocate(self%aobl) diff --git a/src/util/util_fill.f90 b/src/util/util_fill.f90 index 9b542d19c..265138238 100644 --- a/src/util/util_fill.f90 +++ b/src/util/util_fill.f90 @@ -162,7 +162,7 @@ module subroutine util_fill_body(self, inserts, lfill_list) call util_fill(keeps%mu, inserts%mu, lfill_list) call util_fill(keeps%rh, inserts%rh, lfill_list) call util_fill(keeps%vh, inserts%vh, lfill_list) - call util_fill(keeps%xb, inserts%xb, lfill_list) + call util_fill(keeps%rb, inserts%rb, lfill_list) call util_fill(keeps%vb, inserts%vb, lfill_list) call util_fill(keeps%ah, inserts%ah, lfill_list) call util_fill(keeps%aobl, inserts%aobl, lfill_list) @@ -208,7 +208,7 @@ module subroutine util_fill_pl(self, inserts, lfill_list) call util_fill(keeps%k2, inserts%k2, lfill_list) call util_fill(keeps%Q, inserts%Q, lfill_list) call util_fill(keeps%tlag, inserts%tlag, lfill_list) - call util_fill(keeps%xbeg, inserts%xbeg, lfill_list) + call util_fill(keeps%rbeg, inserts%rbeg, lfill_list) call util_fill(keeps%vbeg, inserts%vbeg, lfill_list) call util_fill(keeps%Ip, inserts%Ip, lfill_list) call util_fill(keeps%rot, inserts%rot, lfill_list) diff --git a/src/util/util_get_energy_momentum.f90 b/src/util/util_get_energy_momentum.f90 index ed7119d8b..cc1e64d15 100644 --- a/src/util/util_get_energy_momentum.f90 +++ b/src/util/util_get_energy_momentum.f90 @@ -49,12 +49,12 @@ module subroutine util_get_energy_momentum_system(self, param) system%GMtot = cb%Gmass + sum(pl%Gmass(1:npl), pl%lmask(1:npl)) kecb = cb%mass * dot_product(cb%vb(:), cb%vb(:)) - Lcborbit(:) = cb%mass * (cb%xb(:) .cross. cb%vb(:)) + Lcborbit(:) = cb%mass * (cb%rb(:) .cross. cb%vb(:)) do concurrent (i = 1:npl, pl%lmask(i)) - hx = pl%xb(2,i) * pl%vb(3,i) - pl%xb(3,i) * pl%vb(2,i) - hy = pl%xb(3,i) * pl%vb(1,i) - pl%xb(1,i) * pl%vb(3,i) - hz = pl%xb(1,i) * pl%vb(2,i) - pl%xb(2,i) * pl%vb(1,i) + hx = pl%rb(2,i) * pl%vb(3,i) - pl%rb(3,i) * pl%vb(2,i) + hy = pl%rb(3,i) * pl%vb(1,i) - pl%rb(1,i) * pl%vb(3,i) + hz = pl%rb(1,i) * pl%vb(2,i) - pl%rb(2,i) * pl%vb(1,i) ! Angular momentum from orbit Lplorbitx(i) = pl%mass(i) * hx @@ -87,9 +87,9 @@ module subroutine util_get_energy_momentum_system(self, param) end if if (param%lflatten_interactions) then - call util_get_energy_potential_flat(npl, pl%nplpl, pl%k_plpl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%xb, system%pe) + call util_get_energy_potential_flat(npl, pl%nplpl, pl%k_plpl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%rb, system%pe) else - call util_get_energy_potential_triangular(npl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%xb, system%pe) + call util_get_energy_potential_triangular(npl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%rb, system%pe) end if ! Potential energy from the oblateness term @@ -119,7 +119,7 @@ module subroutine util_get_energy_momentum_system(self, param) end subroutine util_get_energy_momentum_system - subroutine util_get_energy_potential_flat(npl, nplpl, k_plpl, lmask, GMcb, Gmass, mass, xb, pe) + subroutine util_get_energy_potential_flat(npl, nplpl, k_plpl, lmask, GMcb, Gmass, mass, rb, pe) !! author: David A. Minton !! !! Compute total system potential energy @@ -132,7 +132,7 @@ subroutine util_get_energy_potential_flat(npl, nplpl, k_plpl, lmask, GMcb, Gmass real(DP), intent(in) :: GMcb real(DP), dimension(:), intent(in) :: Gmass real(DP), dimension(:), intent(in) :: mass - real(DP), dimension(:,:), intent(in) :: xb + real(DP), dimension(:,:), intent(in) :: rb real(DP), intent(out) :: pe ! Internals integer(I4B) :: i, j @@ -147,18 +147,18 @@ subroutine util_get_energy_potential_flat(npl, nplpl, k_plpl, lmask, GMcb, Gmass end where do concurrent(i = 1:npl, lmask(i)) - pecb(i) = -GMcb * mass(i) / norm2(xb(:,i)) + pecb(i) = -GMcb * mass(i) / norm2(rb(:,i)) end do !$omp parallel do default(private) schedule(static)& - !$omp shared(k_plpl, xb, mass, Gmass, pepl, lstatpl, lmask) & + !$omp shared(k_plpl, rb, mass, Gmass, pepl, lstatpl, lmask) & !$omp firstprivate(nplpl) do k = 1, nplpl i = k_plpl(1,k) j = k_plpl(2,k) lstatpl(k) = (lmask(i) .and. lmask(j)) if (lstatpl(k)) then - pepl(k) = -(Gmass(i) * mass(j)) / norm2(xb(:, i) - xb(:, j)) + pepl(k) = -(Gmass(i) * mass(j)) / norm2(rb(:, i) - rb(:, j)) else pepl(k) = 0.0_DP end if @@ -171,7 +171,7 @@ subroutine util_get_energy_potential_flat(npl, nplpl, k_plpl, lmask, GMcb, Gmass end subroutine util_get_energy_potential_flat - subroutine util_get_energy_potential_triangular(npl, lmask, GMcb, Gmass, mass, xb, pe) + subroutine util_get_energy_potential_triangular(npl, lmask, GMcb, Gmass, mass, rb, pe) !! author: David A. Minton !! !! Compute total system potential energy @@ -182,7 +182,7 @@ subroutine util_get_energy_potential_triangular(npl, lmask, GMcb, Gmass, mass, x real(DP), intent(in) :: GMcb real(DP), dimension(:), intent(in) :: Gmass real(DP), dimension(:), intent(in) :: mass - real(DP), dimension(:,:), intent(in) :: xb + real(DP), dimension(:,:), intent(in) :: rb real(DP), intent(out) :: pe ! Internals integer(I4B) :: i, j @@ -194,18 +194,18 @@ subroutine util_get_energy_potential_triangular(npl, lmask, GMcb, Gmass, mass, x end where do concurrent(i = 1:npl, lmask(i)) - pecb(i) = -GMcb * mass(i) / norm2(xb(:,i)) + pecb(i) = -GMcb * mass(i) / norm2(rb(:,i)) end do pe = 0.0_DP !$omp parallel do default(private) schedule(static)& - !$omp shared(lmask, Gmass, mass, xb) & + !$omp shared(lmask, Gmass, mass, rb) & !$omp firstprivate(npl) & !$omp reduction(+:pe) do i = 1, npl if (lmask(i)) then do concurrent(j = i+1:npl, lmask(i) .and. lmask(j)) - pepl(j) = - (Gmass(i) * mass(j)) / norm2(xb(:, i) - xb(:, j)) + pepl(j) = - (Gmass(i) * mass(j)) / norm2(rb(:, i) - rb(:, j)) end do pe = pe + sum(pepl(i+1:npl), lmask(i+1:npl)) end if diff --git a/src/util/util_index.f90 b/src/util/util_index.f90 new file mode 100644 index 000000000..0fbd40319 --- /dev/null +++ b/src/util/util_index.f90 @@ -0,0 +1,160 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (swiftest_classes) s_util_index_array + use swiftest +contains + + module subroutine util_index_array(ind_arr, n) + !! author: David A. Minton + !! + !! Creates or resizes an index array of size n where ind_arr = [1, 2, ... n]. + !! This subroutine assumes that if ind_arr is already allocated, it is a pre-existing index array of a different size. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: ind_arr !! Index array. Input is a pre-existing index array where n /= size(ind_arr). Output is a new index array ind_arr = [1, 2, ... n] + integer(I4B), intent(in) :: n !! The new size of the index array + ! Internals + integer(I4B) :: nold, i + integer(I4B), dimension(:), allocatable :: itmp + + if (allocated(ind_arr)) then + nold = size(ind_arr) + if (nold == n) return ! Nothing to do, so go home + else + nold = 0 + end if + + allocate(itmp(n)) + if (n >= nold) then + if (nold > 0) itmp(1:nold) = ind_arr(1:nold) + itmp(nold+1:n) = [(i, i = nold + 1, n)] + call move_alloc(itmp, ind_arr) + else + itmp(1:n) = ind_arr(1:n) + call move_alloc(itmp, ind_arr) + end if + + return + end subroutine util_index_array + + + module subroutine util_get_idvalues_system(self, idvals) + !! author: David A. Minton + !! + !! Returns an array of all id values saved in this snapshot + implicit none + ! Arguments + class(swiftest_nbody_system), intent(in) :: self !! Encounter snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + ! Internals + integer(I4B) :: npl, ntp + + if (allocated(self%pl)) then + npl = self%pl%nbody + else + npl = 0 + end if + if (allocated(self%tp)) then + ntp = self%tp%nbody + else + ntp = 0 + end if + + allocate(idvals(1 + npl+ntp)) + + idvals(1) = self%cb%id + if (npl > 0) idvals(2:npl+1) = self%pl%id(:) + if (ntp > 0) idvals(npl+2:npl+ntp+1) = self%tp%id(:) + + return + + end subroutine util_get_idvalues_system + + + subroutine util_get_vals_storage(storage, idvals, tvals) + !! author: David A. Minton + !! + !! Gets the id values in a storage object, regardless of whether it is encounter of collision + ! Argument + class(swiftest_storage(*)), intent(in) :: storage !! Swiftest storage object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values in all snapshots + real(DP), dimension(:), allocatable, intent(out) :: tvals !! Array of all time values in all snapshots + ! Internals + integer(I4B) :: i, n, nlo, nhi, ntotal + integer(I4B), dimension(:), allocatable :: itmp + + associate(nsnaps => storage%iframe) + + allocate(tvals(nsnaps)) + tvals(:) = 0.0_DP + + ! First pass to get total number of ids + ntotal = 0 + do i = 1, nsnaps + if (allocated(storage%frame(i)%item)) then + select type(snapshot => storage%frame(i)%item) + class is (swiftest_nbody_system) + tvals(i) = snapshot%t + call snapshot%get_idvals(itmp) + if (allocated(itmp)) then + n = size(itmp) + ntotal = ntotal + n + end if + end select + end if + end do + + allocate(idvals(ntotal)) + nlo = 1 + ! Second pass to store all ids get all of the ids stored + do i = 1, nsnaps + if (allocated(storage%frame(i)%item)) then + select type(snapshot => storage%frame(i)%item) + class is (swiftest_nbody_system) + tvals(i) = snapshot%t + call snapshot%get_idvals(itmp) + if (allocated(itmp)) then + n = size(itmp) + nhi = nlo + n - 1 + idvals(nlo:nhi) = itmp(1:n) + nlo = nhi + 1 + end if + end select + end if + end do + + end associate + return + end subroutine util_get_vals_storage + + + module subroutine util_index_map_storage(self) + !! author: David A. Minton + !! + !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + implicit none + ! Arguments + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + ! Internals + integer(I4B), dimension(:), allocatable :: idvals + real(DP), dimension(:), allocatable :: tvals + + call util_get_vals_storage(self, idvals, tvals) + + call util_unique(idvals,self%idvals,self%idmap) + self%nid = size(self%idvals) + + call util_unique(tvals,self%tvals,self%tmap) + self%nt = size(self%tvals) + + return + end subroutine util_index_map_storage + +end submodule s_util_index_array \ No newline at end of file diff --git a/src/util/util_index_array.f90 b/src/util/util_index_array.f90 deleted file mode 100644 index b59e829e1..000000000 --- a/src/util/util_index_array.f90 +++ /dev/null @@ -1,47 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_index_array - use swiftest -contains - - module subroutine util_index_array(ind_arr, n) - !! author: David A. Minton - !! - !! Creates or resizes an index array of size n where ind_arr = [1, 2, ... n]. - !! This subroutine assumes that if ind_arr is already allocated, it is a pre-existing index array of a different size. - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: ind_arr !! Index array. Input is a pre-existing index array where n /= size(ind_arr). Output is a new index array ind_arr = [1, 2, ... n] - integer(I4B), intent(in) :: n !! The new size of the index array - ! Internals - integer(I4B) :: nold, i - integer(I4B), dimension(:), allocatable :: itmp - - if (allocated(ind_arr)) then - nold = size(ind_arr) - if (nold == n) return ! Nothing to do, so go home - else - nold = 0 - end if - - allocate(itmp(n)) - if (n >= nold) then - if (nold > 0) itmp(1:nold) = ind_arr(1:nold) - itmp(nold+1:n) = [(i, i = nold + 1, n)] - call move_alloc(itmp, ind_arr) - else - itmp(1:n) = ind_arr(1:n) - call move_alloc(itmp, ind_arr) - end if - - return - end subroutine util_index_array - -end submodule s_util_index_array \ No newline at end of file diff --git a/src/util/util_peri.f90 b/src/util/util_peri.f90 index badd0e328..76252828e 100644 --- a/src/util/util_peri.f90 +++ b/src/util/util_peri.f90 @@ -51,11 +51,11 @@ module subroutine util_peri_tp(self, system, param) end do else do i = 1, ntp - vdotr(i) = dot_product(tp%xb(:, i), tp%vb(:, i)) + vdotr(i) = dot_product(tp%rb(:, i), tp%vb(:, i)) if (tp%isperi(i) == -1) then if (vdotr(i) >= 0.0_DP) then tp%isperi(i) = 0 - call orbel_xv2aeq(system%Gmtot, tp%xb(1,i), tp%xb(2,i), tp%xb(3,i), tp%vb(1,i), tp%vb(2,i), tp%vb(3,i), & + call orbel_xv2aeq(system%Gmtot, tp%rb(1,i), tp%rb(2,i), tp%rb(3,i), tp%vb(1,i), tp%vb(2,i), tp%vb(3,i), & tp%atp(i), e, tp%peri(i)) end if else diff --git a/src/util/util_rescale.f90 b/src/util/util_rescale.f90 index deb3e0e1e..372edd3fb 100644 --- a/src/util/util_rescale.f90 +++ b/src/util/util_rescale.f90 @@ -42,7 +42,7 @@ module subroutine util_rescale_system(self, param, mscale, dscale, tscale) cb%mass = cb%mass / mscale cb%Gmass = param%GU * cb%mass cb%radius = cb%radius / dscale - cb%xb(:) = cb%xb(:) / dscale + cb%rb(:) = cb%rb(:) / dscale cb%vb(:) = cb%vb(:) / vscale cb%rot(:) = cb%rot(:) * tscale pl%mass(1:npl) = pl%mass(1:npl) / mscale @@ -50,7 +50,7 @@ module subroutine util_rescale_system(self, param, mscale, dscale, tscale) pl%radius(1:npl) = pl%radius(1:npl) / dscale pl%rh(:,1:npl) = pl%rh(:,1:npl) / dscale pl%vh(:,1:npl) = pl%vh(:,1:npl) / vscale - pl%xb(:,1:npl) = pl%xb(:,1:npl) / dscale + pl%rb(:,1:npl) = pl%rb(:,1:npl) / dscale pl%vb(:,1:npl) = pl%vb(:,1:npl) / vscale pl%rot(:,1:npl) = pl%rot(:,1:npl) * tscale diff --git a/src/util/util_reset.f90 b/src/util/util_reset.f90 index 7bb8d5ee3..9b37f7d15 100644 --- a/src/util/util_reset.f90 +++ b/src/util/util_reset.f90 @@ -24,8 +24,11 @@ module subroutine util_reset_storage(self) do i = 1, self%nframes if (allocated(self%frame(i)%item)) deallocate(self%frame(i)%item) end do - self%tslot(:) = 0 - self%tvals(:) = huge(1.0_DP) + + if (allocated(self%idmap)) deallocate(self%idmap) + if (allocated(self%tmap)) deallocate(self%tmap) + self%nid = 0 + self%nt = 0 self%iframe = 0 return diff --git a/src/util/util_resize.f90 b/src/util/util_resize.f90 index eee6b0e4c..4963fd689 100644 --- a/src/util/util_resize.f90 +++ b/src/util/util_resize.f90 @@ -299,7 +299,7 @@ module subroutine util_resize_body(self, nnew) call util_resize(self%mu, nnew) call util_resize(self%rh, nnew) call util_resize(self%vh, nnew) - call util_resize(self%xb, nnew) + call util_resize(self%rb, nnew) call util_resize(self%vb, nnew) call util_resize(self%ah, nnew) call util_resize(self%aobl, nnew) @@ -334,7 +334,7 @@ module subroutine util_resize_pl(self, nnew) call util_resize(self%rhill, nnew) call util_resize(self%renc, nnew) call util_resize(self%radius, nnew) - call util_resize(self%xbeg, nnew) + call util_resize(self%rbeg, nnew) call util_resize(self%xend, nnew) call util_resize(self%vbeg, nnew) call util_resize(self%density, nnew) diff --git a/src/util/util_set.f90 b/src/util/util_set.f90 index 05e4b41f9..3e7719bff 100644 --- a/src/util/util_set.f90 +++ b/src/util/util_set.f90 @@ -13,18 +13,18 @@ use swiftest contains - module subroutine util_set_beg_end_pl(self, xbeg, xend, vbeg) + module subroutine util_set_beg_end_pl(self, rbeg, xend, vbeg) !! author: David A. Minton !! - !! Sets one or more of the values of xbeg, xend, and vbeg + !! Sets one or more of the values of rbeg, xend, and vbeg implicit none ! Arguments class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - real(DP), dimension(:,:), intent(in), optional :: xbeg, xend, vbeg + real(DP), dimension(:,:), intent(in), optional :: rbeg, xend, vbeg - if (present(xbeg)) then - if (allocated(self%xbeg)) deallocate(self%xbeg) - allocate(self%xbeg, source=xbeg) + if (present(rbeg)) then + if (allocated(self%rbeg)) deallocate(self%rbeg) + allocate(self%rbeg, source=rbeg) end if if (present(xend)) then if (allocated(self%xend)) deallocate(self%xend) diff --git a/src/util/util_snapshot.f90 b/src/util/util_snapshot.f90 new file mode 100644 index 000000000..c3a98855b --- /dev/null +++ b/src/util/util_snapshot.f90 @@ -0,0 +1,36 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule(swiftest_classes) s_util_snapshot + use swiftest +contains + + module subroutine util_snapshot_system(self, param, system, t, arg) + !! author: David A. Minton + !! + !! Takes a snapshot of the system for later file storage + implicit none + ! Arguments + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) + + self%iframe = self%iframe + 1 + self%nt = self%iframe + self%frame(self%iframe) = system ! Store a snapshot of the system for posterity + self%nid = self%nid + 1 ! Central body + if (allocated(system%pl)) self%nid = self%nid + system%pl%nbody + if (allocated(system%tp)) self%nid = self%nid + system%tp%nbody + + return + end subroutine util_snapshot_system + +end submodule s_util_snapshot \ No newline at end of file diff --git a/src/util/util_sort.f90 b/src/util/util_sort.f90 index b1500afab..6b48103d5 100644 --- a/src/util/util_sort.f90 +++ b/src/util/util_sort.f90 @@ -51,7 +51,7 @@ module subroutine util_sort_body(self, sortby, ascending) call util_sort(direction * body%capom(1:n), ind) case("mu") call util_sort(direction * body%mu(1:n), ind) - case("lfirst", "nbody", "ldiscard", "rh", "vh", "xb", "vb", "ah", "aobl", "atide", "agr") + case("lfirst", "nbody", "ldiscard", "rh", "vh", "rb", "vb", "ah", "aobl", "atide", "agr") write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' case default write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not found!' @@ -687,7 +687,7 @@ module subroutine util_sort_pl(self, sortby, ascending) call util_sort(direction * pl%Q(1:npl), ind) case("tlag") call util_sort(direction * pl%tlag(1:npl), ind) - case("xbeg", "xend", "vbeg", "Ip", "rot", "k_plpl", "nplpl") + case("rbeg", "xend", "vbeg", "Ip", "rot", "k_plpl", "nplpl") write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' case default ! Look for components in the parent class call util_sort_body(pl, sortby, ascending) @@ -762,7 +762,7 @@ module subroutine util_sort_rearrange_body(self, ind) call util_sort_rearrange(self%ldiscard, ind, n) call util_sort_rearrange(self%rh, ind, n) call util_sort_rearrange(self%vh, ind, n) - call util_sort_rearrange(self%xb, ind, n) + call util_sort_rearrange(self%rb, ind, n) call util_sort_rearrange(self%vb, ind, n) call util_sort_rearrange(self%ah, ind, n) call util_sort_rearrange(self%ir3h, ind, n) @@ -964,7 +964,7 @@ module subroutine util_sort_rearrange_pl(self, ind) call util_sort_rearrange(pl%mass, ind, npl) call util_sort_rearrange(pl%Gmass, ind, npl) call util_sort_rearrange(pl%rhill, ind, npl) - call util_sort_rearrange(pl%xbeg, ind, npl) + call util_sort_rearrange(pl%rbeg, ind, npl) call util_sort_rearrange(pl%vbeg, ind, npl) call util_sort_rearrange(pl%radius, ind, npl) call util_sort_rearrange(pl%density, ind, npl) diff --git a/src/util/util_spill.f90 b/src/util/util_spill.f90 index 9b9208252..1ba4b4a2f 100644 --- a/src/util/util_spill.f90 +++ b/src/util/util_spill.f90 @@ -341,7 +341,7 @@ module subroutine util_spill_body(self, discards, lspill_list, ldestructive) call util_spill(keeps%mu, discards%mu, lspill_list, ldestructive) call util_spill(keeps%rh, discards%rh, lspill_list, ldestructive) call util_spill(keeps%vh, discards%vh, lspill_list, ldestructive) - call util_spill(keeps%xb, discards%xb, lspill_list, ldestructive) + call util_spill(keeps%rb, discards%rb, lspill_list, ldestructive) call util_spill(keeps%vb, discards%vb, lspill_list, ldestructive) call util_spill(keeps%ah, discards%ah, lspill_list, ldestructive) call util_spill(keeps%aobl, discards%aobl, lspill_list, ldestructive) @@ -391,7 +391,7 @@ module subroutine util_spill_pl(self, discards, lspill_list, ldestructive) call util_spill(keeps%k2, discards%k2, lspill_list, ldestructive) call util_spill(keeps%Q, discards%Q, lspill_list, ldestructive) call util_spill(keeps%tlag, discards%tlag, lspill_list, ldestructive) - call util_spill(keeps%xbeg, discards%xbeg, lspill_list, ldestructive) + call util_spill(keeps%rbeg, discards%rbeg, lspill_list, ldestructive) call util_spill(keeps%vbeg, discards%vbeg, lspill_list, ldestructive) call util_spill(keeps%Ip, discards%Ip, lspill_list, ldestructive) call util_spill(keeps%rot, discards%rot, lspill_list, ldestructive) diff --git a/src/util/util_unique.f90 b/src/util/util_unique.f90 new file mode 100644 index 000000000..19eb4ba78 --- /dev/null +++ b/src/util/util_unique.f90 @@ -0,0 +1,80 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (swiftest_classes) s_util_unique + use swiftest +contains + + module subroutine util_unique_DP(input_array, output_array, index_map) + !! author: David A. Minton + !! + !! Takes an input unsorted integer array and returns a new array of sorted, unique values (DP version) + implicit none + ! Arguments + real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array + real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + ! Internals + real(DP), dimension(:), allocatable :: unique_array + integer(I4B) :: n + real(DP) :: lo, hi + + allocate(unique_array, mold=input_array) + allocate(index_map(size(input_array))) + lo = minval(input_array) - 1 + hi = maxval(input_array) + + n = 0 + do + n = n + 1 + lo = minval(input_array(:), mask=input_array(:) > lo) + unique_array(n) = lo + where(input_array(:) == lo) index_map(:) = n + if (lo >= hi) exit + enddo + allocate(output_array(n), source=unique_array(1:n)) + + return + end subroutine util_unique_DP + + + module subroutine util_unique_I4B(input_array, output_array, index_map) + !! author: David A. Minton + !! + !! Takes an input unsorted integer array and returns a new array of sorted, unique values (I4B version) + implicit none + ! Arguments + integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array + integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + ! Internals + integer(I4B), dimension(:), allocatable :: unique_array + integer(I4B) :: n, lo, hi + + allocate(unique_array, mold=input_array) + allocate(index_map, mold=input_array) + lo = minval(input_array) - 1 + hi = maxval(input_array) + + n = 0 + do + n = n + 1 + lo = minval(input_array(:), mask=input_array(:) > lo) + unique_array(n) = lo + where(input_array(:) == lo) index_map(:) = n + if (lo >= hi) exit + enddo + allocate(output_array(n), source=unique_array(1:n)) + + return + end subroutine util_unique_I4B + + + +end submodule s_util_unique \ No newline at end of file diff --git a/src/whm/whm_kick.f90 b/src/whm/whm_kick.f90 index d782c89f4..b675e4370 100644 --- a/src/whm/whm_kick.f90 +++ b/src/whm/whm_kick.f90 @@ -90,11 +90,11 @@ module subroutine whm_kick_getacch_tp(self, system, param, t, lbeg) system%lbeg = lbeg if (lbeg) then - ah0(:) = whm_kick_getacch_ah0(pl%Gmass(1:npl), pl%xbeg(:, 1:npl), npl) + ah0(:) = whm_kick_getacch_ah0(pl%Gmass(1:npl), pl%rbeg(:, 1:npl), npl) do concurrent(i = 1:ntp, tp%lmask(i)) tp%ah(:, i) = tp%ah(:, i) + ah0(:) end do - call tp%accel_int(param, pl%Gmass(1:npl), pl%xbeg(:, 1:npl), npl) + call tp%accel_int(param, pl%Gmass(1:npl), pl%rbeg(:, 1:npl), npl) else ah0(:) = whm_kick_getacch_ah0(pl%Gmass(1:npl), pl%xend(:, 1:npl), npl) do concurrent(i = 1:ntp, tp%lmask(i)) @@ -112,14 +112,14 @@ module subroutine whm_kick_getacch_tp(self, system, param, t, lbeg) end subroutine whm_kick_getacch_tp - function whm_kick_getacch_ah0(mu, xhp, n) result(ah0) + function whm_kick_getacch_ah0(mu, rhp, n) result(ah0) !! author: David A. Minton !! !! Compute zeroth term heliocentric accelerations of planets implicit none ! Arguments real(DP), dimension(:), intent(in) :: mu - real(DP), dimension(:,:), intent(in) :: xhp + real(DP), dimension(:,:), intent(in) :: rhp integer(I4B), intent(in) :: n ! Result real(DP), dimension(NDIM) :: ah0 @@ -129,11 +129,11 @@ function whm_kick_getacch_ah0(mu, xhp, n) result(ah0) ah0(:) = 0.0_DP do i = 1, n - r2 = dot_product(xhp(:, i), xhp(:, i)) + r2 = dot_product(rhp(:, i), rhp(:, i)) irh = 1.0_DP / sqrt(r2) ir3h = irh / r2 fac = mu(i) * ir3h - ah0(:) = ah0(:) - fac * xhp(:, i) + ah0(:) = ah0(:) - fac * rhp(:, i) end do return @@ -227,7 +227,7 @@ module subroutine whm_kick_vh_pl(self, system, param, t, dt, lbeg) call pl%accel(system, param, t, lbeg) pl%lfirst = .false. end if - call pl%set_beg_end(xbeg = pl%rh) + call pl%set_beg_end(rbeg = pl%rh) else pl%ah(:, 1:npl) = 0.0_DP call pl%accel(system, param, t, lbeg)