From 7b104d5b20b8c01f0b0ed3f65de29db5250d14b6 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Thu, 25 Jan 2024 09:48:44 +0100 Subject: [PATCH] Add LEED calculator The Low Energy Electron Diffraction spectroscopy is now included with Matrix Inversion algoriyhm only for now. --- src/msspec/calculator.py | 413 +- src/msspec/iodata.py | 37 +- src/msspec/parameters.py | 69 +- src/msspec/spec/fortran/Makefile | 8 +- .../spec/fortran/led_mi_noso_nosp_nosym.mk | 11 + .../fortran/led_mi_noso_nosp_nosym/dwsph.f | 85 + .../fortran/led_mi_noso_nosp_nosym/facdif.f | 26 + .../fortran/led_mi_noso_nosp_nosym/facdif1.f | 113 + .../led_mi_noso_nosp_nosym/inv_mat_ms2_la.f | 192 + .../led_mi_noso_nosp_nosym/lapack_inv.f | 6809 +++++++++++++++++ .../led_mi_noso_nosp_nosym/leddif_mi.f | 915 +++ .../fortran/led_mi_noso_nosp_nosym/main.f | 21 + .../led_mi_noso_nosp_nosym/main_led_ns_mi.f | 1648 ++++ .../fortran/led_mi_noso_nosp_nosym/plotfd.f | 106 + .../fortran/led_mi_noso_nosp_nosym/process.py | 995 +++ .../led_mi_noso_nosp_nosym/treat_led.f | 785 ++ .../led_mi_noso_nosp_nosym/weight_sum.f | 335 + 17 files changed, 12544 insertions(+), 24 deletions(-) create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym.mk create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/dwsph.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif1.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/inv_mat_ms2_la.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/lapack_inv.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/leddif_mi.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main_led_ns_mi.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/plotfd.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/process.py create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/treat_led.f create mode 100644 src/msspec/spec/fortran/led_mi_noso_nosp_nosym/weight_sum.f diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py index 17f36ba..86194de 100644 --- a/src/msspec/calculator.py +++ b/src/msspec/calculator.py @@ -17,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/calculator.py -# Last modified: Tue, 25 Oct 2022 16:21:38 +0200 -# Committed by : Sylvain Tricot 1666707698 +0200 +# Last modified: Thu, 25 Jan 2024 09:48:44 +0100 +# Committed by : Sylvain Tricot """ @@ -83,6 +83,7 @@ from msspec.parameters import CompCurveGeneralParameters from msspec.parameters import DetectorParameters from msspec.parameters import EIGParameters from msspec.parameters import GlobalParameters +from msspec.parameters import LEEDParameters from msspec.parameters import MuffintinParameters from msspec.parameters import PEDParameters from msspec.parameters import PhagenMallocParameters @@ -98,6 +99,7 @@ from msspec.spec.fortran import _eig_pw from msspec.spec.fortran import _phd_mi_noso_nosp_nosym from msspec.spec.fortran import _phd_se_noso_nosp_nosym from msspec.spec.fortran import _phd_ce_noso_nosp_nosym +from msspec.spec.fortran import _led_mi_noso_nosp_nosym from msspec.spec.fortran import _comp_curves from msspec.utils import get_atom_index @@ -150,6 +152,9 @@ class _MSCALCULATOR(Calculator): if spectroscopy == 'PED': self.spectroscopy_parameters = PEDParameters(self.phagen_parameters, self.spec_parameters) + elif spectroscopy == 'LEED': + self.spectroscopy_parameters = LEEDParameters(self.phagen_parameters, + self.spec_parameters) elif spectroscopy == 'EIG': self.spectroscopy_parameters = EIGParameters(self.phagen_parameters, self.spec_parameters) @@ -413,6 +418,14 @@ class _MSCALCULATOR(Calculator): "an allowed combination.".format(self.global_parameters.spectroscopy, self.global_parameters.algorithm)) raise ValueError + elif self.global_parameters.spectroscopy == 'LEED': + if self.global_parameters.algorithm == 'inversion': + do_spec = _led_mi_noso_nosp_nosym.run + else: + LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not " + "an allowed combination.".format(self.global_parameters.spectroscopy, + self.global_parameters.algorithm)) + raise ValueError elif self.global_parameters.spectroscopy == 'EIG': if self.global_parameters.algorithm == 'inversion': do_spec = _eig_mi.run @@ -1047,6 +1060,400 @@ class _EIG(_MSCALCULATOR): return self.iodata +class _LEED(_MSCALCULATOR): + """This class creates a calculator object for Low Electron Energy Diffraction + spectroscopy. + + :param algorithm: The algorithm to use for the computation. See + :ref:`globalparameters-algorithm` for more details about the allowed + values and the type. + + :param polarization: The incoming light polarization (see + :ref:`globalparameters-polarization`) + + :param dichroism: Wether to enable or not the dichroism (see + :ref:`globalparameters-dichroism`) + + :param spinpol: Enable or disable the spin polarization in the calculation + (see :ref:`globalparameters-spinpol`) + + :param folder: The path to the temporary folder for the calculations. See + :ref:`globalparameters-folder` + + :param txt: The name of a file where to redirect standard output. The string + '-' will redirect the standard output to the screen (default). + :type txt: str + + .. note:: + + This class constructor is not meant to be called directly by the user. + Use the :py:func:`MSSPEC` to instanciate any calculator. + + + """ + def __init__(self, algorithm='inversion', polarization=None, dichroism=None, + spinpol=False, folder='./calc', txt='-'): + _MSCALCULATOR.__init__(self, spectroscopy='LEED', algorithm=algorithm, + polarization=polarization, dichroism=dichroism, + spinpol=spinpol, folder=folder, txt=txt) + self.source_parameters.theta = 0 + self.source_parameters.phi = 0 + + self.iodata = iodata.Data('LEED Simulation') + + def _get_scan(self, scan_type='theta', phi=0, + theta=np.linspace(-70, 70, 141), + kinetic_energy=None, data=None, + malloc={}, other_parameters={}): + LOGGER.info("Computting the %s scan...", scan_type) + # Force absorber to be 0. + self.atoms.absorber = get_atom_index(self.atoms, 0, 0, 0) + self.detector_parameters.rotate = True + self.source_parameters.theta = 0 + self.source_parameters.phi = 0 + if data: + self.iodata = data + + if kinetic_energy is None: + LOGGER.error('The kinetic energy is not specified!') + raise ValueError('You must define a kinetic_energy value.') + + # update the parameters + self.scan_parameters.set_parameter('kinetic_energy', kinetic_energy) + all_ke = self.scan_parameters.get_parameter('ke_array') + if np.any(all_ke.value < 0): + LOGGER.error('Source energy is not high enough or level too deep!') + raise ValueError('Kinetic energy is < 0! ({})'.format( + kinetic_energy)) + self.scan_parameters.set_parameter('type', scan_type) + + # make sure there is only one energy point in scatf scan + if scan_type == 'scatf': + assert len(all_ke) == 1, ('kinetic_energy should not be an array ' + 'in scatf scan') + + + if scan_type != 'scatf': + self.scan_parameters.set_parameter('phi', phi) + self.scan_parameters.set_parameter('theta', theta) + + #self.spectroscopy_parameters.set_parameter('level', level) + + # It is still possible to modify any option right before runing phagen + # and spec + for k, v in other_parameters.items(): + grp_str, param_str = k.split('.') + grp = getattr(self, grp_str) + grp.set_parameter(param_str, v, force=True) + + self.get_tmatrix() + self.run_spec(malloc) + + # Now load the data + ndset = len(self.iodata) + dset = self.iodata.add_dset('{} scan [{:d}]'.format(scan_type, ndset)) + for p in self.get_parameters(): + bundle = {'group': str(p.group), + 'name': str(p.name), + 'value': str(p.value), + 'unit': '' if p.unit is None else str(p.unit)} + dset.add_parameter(**bundle) + if scan_type in ('theta', 'phi', 'energy'): + results_fname = os.path.join(self.tmp_folder, 'output/results.dat') + data = self.specio.load_results(results_fname) + for _plane, _theta, _phi, _energy, _dirsig, _cs in data.T: + if _plane == -1: + dset.add_row(theta=_theta, phi=_phi, energy=_energy, cross_section=_cs, direct_signal=_dirsig) + elif scan_type in ('scatf',): + results_fname = os.path.join(self.tmp_folder, 'output/facdif1.dat') + data = self.specio.load_facdif(results_fname) + data = data[:, [1, 4, 5, 6, 8]].T + _proto, _sf_real, _sf_imag, _theta, _energy = data + _sf = _sf_real + _sf_imag * 1j + dset.add_columns(proto_index=_proto, sf_real=np.real(_sf), + sf_imag=np.imag(_sf), sf_module=np.abs(_sf), + theta=_theta, energy=_energy) + elif scan_type in ('theta_phi',): + results_fname = os.path.join(self.tmp_folder, 'output/results.dat') + data = self.specio.load_results(results_fname) + #theta_c, phi_c = data[[2, 3], :] + #xsec_c = data[-1, :] + #dirsig_c = data[-2, :] + + #dset.add_columns(theta=theta_c) + #dset.add_columns(phi=phi_c) + #dset.add_columns(cross_section=xsec_c) + #dset.add_columns(direct_signal=dirsig_c) + for _plane, _theta, _phi, _energy, _dirsig, _cs in data.T: + if _plane == -1: + dset.add_row(theta=_theta, phi=_phi, energy=_energy, cross_section=_cs, + direct_signal=_dirsig) + + # create a view + title = '' + for ke in all_ke.value: + if scan_type == 'theta': + title = 'Polar scan at {:.2f} eV'.format(ke) + xlabel = r'Angle $\theta$($\degree$)' + ylabel = r'Signal (a. u.)' + + view = dset.add_view("E = {:.2f} eV".format(ke), title=title, + xlabel=xlabel, ylabel=ylabel, autoscale=True) + for angle_phi in self.scan_parameters.get_parameter( + 'phi').value: + where = ("energy=={:.2f} and phi=={:.2f}" + "").format(ke, angle_phi) + legend = r'$\phi$ = {:.1f} $\degree$'.format(angle_phi) + view.select('theta', 'cross_section', where=where, + legend=legend) + if scan_type == 'phi': + title = 'Azimuthal scan at {:.2f} eV'.format(ke) + xlabel = r'Angle $\phi$($\degree$)' + ylabel = r'Signal (a. u.)' + + view = dset.add_view("E = {:.2f} eV".format(ke), title=title, + xlabel=xlabel, ylabel=ylabel) + for angle_theta in self.scan_parameters.get_parameter( + 'theta').value: + where = ("energy=={:.2f} and theta=={:.2f}" + "").format(ke, angle_theta) + legend = r'$\theta$ = {:.1f} $\degree$'.format(angle_theta) + view.select('phi', 'cross_section', where=where, + legend=legend) + + if scan_type == 'theta_phi': + absorber_symbol = self.atoms[self.atoms.absorber].symbol + title = ('Stereographic projection at {:.2f} eV' + '').format(ke) + xlabel = r'Angle $\phi$($\degree$)' + ylabel = r'Signal (a. u.)' + + view = dset.add_view("E = {:.2f} eV".format(ke), title=title, + xlabel=xlabel, ylabel=ylabel, + projection='stereo', colorbar=True, autoscale=True) + view.select('theta', 'phi', 'cross_section') + + + if scan_type == 'scatf': + for i in range(self.phagenio.nat): + proto_index = i+1 + title = 'Scattering factor at {:.3f} eV'.format(kinetic_energy) + + mini = min(map(np.min, [dset.sf_real, dset.sf_imag, dset.sf_module])) + maxi = max(map(np.max, [dset.sf_real, dset.sf_imag, dset.sf_module])) + view = dset.add_view("Proto. atom #{:d}".format(proto_index), + title=title, projection='polar', + ylim=[mini, maxi]) + where = "proto_index=={:d}".format(proto_index) + view.select('theta', 'sf_module', where=where, + legend=r'$|f(\theta)|$') + view.select('theta', 'sf_real', where=where, + legend=r'$\Re(f(\theta))$') + view.select('theta', 'sf_imag', where=where, + legend=r'$\Im(f(\theta))$') + + if scan_type == 'energy': + absorber_symbol = self.atoms[self.atoms.absorber].symbol + title = (r'Energy scan of {}({}) at $\theta$={:.2f}$\degree$ and ' + '$\phi$={:.2f}$\degree$').format( + absorber_symbol, level, theta, phi) + xlabel = r'Photoelectron kinetic energy (eV)' + ylabel = r'Signal (a. u.)' + + view = dset.add_view("EnergyScan".format(ke), title=title, + xlabel=xlabel, ylabel=ylabel) + view.select('energy', 'cross_section') + + # save the cluster + #clusbuf = StringIO() + #self.atoms.info['absorber'] = self.atoms.absorber + #self.atoms.write(clusbuf, format='xyz') + #dset.add_parameter(group='Cluster', name='cluster', value=clusbuf.getvalue(), hidden="True") + self.add_cluster_to_dset(dset) + + LOGGER.info('%s scan computing done!', scan_type) + + return self.iodata + + def get_potential(self, atom_index=None, data=None, units={'energy': 'eV', 'space': 'angstrom'}): + """Computes the coulombic part of the atomic potential. + + :param atom_index: The atom indices to get the potential of, either as a list or as a single integer + :param data: The data object to store the results to + :param units: The units to be used. A dictionary with the keys 'energy' and 'space' + :return: A Data object + """ + LOGGER.info("Getting the Potential...") + LOGGER.debug(get_call_info(inspect.currentframe())) + + _units = {'energy': 'eV', 'space': 'angstrom'} + _units.update(units) + + if data: + self.iodata = data + + self.run_phagen() + + filename = os.path.join(self.tmp_folder, 'output/tmatrix.tl') + tl = self.phagenio.load_tl_file(filename) + + filename = os.path.join(self.tmp_folder, 'output/cluster.clu') + self.phagenio.load_cluster_file(filename) + + if self.phagen_parameters.potgen in ('in'): + filename = os.path.join(self.tmp_folder, 'output/plot/plot_vc.dat') + else: + filename = os.path.join(self.tmp_folder, 'output/plot/plot_v.dat') + pot_data = self.phagenio.load_potential_file(filename) + + cluster = self.phagen_parameters.get_parameter('atoms').value + + dset = self.iodata.add_dset('Potential [{:d}]'.format(len(self.iodata))) + r = [] + v = [] + index = np.empty((0,1), dtype=int) + + absorber_position = cluster[cluster.absorber].position + for _pot_data in pot_data: + # find the proto index of these data + at_position = (_pot_data['coord'] * UREG.bohr_radius).to('angstrom').magnitude + absorber_position + at_index = get_atom_index(cluster, *at_position) + at_proto_index = cluster[at_index].get('proto_index') + #values = np.asarray(_pot_data['values']) + values = _pot_data['values'] + index = np.append(index, np.ones(values.shape[0], dtype=int) * at_proto_index) + r = np.append(r, (values[:, 0] * UREG.bohr_radius).to(_units['space']).magnitude) + v = np.append(v, (values[:, 1] * UREG.rydberg).to(_units['energy']).magnitude) + + dset.add_columns(distance=r, potential=v, index=index) + view = dset.add_view('potential data', title='Potential energy of atoms', + xlabel='distance from atomic center [{:s}]'.format(_units['space']), + ylabel='energy [{:s}]'.format(_units['energy']), scale='linear', + autoscale=True) + + if atom_index == None: + for i in range(pot_data[len(pot_data) - 1]['index']): + view.select('distance', 'potential', where="index=={:d}".format(i), + legend="Atom index #{:d}".format(i + 1)) + else: + for i in atom_index: + view.select('distance', 'potential', where="index=={:d}".format(cluster[i].get('proto_index') - 1), + legend="Atom index #{:d}".format(i)) + + return self.iodata + + def get_scattering_factors(self, level='1s', kinetic_energy=None, + data=None, **kwargs): + """Computes the scattering factors of all prototypical atoms in the + cluster. + + This function computes the real and imaginery parts of the scattering + factor as well as its modulus for each non symetrically equivalent atom + in the cluster. The results are stored in the *data* object if provided + as a parameter. + + :param level: The electronic level. See :ref:`pedparameters-level`. + :param kinetic_energy: see :ref:`scanparameters-kinetic_energy`. + :param data: a :py:class:`iodata.Data` object to append the results to + or None. + + :returns: The modified :py:class:`iodata.Data` object passed as an + argument or a new :py:class:`iodata.Data` object. + + """ + data = self._get_scan(scan_type='scatf', level=level, data=data, + kinetic_energy=kinetic_energy, **kwargs) + return data + + def get_theta_scan(self, phi=0, theta=np.linspace(-70, 70, 141), + kinetic_energy=None, data=None, **kwargs): + """Computes a polar scan of the emitted photoelectrons. + + :param phi: The azimuthal angle in degrees. See + :ref:`scanparameters-phi`. + :param theta: All the values of the polar angle to be computed. See + :ref:`scanparameters-theta`. + :param level: The electronic level. See :ref:`pedparameters-level`. + :param kinetic_energy: see :ref:`scanparameters-kinetic_energy`. + :param data: a :py:class:`iodata.Data` object to append the results to + or None. + + :returns: The modified :py:class:`iodata.Data` object passed as an + argument or a new :py:class:`iodata.Data` object. + + """ + data = self._get_scan(scan_type='theta', theta=theta, + phi=phi, kinetic_energy=kinetic_energy, + data=data, **kwargs) + return data + + def get_phi_scan(self, phi=np.linspace(0, 359, 359), theta=0, + kinetic_energy=None, data=None, **kwargs): + """Computes an azimuthal scan of the emitted photoelectrons. + + :param phi: All the values of the azimuthal angle to be computed. See + :ref:`scanparameters-phi`. + :param theta: The polar angle in degrees. See + :ref:`scanparameters-theta`. + :param level: The electronic level. See :ref:`pedparameters-level`. + :param kinetic_energy: see :ref:`scanparameters-kinetic_energy`. + :param data: a :py:class:`iodata.Data` object to append the results to + or None. + + :returns: The modified :py:class:`iodata.Data` object passed as an + argument or a new :py:class:`iodata.Data` object. + + """ + data = self._get_scan(scan_type='phi', theta=theta, + phi=phi, kinetic_energy=kinetic_energy, + data=data, **kwargs) + return data + + def get_theta_phi_scan(self, phi=np.linspace(0, 360), + theta=np.linspace(0, 90, 45), + kinetic_energy=None, data=None, **kwargs): + """Computes a stereographic scan of the emitted photoelectrons. + + The azimuth ranges from 0 to 360° and the polar angle ranges from 0 to + 90°. + + :param level: The electronic level. See :ref:`pedparameters-level`. + :param kinetic_energy: see :ref:`scanparameters-kinetic_energy`. + :param data: a :py:class:`iodata.Data` object to append the results to + or None. + + :returns: The modified :py:class:`iodata.Data` object passed as an + argument or a new :py:class:`iodata.Data` object. + + """ + data = self._get_scan(scan_type='theta_phi', theta=theta, + phi=phi, kinetic_energy=kinetic_energy, data=data, + **kwargs) + return data + + def get_energy_scan(self, phi=0, theta=0, + level=None, kinetic_energy=None, data=None, **kwargs): + """Computes an energy scan of the emitted photoelectrons. + + :param phi: All the values of the azimuthal angle to be computed. See + :ref:`scanparameters-phi`. + :param theta: The polar angle in degrees. See + :ref:`scanparameters-theta`. + :param level: The electronic level. See :ref:`pedparameters-level`. + :param kinetic_energy: see :ref:`scanparameters-kinetic_energy`. + :param data: a :py:class:`iodata.Data` object to append the results to + or None. + + :returns: The modified :py:class:`iodata.Data` object passed as an + argument or a new :py:class:`iodata.Data` object. + + """ + data = self._get_scan(scan_type='energy', level=level, theta=theta, + phi=phi, kinetic_energy=kinetic_energy, + data=data, **kwargs) + return data + + def MSSPEC(spectroscopy='PED', **kwargs): """ The MsSpec calculator constructor. @@ -1285,5 +1692,7 @@ class RFACTOR(object): + + if __name__ == "__main__": pass diff --git a/src/msspec/iodata.py b/src/msspec/iodata.py index 144bd03..11b842e 100644 --- a/src/msspec/iodata.py +++ b/src/msspec/iodata.py @@ -17,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/iodata.py -# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 -# Committed by : sylvain tricot +# Last modified: Thu, 25 Jan 2024 09:48:44 +0100 +# Committed by : Sylvain Tricot """ @@ -86,6 +86,7 @@ from matplotlib.backends.backend_wxagg import FigureCanvasWxAgg as FigureCanvas from matplotlib.backends.backend_agg import FigureCanvasAgg from matplotlib.backends.backend_wxagg import NavigationToolbar2WxAgg from matplotlib.figure import Figure +from matplotlib.ticker import FormatStrFormatter from terminaltables import AsciiTable import msspec @@ -93,13 +94,17 @@ from msspec.msspecgui.msspec.gui.clusterviewer import ClusterViewer from msspec.misc import LOGGER -def cols2matrix(x, y, z, nx=88*1+1, ny=360*1+1): +def cols2matrix(x, y, z, nx=88*1+1, ny=360*1+1, xlim=[None, None], ylim=[None, None]): # mix the values of existing theta and new theta and return the # unique values - newx = np.linspace(np.min(x), np.max(x), nx) + xmin = xlim[0] if xlim[0] is not None else np.min(x) + xmax = xlim[1] if xlim[1] is not None else np.max(x) + ymin = ylim[0] if ylim[0] is not None else np.min(y) + ymax = ylim[1] if ylim[1] is not None else np.max(y) + newx = np.linspace(xmin, xmax, nx) newy = np.linspace(np.min(y), np.max(y), ny) - ux = np.unique(np.append(x, newx)) - uy = np.unique(np.append(y, newy)) + ux = np.unique(np.sort(np.append(x, newx)).clip(xmin, xmax)) + uy = np.unique(np.sort(np.append(y, newy)).clip(ymin, ymax)) # create an empty matrix to hold the results zz = np.empty((len(ux), len(uy))) @@ -813,7 +818,8 @@ class _DataSetView(object): xlabel='', ylabel='', grid=True, legend=[], colorbar=False, projection='rectilinear', xlim=[None, None], ylim=[None, None], scale='linear', - marker=None, autoscale=False) + specular=None, + marker=None, autoscale=True) self._plotopts.update(plotopts) self._selection_tags = [] self._selection_conditions = [] @@ -879,19 +885,26 @@ class _DataSetView(object): axes.set_xticks(xvalues) else: if proj in ('ortho', 'stereo'): - theta, phi, Xsec = cols2matrix(*values) - theta_ticks = np.arange(0, 91, 15) + theta, phi, Xsec = cols2matrix(*values, xlim=opts['xlim'], ylim=opts['ylim']) + #theta_ticks = np.arange(0, 91, 15) + theta_ticks = np.linspace(np.min(theta), np.max(theta), 7) if proj == 'ortho': R = np.sin(np.radians(theta)) R_ticks = np.sin(np.radians(theta_ticks)) elif proj == 'stereo': R = 2 * np.tan(np.radians(theta/2.)) R_ticks = 2 * np.tan(np.radians(theta_ticks/2.)) - #R = np.tan(np.radians(theta/2.)) X, Y = np.meshgrid(np.radians(phi), R) + if opts['specular'] is not None: + Xsec[Y. # # Source file : src/msspec/parameters.py -# Last modified: Tue, 15 Feb 2022 15:37:28 +0100 -# Committed by : Sylvain Tricot +# Last modified: Thu, 25 Jan 2024 09:48:45 +0100 +# Committed by : Sylvain Tricot """ @@ -488,11 +488,11 @@ class SpecParameters(BaseParameters): fmt='.2f'), Parameter('leed_r1', types=float, default=-1.0, fmt='.3f'), - Parameter('leed_thini', types=float, default=-55.0, + Parameter('leed_thini', types=float, default=0., fmt='.2f'), Parameter('leed_phiini', types=float, default=0., fmt='.2f'), - Parameter('leed_imod', types=int, default=1, + Parameter('leed_imod', types=int, default=0, fmt='d'), Parameter('leed_imoy', types=int, default=0, fmt='d'), @@ -833,7 +833,7 @@ class GlobalParameters(BaseParameters): 'AED': ('aed', 'AED'), 'LEED': ('led', 'LED'), 'EXAFS': ('xas', 'XAS'), - 'EIG': ('xpd', 'EIG'), + 'EIG': ('led', 'EIG'), } phagen_calctype, spec_calctype = mapping[p.value] self.phagen_parameters.calctype = phagen_calctype @@ -1154,7 +1154,7 @@ class DetectorParameters(BaseParameters): default=None, doc=""" Used to averaged the signal over directions lying in the cone of half-angle *angular_acceptance*. The number of - directions to take into account depends on the choosen + directions to take into account depends on the chosen value: - **None**, for no averaging at all @@ -1307,7 +1307,7 @@ class ScanParameters(BaseParameters): calculation_parameters.set_parameter('basis_functions', 'spherical', force=True) - LOGGER.info('\'%s\' scan type choosen.', p.value) + LOGGER.info('\'%s\' scan type chosen.', p.value) def bind_theta(self, p): spectro = self.global_parameters.spectroscopy @@ -1422,6 +1422,10 @@ class ScanParameters(BaseParameters): self.spec_parameters.ped_e1 = energies[1] self.spec_parameters.ped_ne = energies[2] + self.spec_parameters.leed_e0 = energies[0] + self.spec_parameters.leed_e1 = energies[1] + self.spec_parameters.leed_ne = energies[2] + self.spec_parameters.eigval_ekini = energies[0] self.spec_parameters.eigval_ekfin = energies[1] self.spec_parameters.eigval_ne = energies[2] @@ -1829,6 +1833,57 @@ class PEDParameters(BaseParameters): self.spec_parameters.ped_iso = somap[p.value] +class LEEDParameters(BaseParameters): + def __init__(self, phagen_parameters, spec_parameters): + # parameters = ( + # Parameter('level', types=str, pattern=r'\d+[spdfgSPDFG](\d/2)?$', + # default='1s', doc=""" + # The level is the electronic level where the electron comes from. + # It is written: *nlJ* + # where: + + # - *n* is the principal quantum number + # - *l* is the orbital quantum number + # - *J* is the spin-orbit component + + # Example:: + + # >>> calc.spectroscopy_parameters.level = '2p3/2' + # >>> calc.spectroscopy_parameters.level = '2p' # is equivalent to '2p1/2' + + # """), + # Parameter('final_state', types=int, limits=(-1, 2), default=2), + # Parameter('spin_orbit', types=(type(None), str), + # allowed_values=(None, 'single', 'both'), default=None), + # ) + BaseParameters.__init__(self) + #self.add_parameters(*parameters) + self.phagen_parameters = phagen_parameters + self.spec_parameters = spec_parameters + + # def bind_level(self, p): + # edge = get_level_from_electron_configuration(p.value) + # self.phagen_parameters.edge = edge + + # li, so = re.match(r'(^\d+[spdfg])(.*$)', p.value).groups() + # if so == '': + # so = '1/2' + + # self.spec_parameters.ped_li = li + # self.spec_parameters.ped_so = so + # self.spec_parameters.extra_level = p.value + + # def bind_final_state(self, p): + # self.spec_parameters.ped_initl = p.value + + # def bind_spin_orbit(self, p): + # somap = { + # None: 0, + # 'single': 1, + # 'both': 2} + # self.spec_parameters.ped_iso = somap[p.value] + + class EIGParameters(BaseParameters): def __init__(self, phagen_parameters, spec_parameters): parameters = ( diff --git a/src/msspec/spec/fortran/Makefile b/src/msspec/spec/fortran/Makefile index 01228ea..a57969f 100644 --- a/src/msspec/spec/fortran/Makefile +++ b/src/msspec/spec/fortran/Makefile @@ -1,6 +1,6 @@ -.PHONY: all phd_se phd_mi phd_ce eig_mi eig_pw comp_curve clean +.PHONY: all phd_se phd_mi phd_ce led_mi eig_mi eig_pw comp_curve clean -all: phd_se phd_mi phd_ce eig_mi eig_pw comp_curve +all: phd_se phd_mi phd_ce led_mi eig_mi eig_pw comp_curve phd_se: @+$(MAKE) -f phd_se_noso_nosp_nosym.mk all @@ -11,6 +11,9 @@ phd_mi: phd_ce: @+$(MAKE) -f phd_ce_noso_nosp_nosym.mk all +led_mi: + @+$(MAKE) -f led_mi_noso_nosp_nosym.mk all + eig_mi: @+$(MAKE) -f eig_mi.mk all @@ -24,6 +27,7 @@ clean:: @+$(MAKE) -f phd_se_noso_nosp_nosym.mk $@ @+$(MAKE) -f phd_mi_noso_nosp_nosym.mk $@ @+$(MAKE) -f phd_ce_noso_nosp_nosym.mk $@ + @+$(MAKE) -f led_mi_noso_nosp_nosym.mk $@ @+$(MAKE) -f eig_mi.mk $@ @+$(MAKE) -f eig_pw.mk $@ @+$(MAKE) -f comp_curve.mk $@ diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym.mk b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym.mk new file mode 100644 index 0000000..7cf040f --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym.mk @@ -0,0 +1,11 @@ +memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/allocation.f +cluster_gen_src := $(wildcard cluster_gen/*.f) +common_sub_src := $(wildcard common_sub/*.f) +renormalization_src := $(wildcard renormalization/*.f) +led_mi_noso_nosp_nosym_src := $(filter-out led_mi_noso_nosp_nosym/lapack_inv.f, $(wildcard led_mi_noso_nosp_nosym/*.f)) + +SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(led_mi_noso_nosp_nosym_src) +MAIN_F = led_mi_noso_nosp_nosym/main.f +SO = _led_mi_noso_nosp_nosym.so + +include ../../../options.mk diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/dwsph.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/dwsph.f new file mode 100644 index 0000000..6d48a79 --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/dwsph.f @@ -0,0 +1,85 @@ +C +C======================================================================= +C + SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED) +C +C This routine recomputes the T-matrix elements taking into account the +C mean square displacements. +C +C When the argument X is tiny, no vibrations are taken into account +C +C Last modified : 25 Apr 2013 +C + USE DIM_MOD +C + USE TRANS_MOD +C + DIMENSION GNT(0:N_GAUNT) +C + COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC +C + COMPLEX*16 FFL(0:2*NL_M) +C + DATA PI4,EPS /12.566371,1.0E-10/ +C + ZEROC=(0.,0.) +C + IF(X.GT.EPS) THEN +C +C Standard case: vibrations +C + IF(ISPEED.LT.0) THEN + NSUM_LB=ABS(ISPEED) + ENDIF +C + COEF=PI4*EXP(-X) + NL2=2*LMAX(JTYP,JE)+2 + IBESP=5 + MG1=0 + MG2=0 +C + CALL BESPHE(NL2,IBESP,X,FFL) +C + DO L=0,LMAX(JTYP,JE) + XL=FLOAT(L+L+1) + SL1=ZEROC +C + DO L1=0,LMAX(JTYP,JE) + XL1=FLOAT(L1+L1+1) + CALL GAUNT(L,MG1,L1,MG2,GNT) + L2MIN=ABS(L1-L) + IF(ISPEED.GE.0) THEN + L2MAX=L1+L + ELSEIF(ISPEED.LT.0) THEN + L2MAX=L2MIN+2*(NSUM_LB-1) + ENDIF + SL2=0. +C + DO L2=L2MIN,L2MAX,2 + XL2=FLOAT(L2+L2+1) + C=SQRT(XL1*XL2/(PI4*XL)) + SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2))) + ENDDO +C + SL1=SL1+SL2*TL(L1,1,JTYP,JE) + ENDDO +C + TLT(L,1,JTYP,JE)=COEF*SL1 +C + ENDDO +C + ELSE +C +C Argument X tiny: no vibrations +C + DO L=0,LMAX(JTYP,JE) +C + TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE) +C + ENDDO +C + ENDIF +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif.f new file mode 100644 index 0000000..2ac7683 --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif.f @@ -0,0 +1,26 @@ +C +C======================================================================= +C + SUBROUTINE FACDIF(COSTH,JAT,JE,FTHETA) +C +C This routine computes the plane wave scattering factor +C + USE DIM_MOD +C + USE TRANS_MOD +C + DIMENSION PL(0:100) +C + COMPLEX FTHETA +C + FTHETA=(0.,0.) + NL=LMAX(JAT,JE)+1 + CALL POLLEG(NL,COSTH,PL) + DO 20 L=0,NL-1 + FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L) + 20 CONTINUE + FTHETA=FTHETA/VK(JE) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif1.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif1.f new file mode 100644 index 0000000..62ac3f8 --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif1.f @@ -0,0 +1,113 @@ +C +C======================================================================= +C + SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J + &E,*) +C +C This routine computes a spherical wave scattering factor +C +C Last modified : 03/04/2006 +C + USE DIM_MOD + USE APPROX_MOD + USE EXPFAC_MOD + USE TRANS_MOD + USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I + &6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST +C + DIMENSION PLMM(0:100,0:100) + DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ + COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE + COMPLEX RHOJK +C +C + DATA PI/3.141593/ +C + A=1. + INTER=0 + IF(ITL.EQ.1) VKE=VK(JE) + RHOJ=VKE*RJ + RHOJK=VKE*RJK + HLM1=(1.,0.) + HLM2=(1.,0.) + HLM3=(1.,0.) + HLM4=(1.,0.) + IEM=1 + CSTH=COS(BETA) + IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN + INTER=1 + BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI)) + ENDIF + CALL PLM(CSTH,PLMM,LMAX(JAT,JE)) + IF(ISPHER.EQ.0) NO1=0 + IF(ISPHER.EQ.1) THEN + IF(NO.EQ.8) THEN + NO1=LMAX(JAT,JE)+1 + ELSE + NO1=NO + ENDIF + CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM) + IF(IEM.EQ.0) THEN + HLM4=HLM(0,L) + ENDIF + IF(RJK.GT.0.0001) THEN + NDUM=0 + CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN) + ENDIF + CALL DJMN(THRJ,D,L) + A1=ABS(D(0,M,L)) + IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1 + & + ENDIF + MUMAX=MIN0(L,NO1) + SMU=(0.,0.) + DO 10 MU=0,MUMAX + IF(MOD(MU,2).EQ.0) THEN + B=1. + ELSE + B=-1. + IF(SIN(BETA).LT.0.) THEN + A=-1. + ENDIF + ENDIF + IF(ISPHER.LE.1) THEN + ALMU=(1.,0.) + C=1. + ENDIF + IF(ISPHER.EQ.0) GOTO 40 + IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L)) + IF(MU.GT.0) THEN + C=B*FLOAT(L+L+1)/EXPF(MU,L) + ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B* + * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU + ELSE + C=1. + ALMU=CMPLX(D(M,0,L))/BLMU + ENDIF + 40 SNU=(0.,0.) + NU1=INT(0.5*(NO1-MU)+0.0001) + NUMAX=MIN0(NU1,L-MU) + DO 20 NU=0,NUMAX + SLP=(0.,0.) + LPMIN=MAX0(MU,NU) + DO 30 LP=LPMIN,LMAX(JAT,JE) + IF(ISPHER.EQ.1) THEN + HLM1=HLM(NU,LP) + IF(RJK.GT.0.0001) HLM3=HLN(0,LP) + ENDIF + SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3 + 30 CONTINUE + IF(ISPHER.EQ.1) THEN + HLM2=HLM(MU+NU,L) + ENDIF + SNU=SNU+SLP*HLM2 + 20 CONTINUE + SMU=SMU+SNU*C*ALMU*A*B + 10 CONTINUE + FSPH=SMU/(VKE*HLM4) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/inv_mat_ms2_la.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/inv_mat_ms2_la.f new file mode 100644 index 0000000..7f992ef --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/inv_mat_ms2_la.f @@ -0,0 +1,192 @@ +C +C======================================================================= +C + SUBROUTINE INV_MAT_MS(JE,TAU) +C +C This subroutine stores the multiple scattering matrix and invert +C it to obtain the scattering path operator exactly. +C +C (Photoelectron case) +C +C Last modified : 24 Apr 2007 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE COOR_MOD + USE INIT_L_MOD + USE TRANS_MOD +C +C PARAMETER(NLTWO=2*NL_M) +C + COMPLEX*16 HL1(0:2*NL_M),SM(LINMAX*NATCLU_M,LINMAX*NATCLU_M) + COMPLEX*16 SUM_L,ONEC,IC,ZEROC,WORK(4*LINMAX*NATCLU_M) + COMPLEX*16 YLM(0:2*NL_M,-2*NL_M:2*NL_M),TLJ,TLK,EXPKJ +C + COMPLEX TAU(LINMAX*LINMAX*NATCLU_M*NATCLU_M) +C +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ +C + INTEGER IPIV(LINMAX*NATCLU_M) +C +C + DATA PI /3.1415926535898D0/ +C + ONEC=(1.D0,0.D0) + IC=(0.D0,1.D0) + ZEROC=(0.D0,0.D0) + IBESS=3 +C +C Construction of the multiple scattering matrix MS = (I-GoT). +C Elements are stored using a linear index LINJ representing +C (J,LJ) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + TLJ=DCMPLX(TL(LJ,1,JTYP,JE)) + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + JLIN=JLIN+1 +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.NE.JATL) THEN + XKJ=DBLE(SYM_AT(1,KATL)-XJ) + YKJ=DBLE(SYM_AT(2,KATL)-YJ) + ZKJ=DBLE(SYM_AT(3,KATL)-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))* + & RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM, + & LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ, + & HL1) + ENDIF +C + DO LK=0,LMK + ILK=LK*LK+LK+1 + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + INDK=ILK+MK + KLIN=KLIN+1 + SM(KLIN,JLIN)=ZEROC + SUM_L=ZEROC + IF(KATL.NE.JATL) THEN + CALL GAUNT2(LK,MK,LJ,MJ,GNT) +C + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L=SUM_L+(IC**L)* + & HL1(L)*YLM(L,M)*GNT(L) + ENDIF + ENDDO + SUM_L=SUM_L*ATTKJ*4.D0*PI*IC + ELSE + SUM_L=ZEROC + ENDIF +C + IF(KLIN.EQ.JLIN) THEN + SM(KLIN,JLIN)=ONEC-TLK* + & SUM_L + ELSE + SM(KLIN,JLIN)=-TLK*SUM_L + ENDIF +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + LWORK=JLIN +C +C Inversion of the multiple scattering matrix MS and +C multiplication by T +C + CALL ZGETRF(JLIN,JLIN,SM,LINMAX*NATCLU_M,IPIV,INFO1) + IF(INFO1.NE.0) THEN + WRITE(6,*) ' ---> INFO1 =',INFO1 + ELSE + CALL ZGETRI(JLIN,SM,LINMAX*NATCLU_M,IPIV,WORK,LWORK,INFO) + IF(INFO.NE.0) THEN + WRITE(6,*) ' ---> WORK(1),INFO =',WORK(1),INFO + ENDIF + ENDIF +C +C Storage of the Tau matrix +C + LIN=0 +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) +C + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + TLJ=DCMPLX(TL(LJ,1,JTYP,JE)) + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + JLIN=JLIN+1 +C + DO LK=0,LMK + ILK=LK*LK+LK+1 + DO MK=-LK,LK + INDK=ILK+MK + KLIN=KLIN+1 + LIN=LIN+1 + TAU(LIN)=CMPLX(SM(KLIN,JLIN)*TLJ) + ENDDO + ENDDO + KLIN=KLIN-INDK +C + ENDDO + ENDDO + KLIN=KLIN+INDK + JLIN=JLIN-INDJ +C + ENDDO + ENDDO + JLIN=JLIN+INDJ +C + ENDDO + ENDDO +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/lapack_inv.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/lapack_inv.f new file mode 100644 index 0000000..482f2d6 --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/lapack_inv.f @@ -0,0 +1,6809 @@ +C +C======================================================================= +C +C LAPACK inversion subroutines +C +C======================================================================= +C +C (version 3.6.1) June 2016 +C +C======================================================================= +C +*> \brief \b ZGETRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGETRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETRI computes the inverse of a matrix using the LU factorization +*> computed by ZGETRF. +*> +*> This method inverts U and then computes inv(A) by solving the system +*> inv(A)*L = inv(U) for inv(A). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the factors L and U from the factorization +*> A = P*L*U as computed by ZGETRF. +*> On exit, if INFO = 0, the inverse of the original matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZGETRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO=0, then WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,N). +*> For optimal performance LWORK >= N*NB, where NB is +*> the optimal blocksize returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is +*> singular and its inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, + $ NBMIN, NN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM, ZTRTRI +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRI', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form inv(U). If INFO > 0 from ZTRTRI, then U is singular, +* and the inverse is not computed. +* + CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) + IF( INFO.GT.0 ) + $ RETURN +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = MAX( LDWORK*NB, 1 ) + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1, -1 ) ) + END IF + ELSE + IWS = N + END IF +* +* Solve the equation inv(A)*L = inv(U) for inv(A). +* + IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN +* +* Use unblocked code. +* + DO 20 J = N, 1, -1 +* +* Copy current column of L to WORK and replace with zeros. +* + DO 10 I = J + 1, N + WORK( I ) = A( I, J ) + A( I, J ) = ZERO + 10 CONTINUE +* +* Compute current column of inv(A). +* + IF( J.LT.N ) + $ CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), + $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) + 20 CONTINUE + ELSE +* +* Use blocked code. +* + NN = ( ( N-1 ) / NB )*NB + 1 + DO 50 J = NN, 1, -NB + JB = MIN( NB, N-J+1 ) +* +* Copy current block column of L to WORK and replace with +* zeros. +* + DO 40 JJ = J, J + JB - 1 + DO 30 I = JJ + 1, N + WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) + A( I, JJ ) = ZERO + 30 CONTINUE + 40 CONTINUE +* +* Compute current block column of inv(A). +* + IF( J+JB.LE.N ) + $ CALL ZGEMM( 'No transpose', 'No transpose', N, JB, + $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, + $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) + CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, + $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) + 50 CONTINUE + END IF +* +* Apply column interchanges. +* + DO 60 J = N - 1, 1, -1 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) + 60 CONTINUE +* + WORK( 1 ) = IWS + RETURN +* +* End of ZGETRI +* + END +C +C====================================================================== +C +*> \brief \b ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZTRTI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRTI2 computes the inverse of a complex upper or lower triangular +*> matrix. +*> +*> This is the Level 2 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the triangular matrix A. If UPLO = 'U', the +*> leading n by n upper triangular part of the array A contains +*> the upper triangular matrix, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n by n lower triangular part of the array A contains +*> the lower triangular matrix, and the strictly upper +*> triangular part of A is not referenced. If DIAG = 'U', the +*> diagonal elements of A are also not referenced and are +*> assumed to be 1. +*> +*> On exit, the (triangular) inverse of the original matrix, in +*> the same storage format. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J + COMPLEX*16 AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZSCAL, ZTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTRTI2', -INFO ) + RETURN + END IF +* + IF( UPPER ) THEN +* +* Compute inverse of upper triangular matrix. +* + DO 10 J = 1, N + IF( NOUNIT ) THEN + A( J, J ) = ONE / A( J, J ) + AJJ = -A( J, J ) + ELSE + AJJ = -ONE + END IF +* +* Compute elements 1:j-1 of j-th column. +* + CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, + $ A( 1, J ), 1 ) + CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* Compute inverse of lower triangular matrix. +* + DO 20 J = N, 1, -1 + IF( NOUNIT ) THEN + A( J, J ) = ONE / A( J, J ) + AJJ = -A( J, J ) + ELSE + AJJ = -ONE + END IF + IF( J.LT.N ) THEN +* +* Compute elements j+1:n of j-th column. +* + CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J, + $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) + CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 ) + END IF + 20 CONTINUE + END IF +* + RETURN +* +* End of ZTRTI2 +* + END +C +C====================================================================== +C +*> \brief \b ZTRTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZTRTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRTRI computes the inverse of a complex upper or lower triangular +*> matrix A. +*> +*> This is the Level 3 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': A is upper triangular; +*> = 'L': A is lower triangular. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> = 'N': A is non-unit triangular; +*> = 'U': A is unit triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the triangular matrix A. If UPLO = 'U', the +*> leading N-by-N upper triangular part of the array A contains +*> the upper triangular matrix, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of the array A contains +*> the lower triangular matrix, and the strictly upper +*> triangular part of A is not referenced. If DIAG = 'U', the +*> diagonal elements of A are also not referenced and are +*> assumed to be 1. +*> On exit, the (triangular) inverse of the original matrix, in +*> the same storage format. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular +*> matrix is singular and its inverse can not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER DIAG, UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT, UPPER + INTEGER J, JB, NB, NN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZTRMM, ZTRSM, ZTRTI2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTRTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check for singularity if non-unit. +* + IF( NOUNIT ) THEN + DO 10 INFO = 1, N + IF( A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + INFO = 0 + END IF +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute inverse of upper triangular matrix +* + DO 20 J = 1, N, NB + JB = MIN( NB, N-J+1 ) +* +* Compute rows 1:j-1 of current block column +* + CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, + $ JB, ONE, A, LDA, A( 1, J ), LDA ) + CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, + $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) +* +* Compute inverse of current diagonal block +* + CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) + 20 CONTINUE + ELSE +* +* Compute inverse of lower triangular matrix +* + NN = ( ( N-1 ) / NB )*NB + 1 + DO 30 J = NN, 1, -NB + JB = MIN( NB, N-J+1 ) + IF( J+JB.LE.N ) THEN +* +* Compute rows j+jb:n of current block column +* + CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG, + $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, + $ A( J+JB, J ), LDA ) + CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG, + $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, + $ A( J+JB, J ), LDA ) + END IF +* +* Compute inverse of current diagonal block +* + CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) + 30 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZTRTRI +* + END +C +C====================================================================== +C +*> \brief \b IEEECK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* .. Scalar Arguments .. +* INTEGER ISPEC +* REAL ONE, ZERO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IEEECK is called from the ILAENV to verify that Infinity and +*> possibly NaN arithmetic is safe (i.e. will not trap). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies whether to test just for inifinity arithmetic +*> or whether to test for infinity and NaN arithmetic. +*> = 0: Verify infinity arithmetic only. +*> = 1: Verify infinity and NaN arithmetic. +*> \endverbatim +*> +*> \param[in] ZERO +*> \verbatim +*> ZERO is REAL +*> Must contain the value 0.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> \endverbatim +*> +*> \param[in] ONE +*> \verbatim +*> ONE is REAL +*> Must contain the value 1.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> +*> RETURN VALUE: INTEGER +*> = 0: Arithmetic failed to produce the correct answers +*> = 1: Arithmetic produced the correct answers +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END +C +C====================================================================== +C +*> \brief \b ILAENV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAENV is called from the LAPACK routines to choose problem-dependent +*> parameters for the local environment. See ISPEC for a description of +*> the parameters. +*> +*> ILAENV returns an INTEGER +*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC +*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. +*> +*> This version provides a set of parameters which should give good, +*> but not optimal, performance on many of the currently available +*> computers. Users are encouraged to modify this subroutine to set +*> the tuning parameters for their particular machine using the option +*> and problem size information in the arguments. +*> +*> This routine will not function correctly if it is converted to all +*> lower case. Converting it to all upper case is allowed. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies the parameter to be returned as the value of +*> ILAENV. +*> = 1: the optimal blocksize; if this value is 1, an unblocked +*> algorithm will give the best performance. +*> = 2: the minimum block size for which the block routine +*> should be used; if the usable block size is less than +*> this value, an unblocked routine should be used. +*> = 3: the crossover point (in a block routine, for N less +*> than this value, an unblocked routine should be used) +*> = 4: the number of shifts, used in the nonsymmetric +*> eigenvalue routines (DEPRECATED) +*> = 5: the minimum column dimension for blocking to be used; +*> rectangular blocks must have dimension at least k by m, +*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) +*> = 6: the crossover point for the SVD (when reducing an m by n +*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +*> this value, a QR factorization is used first to reduce +*> the matrix to a triangular form.) +*> = 7: the number of processors +*> = 8: the crossover point for the multishift QR method +*> for nonsymmetric eigenvalue problems (DEPRECATED) +*> = 9: maximum size of the subproblems at the bottom of the +*> computation tree in the divide-and-conquer algorithm +*> (used by xGELSD and xGESDD) +*> =10: ieee NaN arithmetic can be trusted not to trap +*> =11: infinity arithmetic can be trusted not to trap +*> 12 <= ISPEC <= 16: +*> xHSEQR or related subroutines, +*> see IPARMQ for detailed explanation +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is CHARACTER*(*) +*> The name of the calling subroutine, in either upper case or +*> lower case. +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> \endverbatim +*> +*> \param[in] N3 +*> \verbatim +*> N3 is INTEGER +*> \endverbatim +*> +*> \param[in] N4 +*> \verbatim +*> N4 is INTEGER +*> Problem dimensions for the subroutine NAME; these may not all +*> be required. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The following conventions have been used when calling ILAENV from the +*> LAPACK routines: +*> 1) OPTS is a concatenation of all of the character options to +*> subroutine NAME, in the same order that they appear in the +*> argument list for NAME, even if they are not used in determining +*> the value of the parameter specified by ISPEC. +*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order +*> that they appear in the argument list for NAME. N1 is used +*> first, N2 second, and so on, and unused problem dimensions are +*> passed a value of -1. +*> 3) The parameter value returned by ILAENV is checked for validity in +*> the calling subroutine. For example, ILAENV is used to retrieve +*> the optimal blocksize for STRTRI as follows: +*> +*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +*> IF( NB.LE.1 ) NB = MAX( 1, N ) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF ( C3.EQ.'EVC' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NB = 32 + IF( C3.EQ.'HD3' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NBMIN = 2 + IF( C3.EQ.'HD3' ) THEN + NBMIN = 2 + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NX = 128 + IF( C3.EQ.'HD3' ) THEN + NX = 128 + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or related subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END +C +C====================================================================== +C +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME(CA,CB) +* +* .. Scalar Arguments .. +* CHARACTER CA,CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> CA is CHARACTER*1 +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CB is CHARACTER*1 +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup aux_blas +* +* ===================================================================== + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END +C +C====================================================================== +C +*> \brief \b ZGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETF2 computes an LU factorization of a general m-by-n matrix A +*> using partial pivoting with row interchanges. +*> +*> The factorization has the form +*> A = P * L * U +*> where P is a permutation matrix, L is lower triangular with unit +*> diagonal elements (lower trapezoidal if m > n), and U is upper +*> triangular (upper trapezoidal if m < n). +*> +*> This is the right-looking Level 2 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix to be factored. +*> On exit, the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (min(M,N)) +*> The pivot indices; for 1 <= i <= min(M,N), row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, U(k,k) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and division by zero will occur if it is used +*> to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IZAMAX + EXTERNAL DLAMCH, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), + $ LDA, A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of ZGETF2 +* + END +C +C====================================================================== +C +*> \brief \b ZGETRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETRF computes an LU factorization of a general M-by-N matrix A +*> using partial pivoting with row interchanges. +*> +*> The factorization has the form +*> A = P * L * U +*> where P is a permutation matrix, L is lower triangular with unit +*> diagonal elements (lower trapezoidal if m > n), and U is upper +*> triangular (upper trapezoidal if m < n). +*> +*> This is the right-looking Level 3 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix to be factored. +*> On exit, the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (min(M,N)) +*> The pivot indices; for 1 <= i <= min(M,N), row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and division by zero will occur if it is used +*> to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZGETRF2, ZLASWP, ZTRSM +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL ZGETRF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL ZGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of ZGETRF +* + END +C +C====================================================================== +C +*> \brief \b ZGETRF2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETRF2 computes an LU factorization of a general M-by-N matrix A +*> using partial pivoting with row interchanges. +*> +*> The factorization has the form +*> A = P * L * U +*> where P is a permutation matrix, L is lower triangular with unit +*> diagonal elements (lower trapezoidal if m > n), and U is upper +*> triangular (upper trapezoidal if m < n). +*> +*> This is the recursive version of the algorithm. It divides +*> the matrix into four submatrices: +*> +*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 +*> A = [ -----|----- ] with n1 = min(m,n)/2 +*> [ A21 | A22 ] n2 = n-n1 +*> +*> [ A11 ] +*> The subroutine calls itself to factor [ --- ], +*> [ A12 ] +*> [ A12 ] +*> do the swaps on [ --- ], solve A12, update A22, +*> [ A22 ] +*> +*> then calls itself to factor A22 and do the swaps on A21. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix to be factored. +*> On exit, the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (min(M,N)) +*> The pivot indices; for 1 <= i <= min(M,N), row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and division by zero will occur if it is used +*> to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + COMPLEX*16 TEMP + INTEGER I, IINFO, N1, N2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IZAMAX + EXTERNAL DLAMCH, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZSCAL, ZLASWP, ZTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN + + IF ( M.EQ.1 ) THEN +* +* Use unblocked code for one row case +* Just need to handle IPIV and INFO +* + IPIV( 1 ) = 1 + IF ( A(1,1).EQ.ZERO ) + $ INFO = 1 +* + ELSE IF( N.EQ.1 ) THEN +* +* Use unblocked code for one column case +* +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* +* Find pivot and test for singularity +* + I = IZAMAX( M, A( 1, 1 ), 1 ) + IPIV( 1 ) = I + IF( A( I, 1 ).NE.ZERO ) THEN +* +* Apply the interchange +* + IF( I.NE.1 ) THEN + TEMP = A( 1, 1 ) + A( 1, 1 ) = A( I, 1 ) + A( I, 1 ) = TEMP + END IF +* +* Compute elements 2:M of the column +* + IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN + CALL ZSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) + ELSE + DO 10 I = 1, M-1 + A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) + 10 CONTINUE + END IF +* + ELSE + INFO = 1 + END IF + + ELSE +* +* Use recursive code +* + N1 = MIN( M, N ) / 2 + N2 = N-N1 +* +* [ A11 ] +* Factor [ --- ] +* [ A21 ] +* + CALL ZGETRF2( M, N1, A, LDA, IPIV, IINFO ) + + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* [ A12 ] +* Apply interchanges to [ --- ] +* [ A22 ] +* + CALL ZLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) +* +* Solve A12 +* + CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + $ A( 1, N1+1 ), LDA ) +* +* Update A22 +* + CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) +* +* Factor A22 +* + CALL ZGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), + $ IINFO ) +* +* Adjust INFO and the pivot indices +* + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + N1 + DO 20 I = N1+1, MIN( M, N ) + IPIV( I ) = IPIV( I ) + N1 + 20 CONTINUE +* +* Apply interchanges to A21 +* + CALL ZLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) +* + END IF + RETURN +* +* End of ZGETRF2 +* + END +C +C====================================================================== +C +*> \brief \b ZLASWP performs a series of row interchanges on a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLASWP performs a series of row interchanges on the matrix A. +*> One row interchange is initiated for each of rows K1 through K2 of A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the matrix of column dimension N to which the row +*> interchanges will be applied. +*> On exit, the permuted matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> \endverbatim +*> +*> \param[in] K1 +*> \verbatim +*> K1 is INTEGER +*> The first element of IPIV for which a row interchange will +*> be done. +*> \endverbatim +*> +*> \param[in] K2 +*> \verbatim +*> K2 is INTEGER +*> The last element of IPIV for which a row interchange will +*> be done. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (K2*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K2 of IPIV are accessed. +*> IPIV(K) = L implies rows K and L are to be interchanged. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive values of IPIV. If IPIV +*> is negative, the pivots are applied in reverse order. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Modified by +*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + COMPLEX*16 TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of ZLASWP +* + END +C +C====================================================================== +C +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download XERBLA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END +C +C====================================================================== +C +*> \brief \b ZGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array of DIMENSION ( LDC, n ). +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.6.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA, NCOLA and NROWB as the number of rows and columns of A +* and the number of rows of B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*DCONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMM . +* + END +C +C====================================================================== +C +*> \brief \b ZGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or +*> +*> y := alpha*A**H*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array of DIMENSION at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array of DIMENSION at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine (version 3.6.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 1 + ELSE IF (M.LT.0) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + ELSE IF (INCY.EQ.0) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* + NOCONJ = LSAME(TRANS,'T') +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (LSAME(TRANS,'N')) THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (LENX-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (LENY-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,LENY + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,LENY + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,LENY + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,LENY + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(TRANS,'N')) THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF (INCY.EQ.1) THEN + DO 60 J = 1,N + TEMP = ALPHA*X(JX) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 110 J = 1,N + TEMP = ZERO + IF (NOCONJ) THEN + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = 1,M + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 110 CONTINUE + ELSE + DO 140 J = 1,N + TEMP = ZERO + IX = KX + IF (NOCONJ) THEN + DO 120 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = 1,M + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMV . +* + END +C +C====================================================================== +C +*> \brief \b ZGERU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERU performs the rank 1 operation +*> +*> A := alpha*x*y**T + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array of dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array of dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGERU ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of ZGERU . +* + END +C +C====================================================================== +C +*> \brief \b ZSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSCAL scales a vector by a constant. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = ZA*ZX(I) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = ZA*ZX(I) + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b ZSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSWAP interchanges two vectors. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 + DO I = 1,N + ZTEMP = ZX(I) + ZX(I) = ZY(I) + ZY(I) = ZTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZX(IX) + ZX(IX) = ZY(IY) + ZY(IY) = ZTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b ZTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMM performs one of the matrix-matrix operations +*> +*> B := alpha*op( A )*B, or B := alpha*B*op( A ) +*> +*> where alpha is a scalar, B is an m by n matrix, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) multiplies B from +*> the left or right as follows: +*> +*> SIDE = 'L' or 'l' B := alpha*op( A )*B. +*> +*> SIDE = 'R' or 'r' B := alpha*B*op( A ). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m +*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is (input/output) COMPLEX*16 array of DIMENSION ( LDB, n ). +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B, and on exit is overwritten by the +*> transformed matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (UPPER) THEN + DO 50 J = 1,N + DO 40 K = 1,M + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + DO 30 I = 1,K - 1 + B(I,J) = B(I,J) + TEMP*A(I,K) + 30 CONTINUE + IF (NOUNIT) TEMP = TEMP*A(K,K) + B(K,J) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + TEMP = ALPHA*B(K,J) + B(K,J) = TEMP + IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) + DO 60 I = K + 1,M + B(I,J) = B(I,J) + TEMP*A(I,K) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B or B := alpha*A**H*B. +* + IF (UPPER) THEN + DO 120 J = 1,N + DO 110 I = M,1,-1 + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) + DO 100 K = 1,I - 1 + TEMP = TEMP + DCONJG(A(K,I))*B(K,J) + 100 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 110 CONTINUE + 120 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = 1,M + TEMP = B(I,J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 130 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 130 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) + DO 140 K = I + 1,M + TEMP = TEMP + DCONJG(A(K,I))*B(K,J) + 140 CONTINUE + END IF + B(I,J) = ALPHA*TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 200 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 170 I = 1,M + B(I,J) = TEMP*B(I,J) + 170 CONTINUE + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 180 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + 200 CONTINUE + ELSE + DO 240 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 210 I = 1,M + B(I,J) = TEMP*B(I,J) + 210 CONTINUE + DO 230 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 220 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 220 CONTINUE + END IF + 230 CONTINUE + 240 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T or B := alpha*B*A**H. +* + IF (UPPER) THEN + DO 280 K = 1,N + DO 260 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*DCONJG(A(J,K)) + END IF + DO 250 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*DCONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + ELSE + DO 320 K = N,1,-1 + DO 300 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = ALPHA*A(J,K) + ELSE + TEMP = ALPHA*DCONJG(A(J,K)) + END IF + DO 290 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + TEMP = ALPHA + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = TEMP*A(K,K) + ELSE + TEMP = TEMP*DCONJG(A(K,K)) + END IF + END IF + IF (TEMP.NE.ONE) THEN + DO 310 I = 1,M + B(I,K) = TEMP*B(I,K) + 310 CONTINUE + END IF + 320 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMM . +* + END +C +C====================================================================== +C +*> \brief \b ZTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is (input/output) COMPLEX*16 array of dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> tranformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. + + .NOT.LSAME(TRANS,'C')) THEN + INFO = 2 + ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 6 + ELSE IF (INCX.EQ.0) THEN + INFO = 8 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + NOCONJ = LSAME(TRANS,'T') + NOUNIT = LSAME(DIAG,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form x := A*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = N,1,-1 + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 60 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 80 J = N,1,-1 + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 110 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 140 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 120 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 130 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 130 CONTINUE + END IF + X(JX) = TEMP + JX = JX - INCX + 140 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 170 J = 1,N + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 160 I = J + 1,N + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 180 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 190 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMV . +* + END +C +C====================================================================== +C +*> \brief \b ZTRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSM solves one of the matrix equations +*> +*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +*> +*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> +*> The matrix X is overwritten on B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) appears on the left +*> or right of X as follows: +*> +*> SIDE = 'L' or 'l' op( A )*X = alpha*B. +*> +*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, k ), +*> where k is m when SIDE = 'L' or 'l' +*> and k is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array of DIMENSION ( LDB, n ). +*> Before entry, the leading m by n part of the array B must +*> contain the right-hand side matrix B, and on exit is +*> overwritten by the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B +* or B := alpha*inv( A**H )*B. +* + IF (UPPER) THEN + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 120 K = 1,I - 1 + TEMP = TEMP - DCONJG(A(K,I))*B(K,J) + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) + END IF + B(I,J) = TEMP + 130 CONTINUE + 140 CONTINUE + ELSE + DO 180 J = 1,N + DO 170 I = M,1,-1 + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 150 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 160 K = I + 1,M + TEMP = TEMP - DCONJG(A(K,I))*B(K,J) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) + END IF + B(I,J) = TEMP + 170 CONTINUE + 180 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 230 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 190 I = 1,M + B(I,J) = ALPHA*B(I,J) + 190 CONTINUE + END IF + DO 210 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 200 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 220 I = 1,M + B(I,J) = TEMP*B(I,J) + 220 CONTINUE + END IF + 230 CONTINUE + ELSE + DO 280 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 240 I = 1,M + B(I,J) = ALPHA*B(I,J) + 240 CONTINUE + END IF + DO 260 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 250 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 270 I = 1,M + B(I,J) = TEMP*B(I,J) + 270 CONTINUE + END IF + 280 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ) +* or B := alpha*B*inv( A**H ). +* + IF (UPPER) THEN + DO 330 K = N,1,-1 + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/DCONJG(A(K,K)) + END IF + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + DO 310 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = DCONJG(A(J,K)) + END IF + DO 300 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 320 I = 1,M + B(I,K) = ALPHA*B(I,K) + 320 CONTINUE + END IF + 330 CONTINUE + ELSE + DO 380 K = 1,N + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/DCONJG(A(K,K)) + END IF + DO 340 I = 1,M + B(I,K) = TEMP*B(I,K) + 340 CONTINUE + END IF + DO 360 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = DCONJG(A(J,K)) + END IF + DO 350 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 370 I = 1,M + B(I,K) = ALPHA*B(I,K) + 370 CONTINUE + END IF + 380 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRSM . +* + END +C +C====================================================================== +C +*> \brief \b DLAMCH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMCH determines double precision machine parameters. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CMACH +*> \verbatim +*> Specifies the value to be returned by DLAMCH: +*> = 'E' or 'e', DLAMCH := eps +*> = 'S' or 's , DLAMCH := sfmin +*> = 'B' or 'b', DLAMCH := base +*> = 'P' or 'p', DLAMCH := eps*base +*> = 'N' or 'n', DLAMCH := t +*> = 'R' or 'r', DLAMCH := rnd +*> = 'M' or 'm', DLAMCH := emin +*> = 'U' or 'u', DLAMCH := rmin +*> = 'L' or 'l', DLAMCH := emax +*> = 'O' or 'o', DLAMCH := rmax +*> where +*> eps = relative machine precision +*> sfmin = safe minimum, such that 1/sfmin does not overflow +*> base = base of the machine +*> prec = eps*base +*> t = number of (base) digits in the mantissa +*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +*> emin = minimum exponent before (gradual) underflow +*> rmin = underflow threshold - base**(emin-1) +*> emax = largest exponent before overflow +*> rmax = overflow threshold - (base**emax)*(1-eps) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC1 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC1 determines the machine parameters given by BETA, T, RND, and +*> IEEE1. +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> The number of ( BETA ) digits in the mantissa. +*> \endverbatim +*> +*> \param[out] RND +*> \verbatim +*> Specifies whether proper rounding ( RND = .TRUE. ) or +*> chopping ( RND = .FALSE. ) occurs in addition. This may not +*> be a reliable guide to the way in which the machine performs +*> its arithmetic. +*> \endverbatim +*> +*> \param[out] IEEE1 +*> \verbatim +*> Specifies whether rounding appears to be done in the IEEE +*> 'round to nearest' style. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date April 2012 +*> \ingroup auxOTHERauxiliary +*> +*> \details \b Further \b Details +*> \verbatim +*> +*> The routine is based on the routine ENVRON by Malcolm and +*> incorporates suggestions by Gentleman and Marovich. See +*> +*> Malcolm M. A. (1972) Algorithms to reveal properties of +*> floating-point arithmetic. Comms. of the ACM, 15, 949-951. +*> +*> Gentleman W. M. and Marovich S. B. (1974) More on algorithms +*> that reveal properties of floating point arithmetic units. +*> Comms. of the ACM, 17, 276-277. +*> \endverbatim +*> + SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + ONE = 1 +* +* LBETA, LIEEE1, LT and LRND are the local values of BETA, +* IEEE1, T and RND. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* Compute a = 2.0**m with the smallest positive integer m such +* that +* +* fl( a + 1.0 ) = a. +* + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + B = 1 + C = DLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = DLAMC3( A, B ) + GO TO 20 + END IF +*+ END WHILE +* +* Now compute the base. a and c are neighbouring floating point +* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so +* their difference is beta. Adding 0.25 to c is to ensure that it +* is truncated to beta and not ( beta - 1 ). +* + QTR = ONE / 4 + SAVEC = C + C = DLAMC3( C, -A ) + LBETA = C + QTR +* +* Now determine whether rounding or chopping occurs, by adding a +* bit less than beta/2 and a bit more than beta/2 to a. +* + B = LBETA + F = DLAMC3( B / 2, -B / 100 ) + C = DLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = DLAMC3( B / 2, B / 100 ) + C = DLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.A ) ) + $ LRND = .FALSE. +* +* Try and decide whether rounding is done in the IEEE 'round to +* nearest' style. B/2 is half a unit in the last place of the two +* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit +* zero, and SAVEC is odd. Thus adding B/2 to A should not change +* A, but adding B/2 to SAVEC should change SAVEC. +* + T1 = DLAMC3( B / 2, A ) + T2 = DLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND +* +* Now find the mantissa, t. It should be the integer part of +* log to the base beta of a, however it is safer to determine t +* by powering. So we find t as the smallest positive integer for +* which +* +* fl( beta**t + 1.0 ) = 1.0. +* + LT = 0 + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + FIRST = .FALSE. + RETURN +* +* End of DLAMC1 +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC2 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC2 determines the machine parameters specified in its argument +*> list. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date April 2012 +*> \ingroup auxOTHERauxiliary +*> +*> \param[out] BETA +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> The number of ( BETA ) digits in the mantissa. +*> \endverbatim +*> +*> \param[out] RND +*> \verbatim +*> Specifies whether proper rounding ( RND = .TRUE. ) or +*> chopping ( RND = .FALSE. ) occurs in addition. This may not +*> be a reliable guide to the way in which the machine performs +*> its arithmetic. +*> \endverbatim +*> +*> \param[out] EPS +*> \verbatim +*> The smallest positive number such that +*> fl( 1.0 - EPS ) .LT. 1.0, +*> where fl denotes the computed value. +*> \endverbatim +*> +*> \param[out] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow occurs. +*> \endverbatim +*> +*> \param[out] RMIN +*> \verbatim +*> The smallest normalized number for the machine, given by +*> BASE**( EMIN - 1 ), where BASE is the floating point value +*> of BETA. +*> \endverbatim +*> +*> \param[out] EMAX +*> \verbatim +*> The maximum exponent before overflow occurs. +*> \endverbatim +*> +*> \param[out] RMAX +*> \verbatim +*> The largest positive number for the machine, given by +*> BASE**EMAX * ( 1 - EPS ), where BASE is the floating point +*> value of BETA. +*> \endverbatim +*> +*> \details \b Further \b Details +*> \verbatim +*> +*> The computation of EPS is based on a routine PARANOIA by +*> W. Kahan of the University of California at Berkeley. +*> \endverbatim + SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL DLAMC1, DLAMC4, DLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + ZERO = 0 + ONE = 1 + TWO = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of +* BETA, T, RND, EPS, EMIN and RMIN. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. +* + CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = DLAMC3( B, -HALF ) + THIRD = DLAMC3( SIXTH, SIXTH ) + B = DLAMC3( THIRD, -HALF ) + B = DLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = DLAMC3( HALF, -C ) + B = DLAMC3( HALF, C ) + C = DLAMC3( HALF, -B ) + B = DLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.LEPS ) + $ LEPS = A +* +* Computation of EPS complete. +* +* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). +* Keep dividing A by BETA until (gradual) underflow occurs. This +* is detected when we cannot recover the previous A. +* + RBASE = ONE / LBETA + SMALL = ONE + DO 20 I = 1, 3 + SMALL = DLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = DLAMC3( ONE, SMALL ) + CALL DLAMC4( NGPMIN, ONE, LBETA ) + CALL DLAMC4( NGNMIN, -ONE, LBETA ) + CALL DLAMC4( GPMIN, A, LBETA ) + CALL DLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + LEMIN = NGPMIN - 1 + LT + IEEE = .TRUE. +* ( Non twos-complement machines, with gradual underflow; +* e.g., IEEE standard followers ) + ELSE + LEMIN = MIN( NGPMIN, GPMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) +* ( Twos-complement machines, no gradual underflow; +* e.g., CYBER 205 ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT +* ( Twos-complement machines with gradual underflow; +* no known machine ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF + FIRST = .FALSE. +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* Assume IEEE arithmetic if we found denormalised numbers above, +* or if arithmetic seems to round in the IEEE style, determined +* in routine DLAMC1. A true IEEE machine should have both things +* true; however, faulty machines may have one or the other. +* + IEEE = IEEE .OR. LIEEE1 +* +* Compute RMIN by successive division by BETA. We could compute +* RMIN as BASE**( EMIN - 1 ), but some machines underflow during +* this computation. +* + LRMIN = 1 + DO 30 I = 1, 1 - LEMIN + LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call DLAMC5 to compute EMAX and RMAX. +* + CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of DLAMC2 +* + END +* +************************************************************************ +* +*> \brief \b DLAMC3 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC3 is intended to force A and B to be stored prior to doing +*> the addition of A and B , for use in situations where optimizers +*> might hold one of these in a register. +*> \endverbatim +*> +*> \param[in] A +*> +*> \param[in] B +*> \verbatim +*> The values A and B. +*> \endverbatim + + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC4 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC4 is a service routine for DLAMC2. +*> \endverbatim +*> +*> \param[out] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow, computed by +*> setting A = START and dividing by BASE until the previous A +*> can not be recovered. +*> \endverbatim +*> +*> \param[in] START +*> \verbatim +*> The starting point for determining EMIN. +*> \endverbatim +*> +*> \param[in] BASE +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> + SUBROUTINE DLAMC4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = DLAMC3( A*RBASE, ZERO ) + C1 = A + C2 = A + D1 = A + D2 = A +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = DLAMC3( A / BASE, ZERO ) + C1 = DLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = DLAMC3( A*RBASE, ZERO ) + C2 = DLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of DLAMC4 +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC5 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC5 attempts to compute RMAX, the largest machine floating-point +*> number, without overflow. It assumes that EMAX + abs(EMIN) sum +*> approximately to a power of 2. It will fail on machines where this +*> assumption does not hold, for example, the Cyber 205 (EMIN = -28625, +*> EMAX = 28718). It will also fail if the value supplied for EMIN is +*> too large (i.e. too close to zero), probably with overflow. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> The base of floating-point arithmetic. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> The number of base BETA digits in the mantissa of a +*> floating-point value. +*> \endverbatim +*> +*> \param[in] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow. +*> \endverbatim +*> +*> \param[in] IEEE +*> \verbatim +*> A logical flag specifying whether or not the arithmetic +*> system is thought to comply with the IEEE standard. +*> \endverbatim +*> +*> \param[out] EMAX +*> \verbatim +*> The largest exponent before overflow +*> \endverbatim +*> +*> \param[out] RMAX +*> \verbatim +*> The largest machine floating-point number. +*> \endverbatim +*> + SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* First compute LEXP and UEXP, two powers of 2 that bound +* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum +* approximately to the bound that is closest to abs(EMIN). +* (EMAX is the exponent of the required number RMAX). +* + LEXP = 1 + EXBITS = 1 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* Now -LEXP is less than or equal to EMIN, and -UEXP is greater +* than or equal to EMIN. EXBITS is the number of bits needed to +* store the exponent. +* + IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* Either there are an odd number of bits used to store a +* floating-point number, which is unlikely, or some bits are +* not used in the representation of numbers, which is possible, +* (e.g. Cray machines) or the mantissa has an implicit bit, +* (e.g. IEEE machines, Dec Vax machines), which is perhaps the +* most likely. We have to assume the last alternative. +* If this is true, then we need to reduce EMAX by one because +* there must be some way of representing zero in an implicit-bit +* system. On machines like Cray, we are reducing EMAX by one +* unnecessarily. +* + EMAX = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* Now create RMAX, the largest machine number, which should +* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . +* +* First compute 1.0 - BETA**(-P), being careful that the +* result is less than 1.0 . +* + RECBAS = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = DLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = DLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of DLAMC5 +* + END +C +C====================================================================== +C +*> \brief \b IPARMQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, ISPEC, LWORK, N +* CHARACTER NAME*( * ), OPTS*( * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever +*> IPARMQ is called with 12 <= ISPEC <= 16 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is integer scalar +*> ISPEC specifies which tunable parameter IPARMQ should +*> return. +*> +*> ISPEC=12: (INMIN) Matrices of order nmin or less +*> are sent directly to xLAHQR, the implicit +*> double shift QR algorithm. NMIN must be +*> at least 11. +*> +*> ISPEC=13: (INWIN) Size of the deflation window. +*> This is best set greater than or equal to +*> the number of simultaneous shifts NS. +*> Larger matrices benefit from larger deflation +*> windows. +*> +*> ISPEC=14: (INIBL) Determines when to stop nibbling and +*> invest in an (expensive) multi-shift QR sweep. +*> If the aggressive early deflation subroutine +*> finds LD converged eigenvalues from an order +*> NW deflation window and LD.GT.(NW*NIBBLE)/100, +*> then the next QR sweep is skipped and early +*> deflation is applied immediately to the +*> remaining active diagonal block. Setting +*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +*> multi-shift QR sweep whenever early deflation +*> finds a converged eigenvalue. Setting +*> IPARMQ(ISPEC=14) greater than or equal to 100 +*> prevents TTQRE from skipping a multi-shift +*> QR sweep. +*> +*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in +*> a multi-shift QR iteration. +*> +*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +*> following meanings. +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the +*> far-from-diagonal matrix entries. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. +*> (If xTRMM is slower than xGEMM, then +*> IPARMQ(ISPEC=16)=1 may be more efficient than +*> IPARMQ(ISPEC=16)=2 despite the greater level of +*> arithmetic work implied by the latter choice.) +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is character string +*> This is a concatenation of the string arguments to +*> TTQRE. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is integer scalar +*> N is the order of the Hessenberg matrix H. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer scalar +*> The amount of workspace available. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Little is known about how best to choose these parameters. +*> It is possible to use different values of the parameters +*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +*> +*> It is probably best to choose different parameters for +*> different matrices and different parameters at different +*> times during the iteration, but this has not been +*> implemented --- yet. +*> +*> +*> The best choices of most of the parameters depend +*> in an ill-understood way on the relative execution +*> rate of xLAQR3 and xLAQR5 and on the nature of each +*> particular eigenvalue problem. Experiment may be the +*> only practical way to determine which choices are most +*> effective. +*> +*> Following is a list of default values supplied by IPARMQ. +*> These defaults may be adjusted in order to attain better +*> performance in any particular computational environment. +*> +*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> IPARMQ(ISPEC=13) Recommended deflation window size. +*> This depends on ILO, IHI and NS, the +*> number of simultaneous shifts returned +*> by IPARMQ(ISPEC=15). The default for +*> (IHI-ILO+1).LE.500 is NS. The default +*> for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +*> +*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +*> a multi-shift QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 0 30 NS = 2+ +*> 30 60 NS = 4+ +*> 60 150 NS = 10 +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default matrices of this order are +*> passed to the implicit double shift routine +*> xLAHQR. See IPARMQ(ISPEC=12) above. These +*> values of NS are used only in case of a rare +*> xLAHQR failure. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function increasing from 10 to 64. +*> +*> IPARMQ(ISPEC=16) Select structured matrix multiply. +*> (See ISPEC=16 above for details.) +*> Default: 3. +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* +* +* Convert NAME to upper case if the first character is lower case. +* + IPARMQ = 0 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + END DO + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF + END IF +* + IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. + $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN + IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN + IF( NH.GE.KACMIN ) + $ IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. + $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + END IF +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END +C +C====================================================================== +C +*> \brief \b IZAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup aux_blas +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 1/15/85. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IZAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IZAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DCABS1(ZX(1)) + DO I = 2,N + IF (DCABS1(ZX(I)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DCABS1(ZX(1)) + IX = IX + INCX + DO I = 2,N + IF (DCABS1(ZX(IX)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN + END +C +C======================================================================= +C +*> \brief \b DCABS1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* .. Scalar Arguments .. +* COMPLEX*16 Z +* .. +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup double_blas_level1 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + COMPLEX*16 Z +* .. +* .. +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS,DBLE,DIMAG +* + DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) + RETURN + END +C + + diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/leddif_mi.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/leddif_mi.f new file mode 100644 index 0000000..c42070e --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/leddif_mi.f @@ -0,0 +1,915 @@ +C +C +C======================================================================= +C + SUBROUTINE LEDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK, + &NATCLU,NFICHLEC,JFICH,NP) +C +C This subroutine computes the LEED formula in the spin-independent +C case. +C +C The calculation is performed using a matrix inversion for the +C expression of the scattering path operator +C +C The matrix inversion is performed using the LAPACK inversion +C routines for a general complex matrix +C +C Last modified : 26 Apr 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE ALGORITHM_MOD + USE AMPLI_MOD + USE APPROX_MOD + USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP + USE DEBWAL_MOD + USE DIRECT_MOD, RTHETA => RTHEXT + USE EXTREM_MOD + USE FIXSCAN_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE LIMAMA_MOD + USE MOYEN_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTPB_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TYPCAL_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE VALIN_AV_MOD + USE VALFIN_MOD +C + REAL BEAM(3),AXE(3),EPS(3),DIRBEAM(3),BEAMDIR(3),EMET(3) +C + COMPLEX IC,ONEC,ZEROC,COEF + COMPLEX TLT(0:NT_M,4,NATM,NE_M) + COMPLEX TAU(LINMAX*LINMAX*NATCLU_M*NATCLU_M) + COMPLEX YLMI(LINMAX) + COMPLEX YLMJ(LINMAX) + COMPLEX SLJDIF,SJDIF + COMPLEX SLIDIF,SLIDIR,SIDIF,SIDIR + COMPLEX RHOK(NE_M,NATM,0:18,2,NSPIN2_M),RD + COMPLEX ATT_MI,ATT_MI2,ATT_MJ +C + DIMENSION VAL(NATCLU_M),NATYP(NATM) + DIMENSION R_L(9),COORD(3,NATCLU_M) +C +C +C + CHARACTER*7 STAT + CHARACTER*13 OUTDATA1,OUTDATA2 +C +C + CHARACTER*24 OUTFILE + CHARACTER*24 AMPFILE +C +C + DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/ + DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/ +C + ALGO1='MI' + ALGO2=' ' + ALGO3=' ' + ALGO4=' ' +C + I_DIR=0 + NSET=1 + JEL=1 + JEMET=1 + OUTDATA1='CROSS-SECTION' + IF(I_AMP.EQ.1) THEN + I_MI=1 + OUTDATA2='MS AMPLITUDES' + ELSE + I_MI=0 + ENDIF +C +C The first atom in the list taken as the origin +C + EMET(1)=SYM_AT(1,1) + EMET(2)=SYM_AT(2,1) + EMET(3)=SYM_AT(3,1) +C + IF(SPECTRO.EQ.'LED') THEN + IOUT=IUO2 + OUTFILE=OUTFILE2 + STAT='UNKNOWN' + IF(I_MI.EQ.1) THEN + IOUT2=IUSCR2+1 + N_DOT=1 + DO J_CHAR=1,24 + IF(OUTFILE(J_CHAR:J_CHAR).EQ.'.') GOTO 888 + N_DOT=N_DOT+1 + ENDDO + 888 CONTINUE + AMPFILE=OUTFILE(1:N_DOT)//'amp' + OPEN(UNIT=IOUT2, FILE=AMPFILE, STATUS=STAT) + ENDIF + ENDIF +C +C Position of the initial beam when the analyzer is along the z axis : +C (X_BEAM_Z,Y_BEAM_Z,Z_BEAM_Z) +C + RTHBEAM=THBEAM*PIS180 + RPHBEAM=PHBEAM*PIS180 + X_BEAM_Z=SIN(RTHBEAM)*COS(RPHBEAM) + Y_BEAM_Z=SIN(RTHBEAM)*SIN(RPHBEAM) + Z_BEAM_Z=COS(RTHBEAM) +C + IF(IMOD.EQ.0) THEN +C +C The analyzer is rotated +C + DIRBEAM(1)=X_BEAM_Z + DIRBEAM(2)=Y_BEAM_Z + DIRBEAM(3)=Z_BEAM_Z + ELSE +C +C The sample is rotated ---> beam and analyzer rotated +C + IF(I_EXT.EQ.0) THEN + RTH0=THETA0*PIS180 + RPH0=PHI0*PIS180 + RTH=RTH0 + RPH=RPH0 +C +C R_L is the rotation matrix from 0z to (THETA0,PHI0) expressed as +C a function of the Euler angles ALPHA=PHI0, BETA=THETA0, GAMMA=-PHI0 +C It is stored as (1 2 3) +C (4 5 6) +C (7 8 9) +C + R_L(1)=COS(RTH0)*COS(RPH0)*COS(RPH0)+SIN(RPH0)*SIN(RPH0) + R_L(2)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0) + R_L(3)=SIN(RTH0)*COS(RPH0) + R_L(4)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0) + R_L(5)=COS(RTH0)*SIN(RPH0)*SIN(RPH0)+COS(RPH0)*COS(RPH0) + R_L(6)=SIN(RTH0)*SIN(RPH0) + R_L(7)=-SIN(RTH0)*COS(RPH0) + R_L(8)=-SIN(RTH0)*SIN(RPH0) + R_L(9)=COS(RTH0) +C +C Position of the beam when the analyzer is along (THETA0,PHI0) : BEAM(3) +C + BEAM(1)=X_BEAM_Z*R_L(1)+Y_BEAM_Z*R_L(2)+Z_BEAM_Z*R_L(3) + BEAM(2)=X_BEAM_Z*R_L(4)+Y_BEAM_Z*R_L(5)+Z_BEAM_Z*R_L(6) + BEAM(3)=X_BEAM_Z*R_L(7)+Y_BEAM_Z*R_L(8)+Z_BEAM_Z*R_L(9) +C + ENDIF + ENDIF +C + IC=(0.,1.) + ONEC=(1.,0.) + ZEROC=(0.,0.) + ATTSJ=1. + ATTSI=1. + ZSURF=VAL(1) +C + IF((ISOM.EQ.0).OR.(JFICH.EQ.1)) THEN + OPEN(UNIT=IOUT, FILE=OUTFILE, STATUS=STAT) + ENDIF +C +C Writing the headers in the output file +C + CALL HEADERS(IOUT) +C + IF((ISOM.EQ.0).OR.((ISOM.GT.0).AND.(JFICH.EQ.1))) THEN + WRITE(IOUT,12) SPECTRO,OUTDATA1 + WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA, + & IE,IPH_1,I_EXT + IF(I_MI.EQ.1) THEN + WRITE(IOUT2,12) SPECTRO,OUTDATA2 + WRITE(IOUT2,12) STEREO + WRITE(IOUT2,19) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI, + & ITHETA,IE,IPH_1,I_EXT + WRITE(IOUT2,20) PHI0,THETA0,PHI1,THETA1,NONVOL(1) + ENDIF + ENDIF +C + IF(ISOM.EQ.0) THEN + WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE + IF(I_MI.EQ.1) THEN + WRITE(IOUT2,79) NPLAN,NEMET,NTHETA,NPHI,NE + ENDIF + ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN + WRITE(IOUT,11) NTHETA,NPHI,NE + IF(I_MI.EQ.1) THEN + WRITE(IOUT2,11) NTHETA,NPHI,NE + ENDIF + ENDIF + IJK=0 +C +C Loop over the planes +C + DO JPLAN=1,NPLAN + Z=VAL(JPLAN) + IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN + DZZEM=ABS(Z-ZEM) + IF(DZZEM.LT.SMALL) GOTO 10 + GOTO 1 + ENDIF + 10 CONTINUE +C + IF(ISOM.EQ.1) NP=JPLAN +C +C Loop over the energies +C + DO JE=1,NE + FMIN(0)=1. + FMAX(0)=1. + IF(NE.GT.1) THEN + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ELSEIF(NE.EQ.1) THEN + ECIN=E0 + ENDIF + IF(I_TEST.NE.1) THEN + CFM=16.*PI*PI + ELSE + CFM=1. + ENDIF + CALL LPM(ECIN,XLPM,*6) + XLPM1=XLPM/A + IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 + IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR + ENDIF + IF(ITL.EQ.0) THEN + VK(JE)=SQRT(ECIN+VINT)*CONV*A*(1.,0.) + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDIF + GAMMA=1./(2.*XLPM1) + IF(IPOTC.EQ.0) THEN + VK(JE)=VK(JE)+IC*GAMMA + ENDIF + IF(I_TEST.NE.1) THEN + VKR=REAL(VK(JE)) + ELSE + VKR=1. + ENDIF + IF(I_MI.EQ.1) THEN + WRITE(IOUT2,21) ECIN,VKR*CFM + ENDIF + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN + IF(IDCM.GE.1) WRITE(IUO1,22) + DO JAT=1,N_PROT + IF(IDCM.EQ.0) THEN + XK2UJ2=VK2(JE)*UJ2(JAT) + ELSE + XK2UJ2=VK2(JE)*UJ_SQ(JAT) + WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A + ENDIF + CALL DWSPH(JAT,JE,XK2UJ2,TLT,ISPEED) + DO LAT=0,LMAX(JAT,JE) + TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) + ENDDO + ENDDO + ENDIF + IF(ABS(I_EXT).GE.1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,13) I_DIR,NSET,N_DUM1 + READ(IUI6,14) I_DUM1,N_DUM2,N_DUM3 + ENDIF +C +C Largest angular momenum value (used to compute +C the spherical harmonics) +C + LM_MAX=0 + DO JTYP=1,N_PROT + LMJ=LMAX(JTYP,JE) + LM_MAX=MAX(LM_MAX,LMJ) + ENDDO +C +C Initialization of TAU(LIN) +C + LIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + DO LJ=0,LMJ + DO MJ=-LJ,LJ + DO ITYP=1,N_PROT + NBTYPI=NATYP(ITYP) + LMI=LMAX(ITYP,JE) + DO INUM=1,NBTYPI + DO LI=0,LMI + DO MI=-LI,LI + LIN=LIN+1 + TAU(LIN)=ZEROC + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +C +C Matrix inversion for the calculation of TAU +C + IF(I_TEST.EQ.2) GOTO 666 + CALL INV_MAT_MS(JE,TAU) + 666 CONTINUE +C +C Calculation of the LEED formula +C +C +C Loop over the 'fixed' angle +C + 15 DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + IF(I_EXT.EQ.0) THEN + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + XINCRF=FLOAT(J_FIXED-1)*FIX_STEP + ELSE + XINCRF=0. + ENDIF + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(ABS(I_EXT).GE.1) THEN + READ(IUI6,86) JSET,JLINE,THD,PHD + IF(I_EXT.EQ.-1) BACKSPACE IUI6 + THETA0=THD + PHI0=PHD + ENDIF + IF(IPH_1.EQ.1) THEN + IF(I_EXT.EQ.0) THEN + DPHI=PHI0+XINCRF + ELSE + DPHI=PHD + ENDIF + RPHI=DPHI*PIS180 + IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI + ELSE + ISAUT=0 + IF(I_EXT.EQ.0) THEN + DTHETA=THETA0+XINCRF + ELSE + DTHETA=THD + ENDIF + RTHETA=DTHETA*PIS180 + IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 + IF(I_EXT.GE.1) ISAUT=0 + IF(I_TEST.EQ.2) ISAUT=0 + IF(ISAUT.GT.0) GOTO 8 + IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA + IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) + IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) +C +C THETA-dependent number of PHI points for stereographic +C representation (to obtain a uniform sampling density). +C (Courtesy of J. Osterwalder - University of Zurich) +C + IF(STEREO.EQ.'YES') THEN + N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+ + & SMALL)+1 + ENDIF +C + ENDIF + IF((N_FIXED.GT.1).AND.(IMOD.EQ.1)) THEN +C +C When there are several sets of scans (N_FIXED > 1), +C the initial position BEAM of the beam is recalculated +C for each initial position (RTH,RPH) of the analyzer +C + IF(IPH_1.EQ.1) THEN + RTH=THETA0*PIS180 + RPH=RPHI + ELSE + RTH=RTHETA + RPH=PHI0*PIS180 + ENDIF +C + R_L(1)=COS(RTH)*COS(RPH) + R_L(2)=-SIN(RPH) + R_L(3)=SIN(RTH)*COS(RPH) + R_L(4)=COS(RTH)*SIN(RPH) + R_L(5)=COS(RPH) + R_L(6)=SIN(RTH)*SIN(RPH) + R_L(7)=-SIN(RTH) + R_L(8)=0. + R_L(9)=COS(RTH) +C + BEAM(1)=X_BEAM_Z*R_L(1)+Y_BEAM_Z*R_L(2)+Z_BEAM_Z*R_L(3) + BEAM(2)=X_BEAM_Z*R_L(4)+Y_BEAM_Z*R_L(5)+Z_BEAM_Z*R_L(6) + BEAM(3)=X_BEAM_Z*R_L(7)+Y_BEAM_Z*R_L(8)+Z_BEAM_Z*R_L(9) + ENDIF +C +C Loop over the scanned angle +C + DO J_SCAN=1,N_SCAN + IF(N_SCAN.GT.1) THEN + XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1) + ELSEIF(N_SCAN.EQ.1) THEN + XINCRS=0. + ENDIF + IF(I_EXT.EQ.-1) THEN + READ(IUI6,86) JSET,JLINE,THD,PHD + BACKSPACE IUI6 + ENDIF + IF(IPH_1.EQ.1) THEN + ISAUT=0 + IF(I_EXT.EQ.0) THEN + DTHETA=THETA0+XINCRS + ELSE + DTHETA=THD + ENDIF + RTHETA=DTHETA*PIS180 + IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 + IF(I_EXT.GE.1) ISAUT=0 + IF(I_TEST.EQ.2) ISAUT=0 + IF(ISAUT.GT.0) GOTO 8 + IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA + IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) + IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) + ELSE + IF(I_EXT.EQ.0) THEN + DPHI=PHI0+XINCRS + ELSE + DPHI=PHD + ENDIF + RPHI=DPHI*PIS180 + IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI + ENDIF +C +C Loop over the sets of directions to average over (for gaussian average) +C +C + SSETDIF=0. + SSETDIR=0. +C + SSET2DIF=0. + SSET2DIR=0. +C + IF(I_EXT.EQ.-1) THEN + JREF=INT(NSET)/2+1 + ELSE + JREF=1 + ENDIF +C + DO J_SET=1,NSET + IF(I_EXT.EQ.-1) THEN + READ(IUI6,86) JSET,JLINE,THD,PHD,W + DTHETA=THD + DPHI=PHD + RTHETA=DTHETA*PIS180 + RPHI=DPHI*PIS180 +C +C Here, there are several sets of scans (NSET > 1), so +C the initial position BEAM of the beam must be +C recalculated for each initial position of the analyzer +C + RTH=TH_0(J_SET)*PIS180 + RPH=PH_0(J_SET)*PIS180 +C + IF(IMOD.EQ.1) THEN + R_L(1)=COS(RTH)*COS(RPH) + R_L(2)=-SIN(RPH) + R_L(3)=SIN(RTH)*COS(RPH) + R_L(4)=COS(RTH)*SIN(RPH) + R_L(5)=COS(RPH) + R_L(6)=SIN(RTH)*SIN(RPH) + R_L(7)=-SIN(RTH) + R_L(8)=0. + R_L(9)=COS(RTH) +C + BEAM(1)=X_BEAM_Z*R_L(1)+Y_BEAM_Z*R_L(2)+ + & Z_BEAM_Z*R_L(3) + BEAM(2)=X_BEAM_Z*R_L(4)+Y_BEAM_Z*R_L(5)+ + & Z_BEAM_Z*R_L(6) + BEAM(3)=X_BEAM_Z*R_L(7)+Y_BEAM_Z*R_L(8)+ + & Z_BEAM_Z*R_L(9) +C + ENDIF + ELSE + W=1. + ENDIF +C + IF(I_EXT.EQ.-1) PRINT 89 +C + CALL DIRAN(VINT,ECIN,JEL) +C + IF(J_SET.EQ.JREF) THEN + DTHETAP=DTHETA + DPHIP=DPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + WRITE(IUO1,88) DTHETA,DPHI + ENDIF +C +C .......... Case IMOD=1 only .......... +C +C Calculation of the position of the beam when the analyzer is at +C (THETA,PHI). DIRBEAM is the direction of the beam and its initial +C value (at (THETA0,PHI0)) is BEAM. AXE is the direction of the theta +C rotation axis and EPS is defined so that (AXE,DIRBEAM,EPS) is a +C direct orthonormal basis. The transform of a vector R by a rotation +C of OMEGA about AXE is then given by +C +C R' = R COS(OMEGA) + (AXE.R)(1-COS(OMEGA)) AXE + (AXE^R) SIN(OMEGA) +C +C Here, DIRANA is the internal direction of the analyzer and ANADIR +C its external position +C +C Note that when the initial position of the analyzer is (RTH,RPH) +C which coincides with (RTH0,RPH0) only for the first fixed angle +C + IF(IMOD.EQ.1) THEN + IF(ITHETA.EQ.1) THEN + AXE(1)=-SIN(RPH) + AXE(2)=COS(RPH) + AXE(3)=0. + RANGLE=RTHETA-RTH + ELSEIF(IPHI.EQ.1) THEN + AXE(1)=0. + AXE(2)=0. + AXE(3)=1. + RANGLE=RPHI-RPH + ENDIF + CALL PRVECT(AXE,BEAM,EPS,CVECT) + PRS=PRSCAL(AXE,BEAM) + IF(J_SCAN.EQ.1) THEN + DIRBEAM(1)=BEAM(1) + DIRBEAM(2)=BEAM(2) + DIRBEAM(3)=BEAM(3) + ELSE + DIRBEAM(1)=BEAM(1)*COS(RANGLE)+PRS*(1.-COS( + & RANGLE))*AXE(1)+SIN(RANGLE)*EPS(1) + DIRBEAM(2)=BEAM(2)*COS(RANGLE)+PRS*(1.-COS( + & RANGLE))*AXE(2)+SIN(RANGLE)*EPS(2) + DIRBEAM(3)=BEAM(3)*COS(RANGLE)+PRS*(1.-COS( + & RANGLE))*AXE(3)+SIN(RANGLE)*EPS(3) + ENDIF + ENDIF + IF(DIRBEAM(3).GT.1.) DIRBEAM(3)=1. + IF(DIRBEAM(3).LT.-1.) DIRBEAM(3)=-1. + THETABEAM=ACOS(DIRBEAM(3)) + IF(I_TEST.EQ.2) THETABEAM=-THETABEAM + COEF=DIRBEAM(1)+IC*DIRBEAM(2) + CALL ARCSIN(COEF,DIRBEAM(3),PHIBEAM) +C +C Internal direction of the incoming beam BEAMDIR +C (DIRBEAM is the external direction) +C + CALL REFRAC(VINT,ECIN,THETABEAM,BEAMTHETA) + BEAMDIR(1)=SIN(BEAMTHETA)*COS(PHIBEAM) + BEAMDIR(2)=SIN(BEAMTHETA)*SIN(PHIBEAM) + BEAMDIR(3)=COS(BEAMTHETA) +C + CALL HARSPH3(NL_M,BEAMTHETA,-PHIBEAM,YLMI,LM_MAX) +C + ANABEAM=ANADIR(1,1)*DIRBEAM(1) + ANADIR(2,1)*DIRBEAM(2) + & +ANADIR(3,1)*DIRBEAM(3) +C + IF(IPRINT.GT.0) THEN + WRITE(IUO1,63) (DIRANA(J,1),J=1,3),(BEAMDIR(K), + & K=1,3),ANABEAM + ENDIF + IF(I_EXT.EQ.-1) PRINT 89 +C + SRDIF=0. + SRDIR=0. +C +C Loop over the different directions of the analyzer contained in a cone +C + DO JDIR=1,NDIR + SIDIF=ZEROC + SIDIR=ZEROC + CALL HARSPH3(NL_M,THETAR(JDIR),PHIR(JDIR),YLMJ, + & LM_MAX) +C +C Loop over the first atom I encountered by the electron beam +C when entering the solid +C + LIN=0 + DO ITYP=1,N_PROT + NBTYPI=NATYP(ITYP) + LMI=LMAX(ITYP,JE) + INDI_M=(LMI+1)*(LMI+1) + DO INUM=1,NBTYPI + IATL=NCORR(INUM,ITYP) + XOI=SYM_AT(1,IATL)-EMET(1) + YOI=SYM_AT(2,IATL)-EMET(2) + ZOI=SYM_AT(3,IATL)-EMET(3) + ROI=SQRT(XOI*XOI+YOI*YOI+ZOI*ZOI) + ZSURFI=VAL(1)-SYM_AT(3,IATL) + IF(IATTS.EQ.1) THEN + ATTSI=EXP(-ZSURFI*GAMMA/COS(BEAMTHETA)) + ENDIF + IF(ROI.GT.SMALL) THEN + CSTHIR=(XOI*BEAMDIR(1)+YOI*BEAMDIR(2)+ZOI* + & BEAMDIR(3))/ROI + CTROIS1=ZOI/ROI + CSTHIR2=(XOI*(DIRANA(1,JDIR)-BEAMDIR(1))+YOI* + & (DIRANA(2,JDIR)-BEAMDIR(2))+ZOI*(DIRANA(3,JDIR)- + & BEAMDIR(3)))/ROI + ELSE + CSTHIR=0. + CTROIS1=0. + CSTHIR2=0. + ENDIF + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78 + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + IF(IDCM.GE.1) THEN + UJ2(ITYP)=UJ_SQ(ITYP) + ENDIF + IF(ABS(ZSURFI).LE.SMALL) THEN + IF(ABS(CSTHIR-1.).GT.SMALL) THEN + CSKZ2I=(BEAMDIR(3)-CTROIS1)*(BEAMDIR(3)- + & CTROIS1)/(2.-2.*CSTHIR) + ELSE + CSKZ2I=1. + ENDIF + UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.)) + ELSE + UII=UJ2(ITYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UI2=VK2(JE)*UII + CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED) + ENDIF + 78 IF(IDWSPH.EQ.1) THEN + DWTER=1. + DWTER2=1. + ELSE + DWTER=EXP(-VK2(JE)*UII*(1.-CSTHIR)) + DWTER2=EXP(-VK2(JE)*UII*(1.-CSTHIR2)) + ENDIF + ATT_MI=ATTSI*DWTER*CEXP(IC*VK(JE)*ROI*CSTHIR) + ATT_MI2=ATTSI*DWTER2*CEXP(-IC*VK(JE)*ROI*CSTHIR2) +C +C Kinematic term +C + SLIDIR=ZEROC + DO LI=0,LMI + ILI=LI*LI+LI+1 + DO MI=-LI,LI + INDI=ILI+MI + SLIDIR=SLIDIR+TL(LI,1,ITYP,JE)*YLMJ(INDI) + & *YLMI(INDI) + ENDDO + ENDDO +C +C Loop over the last atom J encountered by the electron beam +C when exiting the solid +C + SJDIF=ZEROC + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + INDJ_M=(LMJ+1)*(LMJ+1) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XOJ=SYM_AT(1,JATL)-EMET(1) + YOJ=SYM_AT(2,JATL)-EMET(2) + ZOJ=SYM_AT(3,JATL)-EMET(3) + ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ) + ZSURFJ=VAL(1)-SYM_AT(3,JATL) + IF(IATTS.EQ.1) THEN + ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR)) + ENDIF + IF(ROJ.GT.SMALL) THEN + CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2, + & JDIR)+ZOJ*DIRANA(3,JDIR))/ROJ + CTROIS1=ZOJ/ROJ + ELSE + CSTHJR=0. + CTROIS1=0. + ENDIF + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 90 + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + IF(IDCM.EQ.1) THEN + UJ2(JTYP)=UJ_SQ(JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(CSTHJR-1.).GT.SMALL) THEN + CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)*( + & DIRANA(3,JDIR)-CTROIS1)/(2.-2.*CSTHJR) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 90 IF(IDWSPH.EQ.1) THEN + DWTER=1. + ELSE + DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR)) + ENDIF + ATT_MJ=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ* + & CSTHJR) +C +C Loop over the angular momentum of atom I +C + SLIDIF=ZEROC + DO INDI=1,INDI_M +C +C Loop over the angular momentum of atom J +C + SLJDIF=ZEROC + DO INDJ=1,INDJ_M + LIN=LIN+1 + SLJDIF=SLJDIF+YLMJ(INDJ)*TAU(LIN) + ENDDO +C + SLIDIF=SLIDIF+SLJDIF*YLMI(INDI) + ENDDO +C +C End of the loops over the last atom J +C + SJDIF=SJDIF+SLIDIF*ATT_MJ +C + ENDDO + ENDDO + SIDIF=SIDIF+SJDIF*ATT_MI + SIDIR=SIDIR+SLIDIR*ATT_MI2 +C +C End of the loops over the first atom I +C + ENDDO + ENDDO +C +C Computing the square modulus +C + SRDIF=SRDIF+CABS(SIDIF)*CABS(SIDIF) + SRDIR=SRDIR+CABS(SIDIR)*CABS(SIDIR) +C +C End of the loop on the directions of the analyzer +C + ENDDO +C + SSETDIF=SSETDIF+SRDIF*CFM*W/NDIR + SSETDIR=SSETDIR+SRDIR*CFM*W/NDIR + IF(ICHKDIR.EQ.2) THEN + IF(JSET.EQ.JREF) THEN + SSET2DIF=SRDIF*CFM/NDIR + SSET2DIR=SRDIR*CFM/NDIR + ENDIF + ENDIF +C +C End of the loop on the set averaging +C + ENDDO +C + IF(ISOM.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + & SSETDIR,SSETDIF + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + & SSET2DIR,SSET2DIF + ENDIF + ELSE + WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + & SSETDIR,SSETDIF + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + & SSET2DIR,SSET2DIF + ENDIF + ENDIF +C +C End of the loop on the scanned angle +C + ENDDO +C + 8 CONTINUE +C +C End of the loop on the fixed angle +C + ENDDO +C +C End of the loop on the energy +C + CLOSE(IUI6) + ENDDO +C + 3 CONTINUE +C + GO TO 1 + 5 IPLAN=JPLAN-1 + IJK=IJK+1 + IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN + ENDIF + 1 CONTINUE +C +C End of the loop on the planes +C + ENDDO +C + IF(ABS(I_EXT).GE.1) CLOSE(IUI6) + IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*) + IF(SPECTRO.EQ.'APC') CLOSE(IOUT) + IF(SPECTRO.EQ.'APC') GOTO 7 +c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN + IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN + NP=0 + CALL TREAT_PHD(ISOM,NFICHLEC,JFICH,NP) + ENDIF + IF(I_EXT.EQ.2) THEN + CALL WEIGHT_SUM(ISOM,I_EXT,0,1) + ENDIF + GOTO 7 + 6 WRITE(IUO1,55) +C + 9 FORMAT(9(2X,I1),2X,I2) + 11 FORMAT(I4,2X,I4,2X,I4) + 12 FORMAT(2X,A3,11X,A13) + 13 FORMAT(6X,I1,1X,I3,2X,I4) + 14 FORMAT(6X,I1,1X,I3,3X,I3) + 19 FORMAT(2(2X,I1),1X,I2,6(2X,I1),2X,I2) + 20 FORMAT(2(5X,F6.2,2X,F6.2),2X,I1) + 21 FORMAT(10X,E12.6,3X,E12.6) + 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/, + &25X,' BY DEBYE UNCORRELATED MODEL:',/) + 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2') + 51 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' DOES NOT CONTAIN ', + *'ANY ABSORBER OF TYPE ',I2,' *******') + 52 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' POSITION OF ','THE + &ABSORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X,'******* ', + &19X,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******') + 53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1,/ + &,10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1,/,10X,' MINIMAL + &INTENSITY : ',E12.6,2X,'No OF THE PATH : ',F15.1, + & /,10X,' MAXIMAL INTENSITY : ',E12.6,2X, + &'No OF THE PATH : ',F15.1) + 54 FORMAT(//,7X,'DUE TO THE SIZE OF THE CLUSTER, THE SUMMATION', + *' HAS BEEN TRUNCATED TO THE ',I2,' TH PLANE') + 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT', + *'AVAILABLE >>>>>>>>>>') + 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X, + *'MEAN FREE PATH = ',F6.3,' * A',//) + 57 FORMAT(25X,'CLUSTER RADIUS = ',F6.3,' *A') + 58 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',I10,/, + &10X,' EFFECTIVE NUMBER OF PATHS : ',I10, /,10X,' + & MINIMAL INTENSITY : ',E12.6,2X,'No OF THE PATH : ',I10, + & /,10X,' MAXIMAL INTENSITY : ', + &E12.6, 2X,'No OF THE PATH : ',I10) + 59 FORMAT(//,15X,'THE SCATTERING DIRECTION IS GIVEN INSIDE ', + *'THE CRYSTAL') + 60 FORMAT(7X,'THE POSITIONS OF THE ATOMS ARE GIVEN WITH RESPECT ', + *'TO THE ABSORBER') + 63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (', + &F6.3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF + &THE BEAM ', ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X, + &'ANALYZER.BEAM : ',F7.4) + 65 FORMAT(////,3X,'++++++++++++++++++',9X, + *'THETA = ',F6.2,' DEGREES',9X,'++++++++', + *'++++++++++',///) + 66 FORMAT(////,3X,'++++++++++++++++++',9X, + *'PHI = ',F6.2,' DEGREES',9X,'++++++++++', + *'++++++++++',///) + 67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 68 FORMAT(10X,' CUT-OFF INTENSITY : ',E12.6) + 69 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X)) + 70 FORMAT(2X,I2,2X,I10,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X)) + 71 FORMAT(//,1X,'JDIF',4X,'No OF THE PATH',2X,'INTENSITY',3X, + &'LENGTH',4X,'ABSORBER',2X,'ORDER OF THE SCATTERERS',/) + 72 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X, + &E12.6,2X,E12.6) + 74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ','==== + &=>') + 76 FORMAT(2X,I2,2X,E12.6,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X)) + 77 FORMAT(' ') + 79 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4) + 80 FORMAT(///) + 81 FORMAT(//,1X,'RANK',1X,'ORDER',4X,'No PATH',3X,'INTENSITY',3X, + &'LENGTH',4X,'ABS',3X,'ORDER OF THE SCATTERERS',/) + 82 FORMAT(I3,4X,I2,1X,E12.6,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X)) + 83 FORMAT(I3,4X,I2,1X,I10,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X)) + 84 FORMAT(/////,18X,'THE ',I3,' MORE INTENSE PATHS BY DECREASING',' + &ORDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ','OF A)') + 85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ',/,24X,'(THE + &LENGTH IS GIVEN IN UNITS OF A)') + 86 FORMAT(2X,I3,1X,I4,5X,F8.3,3X,F8.3,3X,E12.6) + 87 FORMAT(2X,I2,2X,I3,2X,I2,2X,I3,2X,I3,2X,I3,2X,I1,2X,I2,2X,I2,2X, + &E12.6,2X,E12.6,2X,E12.6,2X,E12.6) + 88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =', F6.2) + 89 FORMAT(/,4X,'..........................................','....... + &..............................') +C + 7 RETURN +C + END diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main.f new file mode 100644 index 0000000..460d2b3 --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main.f @@ -0,0 +1,21 @@ + SUBROUTINE RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_, + & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_, + & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_, + & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_) + + USE DIM_MOD + IMPLICIT INTEGER (A-Z) +CF2PY INTEGER, INTENT(IN,COPY) :: NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_ + + CALL ALLOCATION(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_, + & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_, + & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_, + & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_) + + CALL MAIN_LED_NS_MI() + CALL CLOSE_ALL_FILES() + + END SUBROUTINE RUN diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main_led_ns_mi.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main_led_ns_mi.f new file mode 100644 index 0000000..60e693e --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main_led_ns_mi.f @@ -0,0 +1,1648 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * LEED CODE USING MATRIX INVERSION * * +C * * * * +C * ******************************************************** * +C ************************************************************ +C +C +C +C +C Written by D. Sebilleau, Groupe Theorie, +C Departement Materiaux-Nanosciences, +C Institut de Physique de Rennes, +C UMR CNRS-Universite 6251, +C Universite de Rennes-1, +C 35042 Rennes-Cedex, +C France +C +C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada +C +C----------------------------------------------------------------------- +C +C As a general rule in this code, although there might be a few +C exceptions (...), a variable whose name starts with a 'I' is a +C switch, with a 'J' is a loop index and with a 'N' is a number. +C +C The main subroutines are : +C +C * PHDDIF : computes the photoelectron diffraction +C formula +C +C * LEDDIF : computes the low-energy electron +C diffraction formula +C +C * XASDIF : computes the EXAFS or XANES formula +C depending on the energy +C +C * AEDDIF : computes the Auger electron diffraction +C formula +C +C * FINDPATHS : generates the multiple scattering +C paths the electron will follow +C +C * PATHOP : calculates the contribution of a given +C path to the scattering path operator +C +C * MATDIF : computes the Rehr-Albers scattering +C matrices +C +C A subroutine called NAME_A is the Auger equivalent of subroutine +C NAME. The essentail difference between NAME and NAME_A is that +C they do not contain the same arrays. +C +C Always remember, when changing the input data file, to keep the +C format. The rule here is that the last digit of any integer or +C character data must correspond to the tab (+) while for real data, +C the tab precedes the point. +C +C Do not forget, before submitting a calculation, to check the +C consistency of the input data with the corresponding maximal +C values in the include file. +C +C----------------------------------------------------------------------- +C +C Please report any bug or problem to me at : +C +C didier.sebilleau@univ-rennes1.fr +C +C +C +C Last modified : 10 Jan 2016 +C +C======================================================================= +C + SUBROUTINE MAIN_LED_NS_MI() +C +C This routine reads the various input files and calls the subroutine +C performing the requested calculation +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE ADSORB_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE CLUSLIM_MOD + USE COOR_MOD + USE DEBWAL_MOD + USE INDAT_MOD + USE INIT_A_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE INIT_M_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE LIMAMA_MOD + USE LPMOY_MOD + USE MASSAT_MOD + USE MILLER_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TL_AED_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE XMRHO_MOD +C + DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3) + DIMENSION ROT(3,3),EMET(3) + DIMENSION VAL2(NATCLU_M) + DIMENSION IRE(NATCLU_M,2) + DIMENSION REL(NATCLU_M),RHOT(NATM) + DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M) + DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM) + DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M) + DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M) + DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM) +C + COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR +C + INTEGER INV(2) +C + CHARACTER RIEN + CHARACTER*1 B + CHARACTER*2 R +C +C +C +C +C +C + CHARACTER*30 TUNIT,DUMMY +C + DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/ + DATA INV /1,0/ +C + LE_MAX=0 +C +C! READ(*,776) NFICHLEC +C! READ(*,776) ICOM +C! DO JF=1,NFICHLEC +C! READ(*,777) INDATA(JF) +C! ENDDO +C +C.......... Loop on the data files .......... +C + NFICHLEC=1 + ICOM=5 + DO JFICH=1,NFICHLEC +C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD') + OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD') + CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,* + &520,*540,*550,*570,*580,*590,*630) +C +C.......... Atomic case index .......... +C + I_AT=0 + IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1 + IF(SPECTRO.EQ.'APC') THEN + IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1 + ENDIF +C + IF(IBAS.EQ.1) THEN + IF(ITEST.EQ.0) THEN + NEQ=(2*NIV+1)**3 + ELSE + NEQ=(2*NIV+3)**3 + ENDIF + IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518 + ENDIF +C + IF(SPECTRO.EQ.'APC') THEN + N_EL=2 + ELSE + N_EL=1 + ENDIF + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN + IF(I_MULT.EQ.0) THEN + LE_MIN=ABS(LI_C-ABS(LI_I-LI_A)) + LE_MAX=LI_C+LI_A+LI_I + ELSE + LE_MIN=ABS(LI_C-L_MUL) + LE_MAX=LI_C+L_MUL + ENDIF + ENDIF +C +C.......... Test of the dimensions against the input values .......... +C + IF(NO.GT.NO_ST_M) GOTO 600 + IF(LE_MAX.GT.LI_M) GOTO 620 +C + OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD') + OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD') + IF(INTERACT.EQ.'DIPCOUL') THEN + OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD') + OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD') + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (dipolar excitation or no excitation case) .......... +C + IF(INTERACT.NE.'COULOMB') THEN + IF(SPECTRO.EQ.'APC') WRITE(IUO1,418) + READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE + IF(ISPIN.EQ.0) THEN + IF(NAT1.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1 + ENDIF + ENDIF + IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IUI2,530) E_MIN,E_MAX,DE + ENDIF + IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN + NLG=INT(NAT1-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1 + READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX. Waiting for a version of PHAGEN +C with LMAX dependent on the energy +C + DO JE=1,NE + DO JAT=1,NAT1 + LMAX(JAT,JE)=LMAX(JAT,1) + ENDDO + ENDDO +C + NL1=1 + DO JAT=1,NAT1 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + ENDIF + IF(ITL.EQ.0) READ(IUI3,101) NATR,NER + IF(ISPIN.EQ.1) THEN + READ(IUI3,106) L_IN,NATR,NER + IF(LI.NE.L_IN) GOTO 606 + ENDIF + NAT2=NAT+NATA + IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180 + IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL.EQ.0) THEN + DO JAT=1,NAT2 + IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + ENDIF + DO JE=1,NE + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121 + READ(IUI3,103) ENERGIE + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + 121 CONTINUE + DO L=0,LMAX(JAT,JE) + READ(IUI2,7) VK(JE),TL(L,1,JAT,JE) + TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0., + & 1.)*TL(L,1,JAT,JE)) + ENDDO + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5 + DO LL=1,18 + READ(IUI3,104) RH1,RH2,DEF1,DEF2 + RHOR(JE,JAT,LL,1,1)=CMPLX(RH1) + RHOR(JE,JAT,LL,2,1)=CMPLX(RH2) + DLT(JE,JAT,LL,1)=CMPLX(DEF1) + DLT(JE,JAT,LL,2)=CMPLX(DEF2) + ENDDO + 5 CONTINUE + ENDDO + ENDDO + ELSE +C +C.......... TL and RHOR calculated by PHAGEN .......... +C + DO JE=1,NE + NLG=INT(NAT2-0.0001)/4 +1 + IF(NE.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2 + READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL) + ENDDO + NL1=1 + DO JAT=1,NAT2 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + DO JAT=1,NAT2 + READ(IUI2,*) DUMMY + DO L=0,LMAX(JAT,JE) + IF(LMAX_MODE.EQ.0) THEN + READ(IUI2,9) VK(JE),TLSTAR + ELSE + READ(IUI2,9) VK(JE),TLSTAR + ENDIF + TL(L,1,JAT,JE)=CONJG(TLSTAR) + VK(JE)=CONJG(VK(JE)) + ENDDO + ENDDO +C + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333 + IF(JE.EQ.1) THEN + DO JDUM=1,7 + READ(IUI3,102) RIEN + ENDDO + ENDIF + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + ENDDO + 333 VK(JE)=VK(JE)*A + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDDO + ENDIF +C + CLOSE(IUI2) + CLOSE(IUI3) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN + CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL) + ENDIF + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (Coulomb excitation case) .......... +C + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN + IERR=0 + IF(INTERACT.EQ.'COULOMB') THEN + IRD1=IUI2 + IRD2=IUI3 + ELSEIF(INTERACT.EQ.'DIPCOUL') THEN + IRD1=IUI7 + IRD2=IUI8 + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,419) + READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A + IF(ISPIN.EQ.0) THEN + IF(NAT1_A.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1_A + ENDIF + ENDIF + IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A + ENDIF + IF(ITL_A.EQ.1) THEN + READ(IRD2,107) LI_C2,LI_I2,LI_A2 + READ(IRD2,117) LE_MIN1,N_CHANNEL + LE_MAX1=LE_MIN1+N_CHANNEL-1 + IF(I_TEST_A.NE.1) THEN + IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO + & 610 + ELSE + LI_C2=0 + LI_I2=1 + LI_A2=0 + LE_MIN1=1 + N_CHANNEL=1 + ENDIF + ENDIF + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN + NLG=INT(NAT1_A-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1_A + READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX_A. Waiting for a version of PHAGEN +C with LMAX_A dependent on the energy +C + DO JE=1,NE1_A + DO JAT=1,NAT1_A + LMAX_A(JAT,JE)=LMAX_A(JAT,1) + ENDDO + ENDDO +C + NL1_A=1 + DO JAT=1,NAT1_A + NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1) + ENDDO + IF(NL1_A.GT.NL_M) GOTO 184 + ENDIF + IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A + IF(ISPIN.EQ.1) THEN + READ(IRD2,106) L_IN_A,NATR_A,NER_A + IF(LI_C.NE.L_IN_A) GOTO 606 + ENDIF + NAT2_A=NAT+NATA + NAT2=NAT2_A + IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180 + IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) + & GOTO 182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL_A.EQ.0) THEN + CONTINUE + ELSE +C +C.......... TL_A and RHOR_A calculated by PHAGEN .......... +C + DO JE=1,NE_A + NLG=INT(NAT2_A-0.0001)/4 +1 + IF(NE_A.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2_A + READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL) + ENDDO + DO JAT=1,NAT2_A + READ(IRD1,*) DUMMY + DO L=0,LMAX_A(JAT,JE) + IF(LMAX_MODE_A.EQ.0) THEN + READ(IRD1,9) VK_A(JE),TLSTAR + ELSE + READ(IRD1,7) VK_A(JE),TLSTAR + ENDIF + TL_A(L,1,JAT,JE)=CONJG(TLSTAR) + VK_A(JE)=CONJG(VK_A(JE)) + ENDDO + ENDDO +C + IF(IFTHET_A.EQ.1) GOTO 331 + DO LE=LE_MIN,LE_MAX + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IRD2,109) L_E,LB_MIN,LB_MAX + IF(I_TEST_A.EQ.1) THEN + L_E=1 + LB_MIN=0 + LB_MAX=1 + ENDIF + IF(LE.NE.L_E) IERR=1 + L_BOUNDS(L_E,1)=LB_MIN + L_BOUNDS(L_E,2)=LB_MAX + DO LB=LB_MIN,LB_MAX + READ(IRD2,108) L_A,RAD_D,RAD_E + RHOR_A(LE,JM,L_A,1,1)=RAD_D + RHOR_A(LE,JM,L_A,2,1)=RAD_E + IF(I_TEST_A.EQ.1) THEN + IF(LB.EQ.LB_MIN) THEN + RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0) + ELSEIF(LB.EQ.LB_MAX) THEN + RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + 331 VK_A(JE)=VK_A(JE)*A + VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE)) + ENDDO + ENDIF +C + CLOSE(IRD1) + CLOSE(IRD2) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN + CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL) + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,420) +C + ENDIF +C +C.......... Check of the consistency of the two TL and radial .......... +C.......... matrix elements for APECS .......... +C + IF(SPECTRO.EQ.'APC') THEN +C + I_TL_FILE=0 + I_RD_FILE=0 +C + IF(NAT1.NE.NAT1_A) I_TL_FILE=1 + IF(NE1.NE.NE1_A) I_TL_FILE=1 + IF(ITL.NE.ITL_A) I_TL_FILE=1 + IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1 +C + IF(LI_C.NE.LI_C2) I_RD_FILE=1 + IF(LI_I.NE.LI_I2) I_RD_FILE=1 + IF(LI_A.NE.LI_A2) I_RD_FILE=1 +C + IF(I_TL_FILE.EQ.1) GOTO 608 + IF(I_RD_FILE.EQ.1) GOTO 610 + IF(IERR.EQ.1) GOTO 610 +C + ENDIF +C +C.......... Calculation of the scattering factor (only) .......... +C + IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8 + IF(IFTHET.EQ.1) THEN + CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE) + ELSEIF(IFTHET_A.EQ.1) THEN +c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A) + ENDIF + WRITE(IUO1,57) +C! STOP + GO TO 999 +C + 8 IF(IBAS.EQ.0) THEN +C +C............... Reading of an external cluster ............... +C +C +C Cluster originating from CLUSTER_NEW.F : IPHA=0 +C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems) +C Other cluster : the first line must be text; then +C free format : Atomic number,X,Y,Z,number +C of the corresponding prototypical atom ; +C All atoms corresponding to the same +C prototypical atom must follow each other. +C Moreover, the blocks of equivalent atoms +C must be ordered by increasing number of +C prototypical atom. +C + VALZ_MIN=1000.0 + VALZ_MAX=-1000.0 +C + OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD') + READ(IUI4,778,ERR=892) IPHA + GOTO 893 + 892 IPHA=3 + IF(UNIT.EQ.'ANG') THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + ELSEIF(UNIT.EQ.'LPU') THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(UNIT.EQ.'ATU') THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + ELSE + GOTO 890 + ENDIF + 893 NATCLU=0 + DO JAT=1,NAT2 + NATYP(JAT)=0 + ENDDO + IF(IPHA.EQ.0) THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(IPHA.EQ.1) THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + IEMET(1)=1 + ELSEIF(IPHA.EQ.2) THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + IEMET(1)=1 + ENDIF + IF(IPRINT.EQ.2) THEN + IF(I_AT.NE.1) THEN + WRITE(IUO1,558) IUI4,TUNIT + IF(IPHA.EQ.3) WRITE(IUO1,549) + ENDIF + ENDIF + JATM=0 + DO JLINE=1,10000 + IF(IPHA.EQ.0) THEN + READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.1) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.2) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.3) THEN + READ(IUI4,*,END=780) NN,X,Y,Z,JAT + ENDIF + JATM=MAX0(JAT,JATM) + NATCLU=NATCLU+1 + IF(IPHA.NE.3) THEN + CHEM(JAT)=R + ELSE + CHEM(JAT)='XX' + ENDIF + NZAT(JAT)=NN + NATYP(JAT)=NATYP(JAT)+1 + COORD(1,NATCLU)=X*CUNIT + COORD(2,NATCLU)=Y*CUNIT + COORD(3,NATCLU)=Z*CUNIT + VALZ(NATCLU)=Z*CUNIT + IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2, + & NATCLU),COORD(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT) + ENDIF + ENDDO + 780 NBZ=NATCLU + IF(JATM.NE.NAT) GOTO 514 + CLOSE(IUI4) +C + IF(NATCLU.GT.NATCLU_M) GOTO 510 + DO JA1=1,NATCLU + DO JA2=1,NATCLU + DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+( + & COORD(2,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))** + & 2) + IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO + & 895 + ENDDO + ENDDO +C + D_UP=VALZ_MAX-VALZ(1) + D_DO=VALZ(1)-VALZ_MIN + IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN + I_INV=1 + ELSE + I_INV=0 + ENDIF + ELSE +C +C............... Construction of an internal cluster ............... +C + CALL BASE + CALL ROTBAS(ROT) + IF(IVG0.EQ.2) THEN + NMAX=NIV+1 + ELSE + NMAX=(2*NIV+1)**3 + ENDIF + IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN + WRITE(IUO1,37) + WRITE(IUO1,38) NIV + DO NUM=1,NMAX + CALL NUMAT(NUM,NIV,IA,IB,IC) + WRITE(IUO1,17) NUM,IA,IB,IC + ENDDO + WRITE(IUO1,39) + ENDIF + CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP, + & NBZ,NAT2,NCOUCH,NMAX) + IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN + CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL, + & NCOUCH) + IF(IREL.EQ.1) THEN + DO JP=1,NPLAN + VAL(JP)=VAL2(JP) + ENDDO + ENDIF + ENDIF + ENDIF +C +C Storage of the extremal values of x and y for each plane. They define +C the exterior of the cluster when a new cluster has to be build to +C support a point-group +C + IF(I_GR.GE.1) THEN + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + WRITE(IUO1,29) K,VAL(K) + X_MAX(K)=0. + X_MIN(K)=0. + Y_MAX(K)=0. + Y_MIN(K)=0. + ENDDO + ENDIF + DO JAT=1,NATCLU + X=COORD(1,JAT) + Y=COORD(2,JAT) + Z=COORD(3,JAT) + DO JPLAN=1,NPLAN + IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN + X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN)) + X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN)) + Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN)) + Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN)) + ENDIF + ENDDO + ENDDO + ENDIF +C +C Instead of the symmetrization of the cluster (this version only) +C + N_PROT=NAT + NAT_ST=0 + DO JTYP=1,JATM + NB_AT=NATYP(JTYP) + IF(NB_AT.GT.NAT_EQ_M) GOTO 614 + DO JA=1,NB_AT + NAT_ST=NAT_ST+1 + NCORR(JA,JTYP)=NAT_ST + ENDDO + ENDDO + DO JC=1,3 + DO JA=1,NATCLU + SYM_AT(JC,JA)=COORD(JC,JA) + ENDDO + ENDDO +C +C Checking surface-like atoms for mean square displacements +C calculations +C + CALL CHECK_VIB(NAT2) +C +C.......... Set up of the variables used for an internal .......... +C.......... calculation of the mean free path and/or of .......... +C.......... the mean square displacements .......... +C + IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN + DO JTYP=1,NAT2 + XMT(JTYP)=XMAT(NZAT(JTYP)) + RHOT(JTYP)=RHOAT(NZAT(JTYP)) + ENDDO + XMTA=XMT(1) + RHOTA=RHOT(1) + NZA=NZAT(1) + ENDIF + IF(IDCM.GT.0) THEN + CALL CHNOT(3,VECBAS,VEC) + DO J=1,3 + VB1(J)=VEC(J,1) + VB2(J)=VEC(J,2) + VB3(J)=VEC(J,3) + ENDDO + CPR=1. + CALL PRVECT(VB2,VB3,VBS,CPR) + VM=PRSCAL(VB1,VBS) + QD=(6.*PI*PI*NAT/VM)**(1./3.) + ENDIF +C +C.......... Writing of the contents of the cluster, .......... +C.......... of the position of the different planes .......... +C.......... and of their respective absorbers in .......... +C.......... the control file IUO1 .......... +C + IF(I_AT.EQ.1) GOTO 153 + IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN + WRITE(IUO1,40) + NCA=0 + DO J=1,NAT + DO I=1,NMAX + NCA=NCA+1 + WRITE(IUO1,20) J,I + WRITE(IUO1,21) (ATOME(L,NCA),L=1,3) + K=IRE(NCA,1) + IF(K.EQ.0) THEN + WRITE(IUO1,22) + ELSE + WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2) + ENDIF + ENDDO + ENDDO + WRITE(IUO1,41) + ENDIF + IF(IBAS.EQ.1) THEN + WRITE(IUO1,24) + NATCLU=0 + DO I=1,NAT + NN=NATYP(I) + NATCLU=NATCLU+NATYP(I) + WRITE(IUO1,26) NN,I + ENDDO + IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3 + WRITE(IUO1,782) NATCLU + IF(NATCLU.GT.NATCLU_M) GOTO 516 + IF(IPRINT.EQ.3) WRITE(IUO1,559) + IF(IPRINT.EQ.3) THEN + NBTA=0 + DO JT=1,NAT2 + NBJT=NATYP(JT) + DO JN=1,NBJT + NBTA=NBTA+1 + WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA), + & COORD(3,NBTA),JT,JN,CHEM(JT) + ENDDO + ENDDO + ENDIF + ENDIF + 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN + CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) + ENDIF + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) + ENDDO + ENDIF +C + IF(I_AT.EQ.0) WRITE(IUO1,30) + IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,31) (IEMET(J),J=1,NEMET) + ENDIF + ZEM=1.E+20 + DO L=1,NPLAN + Z=VAL(L) + DO JEMED=1,NEMET + CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93) + IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET( + & 3) + IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3) + GO TO 33 + 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM + 33 CONTINUE + ENDDO + ENDDO +C +C.......... Loop on the electrons involved in the .......... +C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... +C.......... LEED or AED and N_EL = 2 for APC .......... +C + DO J_EL=1,N_EL +C +C.......... Writing the information on the spectroscopies .......... +C.......... in the control file IUO1 .......... +C + IF(SPECTRO.EQ.'XAS') GOTO 566 + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,236) + ELSE + WRITE(IUO1,248) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,245) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF +C +C---------- Photoelectron diffraction case (PHD) ---------- +C + IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,35) + ELSE + WRITE(IUO1,246) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,44) + IF(IE.EQ.1) WRITE(IUO1,58) + IF(INITL.EQ.0) WRITE(IUO1,118) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + WRITE(IUO1,418) + WRITE(IUO1,18) + ENDIF + IF(J_EL.EQ.2) GOTO 222 + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + IF(INITL.NE.0) THEN + WRITE(IUO1,337) + WRITE(IUO1,91) + IF(IPOL.EQ.0) THEN + WRITE(IUO1,88) + ELSEIF(ABS(IPOL).EQ.1) THEN + WRITE(IUO1,87) + ELSEIF(IPOL.EQ.2) THEN + WRITE(IUO1,89) + ENDIF + WRITE(IUO1,91) + IF(IDICHR.GT.0) THEN + WRITE(IUO1,338) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,90) + WRITE(IUO1,43) THLUM,PHILUM + IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF + ENDIF +C + IF(INITL.EQ.2) THEN + WRITE(IUO1,79) LI,LI-1,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL, + & 1,1),RHOR(JE,JTE,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,444) JTE,DLT(JE,JTE, + & NNL,1),DLT(JE,JTE,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.-1) THEN + WRITE(IUO1,82) LI,LI-1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 1,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,1) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.1) THEN + WRITE(IUO1,82) LI,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + 222 CONTINUE + ENDIF +C +C---------- LEED case (LED) ---------- +C + IF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,252) + ELSE + WRITE(IUO1,258) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,254) + IF(IE.EQ.1) WRITE(IUO1,256) + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,260) + WRITE(IUO1,261) THLUM,PHILUM + IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF +C +C---------- Auger diffraction case (AED) ---------- +C + IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,235) + ELSE + WRITE(IUO1,247) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,244) + IF(I_TEST_A.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN + WRITE(IUO1,419) + WRITE(IUO1,18) + ENDIF + IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC_A.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,95) AUGER + CALL AUGER_MULT + IF(I_MULT.EQ.0) THEN + WRITE(IUO1,154) + ELSE + WRITE(IUO1,155) MULTIPLET + ENDIF +C + DO JEM=1,NEMET + JTE=IEMET(JEM) + WRITE(IUO1,112) JTE + DO LE=LE_MIN,LE_MAX + WRITE(IUO1,119) LE + LA_MIN=L_BOUNDS(LE,1) + LA_MAX=L_BOUNDS(LE,2) + DO LA=LA_MIN,LA_MAX + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,115) LA,RHOR_A(LE,JTE, + & LA,1,1),RHOR_A(LE,JTE,LA,2,1) + ENDIF + ENDDO + ENDDO + ENDDO +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF + ENDIF +C +C.......... Check of the dimensioning of the treatment routine .......... +C + CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI, + & NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C.......... Call of the subroutine performing either .......... +C.......... the PhD, LEED, AED, EXAFS or APECS calculation .......... +C + 566 IF(ISPIN.EQ.0) THEN + IF(SPECTRO.EQ.'PHD') THEN +c CALL PHDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'LED') THEN + CALL LEDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP, + & RHOR,NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'AED') THEN +c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, +c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) + ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'APC') THEN +c IF(J_EL.EQ.1) THEN +c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(J_EL.EQ.2) THEN +c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, +c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) +c ENDIF + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF(SPECTRO.EQ.'PHD') THEN +c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(SPECTRO.EQ.'AED') THEN +c CALL AEDDIF_SP +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_SP +c ENDIF + continue + ENDIF +C +C.......... End of the MS calculation : .......... +C.......... direct exit or treatment of the results .......... +C +C +C.......... End of the loop on the electrons .......... +C + ENDDO +C + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,52) + ELSE + WRITE(IUO1,249) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,49) + IF(IE.EQ.1) WRITE(IUO1,59) + ELSEIF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,253) + ELSE + WRITE(IUO1,259) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,255) + IF(IE.EQ.1) WRITE(IUO1,257) + ELSEIF(SPECTRO.EQ.'XAS') THEN + WRITE(IUO1,51) + ELSEIF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,237) + ELSE + WRITE(IUO1,250) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,238) + ELSEIF(SPECTRO.EQ.'APC') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,239) + ELSE + WRITE(IUO1,251) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,240) + ENDIF +C + CLOSE(ICOM) + IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN + WRITE(IUO1,562) + ENDIF + IF(ISOM.EQ.0) CLOSE(IUO2) +C! IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1) +C +C.......... End of the loop on the data files .......... +C + ENDDO +C + IF(ISOM.NE.0) THEN + JFF=1 + IF(ISPIN.EQ.0) THEN + IF(SPECTRO.NE.'XAS') THEN + CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP) + ELSE +c CALL TREAT_XAS(ISOM,NFICHLEC,NP) + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP) +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP) +c ENDIF + continue + ENDIF + ENDIF +C +C! IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) +C! STOP + GO TO 999 +C + 1 WRITE(IUO1,60) + STOP + 2 WRITE(IUO1,61) + STOP + 55 WRITE(IUO1,65) + STOP + 56 WRITE(IUO1,64) + STOP + 74 WRITE(IUO1,75) + STOP + 99 WRITE(IUO1,100) + STOP + 180 WRITE(IUO1,181) + STOP + 182 WRITE(IUO1,183) + STOP + 184 WRITE(IUO1,185) + STOP + 504 WRITE(IUO1,505) + STOP + 510 WRITE(IUO1,511) IUI4 + STOP + 514 WRITE(IUO1,515) + STOP + 516 WRITE(IUO1,517) + STOP + 518 WRITE(IUO1,519) + WRITE(IUO1,889) + STOP + 520 WRITE(IUO1,521) + STOP + 540 WRITE(IUO1,541) + STOP + 550 WRITE(IUO1,551) + STOP + 570 WRITE(IUO1,571) + STOP + 580 WRITE(IUO1,581) + STOP + 590 WRITE(IUO1,591) + STOP + 600 WRITE(IUO1,601) + STOP + 602 WRITE(IUO1,603) + STOP + 604 WRITE(IUO1,605) + STOP + 606 WRITE(IUO1,607) + STOP + 608 WRITE(IUO1,609) + STOP + 610 WRITE(IUO1,611) + STOP + 614 WRITE(IUO1,615) NB_AT + STOP + 620 WRITE(IUO1,621) LE_MAX + STOP + 630 WRITE(IUO1,631) + STOP + 890 WRITE(IUO1,891) + STOP + 895 WRITE(IUO1,896) JA1,JA2 +C + 3 FORMAT(5(5X,I4)) + 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) + 9 FORMAT(3X,F9.4,1X,F9.4,E18.6,E18.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',': + & (',I3,',',I3,',',I3,')') + 18 FORMAT(' ',/) + 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5) + 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3, + &',',F7.3,')') + 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER') + 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3, + &',',F7.3,')',5X,'NEW NUMBER : ',I4) + 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/) + 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2) + 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3) + 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/) + 31 FORMAT(38X,10(I2,3X),//) + 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS + &POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', 'OF THE + &EXAFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE + &ATOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + & '++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', ' CONTENTS OF THE + &REDUCED CLUSTER ======================',///) + 41 FORMAT(///,'==================================================== + &','============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2, + &' DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE + &SURFACE)') + 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON + &DIFFRACTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', 'EXAFS + &CALCULATION ##########') + 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON + &DIFFRACTION CALCULATION #####','#####') + 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE') + 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE + &STRUCTURE OSCILLATIONS CALCULATION #####', '#####',/////) + 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE + &OSCILLATIONS CALCULATION #####','#####') + 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M) + & - CHECK THE DIMENSIONING >>>>>>>>>>') + 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', + &' >>>>>>>>>>') + 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ', + &'CLUSTER HAS NOT CONVERGED YET >>>>>>>>>>') + 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ', + & 'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>') + 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ', + & 'IN MAIN ET READ_DATA >>>>>>>>>>') + 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ', + & I1,',',I1,/) + 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ', + &A3,')',//) + 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)') + 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1) + 83 FORMAT(//,32X,'(SPHERICAL WAVES)') + 84 FORMAT(//,34X,'(PLANE WAVES)') + 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)') + 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)') + 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +') + 88 FORMAT(24X,'+ NON POLARIZED LIGHT +') + 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +') + 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/) + 91 FORMAT(24X,'+',35X,'+') + 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++') + 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS + &PRESENT IN THIS PLANE') + 95 FORMAT(////,31X,'AUGER LINE :',A6,//) + 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,') + &') + 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ', + &I1,')') + 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE',' + &>>>>>>>>>>') + 101 FORMAT(24X,I3,24X,I3) + 102 FORMAT(A1) + 103 FORMAT(31X,F7.2) + 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5) + 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X, + &E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) + 106 FORMAT(12X,I3,12X,I3,12X,I3) + 107 FORMAT(5X,I2,5X,I2,5X,I2) + 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 109 FORMAT(5X,I2,12X,I2,11X,I2) + 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + &' :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//) + 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + &' : (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')') + 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + &' : ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON) + &',/,8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//) + 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ', + * 'TYPE ',I2,' : (',F8.5,',',F8.5,')') + 114 FORMAT(/) + 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8. + &5,')') + 117 FORMAT(12X,I2,5X,I2) + 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/) + 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE + &INTEGRAL') + 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ', + &'INVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ', + &'INVERSION)') + 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4) + 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/, + &' ',/,' ') + 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ', + &'LINE',' ',/,' ',/,' ') + 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + &'AND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + &'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ', + &'FILE >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX + &ELEMENTS TAKEN INTO ACCOUNT <-----',///) + 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL + &AUGER DIFFRACTION CALCULATION #####', '#####',/////) + 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL + &APECS DIFFRACTION CALCULATION #####', '#####',/////) + 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &PHOTOELECTRON DIFFRACTION CALCULATION ','##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &AUGER DIFFRACTION CALCULATION ', '##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &APECS DIFFRACTION CALCULATION ', '##########',/////) + 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON + &DIFFRACTION CALCULATION #####','#####') + 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL + &LEED CALCULATION #####', '#####',/////) + 253 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL LEED + &CALCULATION #####', '#####',/////) + 254 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR LEED + &CALCULATION #####', '#####',/////) + 255 FORMAT(/////,6X,'########## END ', 'OF THE POLAR LEED + &CALCULATION #####', '#####',/////) + 256 FORMAT(/////,5X,'########## BEGINNING ', 'OF THE ENERGY LEED + &CALCULATION #####', '#####',/////) + 257 FORMAT(/////,5X,'########## END ', 'OF THE ENERGY LEED + &CALCULATION #####', '#####',/////) + 258 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &LEED CALCULATION ', '##########',/////) + 259 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE LEED + &CALCULATION #####','#####') + 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/) + 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ',F6.2,' + &DEGREES') + 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +') + 335 FORMAT(24X,'+ STANDARD +') + 336 FORMAT(24X,'+ SPIN-POLARIZED +') + 337 FORMAT(24X,'+ WITH +') + 338 FORMAT(24X,'+ IN DICHROIC MODE +') + 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +') + 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','---- + &--------------------') + 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','---- + &--------------------') + 420 FORMAT(///,9X,'----------------------------------------------','- + &---------------------') + 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','( + &',F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')') + 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8. + &5,',',F8.5,')') + 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE + &DIMENSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ', + &'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' + &>>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ', + &'NAT IN THE DATA AND CLUSTER FILES >>>>>>>>>>') + 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ', + &'IBWD >>>>>>>>>>') + 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT',' + &CONSISTENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE + &>>>>>>>>>>') + 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT + &WITH',' THE VALUE OF LI >>>>>>>>>>') + 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4) + 535 FORMAT(29X,F8.5,1X,F8.5) + 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 543 FORMAT(5X,F12.9,5X,F12.9) + 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X, + &'SYM',/) + 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 555 FORMAT(4(7X,I2)) + 556 FORMAT(28X,4(I2,5X)) + 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X, + &A2) + 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' : + & ',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X, + &'ATOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' + &No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL + &ATOMS : ',//) + 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM + &: ',//) + 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE', + &13X,'oooooooooooooooo',///) + 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/) + 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD + &AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT + &CONSISTENT WITH THE INPUT DATA FILE >>>>>>>>>>') + 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ', + &'>>>>>>>>>>',//) + 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE + &','.inc FILE >>>>>>>>>>',//) + 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ', + &'>>>>>>>>>>',//) + 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA + &','FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS + &FILE >>>>>>>>>>',//) + 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ', + &'>>>>>>>>>>',//) + 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ', + &'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ', + &17X,'WITH THE INPUT DATA FILE ',16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ', + &'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ', + &'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ', + &'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE + &IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH + &ELECTRONS IN CLUSTER ROTATION MODE',' >>>>>>>>>>',//) + 776 FORMAT(I2) + 777 FORMAT(A24) + 778 FORMAT(30X,I1) + 779 FORMAT(11X,A2,5X,I2,3F10.4,I5) + 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,' + &ATOMS') + 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M + &>>>>>>>>>>') + 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''', + &'UNITS >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' + &ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' + &ARE IDENTICAL >>>>>>>>>>') +C + 999 END diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/plotfd.f b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/plotfd.f new file mode 100644 index 0000000..bc73cf4 --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/plotfd.f @@ -0,0 +1,106 @@ +C +C======================================================================= +C + SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE) +C +C This routine prepares the output for a plot of the scattering factor +C + USE DIM_MOD +C + USE APPROX_MOD + USE FDIF_MOD + USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 => + & LF2, I10 => ISTEP_LF + USE INIT_J_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS + USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP + &, I13 => I_EXT, I14 => I_TEST + USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO + &L + USE VALFIN_MOD +C +C +C + DIMENSION LMX(NATM,NE_M) +C + COMPLEX FSPH,VKE +C +C +C + DATA PI,CONV/3.141593,0.512314/ +C + OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN') + IF(ISPHER.EQ.0) THEN + L=0 + LMAX=0 + ELSE + LMAX=L + ENDIF + PHITOT=360. + THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI + NPHI=(NFTHET+1)*IPHI+(1-IPHI) + NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+ + * (1-ITHETA) + NE=NFTHET*IE + (1-IE) + WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN + DO 10 JT=1,NTHT + DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1)) + RTHETA=DTHETA*PI/180. + TEST=SIN(RTHETA) + IF(TEST.GE.0.) THEN + POZ=PI + EPS=1. + ELSE + POZ=0. + EPS=-1. + ENDIF + BETA=RTHETA*EPS + IF(ABS(TEST).LT.0.0001) THEN + NPHIM=1 + ELSE + NPHIM=NPHI + ENDIF + DO 20 JP=1,NPHIM + DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1)) + RPHI=DPHI*PI/180. + GAMMA=POZ-RPHI + DO 30 JE=1,NE + IF(NE.EQ.1) THEN + ECIN=E0 + ELSE + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ENDIF + IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.) + DO 40 JAT=1,NAT + IF(L.GT.LMX(JAT,JE)) GOTO 90 + DO 50 M=-LMAX,LMAX + CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J + &AT,JE,*60) + GOTO 70 + 60 WRITE(IUO1,80) + STOP + 70 REFTH=REAL(FSPH) + XIMFTH=AIMAG(FSPH) + WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN + 50 CONTINUE + GOTO 40 + 90 WRITE(IUO1,100) JAT + STOP + 40 CONTINUE + 30 CONTINUE + 20 CONTINUE + 10 CONTINUE + CLOSE(IUO3) + 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2) + 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X, + &F8.2) + 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z + &ERO >>>>>') + 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : ' + &,I2,' >>>>>') +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/process.py b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/process.py new file mode 100644 index 0000000..e960571 --- /dev/null +++ b/src/msspec/spec/fortran/led_mi_noso_nosp_nosym/process.py @@ -0,0 +1,995 @@ +# vim: set et ts=4 sw=4 fdm=indent: +# coding: utf-8 + +import re +import sys +import os +import textwrap + + +class Patterns(object): + col = '(?P |C|\*)' + col += '(?P