From 0d6db435970b4c74eac36f22457929e04617ad1d Mon Sep 17 00:00:00 2001 From: sylvain tricot Date: Mon, 27 Sep 2021 14:33:17 +0200 Subject: [PATCH 01/43] Removed 'syncing website' stage In the CI, the website is not uploaded at the end of the process for the 'devel' branch. --- Jenkinsfile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Jenkinsfile b/Jenkinsfile index 9292a38..ba8fd3a 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -13,9 +13,9 @@ pipeline { } stage('Syncing website...') { steps { - // echo 'Syncing website...' + echo 'Syncing website only in master branch, not here in devel branch...' // sh 'rm -rf $HOME/www/*' - sh 'cp -a ./doc/build/html/* $HOME/www/' + // sh 'cp -a ./doc/build/html/* $HOME/www/' } } From 369e7431970726c135f34c61845f0e0541276e58 Mon Sep 17 00:00:00 2001 From: sylvain tricot Date: Mon, 27 Sep 2021 17:49:48 +0200 Subject: [PATCH 02/43] Removed all f-strings. By replacing f-strings by the standard ".format" call, the package can be now compatible with python3.5 --- src/msspec/__init__.py | 5 +++-- src/msspec/calcio.py | 30 +++++++++++++++++++++++++----- src/msspec/calculator.py | 21 +++++++++++---------- src/msspec/cli.py | 5 +++-- src/msspec/create_tests_results.py | 5 +++-- src/msspec/data/__init__.py | 23 +++++++++++++++++++++-- src/msspec/data/electron_be.py | 20 ++++++++++++++++++++ src/msspec/iodata.py | 13 +++++++------ src/msspec/iodata_gi.py | 15 ++++++++------- src/msspec/iodata_wx.py | 15 ++++++++------- src/msspec/looper.py | 26 ++++++++++++++++++++++---- src/msspec/misc.py | 5 +++-- src/msspec/parameters.py | 11 ++++++----- src/msspec/tests.py | 5 +++-- src/msspec/utils.py | 19 ++++++++++--------- src/msspec/version.py | 5 +++-- src/options.mk | 2 +- 17 files changed, 157 insertions(+), 68 deletions(-) diff --git a/src/msspec/__init__.py b/src/msspec/__init__.py index acffe9f..5fa3547 100644 --- a/src/msspec/__init__.py +++ b/src/msspec/__init__.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -16,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/__init__.py -# Last modified: ven. 10 avril 2020 17:22:12 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot import ase diff --git a/src/msspec/calcio.py b/src/msspec/calcio.py index d83dc74..eaba19e 100644 --- a/src/msspec/calcio.py +++ b/src/msspec/calcio.py @@ -1,5 +1,25 @@ +#!/usr/bin/env python # coding: utf-8 -# vim: set et ts=4 sw=4 fdm=indent mouse=a cc=+1 tw=80: +# +# Copyright © 2016-2020 - Rennes Physics Institute +# +# This file is part of msspec. +# +# msspec is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# msspec is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# You should have received a copy of the GNU General Public License +# along with this msspec. If not, see . +# +# Source file : src/msspec/calcio.py +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot + """ Module calcio @@ -910,7 +930,7 @@ class SpecIO(object): if content != old_content: with open(filename, 'w') as fd: fd.write(content) - LOGGER.debug(f"Writing Spec input file written in {filename}") + LOGGER.debug("Writing Spec input file written in {}".format(filename)) modified = True return modified @@ -1255,13 +1275,13 @@ class CompCurveIO(object): data = [] for i in range(1, 13): #data.append(np.loadtxt(prefix + f'{i:02d}' + '.txt')[-1]) - results = np.loadtxt(prefix + f'{i:02d}' + '.txt') + results = np.loadtxt(prefix + '{:02d}'.format(i) + '.txt') results = results.reshape((-1, 2)) data.append(results[index,1]) suffix = 'ren' exp = {'int': None, 'ren': None, 'chi': None, 'cdf': None} exp_ren = np.loadtxt(os.path.join('exp', 'div', - f'experiment_{suffix}.txt')) + 'experiment_{}.txt'.format(suffix))) calc_ren = np.loadtxt(os.path.join('calc', 'div', - f'calculation{index:d}_{suffix}.txt')) + 'calculation{:d}_{}.txt'.format(index,suffix))) return data, exp_ren, calc_ren diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py index d5ba42c..9f9ef2b 100644 --- a/src/msspec/calculator.py +++ b/src/msspec/calculator.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -16,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/calculator.py -# Last modified: ven. 10 avril 2020 17:19:24 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ @@ -1122,7 +1123,7 @@ class RFACTOR(object): for i in range(noif): X, Y = args[2*i], args[2*i+1] fname = os.path.join('calc', - f'calculation{self.stack_count:d}.txt') + 'calculation{:d}.txt'.format(self.stack_count)) # And save to the working space np.savetxt(fname, np.transpose([X, Y])) self.stack_count += 1 @@ -1130,7 +1131,7 @@ class RFACTOR(object): # Update the list of input calculation files self._params.calc_filename = [] for i in range(self.stack_count): - fname = os.path.join('calc', f'calculation{i:d}.txt') + fname = os.path.join('calc', 'calculation{:d}.txt'.format(i)) self._params.calc_filename.append(fname) # Write the input file @@ -1225,23 +1226,23 @@ class RFACTOR(object): dset_values.x, dset_values.yref = exp_data.T # Append the calculated values ycalc = calc_data[:,1] - dset_values.add_columns(**{f"calc{i:d}": ycalc}) - dset_rfc.add_columns(**{f'variable_set{i:d}': rfc}) + dset_values.add_columns(**{"calc{:d}".format(i): ycalc}) + dset_rfc.add_columns(**{'variable_set{:d}'.format(i): rfc}) # Plot the curves view_values.select('x', 'yref', legend='Reference values') title = '' for k,v in self.best_values.items(): - title += f'{k}={v} ' - view_values.select('x', f"calc{self.index:d}", + title += '{}={} '.format(k, v) + view_values.select('x', "calc{:d}".format(self.index), legend="Best calculated values") view_values.set_plot_options(title=title) view_results.select('counts') for i in range(self.stack_count): - view_rfc.select('rfactor_number', f'variable_set{i:d}', - legend=f"variables set #{i:d}") + view_rfc.select('rfactor_number', 'variable_set{:d}'.format(i), + legend="variables set #{:d}".format(i)) # Save the parameters for p in self.get_parameters(): bundle = {'group': str(p.group), diff --git a/src/msspec/cli.py b/src/msspec/cli.py index a51d78c..56855b1 100644 --- a/src/msspec/cli.py +++ b/src/msspec/cli.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -18,8 +19,8 @@ # along with msspec. If not, see . # # Source file : src/msspec/cli.py -# Last modified: jeu. 04 juin 2020 16:54:12 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot import sys diff --git a/src/msspec/create_tests_results.py b/src/msspec/create_tests_results.py index f0996d9..5af662b 100644 --- a/src/msspec/create_tests_results.py +++ b/src/msspec/create_tests_results.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -18,8 +19,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/create_tests_results.py -# Last modified: ven. 10 avril 2020 17:29:16 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot from msspec.tests import create_tests_results diff --git a/src/msspec/data/__init__.py b/src/msspec/data/__init__.py index b96b7ca..691ec75 100644 --- a/src/msspec/data/__init__.py +++ b/src/msspec/data/__init__.py @@ -1,5 +1,24 @@ -# -*- encoding: utf-8 -*- -# vim: set fdm=indent ts=4 sw=4 sts=4 et ai tw=80 cc=+0 mouse=a nu : # +#!/usr/bin/env python +# coding: utf-8 +# +# Copyright © 2016-2020 - Rennes Physics Institute +# +# This file is part of msspec. +# +# msspec is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# msspec is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# You should have received a copy of the GNU General Public License +# along with this msspec. If not, see . +# +# Source file : src/msspec/data/__init__.py +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot from .electron_be import electron_be diff --git a/src/msspec/data/electron_be.py b/src/msspec/data/electron_be.py index 9709090..d6c428a 100644 --- a/src/msspec/data/electron_be.py +++ b/src/msspec/data/electron_be.py @@ -1,4 +1,24 @@ +#!/usr/bin/env python # coding: utf-8 +# +# Copyright © 2016-2020 - Rennes Physics Institute +# +# This file is part of msspec. +# +# msspec is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# msspec is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# You should have received a copy of the GNU General Public License +# along with this msspec. If not, see . +# +# Source file : src/msspec/data/electron_be.py +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ Module electron_be diff --git a/src/msspec/iodata.py b/src/msspec/iodata.py index cd2a41c..dde6b81 100644 --- a/src/msspec/iodata.py +++ b/src/msspec/iodata.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -16,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/iodata.py -# Last modified: ven. 10 avril 2020 17:23:11 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ @@ -442,24 +443,24 @@ class DataSet(object): for k, v in parameters.items(): if k == 'Cluster': continue - s += f"# {k}:\n" + s += "# {}:\n".format(k) if not(isinstance(v, list)): v = [v,] for p in v: - s += f"# {p['name']} = {p['value']} {p['unit']}\n" + s += "# {} = {} {}\n".format(p['name'], p['value'], p['unit']) return s colnames = self.columns() with open(filename, mode) as fd: # write the date and time of export now = datetime.now() - fd.write(f"# Data exported on {now}\n") + fd.write("# Data exported on {}\n".format(now)) fd.write(rule) # Append notes fd.write("# NOTES:\n") for line in self.notes.split('\n'): - fd.write(f"# {line}\n") + fd.write("# {}\n".format(line)) fd.write(rule) # Append parameters diff --git a/src/msspec/iodata_gi.py b/src/msspec/iodata_gi.py index 4eb0e91..1742f47 100644 --- a/src/msspec/iodata_gi.py +++ b/src/msspec/iodata_gi.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -15,9 +16,9 @@ # You should have received a copy of the GNU General Public License # along with this msspec. If not, see . # -# Source file : src/msspec/iodata.py -# Last modified: ven. 10 avril 2020 17:23:11 -# Committed by : "Sylvain Tricot " +# Source file : src/msspec/iodata_gi.py +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ @@ -491,24 +492,24 @@ class DataSet(object): for k, v in parameters.items(): if k == 'Cluster': continue - s += f"# {k}:\n" + s += "# {}:\n".format(k) if not(isinstance(v, list)): v = [v,] for p in v: - s += f"# {p['name']} = {p['value']} {p['unit']}\n" + s += "# {} = {} {}\n".format(p['name'], p['value'], p['unit']) return s colnames = self.columns() with open(filename, mode) as fd: # write the date and time of export now = datetime.now() - fd.write(f"# Data exported on {now}\n") + fd.write("# Data exported on {}\n".format(now)) fd.write(rule) # Append notes fd.write("# NOTES:\n") for line in self.notes.split('\n'): - fd.write(f"# {line}\n") + fd.write("# {}\n".format(line)) fd.write(rule) # Append parameters diff --git a/src/msspec/iodata_wx.py b/src/msspec/iodata_wx.py index bc1c5b0..861fff9 100644 --- a/src/msspec/iodata_wx.py +++ b/src/msspec/iodata_wx.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -15,9 +16,9 @@ # You should have received a copy of the GNU General Public License # along with this msspec. If not, see . # -# Source file : src/msspec/iodata.py -# Last modified: ven. 10 avril 2020 17:23:11 -# Committed by : "Sylvain Tricot " +# Source file : src/msspec/iodata_wx.py +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ @@ -437,24 +438,24 @@ class DataSet(object): for k, v in parameters.items(): if k == 'Cluster': continue - s += f"# {k}:\n" + s += "# {}:\n".format(k) if not(isinstance(v, list)): v = [v,] for p in v: - s += f"# {p['name']} = {p['value']} {p['unit']}\n" + s += "# {} = {} {}\n".format(p['name'], p['value'], p['unit']) return s colnames = self.columns() with open(filename, mode) as fd: # write the date and time of export now = datetime.now() - fd.write(f"# Data exported on {now}\n") + fd.write("# Data exported on {}\n".format(now)) fd.write(rule) # Append notes fd.write("# NOTES:\n") for line in self.notes.split('\n'): - fd.write(f"# {line}\n") + fd.write("# {}\n".format(line)) fd.write(rule) # Append parameters diff --git a/src/msspec/looper.py b/src/msspec/looper.py index 718fbe8..0dbfdc4 100644 --- a/src/msspec/looper.py +++ b/src/msspec/looper.py @@ -1,6 +1,24 @@ -# coding: utf8 -# -*- encoding: future_fstrings -*- -# vim: set et sw=4 ts=4 nu tw=79 cc=+1: +#!/usr/bin/env python +# coding: utf-8 +# +# Copyright © 2016-2020 - Rennes Physics Institute +# +# This file is part of msspec. +# +# msspec is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# msspec is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# You should have received a copy of the GNU General Public License +# along with this msspec. If not, see . +# +# Source file : src/msspec/looper.py +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot from collections import OrderedDict from functools import partial @@ -21,7 +39,7 @@ class Variable: self.doc = doc def __repr__(self): - return f"" + return "".format(self.name) class Sweep: def __init__(self, key, comments="", unit=None, diff --git a/src/msspec/misc.py b/src/msspec/misc.py index 02786a9..e0d5db7 100644 --- a/src/msspec/misc.py +++ b/src/msspec/misc.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -18,8 +19,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/misc.py -# Last modified: ven. 10 avril 2020 17:30:42 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ diff --git a/src/msspec/parameters.py b/src/msspec/parameters.py index 493a279..51a3817 100644 --- a/src/msspec/parameters.py +++ b/src/msspec/parameters.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -18,8 +19,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/parameters.py -# Last modified: ven. 10 avril 2020 17:31:50 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ @@ -2012,20 +2013,20 @@ class CompCurveGeneralParameters(BaseParameters): value = p.allowed_values.index(p.value) self.compcurve_parameters.general_norm = value LOGGER.info("Curve Comparison: Normalization mode set to " - f"\"{p.value}\"") + "\"{}\"".format(p.value)) def bind_rescale(self, p): self.compcurve_parameters.general_iscale = int(p.value) state = "deactivated" if p.value: state = "activated" - LOGGER.info(f"Curve Comparison: Rescaling of data {state}") + LOGGER.info("Curve Comparison: Rescaling of data {}".format(state)) def bind_function(self, p): value = p.allowed_values.index(p.value) self.compcurve_parameters.general_icur = value LOGGER.info("Curve Comparison: Type of data used for comparison " - f"set to \"{p.value}\"") + "set to \"{}\"".format(p.value)) diff --git a/src/msspec/tests.py b/src/msspec/tests.py index 50246ae..8d76713 100644 --- a/src/msspec/tests.py +++ b/src/msspec/tests.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -16,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/tests.py -# Last modified: ven. 10 avril 2020 17:33:28 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot import os diff --git a/src/msspec/utils.py b/src/msspec/utils.py index 1dee866..1355e11 100644 --- a/src/msspec/utils.py +++ b/src/msspec/utils.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -18,8 +19,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/utils.py -# Last modified: ven. 10 avril 2020 15:49:35 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot """ @@ -66,7 +67,7 @@ class ForeignPotential(object): self.phagen_data = {'types': []} def write(self, filename, prototypical_atoms): - LOGGER.debug(f"Writing Phagen input potential file: {filename}") + LOGGER.debug("Writing Phagen input potential file: {}".format(filename)) def DEPRECATEDappend_atom_potential(atom): Z = atom.number @@ -77,8 +78,8 @@ class ForeignPotential(object): itypes.append(i) # Check now that we have only one type in the list # otherwise we do not know yet how to deal with this. - assert len(itypes) > 0, f"Cannot find the data for atom with Z={Z}" - assert len(itypes) == 1, f"Too many datasets for atom with Z={Z}" + assert len(itypes) > 0, "Cannot find the data for atom with Z={}".format(Z) + assert len(itypes) == 1, "Too many datasets for atom with Z={}".format(Z) # So far so good, let's write the block t = self.phagen_data['types'][itypes[0]] s = "{:<7d}{:<10d}{:1.4f}\n".format( @@ -91,7 +92,7 @@ class ForeignPotential(object): def append_atom_potential(atom): line_fmt = "{:+1.8e} " * 4 + "\n" atom_type = atom.get('atom_type') - assert atom_type != None, f"Unable get the atom type!" + assert atom_type != None, "Unable get the atom type!" for t in self.phagen_data['types']: if t['atom_type'] == atom_type: s = "{:<7d}{:<10d}{:1.4f}\n".format( @@ -134,7 +135,7 @@ class SPRKKRPotential(ForeignPotential): self.potfile = potfile self.load_sprkkr_atom_types() for f in exported_files: - LOGGER.info(f"Loading file {f}...") + LOGGER.info("Loading file {}...".format(f)) # get the IT from the filename m=re.match('SPRKKR-IT_(?P\d+)-PHAGEN.*', os.path.basename(f)) it = int(m.group('IT')) @@ -188,7 +189,7 @@ class SPRKKRPotential(ForeignPotential): return data # load info in *.pot file - LOGGER.info(f"Loading SPRKKR *.pot file {self.potfile}...") + LOGGER.info("Loading SPRKKR *.pot file {}...".format(self.potfile)) with open(self.potfile, 'r') as fd: content = fd.read() @@ -229,7 +230,7 @@ class SPRKKRPotential(ForeignPotential): IT = occupation['ITOQ'] atom = self.atoms[i] atom.set('atom_type', IT) - LOGGER.debug(f"Site #{IQ} is type #{IT}, atom {atom}") + LOGGER.debug("Site #{} is type #{}, atom {}".format(IQ, IT, atom)) diff --git a/src/msspec/version.py b/src/msspec/version.py index 0dd57e8..05f004a 100644 --- a/src/msspec/version.py +++ b/src/msspec/version.py @@ -1,4 +1,5 @@ #!/usr/bin/env python +# coding: utf-8 # # Copyright © 2016-2020 - Rennes Physics Institute # @@ -16,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/version.py -# Last modified: ven. 10 avril 2020 17:34:38 -# Committed by : "Sylvain Tricot " +# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 +# Committed by : sylvain tricot import os diff --git a/src/options.mk b/src/options.mk index ec1a2ad..2ef0e2e 100644 --- a/src/options.mk +++ b/src/options.mk @@ -1,6 +1,6 @@ PYTHON = python PYMAJ = 3 -PYMIN = 6 +PYMIN = 5 FC = gfortran F2PY = f2py3 --f77exec=$(FC) --f90exec=$(FC) From 7567b920a135bfbe355da13cdbe864bd5fc2c238 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 30 Nov 2021 16:21:05 +0100 Subject: [PATCH 03/43] Add Lapack/Blas compilation flag. --- src/msspec/spec/fortran/eig_mi.mk | 3 ++- src/msspec/spec/fortran/phd_mi_noso_nosp_nosym.mk | 2 +- src/options.mk | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/msspec/spec/fortran/eig_mi.mk b/src/msspec/spec/fortran/eig_mi.mk index 173b763..aa5d7bc 100644 --- a/src/msspec/spec/fortran/eig_mi.mk +++ b/src/msspec/spec/fortran/eig_mi.mk @@ -2,7 +2,8 @@ memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/all cluster_gen_src := $(wildcard cluster_gen/*.f) common_sub_src := $(wildcard common_sub/*.f) renormalization_src := $(wildcard renormalization/*.f) -eig_common_src := $(wildcard eig/common/*.f) +#eig_common_src := $(wildcard eig/common/*.f) +eig_common_src := $(filter-out eig/common/lapack_eig.f, $(wildcard eig/common/*.f)) eig_mi_src := $(wildcard eig/mi/*.f) SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(eig_common_src) $(eig_mi_src) diff --git a/src/msspec/spec/fortran/phd_mi_noso_nosp_nosym.mk b/src/msspec/spec/fortran/phd_mi_noso_nosp_nosym.mk index 2179c68..12295a1 100644 --- a/src/msspec/spec/fortran/phd_mi_noso_nosp_nosym.mk +++ b/src/msspec/spec/fortran/phd_mi_noso_nosp_nosym.mk @@ -2,7 +2,7 @@ memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/all cluster_gen_src := $(wildcard cluster_gen/*.f) common_sub_src := $(wildcard common_sub/*.f) renormalization_src := $(wildcard renormalization/*.f) -phd_mi_noso_nosp_nosym_src := $(wildcard phd_mi_noso_nosp_nosym/*.f) +phd_mi_noso_nosp_nosym_src := $(filter-out phd_mi_noso_nosp_nosym/lapack_axb.f, $(wildcard phd_mi_noso_nosp_nosym/*.f)) SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(phd_mi_noso_nosp_nosym_src) MAIN_F = phd_mi_noso_nosp_nosym/main.f diff --git a/src/options.mk b/src/options.mk index 2ef0e2e..3bcb0e5 100644 --- a/src/options.mk +++ b/src/options.mk @@ -31,7 +31,7 @@ IFORT_FFLAGS_DBG = ################################################################################ # F2PY CONFIGURATION # ################################################################################ -F2PYFLAGS = --opt=-O2 +F2PYFLAGS = --opt=-O2 -llapack F2PYFLAGS_DBG = --debug-capi --debug ################################################################################ From 925d69409922aa9db6dc3d9d8a74237fcdb04305 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 30 Nov 2021 16:26:10 +0100 Subject: [PATCH 04/43] Added 'other_parameters' keyword to any scan. This keyword is a dictionary allowing any option to be passed to Phagen or Spec just before runing the calculation. It is usefull to pass special options that are for example set automatically otherwise. --- src/msspec/calculator.py | 33 ++++++++++++++++++++++----------- src/msspec/parameters.py | 2 +- 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py index 9f9ef2b..d78a1c9 100644 --- a/src/msspec/calculator.py +++ b/src/msspec/calculator.py @@ -616,7 +616,7 @@ class _PED(_MSCALCULATOR): def _get_scan(self, scan_type='theta', phi=0, theta=np.linspace(-70, 70, 141), level=None, kinetic_energy=None, data=None, - malloc={}): + malloc={}, other_parameters={}): LOGGER.info("Computting the %s scan...", scan_type) if data: self.iodata = data @@ -651,6 +651,13 @@ class _PED(_MSCALCULATOR): self.spectroscopy_parameters.set_parameter('level', level) + # It is still possible to change any parameter right before + # runing Phagen or Spec + for k, v in other_parameters.items(): + grp_str, parma_str = k.split('.') + grp = getattr(self, grp_str) + grp.set_parameter(parma_str, v, force=True) + self.get_tmatrix() self.run_spec(malloc) @@ -852,7 +859,7 @@ class _PED(_MSCALCULATOR): return self.iodata def get_scattering_factors(self, level='1s', kinetic_energy=None, - data=None): + data=None, **kwargs): """Computes the scattering factors of all prototypical atoms in the cluster. @@ -871,11 +878,12 @@ class _PED(_MSCALCULATOR): """ data = self._get_scan(scan_type='scatf', level=level, data=data, - kinetic_energy=kinetic_energy) + kinetic_energy=kinetic_energy, **kwargs) return data def get_theta_scan(self, phi=0, theta=np.linspace(-70, 70, 141), - level=None, kinetic_energy=None, data=None): + level=None, kinetic_energy=None, data=None, + **kwargs): """Computes a polar scan of the emitted photoelectrons. :param phi: The azimuthal angle in degrees. See @@ -892,11 +900,12 @@ class _PED(_MSCALCULATOR): """ data = self._get_scan(scan_type='theta', level=level, theta=theta, - phi=phi, kinetic_energy=kinetic_energy, data=data) + phi=phi, kinetic_energy=kinetic_energy, + data=data, **kwargs) return data def get_phi_scan(self, phi=np.linspace(0, 359, 359), theta=0, - level=None, kinetic_energy=None, data=None): + level=None, 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 @@ -913,12 +922,13 @@ class _PED(_MSCALCULATOR): """ data = self._get_scan(scan_type='phi', level=level, theta=theta, - phi=phi, kinetic_energy=kinetic_energy, data=data) + 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), level=None, - kinetic_energy=None, data=None): + 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 @@ -935,11 +945,11 @@ class _PED(_MSCALCULATOR): """ data = self._get_scan(scan_type='theta_phi', level=level, theta=theta, phi=phi, kinetic_energy=kinetic_energy, data=data, - malloc={'NPH_M': 8000}) + malloc={'NPH_M': 8000}, **kwargs) return data def get_energy_scan(self, phi=0, theta=0, - level=None, kinetic_energy=None, data=None): + 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 @@ -956,7 +966,8 @@ class _PED(_MSCALCULATOR): """ data = self._get_scan(scan_type='energy', level=level, theta=theta, - phi=phi, kinetic_energy=kinetic_energy, data=data) + phi=phi, kinetic_energy=kinetic_energy, + data=data, **kwargs) return data diff --git a/src/msspec/parameters.py b/src/msspec/parameters.py index 51a3817..8a682f4 100644 --- a/src/msspec/parameters.py +++ b/src/msspec/parameters.py @@ -1540,7 +1540,7 @@ class CalculationParameters(BaseParameters): Parameter('cutoff_factor', types=(int, float), limits=(1e-4, 999.9999), default=0.01, private=False), Parameter('mean_free_path', types=(int, float, str), - default='SeahDench', allowed_values=('mono', 'SeahDench'), + default='SeahDench', #allowed_values=('mono', 'SeahDench'), doc=""" The electron mean free path value. You can either: - Enter a value (in Angströms), in this case any value <=0 will disable the damping From 1fd9509608e390a9e43db1ae73adb171d4527b36 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 8 Feb 2022 14:39:03 +0100 Subject: [PATCH 05/43] Added the malloc keyword. In the stereo scan, the malloc keyword is now specified. --- doc/source/tutorials/RhO/RhO.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/source/tutorials/RhO/RhO.py b/doc/source/tutorials/RhO/RhO.py index 90c8e46..0817b27 100644 --- a/doc/source/tutorials/RhO/RhO.py +++ b/doc/source/tutorials/RhO/RhO.py @@ -18,7 +18,8 @@ for zi, z0 in enumerate(all_z): calc.set_atoms(cluster) # Compute - data = calc.get_theta_phi_scan(level='1s', kinetic_energy=723, data=data) + data = calc.get_theta_phi_scan(level='1s', kinetic_energy=723, data=data, + malloc={'NPH_M': 8000}) dset = data[-1] dset.title = "{:d}) z = {:.2f} angstroms".format(zi, z0) From a657b1874e762ad6a71f720e9c04ea47ffbf2be7 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 8 Feb 2022 15:19:26 +0100 Subject: [PATCH 06/43] Changed memory requirements. --- src/msspec/calculator.py | 2 +- src/msspec/spec/fortran/memalloc/dim_mod.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py index d78a1c9..ca18df4 100644 --- a/src/msspec/calculator.py +++ b/src/msspec/calculator.py @@ -945,7 +945,7 @@ class _PED(_MSCALCULATOR): """ data = self._get_scan(scan_type='theta_phi', level=level, theta=theta, phi=phi, kinetic_energy=kinetic_energy, data=data, - malloc={'NPH_M': 8000}, **kwargs) + **kwargs) return data def get_energy_scan(self, phi=0, theta=0, diff --git a/src/msspec/spec/fortran/memalloc/dim_mod.f b/src/msspec/spec/fortran/memalloc/dim_mod.f index e0432a4..7a84c04 100644 --- a/src/msspec/spec/fortran/memalloc/dim_mod.f +++ b/src/msspec/spec/fortran/memalloc/dim_mod.f @@ -60,7 +60,7 @@ C =============================================================== C N_BESS=100*NL_M C N_GAUNT=5*NL_M - N_BESS=200*NL_M + N_BESS=300*NL_M N_GAUNT=10*NL_M NLTWO=2*NL_M From ca1fd04163e6b8d3f46c1af05bd7184b0efaa5d7 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 8 Feb 2022 15:20:32 +0100 Subject: [PATCH 07/43] Modified cut_cylinder and cut_plane functions. cut_cylinder and cut_plane functions were too slow due to lists modifications in for loops. Implementation was modified a bit while keeping the same API. For now, cutting a cylinder for an axis 'x' or 'y' is not supported anymore. --- src/msspec/utils.py | 47 +++++++++++++++------------------------------ 1 file changed, 15 insertions(+), 32 deletions(-) diff --git a/src/msspec/utils.py b/src/msspec/utils.py index 1355e11..b9eedd3 100644 --- a/src/msspec/utils.py +++ b/src/msspec/utils.py @@ -311,34 +311,13 @@ def cut_cylinder(atoms, axis="z", radius=None): :return: The modified atom cluster :rtype: ase.Atoms """ - if radius is None: - raise ValueError("radius not set") - - new_atoms = atoms.copy() - - dims = {"x": 0, "y": 1, "z": 2} - if axis in dims: - axis = dims[axis] - else: - raise ValueError("axis not valid, must be 'x','y', or 'z'") - - del_list = [] - for index, position in enumerate(new_atoms.positions): - # calculating the distance of the atom to the given axis - r = 0 - for dim in range(3): - if dim != axis: - r = r + position[dim]**2 - r = np.sqrt(r) - - if r > radius: - del_list.append(index) - - del_list.reverse() - for index in del_list: - del new_atoms[index] - - return new_atoms + if axis not in ('z',): + raise ValueError("axis value != 'z' is not supported yet.") + X, Y, Z = atoms.positions.T + R = np.sqrt(X**2 + Y **2) + T = np.arctan2(Y, X) + i = np.where(R <= radius)[0] + return atoms[i] def cut_cone(atoms, radius, z=0): @@ -426,11 +405,15 @@ def cut_plane(atoms, x=None, y=None, z=None): dim_values = np.array(dim_values) - def constraint(coordinates): - return np.all(np.logical_and(coordinates >= dim_values[:, 0], - coordinates <= dim_values[:, 1])) + X, Y, Z = atoms.positions.T + i0 = np.where(X >= dim_values[0, 0])[0] + i1 = np.where(X[i0] <= dim_values[0, 1])[0] + i2 = np.where(Y[i0][i1] >= dim_values[1, 0])[0] + i3 = np.where(Y[i0][i1][i2] <= dim_values[1, 1])[0] + i4 = np.where(Z[i0][i1][i2][i3] >= dim_values[2, 0])[0] + i5 = np.where(Z[i0][i1][i2][i3][i4] <= dim_values[2, 1])[0] + indices = np.arange(len(atoms))[i0][i1][i2][i3][i4][i5] - indices = np.where(list(map(constraint, atoms.positions)))[0] return atoms[indices] From 1dba5cbe473169f6579cdcbae67ae5c8a14236d9 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 11:43:35 +0100 Subject: [PATCH 08/43] Added files common to SE and CE. 5 files are common to Series Expansion and Correlation Expansion algortithms. They are now in the dedicated phd_ce_noso_nosp_nosym folder. --- .../fortran/phd_ce_noso_nosp_nosym/dwsph.f | 85 +++++ .../fortran/phd_ce_noso_nosp_nosym/facdif.f | 26 ++ .../fortran/phd_ce_noso_nosp_nosym/facdif1.f | 113 ++++++ .../fortran/phd_ce_noso_nosp_nosym/plotfd.f | 106 ++++++ .../phd_ce_noso_nosp_nosym/weight_sum.f | 335 ++++++++++++++++++ 5 files changed, 665 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/dwsph.f create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/facdif.f create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/facdif1.f create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/plotfd.f create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/weight_sum.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/dwsph.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/dwsph.f new file mode 100644 index 0000000..6d48a79 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_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/phd_ce_noso_nosp_nosym/facdif.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/facdif.f new file mode 100644 index 0000000..2ac7683 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_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/phd_ce_noso_nosp_nosym/facdif1.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/facdif1.f new file mode 100644 index 0000000..62ac3f8 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_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/phd_ce_noso_nosp_nosym/plotfd.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/plotfd.f new file mode 100644 index 0000000..bc73cf4 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_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/phd_ce_noso_nosp_nosym/weight_sum.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/weight_sum.f new file mode 100644 index 0000000..0db9ffc --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/weight_sum.f @@ -0,0 +1,335 @@ +C +C======================================================================= +C + SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL) +C +C This subroutine performs a weighted sum of the results +C corresponding to different directions of the detector. +C The directions and weights are read from an external input file +C +C JEL is the electron undetected (i.e. for which the outgoing +C directions are integrated over the unit sphere). It is always +C 1 for one electron spectroscopies (PHD). For APECS, It can be +C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron +C detected) +C +C Last modified : 31 Jan 2007 +C + USE DIM_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE OUTUNITS_MOD +C +C + PARAMETER(N_MAX=5810,NPM=20) +C + REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M) + REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX) + REAL*4 SR_1,SF_1,SR_2,SF_2 + REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX) + REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX) +C + CHARACTER*3 SPECTRO,SPECTRO2 + CHARACTER*5 LIKE + CHARACTER*13 OUTDATA +C +C +C +C + DATA JVOL,JTOT/0,-1/ + DATA LIKE /'-like'/ +C + REWIND IUO2 +C + READ(IUO2,15) SPECTRO,OUTDATA + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + SPECTRO2='XAS' + ELSE + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I + &THETA_A,IE_A + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + READ(IUO2,8) NPHI_A,NTHETA_A + IF(JEL.EQ.1) THEN + SPECTRO2='AED' + ELSEIF(JEL.EQ.2) THEN + SPECTRO2='PHD' + ELSEIF(JEL.EQ.0) THEN + SPECTRO2='XAS' + ENDIF + ENDIF +C + IF(NPLAN.GT.NPM) THEN + WRITE(IUO1,4) NPLAN+2 + STOP + ENDIF +C +C Reading the number of angular points +C + IF(SPECTRO.NE.'APC') THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + N_POINTS_A=1 + ELSE + IF(JEL.EQ.1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT_A.EQ.0) THEN + N_POINTS_A=NTHETA_A*NPHI_A + ELSE + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA_A + NPHI0=NPHI_A + ELSEIF(JEL.EQ.2) THEN + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT.EQ.0) THEN + N_POINTS=NTHETA*NPHI + ELSE + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA + NPHI0=NPHI + ELSEIF(JEL.EQ.0) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI9,1) N_POINTS_A + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + ENDIF +C + IF(SPECTRO.NE.'APC') THEN + NANGLE=1 + ELSE + IF(JEL.EQ.1) THEN + NANGLE=N_POINTS_A + ELSEIF(JEL.EQ.2) THEN + NANGLE=N_POINTS + ELSEIF(JEL.EQ.0) THEN + NANGLE=1 + ENDIF + ENDIF +C +C Initialization of the arrays +C + DO JE=1,NE + DO JANGLE=1,NANGLE + DO JPLAN=1,NPLAN+2 + SUMR_1(JPLAN,JE,JANGLE)=0. + SUMF_1(JPLAN,JE,JANGLE)=0. + IF(IDICHR.GT.0) THEN + SUMR_2(JPLAN,JE,JANGLE)=0. + SUMF_2(JPLAN,JE,JANGLE)=0. + ENDIF + ENDDO + ENDDO + ENDDO +C +C Reading of the data to be angle integrated +C + DO JE=1,NE +C + DO JANGLE=1,N_POINTS + IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE) + DO JANGLE_A=1,N_POINTS_A + IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN + READ(IUI9,2) THA,PHA,W_A(JANGLE_A) + ENDIF +C + DO JPLAN=1,NPLAN+2 +C + IF(IDICHR.EQ.0) THEN + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE) + &,SR_1,SF_1 + ELSE + READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1 + ENDIF + ELSE + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),SR_1,SF_1,SR_2,SF_2 + ELSE + READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2 + ENDIF + ENDIF +C + IF(JEL.EQ.1) THEN + SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1 + &*W(JANGLE) + SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1 + &*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A + &(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A + &(JANGLE_A) + ENDIF + IF(IDICHR.GT.0) THEN + IF(JEL.EQ.1) THEN + SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR + &_2*W(JANGLE) + SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF + &_2*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W + &_A(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W + &_A(JANGLE_A) + ENDIF + ENDIF +C + ENDDO +C + ENDDO + IF(I_EXT_A.NE.0) THEN + REWIND IUI9 + READ(IUI9,1) NDUM + READ(IUI9,1) NDUM + ENDIF + ENDDO +C + IF(I_EXT.NE.0) THEN + REWIND IUI6 + READ(IUI6,1) NDUM + READ(IUI6,1) NDUM + ENDIF + ENDDO +C + CLOSE(IUI6) + CLOSE(IUI9) + REWIND IUO2 +C + WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP + WRITE(IUO2,18) NE,NPLAN,ISOM + ELSEIF(JEL.EQ.1) THEN + WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A + &,ITHETA_A,IE_A + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ELSEIF(JEL.EQ.2) THEN + WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ENDIF +C + DO JE=1,NE + DO JANGLE=1,NANGLE + IF(SPECTRO.EQ.'APC') THEN + IF(JEL.EQ.1) THEN + THETA=DTHETAA(JANGLE) + PHI=DPHIA(JANGLE) + ELSEIF(JEL.EQ.2) THEN + THETA=DTHETA(JANGLE) + PHI=DPHI(JANGLE) + ENDIF + ENDIF +C + DO JPLAN=1,NPLAN + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE) + ELSE + WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG + &LE) + ELSE + WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL + &AN,JE,JANGLE) + ENDIF + ENDIF + ENDDO +C + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE) + ELSE + WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE + &,JANGLE) + WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE + &,JANGLE) + ELSE + WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2( + &NPLAN+1,JE,JANGLE) + WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2( + &NPLAN+2,JE,JANGLE) + ENDIF + ENDIF +C + ENDDO + ENDDO +C + 1 FORMAT(13X,I4) + 2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6) + 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN + &THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>') + 5 FORMAT(6X,I1,1X,I3,3X,I3) + 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 9 FORMAT(9(2X,I1),2X,I2) + 13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6) + 15 FORMAT(2X,A3,11X,A13) + 16 FORMAT(2X,A3,A5,1X,A3,2X,A13) + 18 FORMAT(I4,2X,I3,2X,I1) + 19 FORMAT(4(2X,I1)) + 20 FORMAT(8(2X,I1)) + 21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) + 24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6,2X,E12.6,2X,E12.6) + 33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6) + 34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6) + 44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) +C + RETURN +C + END From 39eb3dc9d8ec92e2a62947294df56fbd0e449d4b Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 12:02:24 +0100 Subject: [PATCH 09/43] Added and updated cmngr.f The file cmngr.f was updated to be compatible with Python bindings. --- .../fortran/phd_ce_noso_nosp_nosym/cmngr.f | 41 +++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/cmngr.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/cmngr.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/cmngr.f new file mode 100644 index 0000000..5601793 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/cmngr.f @@ -0,0 +1,41 @@ +C +C====================================================================== +C + SUBROUTINE CMNGR(NAT,NGR,CMN) +C +C input : NAT,NGR +C output : CMN +C +C This subroutine calculate C(NAT-N,M-N) where, +C 1<=M<=NGR<=NAT,1<=N<=M +C C(NAT-N,M-N) is stored as CMN(N,M) +C +C H.-F. Zhao 2007 +C + USE DIM_MOD +C + INTEGER NAT,NGR +C + REAL CMN(NGR_M,NGR_M) +C + IF(NGR.GT.NAT) THEN + WRITE(6,*) 'NGR is larger than NAT, which is wrong' + STOP + ENDIF +C + DO M=1,NGR + DO N=1,NGR + CMN(N,M)=0. + ENDDO + CMN(M,M)=1. + ENDDO +C + DO M=1,NGR + DO N=M-1,1,-1 + CMN(N,M)=CMN(N+1,M)*FLOAT(NAT-N)/FLOAT(M-N) + ENDDO + ENDDO +C + RETURN +C + END From e3c0accbcb94a380a5fecfe0653e004f8a2b0968 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 12:22:05 +0100 Subject: [PATCH 10/43] Added and updated coefpq.f The file coefpq.f was updated to be compatible with Python bindings. The common /Q_ARRAY/ was refactored as a module in memalloc/modules.f and allocated in memalloc/allocation.f. --- src/msspec/spec/fortran/memalloc/allocation.f | 2 + src/msspec/spec/fortran/memalloc/modules.f | 14 ++++++ .../fortran/phd_ce_noso_nosp_nosym/coefpq.f | 46 +++++++++++++++++++ 3 files changed, 62 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f diff --git a/src/msspec/spec/fortran/memalloc/allocation.f b/src/msspec/spec/fortran/memalloc/allocation.f index 1ce3b3d..932aa3e 100644 --- a/src/msspec/spec/fortran/memalloc/allocation.f +++ b/src/msspec/spec/fortran/memalloc/allocation.f @@ -25,6 +25,7 @@ USE OUTUNITS_MOD USE PARCAL_MOD USE PARCAL_A_MOD + USE Q_ARRAY_MOD USE RELADS_MOD USE RELAX_MOD USE RESEAU_MOD @@ -136,6 +137,7 @@ CALL ALLOC_OUTUNITS() CALL ALLOC_PARCAL() CALL ALLOC_PARCAL_A() + CALL ALLOC_Q_ARRAY() CALL ALLOC_RELADS() CALL ALLOC_RELAX() CALL ALLOC_RENORM() diff --git a/src/msspec/spec/fortran/memalloc/modules.f b/src/msspec/spec/fortran/memalloc/modules.f index 9e8ab0d..bc796d9 100644 --- a/src/msspec/spec/fortran/memalloc/modules.f +++ b/src/msspec/spec/fortran/memalloc/modules.f @@ -417,6 +417,20 @@ C======================================================================= END SUBROUTINE ALLOC_PARCAL_A END MODULE PARCAL_A_MOD +C======================================================================= + MODULE Q_ARRAY_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: Q + CONTAINS + SUBROUTINE ALLOC_Q_ARRAY() + USE DIM_MOD + IF (ALLOCATED(Q)) THEN + DEALLOCATE(Q) + ENDIF + ALLOCATE(Q(NGR_M)) + END SUBROUTINE ALLOC_Q_ARRAY + END MODULE Q_ARRAY_MOD + C======================================================================= MODULE RELADS_MOD IMPLICIT NONE diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f new file mode 100644 index 0000000..04413c8 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f @@ -0,0 +1,46 @@ +C +C====================================================================== +C + SUBROUTINE COEFPQ(NAT,NGR) +C +C This subroutine computes the P(n,m) and Q(n) coefficients +C involved in the correlation expansion formulation +C +C Reference : equations (2.15) and (2.16) of +C H. Zhao, D. Sebilleau and Z. Wu, +C J. Phys.: Condens. Matter 20, 275241 (2008) +C +C H.-F. Zhao 2007 +C + USE DIM_MOD + USE Q_ARRAY +C + INTEGER NAT,NGR +C + REAL CMN(NGR_M,NGR_M),P(NGR_M,NGR_M) +C +C + IF(NGR.GT.NAT) THEN + WRITE(6,*) 'NGR is larger than NAT, which is wrong' + STOP + ENDIF +C + CALL CMNGR(NAT,NGR,CMN) +C + DO N=1,NGR + P(N,N)=1. + Q(N)=P(N,N) + DO M=N+1,NGR + P(N,M)=0. + DO I=N,M-1 + P(N,M)=P(N,M)-P(N,I)*CMN(I,M) + ENDDO + Q(N)=Q(N)+P(N,M) +C + ENDDO +C + ENDDO +C + RETURN +C + END From f262f960045f662ab421ce15cd077aee8ee7feb4 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 13:08:06 +0100 Subject: [PATCH 11/43] Added and updated corexp.f The file corexp.f was updated to be compatible with Python bindings. --- .../fortran/phd_ce_noso_nosp_nosym/corexp.f | 47 +++++++++++++++++++ 1 file changed, 47 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp.f new file mode 100644 index 0000000..fe6cc49 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp.f @@ -0,0 +1,47 @@ +C +C====================================================================== +C + SUBROUTINE COREXP_SAVM(JE,IGR,NGR,NLM,ITYPE,IGS,TAU) +C +C This subroutine call the correlation matrices calculations +C for a given order IGR +C +C H.-F. Zhao : 2007 +C + USE DIM_MOD + USE COOR_MOD + USE Q_ARRAY_MOD + USE TRANS_MOD +C + INTEGER NLM(NGR_M),ITYPE(NGR_M),IGS(NGR_M) +C + REAL QI +C + COMPLEX*16 TAU(LINMAX,LINFMAX,NATCLU_M) +C +C + DO ITYP=1,N_PROT + NBTYP=NATYP(ITYP) + NLM(IGR)=LMAX(ITYP,JE) + ITYPE(IGR)=ITYP + DO NUM=1,NBTYP + IGS(IGR)=NCORR(NUM,ITYP) +C + IF(IGS(IGR).GT.IGS(IGR-1)) THEN + QI=Q(IGR) + CALL MPIS(IGR,NLM,ITYPE,IGS,JE,QI,TAU) +C + IGR=IGR+1 + IF(IGR.LE.NGR) THEN + CALL COREXP_SAVM1(JE,IGR,NGR,NLM,ITYPE,IGS,TAU) + ENDIF + IGR=IGR-1 +C + ENDIF +C + ENDDO + ENDDO +C + RETURN +C + END From 0b889681d13b4f83824d09d00e720397cdfe5364 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 13:11:17 +0100 Subject: [PATCH 12/43] Added corexp1.f file The file corexp1.f was updated to be compatible with Python bindings. --- .../fortran/phd_ce_noso_nosp_nosym/corexp1.f | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp1.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp1.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp1.f new file mode 100644 index 0000000..69c0c66 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp1.f @@ -0,0 +1,19 @@ +C +C====================================================================== +C + SUBROUTINE COREXP_SAVM1(JE,IGR,NGR,NLM,ITYPE,IGS,TAU) +C +C This subroutine allows a recursive use of COREXP_SAVM +C +C H.-F. Zhao : 2007 +C + USE DIM_MOD +C + INTEGER NLM(NGR_M),ITYPE(NGR_M),IGS(NGR_M) + COMPLEX*16 TAU(LINMAX,LINFMAX,NATCLU_M) +C + CALL COREXP_SAVM(JE,IGR,NGR,NLM,ITYPE,IGS,TAU) +C + RETURN +C + END From 58e9731ffdc7bf81a8ece412832ec29ba2caf9b8 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 13:24:07 +0100 Subject: [PATCH 13/43] Added gaunt_st.f file. The file gaunt_st.f was updated to be compatible with Python bindings. The module GAUNT_C was created. --- src/msspec/spec/fortran/memalloc/allocation.f | 1 + src/msspec/spec/fortran/memalloc/modules.f | 14 ++ .../fortran/phd_ce_noso_nosp_nosym/gaunt_st.f | 126 ++++++++++++++++++ 3 files changed, 141 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f diff --git a/src/msspec/spec/fortran/memalloc/allocation.f b/src/msspec/spec/fortran/memalloc/allocation.f index 932aa3e..ce93641 100644 --- a/src/msspec/spec/fortran/memalloc/allocation.f +++ b/src/msspec/spec/fortran/memalloc/allocation.f @@ -188,6 +188,7 @@ CALL ALLOC_SPECTRUM() CALL ALLOC_DIRECT() CALL ALLOC_DIRECT_A() + CALL ALLOC_GAUNT_C() CALL ALLOC_PATH() CALL ALLOC_ROT() CALL ALLOC_ROT_CUB() diff --git a/src/msspec/spec/fortran/memalloc/modules.f b/src/msspec/spec/fortran/memalloc/modules.f index bc796d9..8ec49a7 100644 --- a/src/msspec/spec/fortran/memalloc/modules.f +++ b/src/msspec/spec/fortran/memalloc/modules.f @@ -792,6 +792,20 @@ C======================================================================= END SUBROUTINE ALLOC_DEXPFAC END MODULE DEXPFAC_MOD +C======================================================================= + MODULE GAUNT_C_MOD + IMPLICIT NONE + REAL*8, ALLOCATABLE, DIMENSION(:,:,:) :: GNT + CONTAINS + SUBROUTINE ALLOC_GAUNT_C() + USE DIM_MOD + IF (ALLOCATED(GNT)) THEN + DEALLOCATE(GNT) + ENDIF + ALLOCATE(GNT(0:N_GAUNT,LINMAX,LINMAX)) + END SUBROUTINE ALLOC_GAUNT_C + END MODULE GAUNT_C_MOD + C======================================================================= MODULE LOGAMAD_MOD IMPLICIT NONE diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f new file mode 100644 index 0000000..5e963ec --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f @@ -0,0 +1,126 @@ +C +C======================================================================= +C + SUBROUTINE GAUNT_ST(LMAX_T) +C +C This subroutine calculates the Gaunt coefficient G(L2,L3|L1) +C using a downward recursion scheme due to Schulten and Gordon +C for the Wigner's 3j symbols. The result is stored as GNT(L3), +C making use of the selection rule M3 = M1 - M2. +C +C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975) +C +C This is the double precision version where the values are stored +C +C Last modified : 14 May 2009 +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C + USE DIM_MOD + USE LOGAMAD_MOD + USE GAUNT_C_MOD +C + INTEGER LMAX_T +C + REAL*8 F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT),A1(0:N_GAUNT) + REAL*8 B(0:N_GAUNT) +C + DATA PI4/12.566370614359D0/ +C + DO L1=0,LMAX_T + IL1=L1*L1+L1+1 + DO M1=-L1,L1 + IND1=IL1+M1 + LM1=L1+M1 + KM1=L1-M1 + DO L2=0,LMAX_T + IL2=L2*L2+L2+1 +C + IF(MOD(M1,2).EQ.0) THEN + COEF=DSQRT(DFLOAT((L1+L1+1)*(L2+L2+1))/PI4) + ELSE + COEF=-DSQRT(DFLOAT((L1+L1+1)*(L2+L2+1))/PI4) + ENDIF +C + L12=L1+L2 + K12=L1-L2 + L12_1=L12+L12+1 + L12_2=L12*L12 + L12_21=L12*L12+L12+L12+1 + K12_2=K12*K12 +C + F(L12+1)=0.D0 + G(L12+1)=0.D0 + A(L12+1)=0.D0 + A1(L12+1)=0.D0 + A1(L12)=2.D0*DSQRT(DFLOAT(L1*L2*L12_1*L12_2)) + D1=GLD(L2+L2+1,1)-GLD(L12_1+1,1) + D5=0.5D0*(GLD(L1+L1+1,1)+GLD(L2+L2+1,1)-GLD(L12_1+1,1)) + D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1) +C + IF(MOD(K12,2).EQ.0) THEN + G(L12)=DEXP(D5+D6) + ELSE + G(L12)=-DEXP(D5+D6) + ENDIF +C + DO M2=-L2,L2 + IND2=IL2+M2 +C + M3=M1-M2 + LM2=L2+M2 + KM2=L2-M2 +C + DO J=1,N_GAUNT + GNT(J,IND2,IND1)=0.D0 + ENDDO +C + IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10 +C + D2=GLD(L1+L1+1,1)-GLD(LM2+1,1) + D3=GLD(L12+M3+1,1)-GLD(KM2+1,1) + D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1) +C + IF(MOD(KM1-KM2,2).EQ.0) THEN + F(L12)=DSQRT(DEXP(D1+D2+D3+D4)) + ELSE + F(L12)=-DSQRT(DEXP(D1+D2+D3+D4)) + ENDIF +C + A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*L12_1*(L12_2-M3*M3))) + B(L12)=-DFLOAT(L12_1*((L2*L2-L1*L1-K12)*M3+L12*(L12+1) + 1 *(M2+M1))) +C + IF(ABS(M3).LE.L12) THEN + GNT(L12,IND2,IND1)=COEF*F(L12)*G(L12)* + 1 DSQRT(DFLOAT(L12_1)) + ENDIF +C + JMIN=MAX0(ABS(K12),ABS(M3)) +C + DO J=L12-1,JMIN,-1 + J1=J+1 + J2=J+2 + JJ=J*J + A1(J)=DSQRT(DFLOAT(JJ*(JJ-K12_2)*(L12_21-JJ))) + A(J)=DSQRT(DFLOAT((JJ-K12_2)*(L12_21-JJ)*(JJ-M3*M3))) + B(J)=-DFLOAT((J+J1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1* + 1 (M2+M1))) + F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)* + 1 A(J1)) + G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1)) +C + IF(ABS(M3).LE.J) THEN + GNT(J,IND2,IND1)=COEF*F(J)*G(J)*DSQRT(DFLOAT(J+J1)) + ENDIF + ENDDO +C + ENDDO + ENDDO + ENDDO + ENDDO +C + 10 RETURN +C + END + From b1f34aef6a78087457b9496afc8d2727c47c4956 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 13:39:28 +0100 Subject: [PATCH 14/43] Added mpis.f file. The file mpis.f was updated to be compatible with Python bindings. The module CORREXP_MOD was created and is now allocated in memalloc/allocation.f. The parameter NLMM was added to dim_mod.f. --- src/msspec/spec/fortran/memalloc/allocation.f | 1 + src/msspec/spec/fortran/memalloc/dim_mod.f | 2 + src/msspec/spec/fortran/memalloc/modules.f | 14 + .../fortran/phd_ce_noso_nosp_nosym/mpis.f | 280 ++++++++++++++++++ 4 files changed, 297 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/mpis.f diff --git a/src/msspec/spec/fortran/memalloc/allocation.f b/src/msspec/spec/fortran/memalloc/allocation.f index ce93641..11ebe7e 100644 --- a/src/msspec/spec/fortran/memalloc/allocation.f +++ b/src/msspec/spec/fortran/memalloc/allocation.f @@ -175,6 +175,7 @@ CALL ALLOC_C_G() CALL ALLOC_C_G_A() CALL ALLOC_C_G_M() + CALL ALLOC_CORREXP() CALL ALLOC_DEXPFAC2() CALL ALLOC_DFACTSQ() CALL ALLOC_EIGEN() diff --git a/src/msspec/spec/fortran/memalloc/dim_mod.f b/src/msspec/spec/fortran/memalloc/dim_mod.f index 7a84c04..a5392f9 100644 --- a/src/msspec/spec/fortran/memalloc/dim_mod.f +++ b/src/msspec/spec/fortran/memalloc/dim_mod.f @@ -34,6 +34,7 @@ C =============================================================== INTEGER NCG_M INTEGER N_BESS, N_GAUNT INTEGER NLTWO + INTEGER NLMM C =============================================================== CONTAINS SUBROUTINE INIT_DIM() @@ -64,5 +65,6 @@ C N_GAUNT=5*NL_M N_GAUNT=10*NL_M NLTWO=2*NL_M + NLMM=LINMAX*NGR_M END SUBROUTINE INIT_DIM END MODULE DIM_MOD diff --git a/src/msspec/spec/fortran/memalloc/modules.f b/src/msspec/spec/fortran/memalloc/modules.f index 8ec49a7..99fead6 100644 --- a/src/msspec/spec/fortran/memalloc/modules.f +++ b/src/msspec/spec/fortran/memalloc/modules.f @@ -192,6 +192,20 @@ C======================================================================= END SUBROUTINE ALLOC_COOR END MODULE COOR_MOD +C======================================================================= + MODULE CORREXP_MOD + IMPLICIT NONE + COMPLEX*16, ALLOCATABLE, DIMENSION(:,:) :: A + CONTAINS + SUBROUTINE ALLOC_CORREXP() + USE DIM_MOD + IF (ALLOCATED(A)) THEN + DEALLOCATE(A) + ENDIF + ALLOCATE(A(NLMM,NLMM)) + END SUBROUTINE ALLOC_CORREXP + END MODULE CORREXP_MOD + C======================================================================= MODULE DEBWAL_MOD IMPLICIT NONE diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/mpis.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/mpis.f new file mode 100644 index 0000000..4e83935 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/mpis.f @@ -0,0 +1,280 @@ +C +C +C====================================================================== +C + SUBROUTINE MPIS(N,NLM,ITYP,IGS,JE,QI,TAU) +C +C +C This subroutine construct the correlation matrices and uses +C LU decomposition method to do the matrix inversion. +C The inverse matrix which is the contribution of a small atom group +C is kept for further use. +C +C H. -F. Zhao : 2007 +C +C Last modified (DS) : 13 May 2009 +C + USE DIM_MOD + USE COOR_MOD + USE INIT_L_MOD + USE GAUNT_C_MOD + USE TRANS_MOD + USE CORREXP_MOD +C + INTEGER NLM(NGR_M),ITYP(NGR_M),IGS(NGR_M) + COMPLEX*16 TAU(LINMAX,LINFMAX,NATCLU_M) +C + REAL QI +C + COMPLEX*16 ZEROC,ONEC,IC +C + COMPLEX*16 ATTL(0:NT_M,NATM) + COMPLEX*16 EXPJN,ATTJN + COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO) + COMPLEX*16 HL1(0:NLTWO) + COMPLEX*16 SUM_L,SUM_L2 + COMPLEX*16 SUM_L_A,SUM_L2_A,SUM_L_B,SUM_L2_B +C + REAL*8 FOURPI + REAL*8 XJN,YJN,ZJN,RJN,KRJN,ZDJN + REAL*8 IM_VK,RE_VK +C + INTEGER IPIV(NLMM),ONE_L,IN1 +C + COMPLEX*16 FOURPI_IC,IC_L,IC_REF,TEMP,TEMP1,TEMP2,CN1 + COMPLEX*16 AINV(NLMM,NLMM),IN(NLMM,LINFMAX) +C + DATA FOURPI /12.566370614359D0/ +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) + IC=(0.D0,1.D0) + IBESS=3 + FOURPI_IC=-IC*FOURPI +C + LM0=LMAX(1,JE) + LM0=MIN(LM0,LF2) + NRHS=(LM0+1)*(LM0+1) + INDJ=0 +C + NM=0 + DO I=1,N-1 + J=NLM(I)+1 + NM=NM+J*J + ENDDO + L=NLM(N) + LNMAX=L + L=(L+1)*(L+1) + NM1=NM+1 + NML=NM+L + NTYP=ITYP(N) +C + DO L=0,LNMAX + ATTL(L,N)=DCMPLX(TL(L,1,NTYP,JE)) + ENDDO + IM_VK=-DIMAG(DCMPLX(VK(JE))) + RE_VK=DBLE(VK(JE)) +C +C set up matrix blocks C((N-1)*1) and D(1*(N-1)) +C + I=IGS(N) + XN=SYM_AT(1,I) + YN=SYM_AT(2,I) + ZN=SYM_AT(3,I) +C + DO J=1,N-1 + JATL=IGS(J) + LJMAX=NLM(J) + JTYP=ITYP(J) + J1=J-1 +C + XJN=DBLE(SYM_AT(1,JATL)-XN) + YJN=DBLE(SYM_AT(2,JATL)-YN) + ZJN=DBLE(SYM_AT(3,JATL)-ZN) + RJN=DSQRT(XJN*XJN+YJN*YJN+ZJN*ZJN) + KRJN=RE_VK*RJN + ATTJN=FOURPI_IC*DEXP(IM_VK*RJN) + EXPJN=(XJN+IC*YJN)/RJN + ZDJN=ZJN/RJN + CALL SPH_HAR2(2*NL_M,ZDJN,EXPJN,YLM,LNMAX+LJMAX) + CALL BESPHE2(LNMAX+LJMAX+1,IBESS,KRJN,HL1) + DO L=0,LJMAX + ATTL(L,J)=ATTJN*DCMPLX(TL(L,1,JTYP,JE)) + ENDDO +C + II=NM + IN1=-1 + CN1=IC + JJ=0 +C + DO LN=0,LNMAX + ILN=LN*LN+LN+1 + IN1=-IN1 + CN1=-CN1*IC +C + DO MLN=-LN,LN + INDN=ILN+MLN + II=II+1 + JJ0=J1*INDJ + ONE_L=-IN1 + IC_REF=-CN1*IC +C + DO LJ=0,LJMAX + ILJ=LJ*LJ+LJ+1 + L_MIN=ABS(LJ-LN) + L_MAX=LJ+LN + ONE_L=-ONE_L + IC_REF=IC_REF*IC +C +C Case MLJ equal to zero +C + JJ1=JJ0+ILJ + IF(LJ.GE.LN) THEN + IC_L=-IC_REF + ELSE + IC_L=-ONEC/IC_REF + ENDIF +C + SUM_L=ZEROC + SUM_L2=ZEROC +C + DO L=L_MIN,L_MAX,2 + IC_L=-IC_L + IF(ABS(MLN).LE.L) THEN + TEMP=IC_L*HL1(L)*GNT(L,ILJ,INDN) + SUM_L=SUM_L+YLM(L,MLN)*TEMP + SUM_L2=SUM_L2+DCONJG(YLM(L,MLN))*TEMP + ENDIF + ENDDO +C + IF(ONE_L.EQ.-1) SUM_L2=-SUM_L2 + A(JJ1,II)=ATTL(LJ,J)*SUM_L + A(II,JJ1)=ATTJN*ATTL(LN,N)*SUM_L2 +C +C +C Case MLJ not equal to zero +C + DO MLJ=1,LJ + INDJ=ILJ+MLJ + INDJN=ILJ-MLJ + JJ1=JJ0+INDJ + JJ1N=JJ0+INDJN + MA=MLN-MLJ + MB=MLN+MLJ + IF(LJ.GE.LN) THEN + IC_L=-IC_REF + ELSE + IC_L=-ONEC/IC_REF + ENDIF +C + SUM_L_A=ZEROC + SUM_L2_A=ZEROC + SUM_L_B=ZEROC + SUM_L2_B=ZEROC +C + DO L=L_MIN,L_MAX,2 + IC_L=-IC_L + IF(ABS(MA).LE.L) THEN + TEMP1=IC_L*HL1(L)*GNT(L,INDJ,INDN) + SUM_L_A=SUM_L_A+YLM(L,MA)*TEMP1 + SUM_L2_A=SUM_L2_A+DCONJG(YLM(L,MA))*TEMP1 + ENDIF + IF(ABS(MB).LE.L) THEN + TEMP2=IC_L*HL1(L)*GNT(L,INDJN,INDN) + SUM_L_B=SUM_L_B+YLM(L,MB)*TEMP2 + SUM_L2_B=SUM_L2_B+DCONJG(YLM(L,MB))*TEMP2 + ENDIF + ENDDO +C + IF(ONE_L.EQ.-1) THEN + SUM_L2_A=-SUM_L2_A + SUM_L2_B=-SUM_L2_B + ENDIF + A(JJ1,II)=ATTL(LJ,J)*SUM_L_A + A(II,JJ1)=ATTJN*ATTL(LN,N)*SUM_L2_A + A(JJ1N,II)=ATTL(LJ,J)*SUM_L_B + A(II,JJ1N)=ATTJN*ATTL(LN,N)*SUM_L2_B + ENDDO +C +C + ENDDO + JJ=JJ0+INDJ +C + ENDDO + ENDDO +C + JJ=JJ-INDN +C + ENDDO +C +C add B to A +C + DO I=NM1,NML + DO J=NM1,NML + IF(J.EQ.I) THEN + A(J,I)=ONEC + ELSE + A(J,I)=ZEROC + ENDIF + ENDDO + ENDDO +C +C construct AINV +C + DO I=1,NML + DO J=1,NML + AINV(J,I)=A(J,I) + ENDDO + ENDDO +C +C +C matrix inversion(ax=b) +C + CALL ZGETRF(NML,NML,AINV,NLMM,IPIV,INFO1) + IF(INFO1.NE.0) THEN + WRITE(6,*) ' ---> INFO1 =',INFO1 + ELSE +C + DO I=1,NRHS + DO J=1,NML + IF(J.EQ.I) THEN + IN(J,I)=(1.D0,0.D0) + ELSE + IN(J,I)=(0.D0,0.D0) + ENDIF + ENDDO + ENDDO +C + CALL ZGETRS('N',NML,NRHS,AINV,NLMM,IPIV,IN,NLMM,INFO) + IF(INFO.NE.0) THEN + WRITE(6,*) ' ---> INFO =',INFO + ENDIF + ENDIF +C +C sum of tau +C + KLIN=0 + DO K=1,N + KATL=IGS(K) + LMK=NLM(K) + INDKM=(LMK+1)*(LMK+1) +C + DO INDJ=1,NRHS +C + DO INDK=1,INDKM + KLIN=KLIN+1 +C + TAU(INDK,INDJ,KATL)=TAU(INDK,INDJ,KATL) + 1 +DBLE(QI)*IN(KLIN,INDJ) +C + ENDDO + KLIN=KLIN-INDKM +C + ENDDO + KLIN=KLIN+INDKM +C + ENDDO +C + RETURN +C + END From 998fdbee88d23dd9e257fb849a25053eeb012493 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 13:46:03 +0100 Subject: [PATCH 15/43] Added ms_cor.f file. The file ms_cor.f was updated to be compatible with Python bindings. --- .../fortran/phd_ce_noso_nosp_nosym/ms_cor.f | 165 ++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/ms_cor.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/ms_cor.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/ms_cor.f new file mode 100644 index 0000000..e00a626 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/ms_cor.f @@ -0,0 +1,165 @@ +C +C +C====================================================================== +C + SUBROUTINE MS_COR(JE,TAU) +C +C +C This subroutine calculates the scattering path operator by +C the correlation expansion method. +C +C The scattering path operator matrix of each small atom group +C is obtained by using LU decomposition method. +C +C The running time of matrix inversion subroutine used in this program +C scales with N^3, the memory occupied scales with N^2. We advise user to +C use full MS method to get the scattering path operator, i.e. directly +C with matrix inversion method if NGR is larger than 3. If NGR is less +C than 4 (i.e <=3) this subroutine will gain time. +C +C This subroutine never gain memory comparing to the subrourine INV_MAT_MS +C as I use three large matrices stored in common, each matrix is larger or +C as large as the matrix used in INV_MAT_MS. +C +C As I don't find a good way to solve the group problem, where all the contribution +C of group IGR<=NGR are collected and each small contribution has to be stored +C for the further larger-atom-group contribution, it's better that users change the +C parameter NGR_M which is set in included file 'spec.inc' to be NGR or NGR+1 +C where NGR is the cut-off.user insterested. this subrouitne works for NGR is less +C than 6(<=5), if users want to calculate larger NGR, they should modify the code here +C to make them workable, the code is marked by 'C' in each lines (about 300 lines +C below here), users just release them until to the desired cut-off, the maximum is +C 9, however, users can enlarge it if they want to. Warning ! NGR_M set in +C included file should be larger than NGR and the figure listed below, don't forget +C to compile the code after modification. +C +C Users can modify the code to make it less memory-occupied, however, no matter they +C do, the memories that used are more than full MS method used, so the only advantage +C that this code has is to gain time when NGR<=3, with command 'common' used here, +C the code will run faster. +C +C H.-F. Zhao : 2007 +C +C (Photoelectron case) +C +C Last modified : 31 Jan 2008 +C +C +C + USE DIM_MOD + USE COOR_MOD + USE INIT_L_MOD + USE TRANS_MOD + USE APPROX_MOD + USE CORREXP_MOD + USE Q_ARRAY_MOD +C + COMPLEX*16 TAU1(LINMAX,LINFMAX,NATCLU_M),ONEC,ZEROC +C + INTEGER NLM(NGR_M),ITYP(NGR_M),IGS(NGR_M) +C + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M),TLJ +C +C + ONEC=(1.D0,0.D0) + ZEROC=(0.D0,0.D0) +C + LM0=LMAX(1,JE) + LM0=MIN(LM0,LF2) + NRHS=(LM0+1)*(LM0+1) +C + NGR_MAX=NGR_M + NGR=NDIF +C + IF(NGR_M.GT.NATCLU) THEN + WRITE(6,*) ' ---> NGR_M should be smaller than NATCLU' + WRITE(6,*) ' ---> it is reduced to NATCLU=',NATCLU + NGR_MAX=NATCLU + ENDIF +C + IF(NGR.LT.1) THEN + WRITE(6,*) ' ---> NGR < 1, no expansion is done' + STOP + ELSE + IF(NGR.GT.NGR_MAX) THEN + WRITE(6,*) ' ---> NGR is too large, reduce to NGR_M=', + & NGR_MAX + NGR=NGR_MAX + ENDIF + ENDIF +C +C Case NGR = 1 +C + IF(NGR.EQ.1) THEN + DO LJ=0,LM0 + ILJ=LJ*LJ+LJ+1 + TLJ=TL(LJ,1,1,JE) + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + TAU(INDJ,INDJ,1)=TLJ + ENDDO + ENDDO +C + GOTO 100 + ENDIF +C +C NGR >=2 case +C +C + DO INDJ=1,NRHS + TAU1(INDJ,INDJ,1)=DBLE(Q(1))*ONEC + ENDDO +C +C Constructs the group matrix and inverses it +C + IGR=1 + LMJ=LMAX(1,JE) + NLM(IGR)=LMJ + INDJM=(LMJ+1)*(LMJ+1) + ITYP(IGR)=1 + IGS(IGR)=1 +C + DO I=1,INDJM + DO J=1,INDJM + IF (J.EQ.I) THEN + A(J,I)=ONEC + ELSE + A(J,I)=ZEROC + ENDIF + ENDDO + ENDDO +C + IGR=IGR+1 + CALL COREXP_SAVM(JE,IGR,NGR,NLM,ITYP,IGS,TAU1) + IGR=IGR-1 +C +C TAU=TAU*tj +C + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + INDKM=(LMK+1)*(LMK+1) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) +C + DO LJ=0,LM0 + ILJ=LJ*LJ+LJ+1 + TLJ=TL(LJ,1,1,JE) + DO MJ=-LJ,LJ + INDJ=ILJ+MJ +C + DO INDK=1,INDKM + TAU(INDK,INDJ,KATL)=CMPLX(TAU1(INDK,INDJ,KATL))*TLJ + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + 100 CONTINUE +C + RETURN +C + END From 9ebf6c6bc3f527964ac38b20b604c0381c1630b6 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 14:18:22 +0100 Subject: [PATCH 16/43] Added coumat.f and treat_phd.f Those 2 files were copied from the phd_se version since they are identical. --- .../fortran/phd_ce_noso_nosp_nosym/coumat.f | 121 +++ .../phd_ce_noso_nosp_nosym/treat_phd.f | 769 ++++++++++++++++++ 2 files changed, 890 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coumat.f create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/treat_phd.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coumat.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coumat.f new file mode 100644 index 0000000..bb376de --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coumat.f @@ -0,0 +1,121 @@ +C +C======================================================================= +C + SUBROUTINE COUMAT(ITL,MI,LF,MF,DELTA,RADIAL,MATRIX) +C +C This routine calculates the spin-independent PhD optical matrix +C elements for dipolar excitations. It is stored in +C MATRIX(JDIR,JPOL) +C +C Here, the conventions are : +C +C IPOL=1 : linearly polarized light +C IPOL=2 : circularly polarized light +C +C JPOL=1 : +/x polarization for circular/linear light +C JPOL=2 : -/y polarization for circular/linear light +C +C When IDICHR=0, JDIR = 1,2 and 3 correspond respectively to the x,y +C and z directions for the linear polarization. But for IDICHR=1, +C these basis directions are those of the position of the light. +C +C Last modified : 8 Dec 2008 +C + USE DIM_MOD +C + USE INIT_L_MOD , L2 => NNL, L3 => LF1, L4 => LF2, L5 => ISTEP_LF + USE SPIN_MOD , I1 => ISPIN, N1 => NSPIN, N2 => NSPIN2, I2 => ISFLI + &P, I8 => IR_DIA, N3 => NSTEP + USE TYPCAL_MOD , I3 => IPHI, I4 => IE, I5 => ITHETA, I6 => IFTHET, + & I7 => IMOD, I9 => I_CP, I10 => I_EXT +C + COMPLEX MATRIX(3,2),SUM_1,SUM_2,DELTA,YLM(3,-1:1),RADIAL + COMPLEX ONEC,IC,IL,COEF,PROD +C + REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1),GNT(0:N_GAUNT) + REAL THETA(3),PHI(3) +C + DATA PI4S3,C_LIN,SQR2 /4.188790,1.447202,1.414214/ + DATA PIS2 /1.570796/ +C + ONEC=(1.,0.) + IC=(0.,1.) +C + IF(INITL.EQ.0) GOTO 2 +C + M=MF-MI +C + IF(MOD(LF,4).EQ.0) THEN + IL=ONEC + ELSEIF(MOD(LF,4).EQ.1) THEN + IL=IC + ELSEIF(MOD(LF,4).EQ.2) THEN + IL=-ONEC + ELSEIF(MOD(LF,4).EQ.3) THEN + IL=-IC + ENDIF +C + CALL GAUNT(LI,MI,LF,MF,GNT) +C + IF(ITL.EQ.0) THEN +c COEF=CEXP(IC*DELTA)*CONJG(IL) + COEF=CEXP(IC*DELTA)*IL + ELSE + IF(IDICHR.EQ.0) THEN +c COEF=PI4S3*CONJG(IL) + COEF=PI4S3*IL + ELSE +c COEF=C_LIN*CONJG(IL) + COEF=C_LIN*IL + ENDIF + ENDIF +C + PROD=COEF*RADIAL*GNT(1) +C + IF(IDICHR.EQ.0) THEN + YLM(1,-1)=(0.345494,0.) + YLM(1,0)=(0.,0.) + YLM(1,1)=(-0.345494,0.) + YLM(2,-1)=(0.,-0.345494) + YLM(2,0)=(0.,0.) + YLM(2,1)=(0.,-0.345494) + YLM(3,-1)=(0.,0.) + YLM(3,0)=(0.488602,0.) + YLM(3,1)=(0.,0.) +C + DO JDIR=1,3 + MATRIX(JDIR,1)=PROD*CONJG(YLM(JDIR,M)) + ENDDO +C + ELSEIF(IDICHR.GE.1) THEN +C + THETA(1)=PIS2 + PHI(1)=0. + THETA(2)=PIS2 + PHI(2)=PIS2 + THETA(3)=0. + PHI(3)=0. +C + DO JDIR=1,3 + CALL DJMN(THETA(JDIR),RLM,1) + SUM_1=RLM(-1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR)) + SUM_2=RLM(1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR)) + IF(IPOL.EQ.2) THEN + MATRIX(JDIR,1)=SQR2*SUM_1 + MATRIX(JDIR,2)=SQR2*SUM_2 + ELSEIF(ABS(IPOL).EQ.1) THEN + MATRIX(JDIR,1)=(SUM_2-SUM_1) + MATRIX(JDIR,2)=(SUM_2+SUM_1)*IC + ENDIF + ENDDO + ENDIF + GOTO 1 +C + 2 DO JDIR=1,3 + MATRIX(JDIR,1)=ONEC + MATRIX(JDIR,2)=ONEC + ENDDO +C + 1 RETURN +C + END diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/treat_phd.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/treat_phd.f new file mode 100644 index 0000000..a76a31e --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/treat_phd.f @@ -0,0 +1,769 @@ +C +C======================================================================= +C + SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP) +C +C This routine sums up the calculations corresponding to different +C absorbers or different planes when this has to be done +C (parameter ISOM in the input data file). +C +C Last modified : 24 Jan 2013 +C + USE DIM_MOD + USE OUTUNITS_MOD + USE TYPEXP_MOD , DUMMY => SPECTRO + USE VALIN_MOD + USE VALFIN_MOD +C + PARAMETER(N_HEAD=5000,N_FILES=1000) +C + CHARACTER*3 SPECTRO +C + CHARACTER*13 OUTDATA + CHARACTER*72 HEAD(N_HEAD,N_FILES) +C + REAL TAB(NDIM_M,4) + REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M) +C +C + DATA JVOL,JTOT/0,-1/ +C + REWIND IUO2 +C +C Reading and storing the headers: +C + NHEAD=0 + DO JLINE=1,N_HEAD + READ(IUO2,888) HEAD(JLINE,JFICH) + NHEAD=NHEAD+1 + IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333 + ENDDO +C + 333 CONTINUE +C + READ(IUO2,15) SPECTRO,OUTDATA + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IPH_1 + &,I_EXT +C + IF(I_EXT.EQ.2) THEN + IPH_1=0 + ENDIF +C + IF(ISOM.EQ.0) THEN +C +C........ ISOM = 0 : case of independent input files ................. +C + READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE +C + IF(IPH_1.EQ.1) THEN + N_FIXED=NPHI + FIX0=PHI0 + FIX1=PHI1 + N_SCAN=NTHETA + ELSE + N_FIXED=NTHETA + FIX0=THETA0 + FIX1=THETA1 + IF(STEREO.EQ.'YES') THEN + NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001) + &+1 + IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 + ENDIF + N_SCAN=NPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + N_SCAN=2*N_SCAN + ENDIF +C + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + NDP=NEMET*NTHETA*NPHI*NE + ELSEIF(I_EXT.EQ.-1) THEN + NDP=NEMET*NTHETA*NPHI*NE*2 + ELSEIF(I_EXT.EQ.2) THEN + NDP=NEMET*NTHETA*NE + N_FIXED=NTHETA + N_SCAN=NPHI + IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 + ENDIF +C + NTT=NPLAN*NDP + IF(NTT.GT.NDIM_M) GOTO 5 +C + DO JPLAN=1,NPLAN + DO JEMET=1,NEMET + DO JE=1,NE +C + DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1) + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(IPH_1.EQ.1) THEN + JPHI=J_FIXED + ELSE + THETA=THETA0+XINCRF + JTHETA=J_FIXED + IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11 + ENDIF + IF(STEREO.EQ.' NO') THEN + N_SCAN_R=N_SCAN + ELSE + RTHETA=THETA*0.017453 + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + ENDIF +C + DO J_SCAN=1,N_SCAN_R + IF(IPH_1.EQ.1) THEN + JTHETA=J_SCAN + ELSE + JPHI=J_SCAN + ENDIF +C + JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN + (JE-1)*N + &_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI +C + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF +C + READ(IUO2,2) JPL + IF(JPLAN.EQ.JPL) THEN + BACKSPACE IUO2 + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN + &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ELSE + BACKSPACE IUO2 + DO JL=JLIN,JPLAN*NDP + TAB(JL,1)=0.0 + TAB(JL,2)=0.0 + TAB(JL,3)=0.0 + TAB(JL,4)=0.0 + ENDDO + GOTO 10 + ENDIF + ENDDO + ENDDO + 11 CONTINUE + ENDDO + ENDDO + 10 CONTINUE + ENDDO +C + REWIND IUO2 +C +C Skipping the NHEAD lines of headers before rewriting: +C + DO JLINE=1,NHEAD + READ(IUO2,888) HEAD(JLINE,JFICH) + ENDDO +C + WRITE(IUO2,15) SPECTRO,OUTDATA + WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM +C + DO JE=1,NE + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R + TOTDIF_1=0. + TOTDIR_1=0. + VOLDIF_1=0. + VOLDIR_1=0. + TOTDIF_2=0. + TOTDIR_2=0. + VOLDIF_2=0. + VOLDIR_2=0. + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=0. + TOTDIR2_1=0. + VOLDIF2_1=0. + VOLDIR2_1=0. + TOTDIF2_2=0. + TOTDIR2_2=0. + VOLDIF2_2=0. + VOLDIR2_2=0. + ENDIF +C + DO JPLAN=1,NPLAN +C + SF_1=0. + SR_1=0. + SF_2=0. + SR_2=0. + IF(I_EXT.EQ.-1) THEN + SF2_1=0. + SR2_1=0. + SF2_2=0. + SR2_2=0. + ENDIF +C + DO JEMET=1,NEMET + JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (JE-1)*NTHE + &TA*NPHI +(JTHETA-1)*NPHI + JPHI + SF_1=SF_1+TAB(JLIN,2) + SR_1=SR_1+TAB(JLIN,1) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=SF2_1+TAB(JLIN2,2) + SR2_1=SR2_1+TAB(JLIN2,1) + ENDIF + IF(IDICHR.GE.1) THEN + SF_2=SF_2+TAB(JLIN,4) + SR_2=SR_2+TAB(JLIN,3) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=SF2_2+TAB(JLIN2,4) + SR2_2=SR2_2+TAB(JLIN2,3) + ENDIF + ENDIF + ENDDO + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR + &_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &SR2_1,SF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S + &R_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + IF(JPLAN.GT.NONVOL(JFICH)) THEN + VOLDIF_1=VOLDIF_1+SF_1 + VOLDIR_1=VOLDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_1=VOLDIF2_1+SF2_1 + VOLDIR2_1=VOLDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + VOLDIF_2=VOLDIF_2+SF_2 + VOLDIR_2=VOLDIR_1+SR_2 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_2=VOLDIF2_2+SF2_2 + VOLDIR2_2=VOLDIR2_1+SR2_2 + ENDIF + ENDIF + ENDIF + TOTDIF_1=TOTDIF_1+SF_1 + TOTDIR_1=TOTDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=TOTDIF2_1+SF2_1 + TOTDIR2_1=TOTDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + TOTDIF_2=TOTDIF_2+SF_2 + TOTDIR_2=TOTDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_2=TOTDIF2_2+SF2_2 + TOTDIR2_2=TOTDIR2_2+SR2_2 + ENDIF + ENDIF + ENDDO + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOLD + &IR_1,VOLDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO + &LDIR2_1,VOLDIF2_1 + ENDIF + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOTD + &IR_1,TOTDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO + &TDIR2_1,TOTDIF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOL + &DIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V + &OLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2 + ENDIF + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOT + &DIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T + &OTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +C + ELSE +C +C........ ISOM not= 0 : multiple input files to be summed up .......... +C + READ(IUO2,7) NTHETA,NPHI,NE +C + IF(IPH_1.EQ.1) THEN + N_FIXED=NPHI + FIX0=PHI0 + FIX1=PHI1 + N_SCAN=NTHETA + ELSE + N_FIXED=NTHETA + FIX0=THETA0 + FIX1=THETA1 + IF(STEREO.EQ.'YES') THEN + NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001) + &+1 + IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 + ENDIF + N_SCAN=NPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + N_SCAN=2*N_SCAN + ENDIF +C + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + NDP=NTHETA*NPHI*NE + ELSEIF(I_EXT.EQ.-1) THEN + NDP=NTHETA*NPHI*NE*2 + ELSEIF(I_EXT.EQ.2) THEN + NDP=NTHETA*NE + N_FIXED=NTHETA + N_SCAN=NPHI + IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 + ENDIF +C + NTT=NFICHLEC*NDP + IF(NTT.GT.NDIM_M) GOTO 5 +C + IF(ISOM.EQ.1) THEN + NPLAN=NP + NF=NP + ELSEIF(ISOM.EQ.2) THEN + NEMET=NFICHLEC + NF=NFICHLEC + NPLAN=1 + ENDIF +C + DO JF=1,NF +C +C Reading the headers for each file: +C + IF(JF.GT.1) THEN + DO JLINE=1,NHEAD + READ(IUO2,888) HEAD(JLINE,JF) + ENDDO + ENDIF +C + DO JE=1,NE +C + DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1) + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(IPH_1.EQ.1) THEN + JPHI=J_FIXED + ELSE + THETA=THETA0+XINCRF + JTHETA=J_FIXED + IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12 + ENDIF + IF(STEREO.EQ.' NO') THEN + N_SCAN_R=N_SCAN + ELSE + RTHETA=THETA*0.017453 + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + ENDIF +C + DO J_SCAN=1,N_SCAN_R + IF(IPH_1.EQ.1) THEN + JTHETA=J_SCAN + ELSE + JPHI=J_SCAN + ENDIF +C + JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI + + &JPHI + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF +C + IF(ISOM.EQ.1) THEN + READ(IUO2,2) JPL + IF(JF.EQ.JPL) THEN + BACKSPACE IUO2 + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN( + &JE),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN + &(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),EC + &IN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ELSE + BACKSPACE IUO2 + DO JLINE=1,NHEAD + BACKSPACE IUO2 + ENDDO + DO JL=JLIN,JF*NDP + TAB(JL,1)=0.0 + TAB(JL,2)=0.0 + TAB(JL,3)=0.0 + TAB(JL,4)=0.0 + ENDDO + GOTO 13 + ENDIF + ELSEIF(ISOM.EQ.2) THEN + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN + &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ENDIF + ENDDO + 12 CONTINUE + ENDDO + ENDDO + 13 CONTINUE + ENDDO +C + REWIND IUO2 +C +C Writing the headers: +C + DO JLINE=1,2 + WRITE(IUO2,888) HEAD(JLINE,1) + ENDDO + DO JF=1,NFICHLEC + DO JLINE=3,6 + WRITE(IUO2,888) HEAD(JLINE,JF) + ENDDO + WRITE(IUO2,888) HEAD(2,JF) + ENDDO + DO JLINE=7,NHEAD + WRITE(IUO2,888) HEAD(JLINE,1) + ENDDO +C + WRITE(IUO2,15) SPECTRO,OUTDATA + WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM +C + IF(ISOM.EQ.1) THEN +C + DO JE=1,NE +C + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R +C + TOTDIF_1=0. + TOTDIR_1=0. + VOLDIF_1=0. + VOLDIR_1=0. + TOTDIF_2=0. + TOTDIR_2=0. + VOLDIF_2=0. + VOLDIR_2=0. + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=0. + TOTDIR2_1=0. + VOLDIF2_1=0. + VOLDIR2_1=0. + TOTDIF2_2=0. + TOTDIR2_2=0. + VOLDIF2_2=0. + VOLDIR2_2=0. + ENDIF +C + DO JPLAN=1,NPLAN + JF=JPLAN +C + JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JP + &HI +C + SR_1=TAB(JLIN,1) + SF_1=TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=TAB(JLIN2,2) + SR2_1=TAB(JLIN2,1) + ENDIF + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &SR_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),SR2_1,SF2_1 + ENDIF + ELSE + SR_2=TAB(JLIN,3) + SF_2=TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=TAB(JLIN2,4) + SR2_2=TAB(JLIN2,3) + ENDIF + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,SR_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + IF(NONVOL(JPLAN).EQ.0) THEN + VOLDIF_1=VOLDIF_1+SF_1 + VOLDIR_1=VOLDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_1=VOLDIF2_1+SF2_1 + VOLDIR2_1=VOLDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + VOLDIF_2=VOLDIF_2+SF_2 + VOLDIR_2=VOLDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_2=VOLDIF2_2+SF2_2 + VOLDIR2_2=VOLDIR2_1+SR2_2 + ENDIF + ENDIF + ENDIF + TOTDIF_1=TOTDIF_1+SF_1 + TOTDIR_1=TOTDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=TOTDIF2_1+SF2_1 + TOTDIR2_1=TOTDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + TOTDIF_2=TOTDIF_2+SF_2 + TOTDIR_2=TOTDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_2=TOTDIF2_2+SF2_2 + TOTDIR2_2=TOTDIR2_2+SR2_2 + ENDIF + ENDIF + ENDDO +C + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO + &LDIR_1,VOLDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &VOLDIR2_1,VOLDIF2_1 + ENDIF + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO + &TDIR_1,TOTDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &TOTDIR2_1,TOTDIF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V + &OLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2 + ENDIF + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T + &OTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2 + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO + ELSEIF(ISOM.EQ.2) THEN + DO JE=1,NE +C + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R +C + SF_1=0. + SR_1=0. + SF_2=0. + SR_2=0. + IF(I_EXT.EQ.-1) THEN + SF2_1=0. + SR2_1=0. + SF2_2=0. + SR2_2=0. + ENDIF +C + DO JEMET=1,NEMET + JF=JEMET +C + JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + J + &PHI +C + SF_1=SF_1+TAB(JLIN,2) + SR_1=SR_1+TAB(JLIN,1) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=SF2_1+TAB(JLIN2,2) + SR2_1=SR2_1+TAB(JLIN2,1) + ENDIF + IF(IDICHR.GE.1) THEN + SF_2=SF_2+TAB(JLIN,4) + SR_2=SR_2+TAB(JLIN,3) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=SF2_2+TAB(JLIN2,4) + SR2_2=SR2_2+TAB(JLIN2,3) + ENDIF + ENDIF + ENDDO + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR + &_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),SR2_1,SF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S + &R_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +C + GOTO 6 +C + 5 WRITE(IUO1,4) + STOP + 35 WRITE(IUO1,36) N_FIXED + STOP + 37 WRITE(IUO1,38) NTHETA*NPHI + STOP +C + 1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4) + 2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN + &THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>') + 7 FORMAT(I4,2X,I4,2X,I4) + 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 9 FORMAT(9(2X,I1),2X,I2) + 15 FORMAT(2X,A3,11X,A13) + 22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1 + &2.6,2X,E12.6) + 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) + 25 FORMAT(37X,E12.6,2X,E12.6) + 36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL ', + &'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<< + &SHOULD BE AT LEAST ',I6,' >>>>>>>>>>') + 38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE I + &NCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE AT + &LEAST ',I6,' >>>>>>>>>>') + 888 FORMAT(A72) +C + 6 RETURN +C + END From 2b6a8b6e05bda9abeac5e2de777bd855e000ce1d Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 14:19:30 +0100 Subject: [PATCH 17/43] Added phddif_ce.f file. The file was updated to be compatible with Python bindings. --- .../phd_ce_noso_nosp_nosym/phddif_ce.f | 1136 +++++++++++++++++ 1 file changed, 1136 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/phddif_ce.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/phddif_ce.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/phddif_ce.f new file mode 100644 index 0000000..dda52df --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/phddif_ce.f @@ -0,0 +1,1136 @@ +C +C======================================================================= +C + SUBROUTINE PHDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK, + 1 NATCLU,NFICHLEC,JFICH,NP) +C +C This subroutine computes the PhD formula in the spin-independent case +C from a non spin-orbit resolved initial core state LI. +C +C Alternatively, it can compute the PhD amplitude for the APECS process. +C +C The calculation is performed using a correlation expansion approach +C for the expression of the scattering path operator +C +C The correlation matrix inversion is performed using the LAPACK +C inversion routines for a general double complex matrix +C +C Last modified : 10 Jan 2016 +C + 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 Q_ARRAY_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 , PHLUM => PHILUM + USE VALIN_AV_MOD + USE VALFIN_MOD +C + REAL LUM(3),AXE(3),EPS(3),DIRLUM(3),E_PH(NE_M) +C + COMPLEX IC,ONEC,ZEROC,COEF,PW(0:NDIF_M),DELTA + COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX YLMR(0:NL_M,-NL_M:NL_M),MATRIX(3,2) + COMPLEX YLME(0:NL_M,-NL_M:NL_M) + COMPLEX R2,MLFLI(2,-LI_M:LI_M,3,2,3) + COMPLEX SJDIR_1,SJDIR_2,SJDIF_1,SJDIF_2 + COMPLEX RHOK(NE_M,NATM,0:18,5,NSPIN2_M),RD + COMPLEX SLJDIF,ATT_M,MLIL0(2,-LI_M:LI_M,6),SLF_1,SLF_2 + COMPLEX SL0DIF,SMJDIF +C + DIMENSION VAL(NATCLU_M),NATYP(NATM),DIRPOL(3,2) + DIMENSION EMET(3),R_L(9),COORD(3,NATCLU_M) + DIMENSION R(NDIF_M),XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),JPA(NDIF_M) +C + CHARACTER*7 STAT + CHARACTER*13 OUTDATA1,OUTDATA2 + CHARACTER*24 OUTFILE + CHARACTER*24 AMPFILE +C + DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/ + DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/ +C + ALGO1='CE' + ALGO2=' ' + ALGO3=' ' + ALGO4=' ' +C + I_DIR=0 + NSET=1 + JEL=1 + OUTDATA1='CROSS-SECTION' + IF(I_AMP.EQ.1) THEN + I_SO=0 + I_MI=1 + OUTDATA2='MS AMPLITUDES' + ELSE + I_MI=0 + ENDIF +C + IF(SPECTRO.EQ.'PHD') 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 + ELSEIF(SPECTRO.EQ.'APC') THEN + IOUT=IUSCR2+1 + OUTFILE='res/phot.amp' + STAT='UNKNOWN' + ENDIF +C +C Computation of the Q coefficients for correlation expansion +C + CALL COEFPQ(NATCLU,NDIF) +C +C Position of the light when the analyzer is along the z axis : +C (X_LUM_Z,Y_LUM_Z,Z_LUM_Z) +C + RTHLUM=THLUM*PIS180 + RPHLUM=PHLUM*PIS180 + X_LUM_Z=SIN(RTHLUM)*COS(RPHLUM) + Y_LUM_Z=SIN(RTHLUM)*SIN(RPHLUM) + Z_LUM_Z=COS(RTHLUM) +C + IF(IMOD.EQ.0) THEN +C +C The analyzer is rotated +C + DIRLUM(1)=X_LUM_Z + DIRLUM(2)=Y_LUM_Z + DIRLUM(3)=Z_LUM_Z + ELSE +C +C The sample is rotated ---> light 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=0. +C It is stored as (1 2 3) +C (4 5 6) +C (7 8 9) +C + R_L(1)=COS(RTH0)*COS(RPH0) + R_L(2)=-SIN(RPH0) + R_L(3)=SIN(RTH0)*COS(RPH0) + R_L(4)=COS(RTH0)*SIN(RPH0) + R_L(5)=COS(RPH0) + R_L(6)=SIN(RTH0)*SIN(RPH0) + R_L(7)=-SIN(RTH0) + R_L(8)=0. + R_L(9)=COS(RTH0) +C +C Position of the light when the analyzer is along (THETA0,PHI0) : LUM(3) +C + LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) + LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) + LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9) +C + ENDIF + ENDIF +C + IC=(0.,1.) + ONEC=(1.,0.) + ZEROC=(0.,0.) + NSCAT=NATCLU-1 + ATTSE=1. + ATTSJ=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, + 1 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, + 1 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 +C Loop over the different absorbers in a given plane +C + DO JEMET=1,NEMET + CALL EMETT(JEMET,IEMET,Z,SYM_AT,NATYP,EMET,NTYPEM, + 1 JNEM,*4) + GO TO 2 + 4 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,51) JPLAN,NTYPEM + ENDIF + GO TO 3 + 2 IF((ABS(EMET(3)).GT.COUPUR).AND.(IBAS.EQ.1)) GOTO 5 + IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) THEN + WRITE(IUO1,52) JPLAN,EMET(1),EMET(2),EMET(3),NTYPEM + ENDIF + ENDIF + IF(ISOM.EQ.1) NP=JPLAN + ZSURFE=VAL(1)-EMET(3) + JATLEM=JNEM +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) + E_PH(JE)=ELUM+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ELSEIF(NE.EQ.1) THEN + ECIN=E0 + E_PH(JE)=ELUM + ENDIF + IF(I_TEST.NE.1) THEN + CFM=8.*PI*E_PH(JE)*FINSTRUC + 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+ABS(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 Initialization of TAU(INDJ,LINFMAX,JTYP) +C + JATL=0 + DO JTYP=1,N_PROT + NBTYP=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYP + JATL=JATL+1 + DO LF=LF1,LF2,ISTEP_LF + ILF=LF*LF+LF+1 + DO MF=-LF,LF + INDF=ILF+MF + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + TAU(INDJ,INDF,JATL)=ZEROC + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +C +C Storage of the coupling matrix elements MLFLI along the basis +C directions X,Y ET Z +C +C These basis directions refer to the polarization if IDICHR = 0 +C but to the light when IDICHR = 1 +C +C JBASE = 1 : X +C JBASE = 2 : Y +C JBASE = 3 : Z +C + DO MI=-LI,LI + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + DELTA=DLT(JE,NTYPEM,NNL,LR) + RD=RHOK(JE,NTYPEM,NNL,LR,1) + DO MF=-LF,LF + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 333 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 333 + MR=2+MF-MI + CALL COUMAT(ITL,MI,LF,MF,DELTA,RD,MATRIX) + DO JBASE=1,3 + MLFLI(1,MI,MR,LR,JBASE)=MATRIX(JBASE,1) + IF(IDICHR.GE.1) THEN + MLFLI(2,MI,MR,LR,JBASE)=MATRIX(JBASE,2) + ENDIF + ENDDO + 333 CONTINUE + ENDDO + ENDDO + ENDDO +C +C Matrix inversion for the calculation of TAU +C + IF(I_TEST.EQ.2) GOTO 666 +C +C Correlation expansion for the calculaion of TAU +C + CALL MS_COR(JE,TAU) +C + 666 CONTINUE +C +C Calculation of the Photoelectron Diffraction 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 LUM of the light 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 + LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) + LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) + LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_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 + SSETDIR_1=0. + SSETDIF_1=0. + SSETDIR_2=0. + SSETDIF_2=0. +C + SSET2DIR_1=0. + SSET2DIF_1=0. + SSET2DIR_2=0. + SSET2DIF_2=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 LUM of the light 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 + LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) + LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) + LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_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 light when the analyzer is at +C (THETA,PHI). DIRLUM is the direction of the light and its initial +C value (at (THETA0,PHI0)) is LUM. AXE is the direction of the theta +C rotation axis and EPS is defined so that (AXE,DIRLUM,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,LUM,EPS,CVECT) + PRS=PRSCAL(AXE,LUM) + IF(J_SCAN.EQ.1) THEN + DIRLUM(1)=LUM(1) + DIRLUM(2)=LUM(2) + DIRLUM(3)=LUM(3) + ELSE + DIRLUM(1)=LUM(1)*COS(RANGLE)+PRS*(1.-COS(RANGLE)) + 1 *AXE(1)+SIN(RANGLE)*EPS(1) + DIRLUM(2)=LUM(2)*COS(RANGLE)+PRS*(1.-COS(RANGLE)) + 1 *AXE(2)+SIN(RANGLE)*EPS(2) + DIRLUM(3)=LUM(3)*COS(RANGLE)+PRS*(1.-COS(RANGLE)) + 1 *AXE(3)+SIN(RANGLE)*EPS(3) + ENDIF + ENDIF + IF(DIRLUM(3).GT.1.) DIRLUM(3)=1. + IF(DIRLUM(3).LT.-1.) DIRLUM(3)=-1. + THETALUM=ACOS(DIRLUM(3)) + IF(I_TEST.EQ.2) THETALUM=-THETALUM + COEF=DIRLUM(1)+IC*DIRLUM(2) + CALL ARCSIN(COEF,DIRLUM(3),PHILUM) + ANALUM=ANADIR(1,1)*DIRLUM(1) + + 1 ANADIR(2,1)*DIRLUM(2) + + 2 ANADIR(3,1)*DIRLUM(3) +C + SEPSDIR_1=0. + SEPSDIF_1=0. + SEPSDIR_2=0. + SEPSDIF_2=0. +C +C Loop over the directions of polarization +C + DO JEPS=1,NEPS + IF((JEPS.EQ.1).AND.(IPOL.GE.0)) THEN + DIRPOL(1,JEPS)=COS(THETALUM)*COS(PHILUM) + DIRPOL(2,JEPS)=COS(THETALUM)*SIN(PHILUM) + DIRPOL(3,JEPS)=-SIN(THETALUM) + ELSE + DIRPOL(1,JEPS)=-SIN(PHILUM) + DIRPOL(2,JEPS)=COS(PHILUM) + DIRPOL(3,JEPS)=0. + ENDIF + IF(ABS(IPOL).EQ.1) THEN + IF(IPRINT.GT.0) THEN + WRITE(IUO1,61) (DIRANA(J,1),J=1,3), + 1 (DIRLUM(K),K=1,3), + 2 (DIRPOL(K,1),K=1,3), + 3 ANALUM + ENDIF + ELSE + IF((JEPS.EQ.1).AND.(IPRINT.GT.0)) THEN + WRITE(IUO1,63) (DIRANA(J,1),J=1,3), + 1 (DIRLUM(K),K=1,3),ANALUM + ENDIF + ENDIF + IF((JEPS.EQ.1).AND.(I_EXT.EQ.-1)) PRINT 89 +C +C Calculation of the coupling matrix MLIL0 +C + DO MI=-LI,LI + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + LRR=3*(LR-1) + DO MF=-LF,LF + MR=2+MF-MI + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 777 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 777 + LMR=LRR+MR + IF(IDICHR.EQ.0) THEN + IF(I_TEST.NE.1) THEN + MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)* + 1 DIRPOL(1,JEPS) + + 2 MLFLI(1,MI,MR,LR,2)* + 3 DIRPOL(2,JEPS) + + 4 MLFLI(1,MI,MR,LR,3)* + 5 DIRPOL(3,JEPS) + ELSE + MLIL0(1,MI,LMR)=ONEC + ENDIF + ELSEIF(IDICHR.GE.1) THEN + IF(I_TEST.NE.1) THEN + MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)* + 1 DIRLUM(1) + + 2 MLFLI(1,MI,MR,LR,2)* + 3 DIRLUM(2) + + 4 MLFLI(1,MI,MR,LR,3)* + 5 DIRLUM(3) + MLIL0(2,MI,LMR)=MLFLI(2,MI,MR,LR,1)* + 1 DIRLUM(1) + + 2 MLFLI(2,MI,MR,LR,2)* + 3 DIRLUM(2) + + 4 MLFLI(2,MI,MR,LR,3)* + 5 DIRLUM(3) + ELSE + MLIL0(1,MI,LMR)=ONEC + ENDIF + ENDIF + 777 CONTINUE + ENDDO + ENDDO + ENDDO +C + SRDIF_1=0. + SRDIR_1=0. + SRDIF_2=0. + SRDIR_2=0. + +C +C Loop over the different directions of the analyzer contained in a cone +C + DO JDIR=1,NDIR + IF(IATTS.EQ.1) THEN + ATTSE=EXP(-ZSURFE*GAMMA/DIRANA(3,JDIR)) + ENDIF +C + SMIDIR_1=0. + SMIDIF_1=0. + SMIDIR_2=0. + SMIDIF_2=0. +C +C Loop over the equiprobable azimuthal quantum numbers MI corresponding +C to the initial state LI +C + LME=LMAX(1,JE) + CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME) + DO MI=-LI,LI + SJDIR_1=ZEROC + SJDIF_1=ZEROC + SJDIR_2=ZEROC + SJDIF_2=ZEROC +C +C Calculation of the direct emission (used a a reference for the output) +C + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + LRR=3*(LR-1) + ILF=LF*LF+LF+1 + IF(ISPEED.EQ.1) THEN + R2=TL(LF,1,1,JE) + ELSE + R2=TLT(LF,1,1,JE) + ENDIF + DO MF=-LF,LF + MR=2+MF-MI + LMR=LRR+MR + INDF=ILF+MF + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 444 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 444 + SJDIR_1=SJDIR_1+YLME(LF,MF)*ATTSE*MLIL0(1,MI,LMR)* + 1 R2 + IF(IDICHR.GE.1) THEN + SJDIR_2=SJDIR_2+YLME(LF,MF)*ATTSE*MLIL0(2,MI,LMR)* + 1 R2 + ENDIF +C +C Contribution of the absorber to TAU (initialization of SJDIF) +C + IF(I_TEST.EQ.2) GOTO 444 + SL0DIF=ZEROC + DO L0=0,LME + IL0=L0*L0+L0+1 + SL0DIF=SL0DIF+YLME(L0,0)*TAU(IL0,INDF,1) + DO M0=1,L0 + IND01=IL0+M0 + IND02=IL0-M0 + SL0DIF=SL0DIF+(YLME(L0,M0)* + 1 TAU(IND01,INDF,1)+ + 2 YLME(L0,-M0)* + 3 TAU(IND02,INDF,1)) + ENDDO + ENDDO + SJDIF_1=SJDIF_1+SL0DIF*MLIL0(1,MI,LMR) + IF(IDICHR.GE.1) THEN + SJDIF_2=SJDIF_2+SL0DIF*MLIL0(2,MI,LMR) + ENDIF + 444 CONTINUE + ENDDO + ENDDO + SJDIF_1=SJDIF_1*ATTSE + IF(IDICHR.GE.1) THEN + SJDIF_2=SJDIF_2*ATTSE + ENDIF +C +C Loop over the last atom J encountered by the photoelectron +C before escaping the solid +C + IF(I_TEST.EQ.2) GOTO 111 + DO JTYP=2,N_PROT + NBTYP=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYP + 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) + CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLMR, + 1 LMJ) + IF(IATTS.EQ.1) THEN + ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR)) + ENDIF + CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+ + 1 ZOJ*DIRANA(3,JDIR))/ROJ + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78 + CTROIS1=ZOJ/ROJ + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + IF(IDCM.GE.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)* + 1 (DIRANA(3,JDIR)-CTROIS1)/(2. + 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 + 78 IF(IDWSPH.EQ.1) THEN + DWTER=1. + ELSE + DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR)) + ENDIF + IF(JATL.EQ.JATLEM) THEN + ATT_M=ATTSE*DWTER + ELSE + ATT_M=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*CSTHJR) + ENDIF +C + SLF_1=ZEROC + SLF_2=ZEROC + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + LRR=3*(LR-1) + ILF=LF*LF+LF+1 + DO MF=-LF,LF + MR=2+MF-MI + INDF=ILF+MF + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 555 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 555 + LMR=LRR+MR + SLJDIF=ZEROC + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDF,JATL) + IF(LJ.GT.0) THEN + DO MJ=1,LJ + INDJ1=ILJ+MJ + INDJ2=ILJ-MJ + SMJDIF=SMJDIF+(YLMR(LJ,MJ)* + 1 TAU(INDJ1,INDF,JATL)+ + 2 YLMR(LJ,-MJ)* + 3 TAU(INDJ2,INDF,JATL)) + ENDDO + ENDIF + SLJDIF=SLJDIF+SMJDIF + ENDDO + SLF_1=SLF_1+SLJDIF*MLIL0(1,MI,LMR) + IF(IDICHR.GE.1) THEN + SLF_2=SLF_2+SLJDIF*MLIL0(2,MI,LMR) + ENDIF + 555 CONTINUE + ENDDO + ENDDO + SJDIF_1=SJDIF_1+SLF_1*ATT_M + IF(IDICHR.GE.1) THEN + SJDIF_2=SJDIF_2+SLF_2*ATT_M + ENDIF +C +C End of the loops over the last atom J +C + ENDDO + ENDDO +C +C Writing the amplitudes in file IOUT for APECS, or +C in file IOUT2 for PhD (orientated orbitals' case) +C + 111 IF(SPECTRO.EQ.'APC') THEN + WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN, + 1 JEPS,JDIR,MI,SJDIR_1,SJDIF_1 + IF(IDICHR.GE.1) THEN + WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN, + 1 JEPS,JDIR,MI,SJDIR_2,SJDIF_2 + ENDIF + ELSE + IF(I_MI.EQ.1) THEN + WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED, + 1 J_SCAN,JEPS,JDIR,MI,SJDIR_1, + 2 SJDIF_1 + IF(IDICHR.GE.1) THEN + WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED, + 1 J_SCAN,JEPS,JDIR,MI,SJDIR_2, + 2 SJDIF_2 + ENDIF + ENDIF +C +C Computing the square modulus +C + SMIDIF_1=SMIDIF_1+CABS(SJDIF_1)*CABS(SJDIF_1) + SMIDIR_1=SMIDIR_1+CABS(SJDIR_1)*CABS(SJDIR_1) + IF(IDICHR.GE.1) THEN + SMIDIF_2=SMIDIF_2+CABS(SJDIF_2)*CABS(SJDIF_2) + SMIDIR_2=SMIDIR_2+CABS(SJDIR_2)*CABS(SJDIR_2) + ENDIF + ENDIF +C +C End of the loop over MI +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 220 + SRDIR_1=SRDIR_1+SMIDIR_1 + SRDIF_1=SRDIF_1+SMIDIF_1 + IF(IDICHR.GE.1) THEN + SRDIR_2=SRDIR_2+SMIDIR_2 + SRDIF_2=SRDIF_2+SMIDIF_2 + ENDIF + 220 CONTINUE +C +C End of the loop on the directions of the analyzer +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 221 + SEPSDIF_1=SEPSDIF_1+SRDIF_1*VKR*CFM/NDIR + SEPSDIR_1=SEPSDIR_1+SRDIR_1*VKR*CFM/NDIR + IF(IDICHR.GE.1) THEN + SEPSDIF_2=SEPSDIF_2+SRDIF_2*VKR*CFM/NDIR + SEPSDIR_2=SEPSDIR_2+SRDIR_2*VKR*CFM/NDIR + ENDIF + 221 CONTINUE +C +C End of the loop on the polarization +C + ENDDO +C + SSETDIR_1=SSETDIR_1+SEPSDIR_1*W + SSETDIF_1=SSETDIF_1+SEPSDIF_1*W + IF(ICHKDIR.EQ.2) THEN + IF(JSET.EQ.JREF) THEN + SSET2DIR_1=SEPSDIR_1 + SSET2DIF_1=SEPSDIF_1 + ENDIF + ENDIF + IF(IDICHR.GE.1) THEN + SSETDIR_2=SSETDIR_2+SEPSDIR_2*W + SSETDIF_2=SSETDIF_2+SEPSDIF_2*W + IF(ICHKDIR.EQ.2) THEN + IF(JSET.EQ.JREF) THEN + SSET2DIR_2=SEPSDIR_2 + SSET2DIF_2=SEPSDIF_2 + ENDIF + ENDIF + ENDIF +C +C End of the loop on the set averaging +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 222 + IF(IDICHR.EQ.0) THEN + IF(ISOM.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + 1 SSETDIR_1,SSETDIF_1 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + 1 SSET2DIR_1,SSET2DIF_1 + ENDIF + ELSE + WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + 1 SSETDIR_1,SSETDIF_1 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + 1 SSET2DIR_1,SSET2DIF_1 + ENDIF + ENDIF + ELSE + IF(ISOM.EQ.2) THEN + WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + 1 SSETDIR_1,SSETDIF_1, + 2 SSETDIR_2,SSETDIF_2 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + 1 SSET2DIR_1,SSET2DIF_1, + 2 SSET2DIR_2,SSET2DIF_2 + ENDIF + ELSE + WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + 1 SSETDIR_1,SSETDIF_1,SSETDIR_2,SSETDIF_2 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + 1 SSET2DIR_1,SSET2DIF_1, + 2 SSET2DIR_2,SSET2DIF_2 + ENDIF + ENDIF + ENDIF + 222 CONTINUE +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 +C End of the loop on the emitters +C + ENDDO +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',/, + 1 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 ', + 1'THE ABSORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X, + 2'******* ',19X,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******') + 53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1, + 1 /,10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1, + 2 /,10X,' MINIMAL INTENSITY : ',E12.6, + 3 2X,'No OF THE PATH : ',F15.1, + 4 /,10X,' MAXIMAL INTENSITY : ',E12.6, + 5 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, + 1 /,10X,' EFFECTIVE NUMBER OF PATHS : ',I10, + 2 /,10X,' MINIMAL INTENSITY : ',E12.6, + 3 2X,'No OF THE PATH : ',I10, + 4 /,10X,' MAXIMAL INTENSITY : ',E12.6, + 5 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') + 61 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (', + 1 F6.3,',',F6.3,',',F6.3, + 2 ') ..........',/,16X,'DIRECTION OF THE LIGHT ', + 3 ' : (',F6.3,',',F6.3,',',F6.3, + 4 ')',/,16X,'DIRECTION OF THE POLARIZATION : (', + 5 F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZER.LIGHT ', + 6 ' : ',F7.4) + 63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (', + 1 F6.3,',',F6.3,',',F6.3, + 2 ') ..........',/,16X,'DIRECTION OF THE LIGHT ', + 3 ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X, + 4 'ANALYZER.LIGHT : ',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, + 1 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, + 1 'INTENSITY',3X,'LENGTH',4X,'ABSORBER',2X, + 2 'ORDER OF THE SCATTERERS',/) + 72 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6, + 1 2X,E12.6,2X,E12.6,2X,E12.6) + 74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ', + 1 '=====>') + 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, + 1 'INTENSITY',3X,'LENGTH',4X,'ABS',3X, + 2 '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', + 1 ' ORDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ', + 2 'OF A)') + 85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ', + 1 /,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, + 1 2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6) + 88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =', + 1 F6.2) + 89 FORMAT(/,4X,'..........................................', + 1 '.....................................') +C + 7 RETURN +C + END From f4f204305e3f28e14496e96997a3872b24080e9c Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 14:34:52 +0100 Subject: [PATCH 18/43] Added lapack_axb.f This file is the same as for the matrix inversion. --- .../phd_ce_noso_nosp_nosym/lapack_axb.f | 5123 +++++++++++++++++ 1 file changed, 5123 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/lapack_axb.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/lapack_axb.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/lapack_axb.f new file mode 100644 index 0000000..8019303 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/lapack_axb.f @@ -0,0 +1,5123 @@ +C +C======================================================================= +C +C LAPACK Ax=b subroutines +C +C======================================================================= +C +C (version 3.6.1) June 2016 +C +C======================================================================= +C +*> \brief \b ZGETRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETRS solves a system of linear equations +*> A * X = B, A**T * X = B, or A**H * X = B +*> with a general N-by-N matrix A using the LU factorization computed +*> by ZGETRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the form of the system of equations: +*> = 'N': A * X = B (No transpose) +*> = 'T': A**T * X = B (Transpose) +*> = 'C': A**H * X = B (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The factors L and U from the factorization A = P*L*U +*> as computed by ZGETRF. +*> \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[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= 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 +*> \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 ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, 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 TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLASWP, ZTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A**T * X = B or A**H * X = B. +* +* Solve U**T *X = B or U**H *X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Solve L**T *X = B, or L**H *X = B overwriting B with X. +* + CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, + $ LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of ZGETRS +* + 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 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 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 +*> \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 + From d09ba1b59048730e5698499e0ec7b2525204c042 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 14:35:26 +0100 Subject: [PATCH 19/43] Added main_phd_ns_ce.f This file was updated to be compatible with Python bindings. The begining of the file is identical to the series expansion version, so it was copied from there. --- .../phd_ce_noso_nosp_nosym/main_phd_ns_ce.f | 1697 +++++++++++++++++ 1 file changed, 1697 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f new file mode 100644 index 0000000..ca0b771 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f @@ -0,0 +1,1697 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * PHOTOELECTRON DIFFRACTION CODE * * +C * * BASED ON CORRELATION EXPANSION * * +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 +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_PHD_NS_CE() +C +C This routine reads the various input files and calls the subroutine +C performing the requested calculation +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 + COMPLEX RHOR(NE_M,NATM,0:18,5,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHOR5STAR +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 /0,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,*5 + &20,*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.)* + 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 +C +C Reading or regular (RHOR) and irregular (RHOI) radial integrals +C +C 1-2 : dipole terms +C 3-5 : quadrupole terms +C + DO JEMET=1,NEMET +C + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR, + 1 RHOR5STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + RHOR(JE,JM,NNL,3,1)=CONJG(RHOR3STAR) + RHOR(JE,JM,NNL,4,1)=CONJG(RHOR4STAR) + RHOR(JE,JM,NNL,5,1)=CONJG(RHOR5STAR) +C + ENDDO +C + 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))) + 1 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.......... Checking maximum value for l_max .......... +C.......... and storage of Gaunt coefficients .......... +C + LM_PE=0 + DO JAT=1,NAT2 + DO JE=1,NE + LM_PE=MAX(LM_PE,LMAX(JAT,JE)) + ENDDO + ENDDO +C + LM_AE=0 + DO JAT=1,NAT2_A + DO JE=1,NE_A + LM_AE=MAX(LM_AE,LMAX_A(JAT,JE)) + ENDDO + ENDDO +C + LM_PA=MAX(LM_PE,LM_AE) + CALL GAUNT_ST(LM_PA) + CALL COEFPQ(MAX(NAT2,NAT2_A),NDIF) +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) + STOP +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), + 1 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 + 1 +(COORD(2,JA1)-COORD(2,JA2))**2 + 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, + 1 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, + 1 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), + 1 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), + 1 RHOR(JE,JTE,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1), + 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), + 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, + 1 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 + CALL PHDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, + 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'LED') THEN +c CALL LEDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'AED') THEN +c CALL AEDDIF_CE(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_CE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'APC') THEN +c IF(J_EL.EQ.1) THEN +c CALL PHDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(J_EL.EQ.2) THEN +c CALL AEDDIF_CE(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) + 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 + IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) + STOP +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,5X,E12.6,5X,E12.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ', + 1': (',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,',', + 1 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,',', + 1 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 ', + 1I2,' IS POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', + 1'OF THE EXAFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', + 1' NUMBERING OF THE ATOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + 1'++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', + 1' CONTENTS OF THE REDUCED CLUSTER ======================', + 2 ///) + 41 FORMAT(///,'====================================================', + 1'============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ', + 1 F6.2,' DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', + 1'OF THE POLAR PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ', + 1 'THE NORMAL TO THE SURFACE)') + 49 FORMAT(/////,'########## END OF THE ', + 1'POLAR PHOTOELECTRON DIFFRACTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', + 1'EXAFS CALCULATION ##########') + 52 FORMAT(/////,'########## END OF THE ', + 1'AZIMUTHAL PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####') + 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE') + 58 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FINE STRUCTURE OSCILLATIONS CALCULATION #####', + 2'#####',/////) + 59 FORMAT(/////,'########## END OF THE ', + 1'FINE STRUCTURE OSCILLATIONS CALCULATION #####', + 2'#####') + 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,', + 1 'NEMET_M) - CHECK THE DIMENSIONING >>>>>>>>>>') + 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', + 1' >>>>>>>>>>') + 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ', + 1'CLUSTER HAS NOT CONVERGED YET >>>>>>>>>>') + 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ', + 1'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>') + 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ', + 1'IN MAIN ET READ_DATA >>>>>>>>>>') + 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ', + 1I1,',',I1,/) + 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ', + 1 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, + 1' IS PRESENT IN THIS PLANE') + 95 FORMAT(////,31X,'AUGER LINE :',A6,//) + 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1, + 1 ')') + 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ', + 1 I1,')') + 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE', + 1 ' >>>>>>>>>>') + 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, + 1 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, + 1 ' :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//) + 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ', + 1 I2,' : (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')') + 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ', + 1 I2,' : ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER', + 2 ' ELECTRON)',/, + 2 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, + 1 '(',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, + 1 'EXCHANGE INTEGRAL') + 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ', + 1 'INVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ', + 1 'INVERSION)') + 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4) + 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE', + 1 ' ',/,' ',/,' ') + 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ', + 1 'LINE',' ',/,' ',/,' ') + 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + 1 'AND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + 1 'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ', + 1 'FILE >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ', + 1 'MATRIX ELEMENTS TAKEN INTO ACCOUNT <-----',///) + 235 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 236 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 237 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 238 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 239 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 240 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE PHOTOELECTRON DIFFRACTION CALCULATION ', + 2'##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE AUGER DIFFRACTION CALCULATION ', + 2'##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE APECS DIFFRACTION CALCULATION ', + 2'##########',/////) + 249 FORMAT(/////,'########## END OF THE ', + 1'FULL ANGLE PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####') + 250 FORMAT(/////,'########## END ', + 1'OF THE FULL ANGLE AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 251 FORMAT(/////,'########## END ', + 1'OF THE FULL ANGLE APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL LEED CALCULATION #####', + 2'#####',/////) + 253 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL LEED CALCULATION #####', + 2'#####',/////) + 254 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR LEED CALCULATION #####', + 2'#####',/////) + 255 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR LEED CALCULATION #####', + 2'#####',/////) + 256 FORMAT(/////,5X,'########## BEGINNING ', + 1'OF THE ENERGY LEED CALCULATION #####', + 2'#####',/////) + 257 FORMAT(/////,5X,'########## END ', + 1'OF THE ENERGY LEED CALCULATION #####', + 2'#####',/////) + 258 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE LEED CALCULATION ', + 2'##########',/////) + 259 FORMAT(/////,'########## END OF THE ', + 1'FULL ANGLE LEED CALCULATION #####', + 2'#####') + 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/) + 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ', + 1 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 : ', + 1 '------------------------') + 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ', + 1 '------------------------') + 420 FORMAT(///,9X,'----------------------------------------------', + 1 '----------------------') + 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ', + 1 '(',F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')') + 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (', + 1 F8.5,',',F8.5,')') + 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ', + 1 'CHECK THE DIMENSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ', + 1 'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2, + 2 ' >>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ', + 1 'NAT IN THE DATA AND CLUSTER FILES >>>>>>>>>>') + 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ', + 1 'IBWD >>>>>>>>>>') + 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT', + 1 ' CONSISTENT WITH THE NUMBER OF ATOMS GENERATED BY THE ', + 2 'CODE >>>>>>>>>>') + 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH', + 1 ' 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 ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 543 FORMAT(5X,F12.9,5X,F12.9) + 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X, + 2 'SNo',2X,'SYM',/) + 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ', + 1 '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, + 1 3X,A2) + 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ', + 1 I2,' : ',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)', + 2 10X,'CLASS',1X,'ATOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//, + 1 14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3, + 1 ' PROTOTYPICAL ATOMS : ',//) + 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ', + 1 'PROTOTYPICAL ATOM : ',//) + 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE', + 1 13X,'oooooooooooooooo',///) + 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/) + 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ', + 1 'PHD AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ', + 1 'NOT CONSISTENT WITH THE INPUT DATA FILE >>>>>>>>>>') + 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ', + 1 '>>>>>>>>>>',//) + 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ', + 1 '.inc FILE >>>>>>>>>>',//) + 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ', + 1 '>>>>>>>>>>',//) + 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ', + 1 'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ', + 2 'ELEMENTS FILE >>>>>>>>>>',//) + 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ', + 1 '>>>>>>>>>>',//) + 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ', + 1 'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/, + 2 3X,'<<<<<<<<<< ',17X,'WITH THE INPUT DATA FILE ', + 3 16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ', + 1 ' BE IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ', + 2 'FOR BOTH ELECTRONS IN CLUSTER ROTATION MODE', + 3 ' >>>>>>>>>>',//) + 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, + 1 ' ATOMS') + 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE', + 1 ' NATCLU_M >>>>>>>>>>') + 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''', + 1 'UNITS >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE', + 1 ' ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4, + 2 ' AND ',I4,' ARE IDENTICAL >>>>>>>>>>') +C + END From 6986dde63672298d8d9a02ed52806a508052191e Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 19:07:03 +0100 Subject: [PATCH 20/43] Added main anf Makefile rules for CE. --- .../spec/fortran/phd_ce_noso_nosp_nosym.mk | 11 ++++++++++ .../fortran/phd_ce_noso_nosp_nosym/main.f | 21 +++++++++++++++++++ 2 files changed, 32 insertions(+) create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym.mk create mode 100644 src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main.f diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym.mk b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym.mk new file mode 100644 index 0000000..acbd20b --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_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) +phd_ce_noso_nosp_nosym_src := $(filter-out phd_ce_noso_nosp_nosym/lapack_axb.f, $(wildcard phd_ce_noso_nosp_nosym/*.f)) + +SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(phd_ce_noso_nosp_nosym_src) +MAIN_F = phd_ce_noso_nosp_nosym/main.f +SO = _phd_ce_noso_nosp_nosym.so + +include ../../../options.mk diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main.f new file mode 100644 index 0000000..d1f2af8 --- /dev/null +++ b/src/msspec/spec/fortran/phd_ce_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_PHD_NS_CE() + CALL CLOSE_ALL_FILES() + + END SUBROUTINE RUN From 39074f75b6f9982503651d03b250fc02bdf4ad3e Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 9 Feb 2022 19:08:22 +0100 Subject: [PATCH 21/43] Fixed some minor bugs. Fixed some bugs. The correlation expansion version now compiles! The shared object is imported in the calculator.py module. --- src/msspec/calculator.py | 7 +++++-- src/msspec/spec/fortran/Makefile | 8 ++++++-- src/msspec/spec/fortran/memalloc/allocation.f | 2 ++ .../spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f | 2 +- .../spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f | 2 +- .../fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f | 13 ++++++++----- 6 files changed, 23 insertions(+), 11 deletions(-) diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py index ca18df4..83312f0 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: Mon, 27 Sep 2021 17:49:48 +0200 -# Committed by : sylvain tricot +# Last modified: Wed, 09 Feb 2022 19:08:22 +0100 +# Committed by : Sylvain Tricot """ @@ -97,6 +97,7 @@ from msspec.spec.fortran import _eig_mi 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 _comp_curves from msspec.utils import get_atom_index @@ -405,6 +406,8 @@ class _MSCALCULATOR(Calculator): do_spec = _phd_se_noso_nosp_nosym.run elif self.global_parameters.algorithm == 'inversion': do_spec = _phd_mi_noso_nosp_nosym.run + elif self.global_parameters.algorithm == 'correlation': + do_spec = _phd_ce_noso_nosp_nosym.run else: LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not " "an allowed combination.".format(self.global_parameters.spectroscopy, diff --git a/src/msspec/spec/fortran/Makefile b/src/msspec/spec/fortran/Makefile index ad5e58f..01228ea 100644 --- a/src/msspec/spec/fortran/Makefile +++ b/src/msspec/spec/fortran/Makefile @@ -1,6 +1,6 @@ -.PHONY: all phd_se phd_mi eig_mi eig_pw comp_curve clean +.PHONY: all phd_se phd_mi phd_ce eig_mi eig_pw comp_curve clean -all: phd_se phd_mi eig_mi eig_pw comp_curve +all: phd_se phd_mi phd_ce eig_mi eig_pw comp_curve phd_se: @+$(MAKE) -f phd_se_noso_nosp_nosym.mk all @@ -8,6 +8,9 @@ phd_se: phd_mi: @+$(MAKE) -f phd_mi_noso_nosp_nosym.mk all +phd_ce: + @+$(MAKE) -f phd_ce_noso_nosp_nosym.mk all + eig_mi: @+$(MAKE) -f eig_mi.mk all @@ -20,6 +23,7 @@ comp_curve: 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 eig_mi.mk $@ @+$(MAKE) -f eig_pw.mk $@ @+$(MAKE) -f comp_curve.mk $@ diff --git a/src/msspec/spec/fortran/memalloc/allocation.f b/src/msspec/spec/fortran/memalloc/allocation.f index 11ebe7e..84aea9d 100644 --- a/src/msspec/spec/fortran/memalloc/allocation.f +++ b/src/msspec/spec/fortran/memalloc/allocation.f @@ -25,6 +25,8 @@ USE OUTUNITS_MOD USE PARCAL_MOD USE PARCAL_A_MOD + USE CORREXP_MOD + USE GAUNT_C_MOD USE Q_ARRAY_MOD USE RELADS_MOD USE RELAX_MOD diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f index 04413c8..ca093dc 100644 --- a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f @@ -13,7 +13,7 @@ C C H.-F. Zhao 2007 C USE DIM_MOD - USE Q_ARRAY + USE Q_ARRAY_MOD C INTEGER NAT,NGR C diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f index 5e963ec..3302bcf 100644 --- a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f @@ -14,11 +14,11 @@ C This is the double precision version where the values are stored C C Last modified : 14 May 2009 C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) C USE DIM_MOD USE LOGAMAD_MOD USE GAUNT_C_MOD + IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER LMAX_T C diff --git a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f index ca0b771..e1670ea 100644 --- a/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f +++ b/src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f @@ -577,8 +577,9 @@ C 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) - STOP + WRITE(IUO1,57) +CST STOP + GO TO 999 C 8 IF(IBAS.EQ.0) THEN C @@ -1325,7 +1326,8 @@ c ENDIF C IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) IF(ISOM.NE.0) CLOSE(IUO2) - STOP +CST STOP + GO TO 999 C 1 WRITE(IUO1,60) STOP @@ -1392,7 +1394,8 @@ C 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,5X,E12.6,5X,E12.6) +CST 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) + 9 FORMAT(3X,F9.4,1X,F9.4,E18.6,5X,E18.6) 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ', 1': (',I3,',',I3,',',I3,')') 18 FORMAT(' ',/) @@ -1694,4 +1697,4 @@ C 1 ' ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4, 2 ' AND ',I4,' ARE IDENTICAL >>>>>>>>>>') C - END + 999 END From 4b75be2045000cb0656bff73e84c32be8a85bdf7 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 15 Feb 2022 15:34:30 +0100 Subject: [PATCH 22/43] Changed 'python' command in sdist target. The 'python' command might not be the true interpreter. It is better to use the provided PYTHON_EXE command. --- src/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makefile b/src/Makefile index ad3ab91..0e8bf39 100644 --- a/src/Makefile +++ b/src/Makefile @@ -11,7 +11,7 @@ frontend: $(INSTALL_PREFIX)/bin/msspec dist/msspec-$(VERSION).tar.gz: VERSION @echo "Creating Python source distribution..." - @python setup.py sdist + @$(PYTHON_EXE) setup.py sdist $(INSTALL_PREFIX)/bin/msspec: msspec.sh.template VERSION From 9787e99d2e0c70e771e988986a21e08ac2bee0a9 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 15 Feb 2022 15:37:28 +0100 Subject: [PATCH 23/43] Added the binding for polarization keyword. The polarization keyword may be None, 'linear_qOz', 'linear_xOy' or 'circular'. The IPOL parameter in spec.dat is set accordingly to 0, 1, -1 or 2 respectively. --- src/msspec/parameters.py | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/msspec/parameters.py b/src/msspec/parameters.py index 8a682f4..3b4b40c 100644 --- a/src/msspec/parameters.py +++ b/src/msspec/parameters.py @@ -19,8 +19,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/parameters.py -# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 -# Committed by : sylvain tricot +# Last modified: Tue, 15 Feb 2022 15:37:28 +0100 +# Committed by : Sylvain Tricot """ @@ -839,6 +839,17 @@ class GlobalParameters(BaseParameters): self.phagen_parameters.calctype = phagen_calctype self.spec_parameters.calctype_spectro = spec_calctype + def bind_polarization(self, p): + if p.value is None: + ipol = 0 + elif p.value == 'linear_qOz': + ipol = 1 + elif p.value == 'linear_xOy': + ipol = -1 + elif p.value == 'circular': + ipol = 2 + self.spec_parameters.calctype_ipol = ipol + def bind_spinpol(self, p): if p.value == True: LOGGER.error('Spin polarization is not yet enabled in the Python version.') From c455b3bdfa1ef9391d9e02f4e7d44da03e51d764 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 25 Oct 2022 16:21:38 +0200 Subject: [PATCH 24/43] Fix bug with matplotlib > 3.4.3 In newer versions of matplotlib, the autoscale was not working. Changing "autoscale" to False simply fixes the bug... --- src/msspec/calculator.py | 6 +++--- src/pip.freeze | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py index ff0e313..f3a58e4 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: Wed, 09 Feb 2022 19:08:22 +0100 -# Committed by : Sylvain Tricot +# Last modified: Tue, 25 Oct 2022 16:21:38 +0200 +# Committed by : Sylvain Tricot 1666707698 +0200 """ @@ -749,7 +749,7 @@ class _PED(_MSCALCULATOR): view = dset.add_view("E = {:.2f} eV".format(ke), title=title, xlabel=xlabel, ylabel=ylabel, - projection='stereo', colorbar=True, autoscale=True) + projection='stereo', colorbar=True, autoscale=False) view.select('theta', 'phi', 'cross_section') diff --git a/src/pip.freeze b/src/pip.freeze index 196bfa6..406ab63 100644 --- a/src/pip.freeze +++ b/src/pip.freeze @@ -2,7 +2,7 @@ ase h5py ipython lxml -matplotlib==3.4.3 +matplotlib numpy Pint pandas From 6785e7228ac3a82aaa7bcc1f5095c6e733e8487b Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 25 Oct 2022 16:24:23 +0200 Subject: [PATCH 25/43] Fix attrdict issue when building wxPython>=4.2.0 When building wxPython, the "attrdict" package is needed, but is now incompatible with Python > 3.10, due to the "collections" package. The workaround is to ship a patched version of "attrdict" along with msspec since "attrdict" isn't developped anylonger. --- Makefile | 20 ++++++++++++++------ thirdparty/attrdict-2.0.1.tar.gz | Bin 0 -> 10902 bytes 2 files changed, 14 insertions(+), 6 deletions(-) create mode 100644 thirdparty/attrdict-2.0.1.tar.gz diff --git a/Makefile b/Makefile index ac7394b..69a0d0f 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ include src/options.mk -.PHONY: pybinding install devel venv doc clean +.PHONY: pybinding install devel venv doc clean _attrdict pybinding: @@ -37,20 +37,28 @@ light: venv @$(INSIDE_VENV) pip install src/ -_build_wx/wxPython.target: +_attrdict: + # Check if virtualenv python version > 3.3.0 + # If so, install the patched version of attrdict used to build the version 4.2.0 of wxPython + @$(INSIDE_VENV) if `python -c "import sys; exit(sys.version_info > (3,3))"`; then \ + pip install --no-cache attrdict; \ + else \ + pip install thirdparty/attrdict-2.0.1.tar.gz; \ + fi + + +_build_wx/wxPython.target: _attrdict @$(INSIDE_VENV) echo "Building wxPython for your `python --version 2>&1` under Linux $(DISTRO_RELEASE)..." # Create a folder to build wx into @mkdir -p _build_wx - @$(INSIDE_VENV) pip install attrdict sip - # TODO: attrdict is no longer compatible with collections package. The build will fail # download the wheel or the source if it cannot find a wheel - @$(INSIDE_VENV) cd _build_wx && pip download -f https://extras.wxpython.org/wxPython4/extras/linux/gtk3/$(DISTRO_RELEASE) wxPython + $(INSIDE_VENV) cd _build_wx && pip download -f https://extras.wxpython.org/wxPython4/extras/linux/gtk3/$(DISTRO_RELEASE) wxPython # Build the source if a tar.gz was downloaded @$(INSIDE_VENV) cd _build_wx && \ if [ -e wxPython*.tar.gz ]; then \ tar -x --skip-old-files -vzf wxPython*.tar.gz; \ cd `ls -d wxPython*/`; \ - pip install requests; \ + pip install requests sip; \ python build.py dox etg --nodoc sip build bdist_wheel; \ ln -sf `readlink -f dist/wxPython*.whl` ../; \ fi; diff --git a/thirdparty/attrdict-2.0.1.tar.gz b/thirdparty/attrdict-2.0.1.tar.gz new file mode 100644 index 0000000000000000000000000000000000000000..ec2ae4e7684434d3f68aa2dbcb411739eb930112 GIT binary patch literal 10902 zcma*tRZyL=+9+V$T?)nBwJk0ScP|db-Q8gU#jO-~EAH+Tm*VbP+}&Y)r+feZoQrdH zW-`f4=ABHE$wl(yC67iz8X4Czg#nD+++578P2E^Ov2n0*vbh<%K%M*hdagC6I06SH zJx^J_v_&|q&ns3bmgT%k1=erc&2#IUmGi+8GA4>Y`Qgl^k4JTHDGzWrm0cb;p=9EH zmK|_f4nyp0WNC7UU*XTlp*`m|-mYW7UbLKLOL98S63|(2XZ66FOumigO^vV+kIarJ@@bJ^#x^3rpRexSzC^qxw|vo zE-x?sTH1nJ%0PO2>5k`ij^`JbXZ9`I0k*!rzJNgUYuXKa;xf6!pHVkYA%MPXy*mW5 zr8f_(6+ysw@7?Biz{TX;!NnYTv#vvfIpu zs#34Xxl%_i#d%xMYe&@=LLY!vpAQ5jI3BBca%Wae9B|Wt2gTX3Sgy>eK8AyPd;`EK zNM){#3K*rkj0axa#B~G^M9Q@@u{Tq?zMy!P7;UUjYU~D4yv+z+Y%+N&4ZCdY&tqm7 z_}9=hsmoM5#_(%8i5@&H0X-l(TKQpsCkKXu!{Hk5O4Rs`Nuzp~rgV4~AHKeO#+SRalD36J_bbvU zhww%x-pDa6OR+>X%ZRbVgRzSA0f4-MiK1cih$t+U1aqV#OBaHS)=m3$czbBd^E9g| ztdwy4jl>D3D2RHdsafBg)GZICvk!-*we7N1VJo2thh{=(O`#>}8?epkipsLM`bvz36Y zgXH!~H|~v?N{n!$-usIwELnXSs1@Pj1nN;Z+y+ooeQlvRkYzBT@Bnke*fdQL8lXQ@ zME>RLxc}ZmWnjpGJ*>)5kdAhs;)VsawGk&-%12;hF}K{k6FD-5(v)Sq=E;*Oa#W(T zHgyoLdQ^{*gsni8{sm#ij0lN=@db&RIv#!YMvaqTAeDMXqBJRU^^?*!?A@c zv-vDBwk8gDA_LwC=?s_OE(eln9s?dHfnZ8clO6Xx?@de!H6e{zY%fck^PcDk%?&+L zG7%TT3DnmRj+ASzgIin%%!vK1z)?nf*JB_R0+_x69aR>`0JsAJoL=nA{283teE}vm z=7Fu%wKZx0>{xOKkni%x6yGkB$Kq;|&X06iPW9;fZXc2a?;IHKb{9A^^jf=3N(f%l zt~hbLnPQ_}`AWsZkzDb&28-p{lgD@~{C0zT@SiL;x}Q0E#Jvc&+U0v%n`?t*`~!}k z;b_~hqp%E=|A_7vhv7d{g5GmoQy@_1obPHkUy7rA)dS5AmzyrVZ5{L-8pDspYPmLs zzxBg+qXT2&@!g)>ryvyZ)8Xw4H1J%PL;KlXvdB(MQ zrY&%b*!`i|_xa>*g7!P!VRqt};qo!+BHwf9`@E31fu%HXc=mSmH#j>-U}LvoX@k0T zNr=zy{lNQikJcCASxJd~<@Cb&5eKD9&|Ev8t=!iwD3p{udpBdq{7~o7{qZKX{kFi@ zJJ|d;uaG6F$0A?%8QE{|4L(at$H^%r_PD&4LzOex$Gt(mc^5Z7HkjE*D0h7Wf|?7O*$_Uihyruj+k$f;V^th1vwebKQ^jpUpGw?H~V^PVyga zpwf&)-_Gr}f8PrsDN#q-6W~)TqA1gGkf1<@1h_gUeHh6hcQ+8%;Si*6+hKmco(0(7 zfqzvE*ct#@U1$BB-JFkKc78nr69*4UGl1j8Wy-(Pt-m^Ks_Zm+Xx43#o}`=C2>dVu z0x|m=6v85k67OWt@2n*7tU&eH8*;t=kgM#tqu&bQ zlLOul7rVpJ%o*@Q&0w47%p<|VXI$AHmF9Bv?vr$IM!**^ zBgxWGSfv0946+e^-r3%!hC9EWHg|Q z-QZKWkQ2t!LYgc)5p2pRH{ysk#}oIl(naFZ$`zDlz7g>r>cee>u-R72=}qjr4I**| z=4kP-#Tk&38i?`r+TqL+aZ;B~bUTWKRR{C@oG*e&!euTNA)|=f;13oI^g;^Gzk=Ey zG>Rn`$NkQiNog@SeROGeqO4dxp2k~3#B-N$CX(V4B8jNVaM6gz^xk6{DnO(K6Oy60 zaV!Y$$T!t`hjU0r-38E;2EO1*-{7QRFFmCzHRKVy`JVsV{vYXKGm z9=bE3HwWph6F2s@gDM9$T3tl4L3+@A>^?nR$N}M|Ic+4(IQ18o=BmLr|-O< zrWu&9Z4krZ{i2Zpbexa#No<2nzM)lvd8ATjf<|c7UJDoLPSVq#Ybm*w)WQ=sWK!SZ zPFBevN$6~x%@tB|P5;hTqugVkSm}(_)Bwyc5qzZ-l!$2L+6{M>42GgwhtbG^lNeD( zJW28I+kD|u305#>l9lTuI$y$}LIsy4?R)Nce~!z*T#DjMf6XK7twTL%cQ$MKL>!vT z_F1$$QI_)SUEK|1gJe9$#7|V^*!^dultXjhW9pTm|(~}g=R<;5g7t$;P=hb zDPtp*mO!^2#P}{ARO8W|$edrps^a>h9q^^NNXo4_G)&eTwKwbOgj|X8VH;hD*qi%h zDpRF5KUTs=OCA|@!kDD|B;lWp<%*jF;s_!F($p21{B#=_WVUM6hudP}gESiXNxSjJ zQ8MV#zlQDwV9APt^R<_mSj^wsO`Wpx@I)~4o`-AQ4P$x-zni?EM9K0F)z$LZpaeCwp&&tVr6=7Drk8^qD~kLDr-5WlRN3 z+V)O=2D|F3vck`lnWp@TM?XU3sHrEzU@FGzi-|(^S z+q{sJl-CRZPmT0OiGQ_J9k1V^(CT!;jq(#jqV{RKAFgsVnW#vBg9M45jxq8}sdN+3 zM7{I3gQkT~rg*1n-%yZ03&jf+* zi#X+nD?E*``b^89;nh$)QV5sLAf}!ZvG7Hr&Z>NTQ3>=2&P^wgPy(6ig;0dz99Y!3 zRDOQu>92wRHs;S{Kx6!;AmnEp>@~`pt%m$Vf+)Kq+pk*aZ`NqNf#y+lTgs7;7d5T-xU6Z z*D6XiP+gZ*_N)r2NPQ0i+F!nI^qLFewmm$0BLOqnp7;i3pHG#^fsm6a-(kKF*GNOm zUvGL6<;v#b30X@v?8H*MKGCmk03Yyfib9#`d!_8r}L#M*+!X}zW){T~rW|h!tPbOW2NLu7M zJG{gdiY*yDt5Nl`hXvoA&(UW$DeJ&qHPJr}2+3w-C3KGac^T-IQi8!q4yLgg3*VlP}-=K~p?MCrmK-VfuNwo3tnQ^5f+_nOsrh z$${lesrf!+vv@YO7%PF^{~L3rG4B+M^0M+k$e9XKxzrS5gI4Fr*0+-jm^D_f>Sgpb z-=b%UN&mrwBtR}kVL;?^;cb=asoJL~`iv&!zy!Mawj8(BCZ$T95V9fm^-}(}9P`Nm zHXeId!xsI;qQ4>L~Ho z$sZos($G&D&`Lfkv1*{t1cgiT_k+;*a7<`tq>Q8-uCjvS8t*IbH4S21m_$n;k=T|y zgv8k=3zQc@)aVeoXj|oKgS@osqAx;1h`jLQ#J}BT}rU2pDK>b?q-u^Q?Eu>@~_z?pzK7yI=K_@^3Gw3d{ zg4vTF7=6mMa77Fe>IT*zi<<$FfOm|oscFA#9Suj&fPIEDiUd?Tmv)L9juLZdz!}55 zoUmA2=;1U|HRH5cm5~>1?uaf2bAcWT^1WC|wp`5)|KtMxm%9^`;@_7{?PU5ovZ)#4 zp2_()kTrFmqIdT5ZXsZ8bA#>t-^G`w$>tsB0APFVZt2dR0CatMfi?Ciu$RQ^mMkZ1 zt5SK88=i^$l0+(rv_<-(C>~s}U9+1v*yyYdqm3^P!upP>G(&y`%Ih}%WTwH+xt(6* zL9(DL@M5)JRaRtWM;74GN0m}JEw5{A;IWpNFI%B-v1`MZ}_kdj4^9f!soVLEA_mRZED!N91=KEzC&pHI6NGPQt>3(R@m3 z(1s=>*PBMK{r7xdT1hdetWk~p?qqnBc}PZV3?LT5u6}XA8 zzD3tOTIu~L>F%Y}#Lh8@ufKE@V#IeHRHv^H3{sh(5^0NNkXyWy(m8c>1N({#W1HH) zE%BhvbGImlS7{o?N(6@}>EIvNb#9RE4_jXK-ywa7g$=EA7{aAjrCQ~WtIAZ6bZU+q zU#_dbRJ9L#I=+>Wm?4g^DtF+GA@0|*PpJ$$fvlkxoE{fUPRU4R&k$Pg(18&_Kj)Zi z)3QI7Ilg=o(H=D8#W3m=d^Vo8-S}*y%E_l2y?X?zdH3ql3nvzYrFlge{yrXP7bjNF z>@<-$o9dT!LJ{!py}Ku_gul_1FNt)+Od8V=-`T2e-8$ET1&M3P{7l;Eoi(9fvf$pn z;8epC3(wtEThe(2Up9lt)cZ`ZosNo|&NiP!R1JBcYw~Bwx{~Fad5PT!E3_Nk&||QZ z<$}Hzx83mequ4FyyuD21*1bqTxjF5U{`%(>`e(K112R4RZ*uv%n2sU%ly~Hu@6HZ^(T7>*$7>?;Yha z({&o{sE8k_kc)!P(Jq-xsxO=@d}TzM13}Zcg2llho}jh&&alflMZ*w}-Rjt1=h!HA z8xLPW3gYr!qYp6eg7@#kmw;Kq@k4g#O?L?M&>PBi_q%3=KH%GV4`PQGDgLJ{22^@P zqk3I#mNk#8Y`ex+RkdN^70TLH*;P729n#E~+O@uYyVzbx$~pR5e|g5};~N;q&lL3L zN986I8wfu0KYHX_O2Lb0{zl|gik8F(@gHO4g4*k0i^BFs%EtbY*@UH%%K;<1E4}b`OE%sfY2*|a|;Chmd04}#b;{sbY7iw?d z?ic`+1AwIi-)5-akru|Lu(l^HC7v#`2-mS2fYY!&Ag{*r(&-I!|F#z`)pKe0r<}v; zBPPURxAzA&{JUNN56x5P$@k{sGzrf2kc(2S81GU~j1G8oL60h&c5!ZeYzF=&;|ZrQ zy}+XtRxXK4?LYxmh4)@}ig_jL04w~PyJMj5;qN43eO^SK)Ov}y{clO%@vG;XkAK5d zA2hYOv&pNG;~+YeGgFbC5P4Q5L7SfIT!ApFP$(^lHxzj&!#RNY5ZHeM@c@8vNfwZL z3n;EK?naM8F5>{M$H#_e;KL}ex%uG12Y@@D$j==Y2yZeYI#q-?HP(s*jUI9{N4{EQ z4E>5NGF%WrOKdN%;s_n?`VD8Fn(R=O{@aZ(NSx;br|zyS`N8><*x%R)*bTXchSZz7 zX?8_{f|sJ{(NXB04~^CcQCqV)s~9-uYS#0=4K}e?equB%MUv@ zYj!p@PPDrJJ@4PjLpC$Q7BOa13}*C_5nILoO0SF3QKBr?Td>io3}{Hcp_g#smOa2P z3M8&<6ifI_Df{JUtkgzLb&@SeeXbjrU!-x=F^>vhwrSv>9w|4_ATFBJK$P50Ij#`6 z?oRax&LIx8T@0TW_{DPIU8mUvr{46zwf?3apLA8eF=Dp}>5Czn;iP_u%2()y+cIiB$L z`;A!I3mc_6`9n6sEUCSivNU(XhbJ3K4VkjdtWg0bDWt@o(h)7zoS5i{PEzUb_wvOZ zPD7@&a`66QHeJ5Jk=VU%W1e1w(0}KQ**K`V9Fsfs9{L3di106w36Xz6OY{7Zo;~xD2mDYO~CdqGN8wjuGi3|Qb+1sdx zWZL2b$4%?W=4o({ggFTk0lDnl9*Fid9Oe(yUC1V<+e~;{a};O%mwU^A?J`$rG3U%M zkqJu7U|C`8XiJGQ*x)M?`e>AA{AUm)O`h30W>A;7`}{~2V}uwd#hg^K=^}AhC|0Fg z(xc)YlPZ}u4f!zsMl8QsiZo9B+NZ4@Y7A^teD-(cUca(u{rVU;`bsG&t* zzG@@62T&8J62}j=3Lpt%K1<}H_M@v)D0A6fUA^m9%@YK{F@+lt%l=yZzy_l%PSuut zqJoAxq=HyS=0qX|s*CHWrKMt($+i&n)l>J!7hBXYO?jizv_IE-g40(;3h%49kpS)( zXe3`kX@A6yUQ!6=eo7zglIR;z<4)cRYXAGy+>{ZC*E~yv?5O2NR=1{lo7h64eftpl z0<1Ew;d;}Zvdb;gr9Rh^8~xMF?gUnZ=ATyKxu5u3#|-07%c{?R!tWor(7441c|kD& zjnsh`8TrEY(7z#}KD+Ufaw|Vw6LRi~2Z|h0bWv?mY*4*aP1Ri_NX6DkOU}$PR+-FAY*vYtIYsp>&SYP(K_Rn@&I@H+>Gp3Q7^|Y` zh7ZV+CR@AWn7r^mFrnb1k6c*Q;JC~A48(E|98v1n4lSw)NQ%p_t~6c(i&CA1{y7t@ zhF`2DnL~wn_x@1h7YRK??*-j49~-A8`fR$P6_?53=VsgH``ynYRuu?KCic+II_ z1()PLx>3OwG9`sHAQH8Uxqhs-PVh__N3LN`pR-V)nRRI%XeN6TZO1ul)U6yIk4k}O zh=TckT)}Iqxkt}LQHy$U=kLd<9^_`z^p~58djTVjJ3nKGfD**}CB<0AQ?O30iQp_M zKPI`IVl7~2%&_#rnS4@I{@wpI7sq$@ zPu2I4Me4u>)Zh<0^`3C%C*6AIY)`8+S;BZmwQMX92Skd(8uCDJ8F z=q3-T+S;J6n}m4y*F;#fq^p_?Z}}1iT{B4;ZTi7i8(h}1$_ER2N+p8kN>i@DRpEZX zS9}v3Ow9Zy_-%~F&WX1dt1*G)tyv>nl?Dc6>mktSOZ!6G#;MvHKs7aI{0Eg-Wpk!0 z{4>zsw%VyxYv$QqGc*Ig>aU@xSrQA@(1e^017o+jkj5vlH{|O_z%T~rF!^Hhw8OFb zCUyhV-sV0$cs%@zkbBcA1IUU0@%DS;066&tGzVCMy6oJP4YC4+-j*D2f0w*;w<*7N zCqLB;w>h2v*+q7IV=<9ceP(Uh&*~W{$fl|$IsM2H>B^a@a1~?TK%1$Ht^d3IjwvHz zDCtLDt8;>axv#4$+#gGSPb@|5*Y8{0a}C-2pVNqj?H^b^@!#y2hwDKjlDAHeKQ2R_7QH9TybNjm9%>6lD!wolbfJ_e~&AU2N z2V2Qi^b>HTX2~u(H25zXZNy`8tS8BD4$=}~?&^G=q9;)jV1;E!lCK~RWK?2rul$@n z#L@70)v_ThFs4HiYa*P!ozY`U7H1*Cr2ys*j|+dYKg~bhct<=~4lsIg2v|dJbuIn( z@Zqz(ZD{*AH-rib4D#O)669~=bxFjGG{rESR5F~rXl1*lA949OMa$WJZEm{Vp(;39 zm(A=b1*{-S5yxQCk));?Kdd8UbKv~(zah9`EAz#gF}4YEd$;=hVNT`%W%p>8KoZe^Vf;t_gZ8%gU$1J-h@YJP$|GFiU3_i>dPIwT8Y{oy#rj*EILz|n z0#Uo(IGt8h_xK18`(_+oT5sM|_xl;j8+D4NcIA9%1f;#N{YzdCE(GM>Hhs1WkC0&3 z)Bo4LX<6Ck#0uiz!i2NG3jY_rW8!o16c4Nl(kA0aVaqTp@Dm5JZ)H`=j1R+mstK*W z!4>Ib_wQBji96#cEO;wd5S&dH4fhhph&^o577LjyhRhd^#zeXjF)Mk=dQiv<^%cMhR=u;y=g(paYPNpX zc!5LW%50x&D_e8UaX!XeCPofEW;v%(rz{l38xqsL`V-VAxum0fsW>xd$Z4t^TIRDD z1S>?aBzhP#3{w=2-bM~X z*}I(>@;(Yz!-1ycSY|1qszp}jA6MZz6I?w03v=QIRl!aQlPXG+F3uN9k!5lDsbA)!zv-Kd&aT9dg!)#q>$9`{Zl z9q*GQIdkqOJ+u68|0CBV)JT1(|B-7xy1bmN@?mXl3Kle@dLsPWup^t9p&a{H z5>qp~gioJ-`Y0PuBcsH1r2J!RA@o%NMl*lx(g2?S7p*zgSuFjddh_l%%xq2%-K?OG z0t;=_cIGl9MPI^-_$SRn&?-4BKh9e7q9zBRy_q>|0t+Q#SHb0U^*kthSBI)ZoLo`hPg+TZ_98HsWZ3m=0WxF8pSAy-k5un5gv zz;n$Az3sq>Q;htBVZZW!>DqzM3R^QagD(VYWLi8KDhw}w-Ni1RI_se>N{ywX{}rb* zLxSRyK-N~m>Zf1PkzTsfYjxylWO8oauPV#>T@)hxxb=L+bMeVNCRRPyU~W7k_h$k568lX!dC+1{5?eJVKXS*OQpdq80`4#=_LsNbfsTF&FXSVGj}d%TMRS( z3i-MSA@(2TqPYB^_nJQXKIVa*k~IKtU5X~uRRjh4%omXrFw}fk9U0Q5Q%Q2F0GYV5 z73B#x05ZNgfmQothLO7jNEQ>ay;sIE#~AEHw1~txjM8T`e&>f7u$0sYyN(S<&i@^$ zzr@tG{ivwd79c_$NIbm9emDM;TPV%pC#Z<7N=|ut4b;GR|}S?l8*5s)-kD^G4>%A`5L^haIBz!8a(&*&H`pS>I_qHW^H^fu4LVCST8RpiB;!8 z)RloZ*6XSGUUadKecH7tUY4Y}@y0^bRJp#jrv5UECw4y9WQaEqwYB zJ;!qxE=@q__Rjx=>4ngjvjc2DYr1;+Rt$gzhuojaU2oLTYfOiiehAQS5J(fGR+IDp zPiB(?3$C=|l&JBx6jcwXWS;3SH(?wJuCMECcHy`xaa*PjS$wx8Ip6WW51JvJ|>wt^_>>Hua&q5%{OW zHQg!ihQ+YmweR7%@UPuXTTD}cPf`Wmy$i%}6_|zmH%|VaA-6rt-2xV_B}Rarp1{N` z1T+--dYYo9@_&Ph-VM8bo|DhO6}*6>{blL{pgP=*_xztB0KI0QLqIvR<6joue;vBp z&h5tF6j&3`>)3{~yF53319#}G0@7`As_g%9YWY{kGr*yu5!kAIH;lV{fw}2kgj}9| z{5Qeyhwi3sO!A_4aESal!)KgHj_swti1aaqPV>SBtWG(Oa{Tcw%XraLfN(36}{{WNkmjeI* literal 0 HcmV?d00001 From 6f254e688e0a431cb066bee16faca75442894170 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 26 Oct 2022 17:15:24 +0200 Subject: [PATCH 26/43] Change the version mechanism --- src/msspec.sh.template | 9 ++++++--- src/msspec/version.py | 15 ++++++--------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/msspec.sh.template b/src/msspec.sh.template index 38cdfca..bb250fb 100644 --- a/src/msspec.sh.template +++ b/src/msspec.sh.template @@ -2,12 +2,11 @@ SCRIPT_PATH="$0" SCRIPT_NAME=$(basename "$SCRIPT_PATH") -VERSION="__VERSION__" VENV_PATH="__VENV_PATH__" # Check venv path if ! [ -d "$VENV_PATH" ]; then - echo "ERROR: Unable to find version $VERSION of msspec!!" + echo "ERROR: Unable to find msspec!!" exit 1 fi @@ -15,6 +14,10 @@ launch_script() { . "$VENV_PATH/bin/activate" && python "$@" } +show_version () { + . "$VENV_PATH/bin/activate" && python -c "import msspec; print(msspec.__version__)" +} + show_help () { echo "Usage: 1) $SCRIPT_NAME -p [PYTHON OPTIONS] SCRIPT [ARGUMENTS...]" echo " 2) $SCRIPT_NAME [-l FILE | -i | -h]" @@ -92,7 +95,7 @@ while getopts "hvil:p:eu" option; do ;; u) uninstall ;; - v) echo $VERSION + v) show_version ;; *|h) show_help ;; diff --git a/src/msspec/version.py b/src/msspec/version.py index 7e6ff1a..bcd00c0 100644 --- a/src/msspec/version.py +++ b/src/msspec/version.py @@ -17,12 +17,13 @@ # along with this msspec. If not, see . # # Source file : src/msspec/version.py -# Last modified: Thu, 06 Oct 2022 18:27:24 +0200 -# Committed by : Sylvain Tricot 1665073644 +0200 +# Last modified: Wed, 26 Oct 2022 17:15:24 +0200 +# Committed by : Sylvain Tricot 1666797324 +0200 import os +from setuptools_scm import get_version from importlib.metadata import version import subprocess @@ -34,14 +35,10 @@ import subprocess PKGNAME = 'msspec' try: - __version__ = version(PKGNAME) + __version__ = get_version(root='../..', relative_to=__file__) except Exception as err: try: - p = subprocess.run(["git", "describe"], capture_output=True, text=True) - if p.stdout not in ("", None): - __version__ = p.stdout.strip() - else: - raise NameError("git describe failed!") + __version__ = version(PKGNAME) except Exception as err: try: thisfile_path = os.path.abspath(__file__) @@ -51,4 +48,4 @@ except Exception as err: __version__ = fd.readline().strip() except Exception as err: print("Unable to get the version number!") - __version__ = "9.9.9" + __version__ = "0.0.0" From d1e52eae862ca59788e67cbe29b1f4ef4726f702 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Thu, 27 Oct 2022 14:45:38 +0200 Subject: [PATCH 27/43] Switch to pyprojetc.toml The packaging uses now the modern pyproject.toml and setup.cfg files. The setup.py is deprecated. --- Makefile | 15 ++++----- src/MANIFEST.in | 6 ---- src/Makefile | 6 ++-- src/pip.freeze | 12 ------- src/pyproject.toml | 3 ++ src/setup.cfg | 54 ++++++++++++++++++++++++++++++++ src/setup.py | 78 ---------------------------------------------- 7 files changed, 68 insertions(+), 106 deletions(-) delete mode 100644 src/MANIFEST.in delete mode 100644 src/pip.freeze create mode 100644 src/pyproject.toml create mode 100644 src/setup.cfg delete mode 100644 src/setup.py diff --git a/Makefile b/Makefile index 69a0d0f..d0dfe5f 100644 --- a/Makefile +++ b/Makefile @@ -11,19 +11,20 @@ pybinding: venv: ifeq ($(NO_VENV),0) @virtualenv --python=$(PYTHON_EXE) --prompt="(msspec-$(VERSION)) " $(VENV_PATH) - $(INSIDE_VENV) \ - wget https://bootstrap.pypa.io/get-pip.py && \ - python get-pip.py && \ - pip install --upgrade setuptools && \ - pip install -r src/pip.freeze && \ - rm -f get-pip.py + $(INSIDE_VENV) python -m ensurepip --upgrade endif +# wget https://bootstrap.pypa.io/get-pip.py && \ +# python get-pip.py && \ +# rm -f get-pip.py +# pip install --upgrade setuptools && \ +# pip install -r src/pip.freeze && \ + install: venv pybinding wx @+$(INSIDE_VENV) $(MAKE) -C src sdist @+$(INSIDE_VENV) $(MAKE) -C src frontend - @+$(INSIDE_VENV) pip install src/dist/msspec-$(VERSION).tar.gz + @+$(INSIDE_VENV) pip install src/dist/msspec-$(VERSION)*.whl @echo "Do not forget to check that $(INSTALL_PREFIX)/bin is set in your \$$PATH" diff --git a/src/MANIFEST.in b/src/MANIFEST.in deleted file mode 100644 index cfb311f..0000000 --- a/src/MANIFEST.in +++ /dev/null @@ -1,6 +0,0 @@ -recursive-include msspec *.so -recursive-include . SConstruct -include setup_requirements.txt -include requirements.txt -include pip.freeze -include VERSION diff --git a/src/Makefile b/src/Makefile index 0e8bf39..668d735 100644 --- a/src/Makefile +++ b/src/Makefile @@ -11,14 +11,14 @@ frontend: $(INSTALL_PREFIX)/bin/msspec dist/msspec-$(VERSION).tar.gz: VERSION @echo "Creating Python source distribution..." - @$(PYTHON_EXE) setup.py sdist + @+$(INSIDE_VENV) pip install build + @+$(INSIDE_VENV) $(PYTHON_EXE) -m build $(INSTALL_PREFIX)/bin/msspec: msspec.sh.template VERSION @echo "Installing frontend command..." @mkdir -p $(dir $@) - @cat $< | sed -e 's/__VERSION__/$(VERSION)/' -e 's#__VENV_PATH__#$(VENV_PATH)#' > $@ - #@cat $< | sed 's/__VERSION__/$(VERSION)/' > $@ + @cat $< | sed -e 's#__VENV_PATH__#$(VENV_PATH)#' > $@ @chmod 755 $@ diff --git a/src/pip.freeze b/src/pip.freeze deleted file mode 100644 index 406ab63..0000000 --- a/src/pip.freeze +++ /dev/null @@ -1,12 +0,0 @@ -ase -h5py -ipython -lxml -matplotlib -numpy -Pint -pandas -pycairo -scipy -setuptools-scm -terminaltables diff --git a/src/pyproject.toml b/src/pyproject.toml new file mode 100644 index 0000000..60ddec8 --- /dev/null +++ b/src/pyproject.toml @@ -0,0 +1,3 @@ +[build-system] +requires = ["setuptools>=45", "setuptools_scm[toml]>=6.2"] +build-backend = "setuptools.build_meta" diff --git a/src/setup.cfg b/src/setup.cfg new file mode 100644 index 0000000..ce2c01f --- /dev/null +++ b/src/setup.cfg @@ -0,0 +1,54 @@ +[metadata] +name = msspec +version = attr: msspec.version.__version__ +author = Didier Sébilleau, Sylvain Tricot +author_email = sylvain.tricot@univ-rennes1.fr +url = https://msspec.cnrs.fr +description = A multiple scattering package for sepectroscopies using electrons to probe materials +long_description = MsSpec is a Fortran package to compute the + cross-section of several spectroscopies involving one (or more) + electron(s) as the probe. This package provides a python interface to + control all the steps of the calculation. + + Available spectroscopies: + * Photoelectron diffraction + * Auger electron diffraction + * Low energy electron diffraction + * X-Ray absorption spectroscopy + * Auger Photoelectron coincidence spectroscopy + * Computation of the spectral radius""", +keywords = spectroscopy atom electron photon multiple scattering +license = GPL +classifiers = + Development Status :: 3 - Alpha + Environment :: Console + Intended Audience :: Science/Research + License :: OSI Approved :: GNU General Public License (GPL) + Natural Language :: English + Operating System :: Microsoft :: Windows :: Windows 10 + Operating System :: POSIX :: Linux + Operating System :: MacOS :: MacOS X + Programming Language :: Fortran + Programming Language :: Python :: 3 :: Only + Topic :: Scientific/Engineering :: Physics + +[options] +packages = find: +zip_safe = False +install_requires = + setuptools_scm + ase + h5py + ipython + lxml + matplotlib + numpy + Pint + pandas + pycairo + scipy + terminaltables + +[options.package_data] +msspec.phagen.fortran = *.so +msspec.spec.fortran = *.so diff --git a/src/setup.py b/src/setup.py deleted file mode 100644 index 8dd9c43..0000000 --- a/src/setup.py +++ /dev/null @@ -1,78 +0,0 @@ -#!/usr/bin/env python -# -# Copyright © 2016-2020 - Rennes Physics Institute -# -# This file is part of msspec. -# -# msspec is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. - -# msspec is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. - -# You should have received a copy of the GNU General Public License -# along with this msspec. If not, see . -# -# Source file : src/setup.py -# Last modified: mar. 07 avril 2020 17:01:42 -# Committed by : "Sylvain Tricot " - -import sys -sys.path.insert(0, "msspec") -from setuptools import setup, find_packages -from version import __version__ - -with open('pip.freeze', 'r') as fd: - REQUIREMENTS = fd.read().strip().split('\n') - -if __name__ == "__main__": - setup(name='msspec', - version=__version__, - include_package_data=True, - packages=find_packages(include='msspec.*'), - #setup_requires=SETUP_REQUIREMENTS, - install_requires=REQUIREMENTS, - - author='Didier Sébilleau, Sylvain Tricot', - author_email='sylvain.tricot@univ-rennes1.fr', - maintainer='Sylvain Tricot', - maintainer_email='sylvain.tricot@univ-rennes1.fr', - url='https://msspec.cnrs.fr', - description=('A multiple scattering package for sepectroscopies ' - 'using electrons to probe materials'), - long_description="""MsSpec is a Fortran package to compute the - cross-section of several spectroscopies involving one (or more) - electron(s) as the probe. This package provides a python interface to - control all the steps of the calculation. - - Available spectroscopies: - * Photoelectron diffraction - * Auger electron diffraction - * Low energy electron diffraction - * X-Ray absorption spectroscopy - * Auger Photoelectron coincidence spectroscopy - * Computation of the spectral radius""", - download_url='https://msspec.cnrs.fr/downloads.html', - # See https://pypi.python.org/pypi?%3Aaction=list_classifiers - classifiers=[ - 'Development Status :: 3 - Alpha', - 'Environment :: Console', - 'Intended Audience :: Science/Research', - 'License :: OSI Approved :: GNU General Public License (GPL)', - 'Natural Language :: English', - 'Operating System :: Microsoft :: Windows :: Windows 10', - 'Operating System :: POSIX :: Linux', - 'Operating System :: MacOS :: MacOS X', - 'Programming Language :: Fortran', - 'Programming Language :: Python :: 3 :: Only', - 'Topic :: Scientific/Engineering :: Physics', - ], - keywords='spectroscopy atom electron photon multiple scattering', - license='GPL', - #entry_points={ - # 'console_scripts': ['msspec=msspec.cli:main']} - ) From f94426476dcba1f2076004f4a142f6773046159c Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Thu, 27 Oct 2022 16:06:51 +0200 Subject: [PATCH 28/43] Add multistage build To reduce the size of the Docker image. We use a multistage build based on an alpine distro, the size is reduced by a factor of 7. --- Dockerfile | 106 ++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 92 insertions(+), 14 deletions(-) diff --git a/Dockerfile b/Dockerfile index 6c3feba..51a63e6 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,24 +1,102 @@ # Get the base Python image -FROM python:latest +FROM alpine:edge AS builder + +# Variables +ARG branch="devel" +ARG login="" password="" +ARG folder=/opt/msspec user=msspec # Install system dependencies -RUN apt-get update && apt-get install -y virtualenv gfortran libgtk-3-dev nano - -# Add a non-privileged user -RUN useradd -ms /bin/bash -d /opt/msspec msspec - -# Set the working directory in the container -USER msspec -RUN mkdir -p /opt/msspec/code -WORKDIR /opt/msspec/code +# tools +RUN apk add bash git make gfortran python3 +# headers +RUN apk add python3-dev lapack-dev musl-dev +# python packages +RUN apk add py3-virtualenv py3-pip py3-numpy-dev py3-h5py py3-lxml py3-matplotlib py3-numpy py3-pandas py3-cairo py3-scipy py3-setuptools_scm +RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/testing py3-wxpython +RUN pip install ase pint terminaltables ipython +# for GUI +RUN apk add ttf-droid adwaita-icon-theme +RUN apk add build-base # Fetch the code -RUN git clone https://git.ipr.univ-rennes1.fr/epsi/msspec_python3.git . -#COPY --chown=msspec:msspec . . +RUN mkdir -p ${folder}/code +WORKDIR ${folder}/code +RUN git clone --branch ${branch} https://${login}:${password}@git.ipr.univ-rennes1.fr/epsi/msspec_python3.git . +# Build +RUN make pybinding NO_VENV=1 PYTHON=python3 VERBOSE=1 +RUN make -C src sdist PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv && \ + pip install src/dist/msspec*tar.gz + +# Add a non-privileged user +RUN adduser -D -s /bin/bash -h ${folder} ${user} + +# Set the working directory in the container +USER ${user} + +RUN virtualenv --system-site-packages ${folder}/.local/src/msspec_venv +RUN make -C src frontend PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv + + + +FROM alpine:edge +# Variables +ARG folder=/opt/msspec user=msspec +# Install system dependencies +RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/testing \ +# hdf5-hl cairo openblas lapack libxml2 libxslt libzlf wxwidgets-gtk3 openjpeg libimagequant \ + nano \ + py3-virtualenv \ + lapack \ + bash \ +# git \ +# make \ +# gfortran \ + python3 \ +# ttf-droid \ + ttf-liberation \ + adwaita-xfce-icon-theme \ +# python3-dev \ +# lapack-dev \ +# musl-dev \ +# py3-virtualenv \ + py3-pip \ +# py3-numpy-dev \ + py3-h5py \ + py3-lxml \ + py3-matplotlib \ + py3-numpy \ + py3-pandas \ + py3-cairo \ + py3-scipy \ + py3-setuptools_scm \ + py3-wxpython \ + && pip install \ + ase \ + pint \ + terminaltables \ + ipython \ + && pip cache purge \ + # Add a non-privileged user + && adduser -D -s /bin/bash -h ${folder} ${user} + +# Set the working directory in the container +USER ${user} +WORKDIR ${folder} # Install msspec -ENV PATH=/opt/msspec/.local/bin:$PATH -RUN make install VERBOSE=1 +#COPY --from=builder ${folder}/.local ${folder}/.local +#COPY --from=builder /usr/lib/python3.10/site-packages /usr/lib/python3.10/site-packages + +COPY --from=builder ${folder}/code/src/dist/msspec*tar.gz msspec.tar.gz +RUN virtualenv --system-site-packages .local/src/msspec_venv && \ + . .local/src/msspec_venv/bin/activate && \ + pip install msspec.tar.gz && \ + rm -f msspec.tar.gz && \ + mkdir -p .local/bin + +COPY --from=builder ${folder}/.local/bin/msspec .local/bin/msspec +ENV PATH=${folder}/.local/bin:$PATH # Run the msspec frontend command on startup ENTRYPOINT ["msspec"] From cb0b432041516e601b21e8e5e4500b63514915d1 Mon Sep 17 00:00:00 2001 From: kmdunseath <73846968+kmdunseath@users.noreply.github.com> Date: Thu, 1 Jun 2023 15:52:11 +0200 Subject: [PATCH 29/43] Added file src/msspec/spec/fortran/eig/common/save_eigenvalues.f which writes the eigenvalues to a fortran stream file called eigenvalues.dat, facilitating reading by a python script. Added call to save_eigenvalues in src/msspec/spec/fortran/eig/common/eig_mat_ms.f --- .../spec/fortran/eig/common/eig_mat_ms.f | 4 ++ .../fortran/eig/common/save_eigenvalues.f | 37 +++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 src/msspec/spec/fortran/eig/common/save_eigenvalues.f diff --git a/src/msspec/spec/fortran/eig/common/eig_mat_ms.f b/src/msspec/spec/fortran/eig/common/eig_mat_ms.f index 03ee7e7..06896f2 100644 --- a/src/msspec/spec/fortran/eig/common/eig_mat_ms.f +++ b/src/msspec/spec/fortran/eig/common/eig_mat_ms.f @@ -178,6 +178,10 @@ CKMD WRITE(IUO1,*) ' ' CKMD WRITE(IUO1,*) ' ---> WORK(1),INFO =',WORK(1),INFO CKMD WRITE(IUO1,*) ' ' CKMD ENDIF +C +CKMD Save eigenvalues to unformatted stream file eigenvalues.dat +C + call save_eigenvalues(w, jlin, e_kin) C N_EIG=0 C diff --git a/src/msspec/spec/fortran/eig/common/save_eigenvalues.f b/src/msspec/spec/fortran/eig/common/save_eigenvalues.f new file mode 100644 index 0000000..0824c4b --- /dev/null +++ b/src/msspec/spec/fortran/eig/common/save_eigenvalues.f @@ -0,0 +1,37 @@ +c +c======================================================================= +c + subroutine save_eigenvalues (evalues, n, ke) +c + implicit none +c + integer, intent(in) :: n + real, intent(in) :: ke + complex*16, intent(in) :: evalues(n) +c +c Local variables +c + integer :: io + logical :: exists +c +c + inquire(file='eigenvalues.dat', exist=exists) +c + if (exists) then + open(newunit=io, file='eigenvalues.dat', status='old', + + form='unformatted', access='stream', action='write', + + position='append') + else + open(newunit=io, file='eigenvalues.dat', status='new', + + form='unformatted', access='stream', action='write') + end if +c + write(io) ke, n, evalues(1:n) +c + close(io) +c + return + end subroutine save_eigenvalues +c +c======================================================================= +c From 5b76612c72d46be015fe6b04b13b583b75c005e6 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 2 Jun 2023 10:49:09 +0200 Subject: [PATCH 30/43] Change the version mechanism. setuptools_scm is no longer used to get the version of msspec. This commit is an attempt to sanitize this. --- src/Makefile | 11 +++++------ src/msspec/version.py | 30 +++++++++++++++++++----------- src/options.mk | 2 +- src/setup.cfg | 5 +++-- 4 files changed, 28 insertions(+), 20 deletions(-) diff --git a/src/Makefile b/src/Makefile index 668d735..8f9d272 100644 --- a/src/Makefile +++ b/src/Makefile @@ -9,13 +9,12 @@ sdist: dist/msspec-$(VERSION).tar.gz frontend: $(INSTALL_PREFIX)/bin/msspec -dist/msspec-$(VERSION).tar.gz: VERSION +dist/msspec-$(VERSION).tar.gz: msspec/VERSION @echo "Creating Python source distribution..." - @+$(INSIDE_VENV) pip install build - @+$(INSIDE_VENV) $(PYTHON_EXE) -m build + @+$(INSIDE_VENV) pip install build && python -m build -$(INSTALL_PREFIX)/bin/msspec: msspec.sh.template VERSION +$(INSTALL_PREFIX)/bin/msspec: msspec.sh.template msspec/VERSION @echo "Installing frontend command..." @mkdir -p $(dir $@) @cat $< | sed -e 's#__VENV_PATH__#$(VENV_PATH)#' > $@ @@ -26,7 +25,7 @@ pybinding: @echo "Building Python binding for phagen and spec..." @+$(MAKE) -C msspec/phagen/fortran all @+$(MAKE) -C msspec/spec/fortran all - @echo "$(VERSION)" > VERSION + @echo "$(VERSION)" > msspec/VERSION results: msspec/results.txt @@ -54,7 +53,7 @@ clean:: # remove previous sdist @rm -rf dist @rm -rf *.egg* - @rm -f VERSION + @rm -f msspec/VERSION help: diff --git a/src/msspec/version.py b/src/msspec/version.py index bcd00c0..ebf350c 100644 --- a/src/msspec/version.py +++ b/src/msspec/version.py @@ -23,29 +23,37 @@ import os -from setuptools_scm import get_version from importlib.metadata import version import subprocess # find the version number -# 1- If it fails, try to read it from the distribution file -# 2- Try to read it from the git info -# 3- If it fails, try to read it from the VERSION file +# 1- Try to read it from the git info +# 2- If it fails, try to read it from the VERSION file +# 3- If it fails, try to read it from the distribution file PKGNAME = 'msspec' try: - __version__ = get_version(root='../..', relative_to=__file__) + cmd = ["git describe|sed 's/-\([0-9]\+\)-.*/.dev\\1/g'"] + result = subprocess.run(cmd, stdout=subprocess.PIPE, shell=True) + __version__ = result.stdout.decode('utf-8').strip() + if __version__ != "": + print("from git: ", __version__) + else: + raise NameError("Not a git repo") except Exception as err: + print(err) try: - __version__ = version(PKGNAME) + thisfile_path = os.path.abspath(__file__) + thisfile_dir = os.path.dirname(thisfile_path) + versionfile = os.path.join(thisfile_dir, "./VERSION") + with open(versionfile, "r") as fd: + __version__ = fd.readline().strip() + print("from VERSION: ", __version__) except Exception as err: try: - thisfile_path = os.path.abspath(__file__) - thisfile_dir = os.path.dirname(thisfile_path) - versionfile = os.path.join(thisfile_dir, "../VERSION") - with open(versionfile, "r") as fd: - __version__ = fd.readline().strip() + __version__ = version(PKGNAME) + print("from metadata: ", __version__) except Exception as err: print("Unable to get the version number!") __version__ = "0.0.0" diff --git a/src/options.mk b/src/options.mk index 15cb602..5e08919 100644 --- a/src/options.mk +++ b/src/options.mk @@ -41,7 +41,7 @@ F2PYFLAGS_DBG = --debug-capi --debug # /!\ DO NOT EDIT BELOW THAT LINE (unlesss you know what you're doing...) # # CORE CONFIGURATION # ################################################################################ -VERSION:=$(shell git describe) +VERSION:=$(shell git describe|sed 's/-\([0-9]\+\)-.*/.dev\1/g') VENV_PATH := $(INSTALL_PREFIX)/src/msspec_venv_$(VERSION) diff --git a/src/setup.cfg b/src/setup.cfg index ce2c01f..a4df7f2 100644 --- a/src/setup.cfg +++ b/src/setup.cfg @@ -50,5 +50,6 @@ install_requires = terminaltables [options.package_data] -msspec.phagen.fortran = *.so -msspec.spec.fortran = *.so +msspec.phagen = fortran/*.so +msspec.spec = fortran/*.so +msspec = VERSION From 3811c4baf04ee3d0ba76c9ca2f83a76cb6b3a90a Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 2 Jun 2023 11:03:08 +0200 Subject: [PATCH 31/43] Restore pip.freeze and setup.py in src/ Since those files are still required for an editable install (make devel) --- src/pip.freeze | 12 ++++++++ src/setup.py | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 90 insertions(+) create mode 100644 src/pip.freeze create mode 100644 src/setup.py diff --git a/src/pip.freeze b/src/pip.freeze new file mode 100644 index 0000000..406ab63 --- /dev/null +++ b/src/pip.freeze @@ -0,0 +1,12 @@ +ase +h5py +ipython +lxml +matplotlib +numpy +Pint +pandas +pycairo +scipy +setuptools-scm +terminaltables diff --git a/src/setup.py b/src/setup.py new file mode 100644 index 0000000..8dd9c43 --- /dev/null +++ b/src/setup.py @@ -0,0 +1,78 @@ +#!/usr/bin/env python +# +# Copyright © 2016-2020 - Rennes Physics Institute +# +# This file is part of msspec. +# +# msspec is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# msspec is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this msspec. If not, see . +# +# Source file : src/setup.py +# Last modified: mar. 07 avril 2020 17:01:42 +# Committed by : "Sylvain Tricot " + +import sys +sys.path.insert(0, "msspec") +from setuptools import setup, find_packages +from version import __version__ + +with open('pip.freeze', 'r') as fd: + REQUIREMENTS = fd.read().strip().split('\n') + +if __name__ == "__main__": + setup(name='msspec', + version=__version__, + include_package_data=True, + packages=find_packages(include='msspec.*'), + #setup_requires=SETUP_REQUIREMENTS, + install_requires=REQUIREMENTS, + + author='Didier Sébilleau, Sylvain Tricot', + author_email='sylvain.tricot@univ-rennes1.fr', + maintainer='Sylvain Tricot', + maintainer_email='sylvain.tricot@univ-rennes1.fr', + url='https://msspec.cnrs.fr', + description=('A multiple scattering package for sepectroscopies ' + 'using electrons to probe materials'), + long_description="""MsSpec is a Fortran package to compute the + cross-section of several spectroscopies involving one (or more) + electron(s) as the probe. This package provides a python interface to + control all the steps of the calculation. + + Available spectroscopies: + * Photoelectron diffraction + * Auger electron diffraction + * Low energy electron diffraction + * X-Ray absorption spectroscopy + * Auger Photoelectron coincidence spectroscopy + * Computation of the spectral radius""", + download_url='https://msspec.cnrs.fr/downloads.html', + # See https://pypi.python.org/pypi?%3Aaction=list_classifiers + classifiers=[ + 'Development Status :: 3 - Alpha', + 'Environment :: Console', + 'Intended Audience :: Science/Research', + 'License :: OSI Approved :: GNU General Public License (GPL)', + 'Natural Language :: English', + 'Operating System :: Microsoft :: Windows :: Windows 10', + 'Operating System :: POSIX :: Linux', + 'Operating System :: MacOS :: MacOS X', + 'Programming Language :: Fortran', + 'Programming Language :: Python :: 3 :: Only', + 'Topic :: Scientific/Engineering :: Physics', + ], + keywords='spectroscopy atom electron photon multiple scattering', + license='GPL', + #entry_points={ + # 'console_scripts': ['msspec=msspec.cli:main']} + ) From d61408e5943a1fc3a3399bb9a4dbb2ad62bf3364 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 2 Jun 2023 11:14:21 +0200 Subject: [PATCH 32/43] Remove 'print' calls in version.py --- src/msspec/version.py | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/msspec/version.py b/src/msspec/version.py index ebf350c..bc5a91b 100644 --- a/src/msspec/version.py +++ b/src/msspec/version.py @@ -37,23 +37,15 @@ try: cmd = ["git describe|sed 's/-\([0-9]\+\)-.*/.dev\\1/g'"] result = subprocess.run(cmd, stdout=subprocess.PIPE, shell=True) __version__ = result.stdout.decode('utf-8').strip() - if __version__ != "": - print("from git: ", __version__) - else: - raise NameError("Not a git repo") except Exception as err: - print(err) try: thisfile_path = os.path.abspath(__file__) thisfile_dir = os.path.dirname(thisfile_path) versionfile = os.path.join(thisfile_dir, "./VERSION") with open(versionfile, "r") as fd: __version__ = fd.readline().strip() - print("from VERSION: ", __version__) except Exception as err: try: __version__ = version(PKGNAME) - print("from metadata: ", __version__) except Exception as err: - print("Unable to get the version number!") __version__ = "0.0.0" From 893d012c99a3049d3ba7d3071f26668d73d13fe5 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 2 Jun 2023 11:33:22 +0200 Subject: [PATCH 33/43] Remove stderr output for 'git describe' call --- src/msspec/version.py | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/msspec/version.py b/src/msspec/version.py index bc5a91b..74c7351 100644 --- a/src/msspec/version.py +++ b/src/msspec/version.py @@ -35,8 +35,10 @@ PKGNAME = 'msspec' try: cmd = ["git describe|sed 's/-\([0-9]\+\)-.*/.dev\\1/g'"] - result = subprocess.run(cmd, stdout=subprocess.PIPE, shell=True) + result = subprocess.run(cmd, stdout=subprocess.PIPE, stderr=subprocess.DEVNULL, shell=True) __version__ = result.stdout.decode('utf-8').strip() + if __version__ == "": + raise except Exception as err: try: thisfile_path = os.path.abspath(__file__) From 5f19198decd5d111e7b1b00c30a078018ad2fa96 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Mon, 19 Jun 2023 14:50:08 +0200 Subject: [PATCH 34/43] Remove the creation of output file "fort.354" This file was created for debugging purposes by the renormalization procedure. But since it had one line per diffusion path, its size could rapidly become an issue. The line is simply commented in the code. --- src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f index e07d33d..55d90bc 100644 --- a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f @@ -115,7 +115,7 @@ C Renormalization of the path C IF(I_REN.GE.1) THEN COEF=COEF*C_REN(JORDP) - write(354,*) JORDP,C_REN(JORDP) +C write(354,*) JORDP,C_REN(JORDP) ENDIF C C Call of the subroutines used for the R-A termination matrix From de70cc04a1a57e1922fcfc4f6bcf9e8613485786 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 1 Dec 2023 10:17:09 +0100 Subject: [PATCH 35/43] Update the Dockerfile. Dockerfile has been modified to be compatible with the last package versions of the Alpine distro --- Dockerfile | 50 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 30 insertions(+), 20 deletions(-) diff --git a/Dockerfile b/Dockerfile index 51a63e6..67cff5b 100644 --- a/Dockerfile +++ b/Dockerfile @@ -8,13 +8,15 @@ ARG folder=/opt/msspec user=msspec # Install system dependencies # tools -RUN apk add bash git make gfortran python3 +RUN apk add bash git make gfortran python3 py3-numpy-f2py # headers -RUN apk add python3-dev lapack-dev musl-dev +RUN apk add python3-dev lapack-dev musl-dev hdf5-dev cairo-dev # python packages -RUN apk add py3-virtualenv py3-pip py3-numpy-dev py3-h5py py3-lxml py3-matplotlib py3-numpy py3-pandas py3-cairo py3-scipy py3-setuptools_scm -RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/testing py3-wxpython -RUN pip install ase pint terminaltables ipython +RUN apk add py3-virtualenv py3-pip py3-numpy-dev py3-h5py py3-lxml py3-matplotlib \ + py3-numpy py3-pandas py3-cairo py3-scipy py3-setuptools_scm \ + py3-terminaltables ipython +RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/community py3-wxpython +#RUN pip install ase pint terminaltables ipython # for GUI RUN apk add ttf-droid adwaita-icon-theme RUN apk add build-base @@ -24,19 +26,29 @@ RUN mkdir -p ${folder}/code WORKDIR ${folder}/code RUN git clone --branch ${branch} https://${login}:${password}@git.ipr.univ-rennes1.fr/epsi/msspec_python3.git . +RUN virtualenv --system-site-packages ${folder}/.local/src/msspec_venv +RUN make pybinding PYTHON=python3 VENV_PATH=${folder}/.local/src/msspec_venv VERBOSE=1 +RUN make -C src sdist PYTHON=python3 VENV_PATH=${folder}/.local/src/msspec_venv VERBOSE=1 +RUN make -C src frontend PYTHON=python3 VENV_PATH=${folder}/.local/src/msspec_venv VERBOSE=1 +RUN source ${folder}/.local/src/msspec_venv/bin/activate && pip install src/dist/msspec*tar.gz + + + # Build -RUN make pybinding NO_VENV=1 PYTHON=python3 VERBOSE=1 -RUN make -C src sdist PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv && \ - pip install src/dist/msspec*tar.gz +#RUN make pybinding NO_VENV=1 PYTHON=python3 VERBOSE=1 +#RUN make -C src sdist PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv +#&& \ +# pip install src/dist/msspec*tar.gz # Add a non-privileged user -RUN adduser -D -s /bin/bash -h ${folder} ${user} +#RUN adduser -D -s /bin/bash -h ${folder} ${user} # Set the working directory in the container -USER ${user} +#USER ${user} -RUN virtualenv --system-site-packages ${folder}/.local/src/msspec_venv -RUN make -C src frontend PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv +#RUN virtualenv --system-site-packages ${folder}/.local/src/msspec_venv +#RUN source ${folder}/.local/src/msspec_venv/bin/activate && pip install src/dist/msspec*.tar.gz +#RUN make -C src frontend PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv @@ -44,7 +56,7 @@ FROM alpine:edge # Variables ARG folder=/opt/msspec user=msspec # Install system dependencies -RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/testing \ +RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/community \ # hdf5-hl cairo openblas lapack libxml2 libxslt libzlf wxwidgets-gtk3 openjpeg libimagequant \ nano \ py3-virtualenv \ @@ -72,12 +84,8 @@ RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/testing \ py3-scipy \ py3-setuptools_scm \ py3-wxpython \ - && pip install \ - ase \ - pint \ - terminaltables \ - ipython \ - && pip cache purge \ + py3-terminaltables \ + py3-bayesian-optimization \ # Add a non-privileged user && adduser -D -s /bin/bash -h ${folder} ${user} @@ -92,10 +100,12 @@ COPY --from=builder ${folder}/code/src/dist/msspec*tar.gz msspec.tar.gz RUN virtualenv --system-site-packages .local/src/msspec_venv && \ . .local/src/msspec_venv/bin/activate && \ pip install msspec.tar.gz && \ + pip install ipython && \ + pip cache purge && \ rm -f msspec.tar.gz && \ mkdir -p .local/bin -COPY --from=builder ${folder}/.local/bin/msspec .local/bin/msspec +COPY --from=builder /root/.local/bin/msspec .local/bin/msspec ENV PATH=${folder}/.local/bin:$PATH # Run the msspec frontend command on startup From af72a764e5466efc55b4a3c279d45d701737d577 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 1 Dec 2023 10:19:22 +0100 Subject: [PATCH 36/43] Fix the stereographic projection issue. The matplotlib function changed. A new keyword is needed to make the plotting "pcolormesh" function works. This keyword is "shading='gouraud'" --- src/msspec/iodata.py | 2 +- src/msspec/iodata_gi.py | 48 +++++++++++++++++++++++++---------------- 2 files changed, 31 insertions(+), 19 deletions(-) diff --git a/src/msspec/iodata.py b/src/msspec/iodata.py index dde6b81..144bd03 100644 --- a/src/msspec/iodata.py +++ b/src/msspec/iodata.py @@ -889,7 +889,7 @@ class _DataSetView(object): 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) - im = axes.pcolormesh(X, Y, Xsec) + im = axes.pcolormesh(X, Y, Xsec, shading='gouraud') axes.set_yticks(R_ticks) axes.set_yticklabels(theta_ticks) diff --git a/src/msspec/iodata_gi.py b/src/msspec/iodata_gi.py index 1742f47..2a61b6d 100644 --- a/src/msspec/iodata_gi.py +++ b/src/msspec/iodata_gi.py @@ -235,8 +235,8 @@ class DataSet(object): float: '{:<20.10e}', complex: 's'} self._formats = ((np.integer, '{:<20d}'), (np.floating, '{:<20.10e}'), - (np.complex, '({0.real:<.10e} {0.imag:<.10e}j)'), - (np.bool, '{:s}'), + (complex, '({0.real:<.10e} {0.imag:<.10e}j)'), + (bool, '{:s}'), (str, '{:s}')) @@ -450,9 +450,13 @@ class DataSet(object): :return: The cluster :rtype: :py:class:`ase.Atoms` """ + p = self.get_parameter(group='Cluster', name='cluster')['value'] s = StringIO() s.write(self.get_parameter(group='Cluster', name='cluster')['value']) - return ase.io.read(s, format='xyz') + s.seek(0) + #return ase.io.read(s, format='xyz') + cluster = list(read_xyz(s))[-1] + return cluster def select(self, *args, **kwargs): @@ -785,13 +789,13 @@ class Data(object): dset = output.add_dset(dset_name) dset.notes = fd['DATA'][dset_name].attrs['notes'] for h5dset in fd['DATA'][dset_name]: - dset.add_columns(**{h5dset: fd['DATA'][dset_name][h5dset].value}) + dset.add_columns(**{h5dset: fd['DATA'][dset_name][h5dset][...]}) try: vfile = LooseVersion(fd['MsSpec viewer metainfo'].attrs['version']) if vfile > LooseVersion(msspec.__version__): raise NameError('File was saved with a more recent format') - xml = fd['MsSpec viewer metainfo']['info'].value.tostring() + xml = fd['MsSpec viewer metainfo']['info'][...].tobytes() root = etree.fromstring(xml) for elt0 in root.iter('parameters'): dset_name = elt0.attrib['dataset'] @@ -854,7 +858,7 @@ class Data(object): #win.show() #Gtk.main() app = _Application(self) - exit_status = app.run(sys.argv) + exit_status = app.run()#sys.argv) sys.exit(exit_status) class _Application(Gtk.Application): @@ -947,7 +951,8 @@ class _DataSetView(object): if np.shape(values)[0] == 1: xvalues = list(range(len(values[0]))) axes.bar(xvalues, values[0], label=label, - picker=5) + # picker=5 + ) axes.set_xticks(xvalues) else: if proj in ('ortho', 'stereo'): @@ -961,7 +966,7 @@ class _DataSetView(object): 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) - im = axes.pcolormesh(X, Y, Xsec) + im = axes.pcolormesh(X, Y, Xsec, shading='gouraud') axes.set_yticks(R_ticks) axes.set_yticklabels(theta_ticks) @@ -969,7 +974,7 @@ class _DataSetView(object): elif proj == 'polar': values[0] = np.radians(values[0]) - axes.plot(*values, label=label, picker=5, + axes.plot(*values, label=label, #picker=5, marker=opts['marker']) else: if scale == 'semilogx': @@ -980,7 +985,7 @@ class _DataSetView(object): pltcmd = axes.loglog else: pltcmd = axes.plot - pltcmd(*values, label=label, picker=5, + pltcmd(*values, label=label, #picker=5, marker=opts['marker']) axes.grid(opts['grid']) axes.set_title(opts['title']) @@ -988,6 +993,7 @@ class _DataSetView(object): axes.set_ylabel(opts['ylabel']) axes.set_xlim(*opts['xlim']) axes.set_ylim(*opts['ylim']) + #axes.set_pickradius(5) if label: axes.legend() axes.autoscale(enable=opts['autoscale']) @@ -1242,7 +1248,7 @@ class _DataWindow(Gtk.ApplicationWindow): def on_close(self, action, param): if self.data.is_dirty(): dlg = Gtk.Dialog(title="Warning: Unsaved data", - transient_for=self, flags=Gtk.DialogFlags.MODAL) + transient_for=self, modal=True) dlg.add_buttons(Gtk.STOCK_YES, Gtk.ResponseType.YES, Gtk.STOCK_NO, Gtk.ResponseType.NO) dlg.set_default_size(150, 100) @@ -1474,9 +1480,14 @@ class OLD_DataWindow(wx.Frame): cluster_viewer = ClusterViewer(win, size=wx.Size(480, 340)) dset = self.data[self._current_dset] - s = StringIO() - s.write(dset.get_parameter(group='Cluster', name='cluster')['value']) - atoms = ase.io.read(s, format='xyz') + #s = StringIO() + #s.write(dset.get_parameter(group='Cluster', name='cluster')['value']) + #_s = dset.get_parameter(group='Cluster', name='cluster')['value'] + #print(_s) + # rewind to the begining of the string + #s.seek(0) + #atoms = ase.io.read(s, format='xyz') + atoms = dset.get_cluster() cluster_viewer.set_atoms(atoms, rescale=True, center=True) cluster_viewer.rotate_atoms(0., 180.) cluster_viewer.rotate_atoms(-45., -45.) @@ -1677,7 +1688,7 @@ class OLD_DataWindow(wx.Frame): if __name__ == "__main__": - if True: + if False: data = Data('all my data') dset = data.add_dset('Dataset 0') X = np.arange(0, 20) @@ -1713,6 +1724,7 @@ if __name__ == "__main__": view.select('x', 'y') data.view() - #import sys - #data = Data.load(sys.argv[1]) - #data.view() + exit() + import sys + data = Data.load(sys.argv[1]) + data.view() From 44b424e3c67752b3f7274ed6f1de95b2f74cc5c6 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 1 Dec 2023 10:22:06 +0100 Subject: [PATCH 37/43] Increase the lmax in Phagen. The lmax value is increased from 50 to 80 (for very high energies) --- src/msspec/phagen/fortran/phagen_2.2_dp/msxas3.inc | 2 +- src/msspec/phagen/fortran/phagen_2.2_dp/phagen_scf_2.2_dp.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/msspec/phagen/fortran/phagen_2.2_dp/msxas3.inc b/src/msspec/phagen/fortran/phagen_2.2_dp/msxas3.inc index 2151d02..7b5ccac 100644 --- a/src/msspec/phagen/fortran/phagen_2.2_dp/msxas3.inc +++ b/src/msspec/phagen/fortran/phagen_2.2_dp/msxas3.inc @@ -28,7 +28,7 @@ c integer fl_, rdx_ c parameter ( rdx_ = 1600, - $ lmax_ = 50, + $ lmax_ = 80, $ npss = lmax_ + 2, $ fl_ = 2*npss + 1, $ nef_ = 10, diff --git a/src/msspec/phagen/fortran/phagen_2.2_dp/phagen_scf_2.2_dp.f b/src/msspec/phagen/fortran/phagen_2.2_dp/phagen_scf_2.2_dp.f index 3e0bebb..31665e8 100644 --- a/src/msspec/phagen/fortran/phagen_2.2_dp/phagen_scf_2.2_dp.f +++ b/src/msspec/phagen/fortran/phagen_2.2_dp/phagen_scf_2.2_dp.f @@ -14625,7 +14625,7 @@ c check = .true. ! do ! - if ( r_real ( i ) > r_in ) then + if (( r_real ( i ) > r_in ) .or. ( i .ge. size(r_real) )) then exit From 6c7038cdde3cf3984c9c6fcdbe3da96ae8b7c83e Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Fri, 1 Dec 2023 10:24:21 +0100 Subject: [PATCH 38/43] Simplify the version mechanism. No "setuptools-scm" anymore. The version is read by a subprocess command or using package metadata or the VERSION file. I still don't know if this is my last attempt to make the version number reliable... --- src/msspec/version.py | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/msspec/version.py b/src/msspec/version.py index 74c7351..bd407ab 100644 --- a/src/msspec/version.py +++ b/src/msspec/version.py @@ -33,16 +33,18 @@ import subprocess PKGNAME = 'msspec' +thisfile_path = os.path.abspath(__file__) +thisfile_dir = os.path.dirname(thisfile_path) + try: cmd = ["git describe|sed 's/-\([0-9]\+\)-.*/.dev\\1/g'"] - result = subprocess.run(cmd, stdout=subprocess.PIPE, stderr=subprocess.DEVNULL, shell=True) + result = subprocess.run(cmd, stdout=subprocess.PIPE, stderr=subprocess.DEVNULL, + shell=True, cwd=thisfile_dir) __version__ = result.stdout.decode('utf-8').strip() if __version__ == "": raise except Exception as err: try: - thisfile_path = os.path.abspath(__file__) - thisfile_dir = os.path.dirname(thisfile_path) versionfile = os.path.join(thisfile_dir, "./VERSION") with open(versionfile, "r") as fd: __version__ = fd.readline().strip() From 583eb089248a6b5b9e67bdb79f7cd31376cbfe31 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Mon, 11 Mar 2024 09:51:47 +0100 Subject: [PATCH 39/43] Change the stereographic projection radius scale Now the scale is linear (as it should be...) --- src/msspec/iodata.py | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/msspec/iodata.py b/src/msspec/iodata.py index 144bd03..27369d9 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: Mon, 11 Mar 2024 09:51:47 +0100 +# Committed by : Sylvain Tricot """ @@ -885,8 +885,10 @@ class _DataSetView(object): 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 = 2 * np.tan(np.radians(theta/2.)) + #R_ticks = 2 * np.tan(np.radians(theta_ticks/2.)) + R = theta/90. + R_ticks = theta_ticks/90. #R = np.tan(np.radians(theta/2.)) X, Y = np.meshgrid(np.radians(phi), R) im = axes.pcolormesh(X, Y, Xsec, shading='gouraud') From a98fd58385edd712f4734e22168978d04d0040c2 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 26 Feb 2025 11:10:17 +0100 Subject: [PATCH 40/43] Add a new 'nogui' compilation target Makefile has a new 'nogui' target to build msspec without any graphical user interface. Exporting data to text files and *.png images are still possible. Useful for installing on headless machines or if the gui is too difficult to install (due to WxPython). --- Makefile | 4 + src/msspec/iodata.py | 808 ++++++++++++++++++++++--------------------- 2 files changed, 416 insertions(+), 396 deletions(-) diff --git a/Makefile b/Makefile index d0dfe5f..0a8db3d 100644 --- a/Makefile +++ b/Makefile @@ -37,6 +37,10 @@ light: VENV_PATH = ./_venv light: venv @$(INSIDE_VENV) pip install src/ +nogui: VENV_PATH = ./_venv +nogui: venv pybinding + @$(INSIDE_VENV) pip install -e src/ + _attrdict: # Check if virtualenv python version > 3.3.0 diff --git a/src/msspec/iodata.py b/src/msspec/iodata.py index 27369d9..1ddb185 100644 --- a/src/msspec/iodata.py +++ b/src/msspec/iodata.py @@ -17,7 +17,7 @@ # along with this msspec. If not, see . # # Source file : src/msspec/iodata.py -# Last modified: Mon, 11 Mar 2024 09:51:47 +0100 +# Last modified: Wed, 26 Feb 2025 11:10:17 +0100 # Committed by : Sylvain Tricot @@ -79,19 +79,26 @@ import ase.io from ase.io.extxyz import read_xyz, write_xyz import h5py import numpy as np -import wx.grid from lxml import etree -from matplotlib.backends.backend_wxagg import FigureCanvasWxAgg as FigureCanvas #from matplotlib.backends.backend_wxagg import FigureCanvasWx as FigureCanvas from matplotlib.backends.backend_agg import FigureCanvasAgg -from matplotlib.backends.backend_wxagg import NavigationToolbar2WxAgg +#from matplotlib.backends.backend_cairo import FigureCanvasCairo as FigureCanvasAgg from matplotlib.figure import Figure from terminaltables import AsciiTable import msspec -from msspec.msspecgui.msspec.gui.clusterviewer import ClusterViewer from msspec.misc import LOGGER +try: + import wx.grid + from matplotlib.backends.backend_wxagg import FigureCanvasWxAgg as FigureCanvas + from matplotlib.backends.backend_wxagg import NavigationToolbar2WxAgg + from msspec.msspecgui.msspec.gui.clusterviewer import ClusterViewer + has_gui = True +except ImportError: + LOGGER.warning('No modules for GUI') + has_gui = False + def cols2matrix(x, y, z, nx=88*1+1, ny=360*1+1): # mix the values of existing theta and new theta and return the @@ -796,11 +803,17 @@ class Data(object): """Pops up a grphical window to show all the defined views of the Data object. """ - app = wx.App(False) - app.SetAppName('MsSpec Data Viewer') - frame = _DataWindow(self) - frame.Show(True) - app.MainLoop() + if has_gui: + app = wx.App(False) + app.SetAppName('MsSpec Data Viewer') + frame = _DataWindow(self) + frame.Show(True) + app.MainLoop() + else: + print('**** INFORMATION ****') + print('You can not use the Data.view() method since ther is no') + print('graphical user interface available in this version of MsSpec.') + print("Install WxPython if you need it or use Data.export(...) method instead.") class _DataSetView(object): @@ -895,7 +908,8 @@ class _DataSetView(object): axes.set_yticks(R_ticks) axes.set_yticklabels(theta_ticks) - figure.colorbar(im) + cbar = figure.colorbar(im) + #im.set_clim(0, 0.0275) elif proj == 'polar': values[0] = np.radians(values[0]) @@ -918,6 +932,7 @@ class _DataSetView(object): axes.set_ylabel(opts['ylabel']) axes.set_xlim(*opts['xlim']) axes.set_ylim(*opts['ylim']) + #axes.set_axis_off() #axes.set_pickradius(5) if label: axes.legend() @@ -1008,425 +1023,426 @@ class _DataSetView(object): s += '\tconditions : %s\n' % str(self._selection_conditions) return s -class _GridWindow(wx.Frame): - def __init__(self, dset, parent=None): - title = 'Data: ' + dset.title - wx.Frame.__init__(self, parent, title=title, size=(640, 480)) - self.create_grid(dset) +if has_gui: + class _GridWindow(wx.Frame): + def __init__(self, dset, parent=None): + title = 'Data: ' + dset.title + wx.Frame.__init__(self, parent, title=title, size=(640, 480)) + self.create_grid(dset) - def create_grid(self, dset): - grid = wx.grid.Grid(self, -1) - grid.CreateGrid(len(dset), len(dset.columns())) - for ic, c in enumerate(dset.columns()): - grid.SetColLabelValue(ic, c) - for iv, v in enumerate(dset[c]): - grid.SetCellValue(iv, ic, str(v)) + def create_grid(self, dset): + grid = wx.grid.Grid(self, -1) + grid.CreateGrid(len(dset), len(dset.columns())) + for ic, c in enumerate(dset.columns()): + grid.SetColLabelValue(ic, c) + for iv, v in enumerate(dset[c]): + grid.SetCellValue(iv, ic, str(v)) -class _ParametersWindow(wx.Frame): - def __init__(self, dset, parent=None): - title = 'Parameters: ' + dset.title - wx.Frame.__init__(self, parent, title=title, size=(400, 480)) - self.create_tree(dset) + class _ParametersWindow(wx.Frame): + def __init__(self, dset, parent=None): + title = 'Parameters: ' + dset.title + wx.Frame.__init__(self, parent, title=title, size=(400, 480)) + self.create_tree(dset) - def create_tree(self, dset): - datatree = {} - for p in dset.parameters(): - is_hidden = p.get('hidden', "False") - if is_hidden == "True": - continue - group = datatree.get(p['group'], []) - #strval = str(p['value'] * p['unit'] if p['unit'] else p['value']) - #group.append("{:s} = {:s}".format(p['name'], strval)) - group.append("{} = {} {}".format(p['name'], p['value'], p['unit'])) - datatree[p['group']] = group + def create_tree(self, dset): + datatree = {} + for p in dset.parameters(): + is_hidden = p.get('hidden', "False") + if is_hidden == "True": + continue + group = datatree.get(p['group'], []) + #strval = str(p['value'] * p['unit'] if p['unit'] else p['value']) + #group.append("{:s} = {:s}".format(p['name'], strval)) + group.append("{} = {} {}".format(p['name'], p['value'], p['unit'])) + datatree[p['group']] = group - tree = wx.TreeCtrl(self, -1) - root = tree.AddRoot('Parameters') + tree = wx.TreeCtrl(self, -1) + root = tree.AddRoot('Parameters') - for key in list(datatree.keys()): - item0 = tree.AppendItem(root, key) - for item in datatree[key]: - tree.AppendItem(item0, item) - tree.ExpandAll() - tree.SelectItem(root) + for key in list(datatree.keys()): + item0 = tree.AppendItem(root, key) + for item in datatree[key]: + tree.AppendItem(item0, item) + tree.ExpandAll() + tree.SelectItem(root) -class _DataWindow(wx.Frame): - def __init__(self, data): - assert isinstance(data, (Data, DataSet)) + class _DataWindow(wx.Frame): + def __init__(self, data): + assert isinstance(data, (Data, DataSet)) - if isinstance(data, DataSet): - dset = data - data = Data() - data.first = dset - self.data = data - self._filename = None - self._current_dset = None + if isinstance(data, DataSet): + dset = data + data = Data() + data.first = dset + self.data = data + self._filename = None + self._current_dset = None - wx.Frame.__init__(self, None, title="", size=(640, 480)) + wx.Frame.__init__(self, None, title="", size=(640, 480)) - self.Bind(wx.EVT_CLOSE, self.on_close) + self.Bind(wx.EVT_CLOSE, self.on_close) - # Populate the menu bar - self.create_menu() + # Populate the menu bar + self.create_menu() - # Create the status bar - statusbar = wx.StatusBar(self, -1) - statusbar.SetFieldsCount(3) - statusbar.SetStatusWidths([-2, -1, -1]) - self.SetStatusBar(statusbar) + # Create the status bar + statusbar = wx.StatusBar(self, -1) + statusbar.SetFieldsCount(3) + statusbar.SetStatusWidths([-2, -1, -1]) + self.SetStatusBar(statusbar) - # Add the notebook to hold all graphs - self.notebooks = {} - sizer = wx.BoxSizer(wx.VERTICAL) - #sizer.Add(self.notebook) - self.SetSizer(sizer) + # Add the notebook to hold all graphs + self.notebooks = {} + sizer = wx.BoxSizer(wx.VERTICAL) + #sizer.Add(self.notebook) + self.SetSizer(sizer) - self.Bind(wx.EVT_NOTEBOOK_PAGE_CHANGED, self.on_page_changed) + self.Bind(wx.EVT_NOTEBOOK_PAGE_CHANGED, self.on_page_changed) - self.create_notebooks() - - self.update_title() - - def create_notebooks(self): - for key in list(self.notebooks.keys()): - nb = self.notebooks.pop(key) - nb.Destroy() - - for dset in self.data: - nb = wx.Notebook(self, -1) - self.notebooks[dset.title] = nb - #self.GetSizer().Add(nb, 1, wx.ALL|wx.EXPAND) - self.GetSizer().Add(nb, proportion=1, flag=wx.ALL|wx.EXPAND) - for view in dset.views(): - self.create_page(nb, view) - - self.create_menu() - - self.show_dataset(self.data[0].title) - - - def create_menu(self): - menubar = wx.MenuBar() - menu1 = wx.Menu() - menu1.Append(110, "Open\tCtrl+O") - menu1.Append(120, "Save\tCtrl+S") - menu1.Append(130, "Save as...") - menu1.Append(140, "Export\tCtrl+E") - menu1.AppendSeparator() - menu1.Append(199, "Close\tCtrl+Q") - - menu2 = wx.Menu() - for i, dset in enumerate(self.data): - menu_id = 201 + i - menu2.AppendRadioItem(menu_id, dset.title) - self.Bind(wx.EVT_MENU, self.on_menu_dataset, id=menu_id) - - self.Bind(wx.EVT_MENU, self.on_open, id=110) - self.Bind(wx.EVT_MENU, self.on_save, id=120) - self.Bind(wx.EVT_MENU, self.on_saveas, id=130) - self.Bind(wx.EVT_MENU, self.on_export, id=140) - self.Bind(wx.EVT_MENU, self.on_close, id=199) - - - menu3 = wx.Menu() - menu3.Append(301, "Data") - menu3.Append(302, "Cluster") - menu3.Append(303, "Parameters") - - self.Bind(wx.EVT_MENU, self.on_viewdata, id=301) - self.Bind(wx.EVT_MENU, self.on_viewcluster, id=302) - self.Bind(wx.EVT_MENU, self.on_viewparameters, id=303) - - menubar.Append(menu1, "&File") - menubar.Append(menu2, "&Datasets") - menubar.Append(menu3, "&View") - self.SetMenuBar(menubar) - - def on_open(self, event): - if self.data.is_dirty(): - mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do ' - 'you wish to save before opening' - 'another file ?'), - 'Warning: Unsaved data', - wx.YES_NO | wx.ICON_WARNING) - if mbx.ShowModal() == wx.ID_YES: - self.on_saveas(wx.Event()) - mbx.Destroy() - - wildcard = "HDF5 files (*.hdf5)|*.hdf5" - dlg = wx.FileDialog( - self, message="Open a file...", defaultDir=os.getcwd(), - defaultFile="", wildcard=wildcard, style=wx.FD_OPEN - ) - - if dlg.ShowModal() == wx.ID_OK: - path = dlg.GetPath() - self._filename = path - self.data = Data.load(path) self.create_notebooks() - dlg.Destroy() - self.update_title() - def on_save(self, event): - if self._filename: + self.update_title() + + def create_notebooks(self): + for key in list(self.notebooks.keys()): + nb = self.notebooks.pop(key) + nb.Destroy() + + for dset in self.data: + nb = wx.Notebook(self, -1) + self.notebooks[dset.title] = nb + #self.GetSizer().Add(nb, 1, wx.ALL|wx.EXPAND) + self.GetSizer().Add(nb, proportion=1, flag=wx.ALL|wx.EXPAND) + for view in dset.views(): + self.create_page(nb, view) + + self.create_menu() + + self.show_dataset(self.data[0].title) + + + def create_menu(self): + menubar = wx.MenuBar() + menu1 = wx.Menu() + menu1.Append(110, "Open\tCtrl+O") + menu1.Append(120, "Save\tCtrl+S") + menu1.Append(130, "Save as...") + menu1.Append(140, "Export\tCtrl+E") + menu1.AppendSeparator() + menu1.Append(199, "Close\tCtrl+Q") + + menu2 = wx.Menu() + for i, dset in enumerate(self.data): + menu_id = 201 + i + menu2.AppendRadioItem(menu_id, dset.title) + self.Bind(wx.EVT_MENU, self.on_menu_dataset, id=menu_id) + + self.Bind(wx.EVT_MENU, self.on_open, id=110) + self.Bind(wx.EVT_MENU, self.on_save, id=120) + self.Bind(wx.EVT_MENU, self.on_saveas, id=130) + self.Bind(wx.EVT_MENU, self.on_export, id=140) + self.Bind(wx.EVT_MENU, self.on_close, id=199) + + + menu3 = wx.Menu() + menu3.Append(301, "Data") + menu3.Append(302, "Cluster") + menu3.Append(303, "Parameters") + + self.Bind(wx.EVT_MENU, self.on_viewdata, id=301) + self.Bind(wx.EVT_MENU, self.on_viewcluster, id=302) + self.Bind(wx.EVT_MENU, self.on_viewparameters, id=303) + + menubar.Append(menu1, "&File") + menubar.Append(menu2, "&Datasets") + menubar.Append(menu3, "&View") + self.SetMenuBar(menubar) + + def on_open(self, event): if self.data.is_dirty(): - self.data.save(self._filename) - else: - self.on_saveas(event) - - def on_saveas(self, event): - overwrite = True - wildcard = "HDF5 files (*.hdf5)|*.hdf5|All files (*.*)|*.*" - dlg = wx.FileDialog( - self, message="Save file as ...", defaultDir=os.getcwd(), - defaultFile='{}.hdf5'.format(self.data.title.replace(' ','_')), - wildcard=wildcard, style=wx.FD_SAVE) - dlg.SetFilterIndex(0) - - if dlg.ShowModal() == wx.ID_OK: - path = dlg.GetPath() - if os.path.exists(path): - mbx = wx.MessageDialog(self, ('This file already exists. ' - 'Do you wish to overwrite it ?'), - 'Warning: File exists', - wx.YES_NO | wx.ICON_WARNING) - if mbx.ShowModal() == wx.ID_NO: - overwrite = False + mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do ' + 'you wish to save before opening' + 'another file ?'), + 'Warning: Unsaved data', + wx.YES_NO | wx.ICON_WARNING) + if mbx.ShowModal() == wx.ID_YES: + self.on_saveas(wx.Event()) mbx.Destroy() - if overwrite: - self.data.save(path) + + wildcard = "HDF5 files (*.hdf5)|*.hdf5" + dlg = wx.FileDialog( + self, message="Open a file...", defaultDir=os.getcwd(), + defaultFile="", wildcard=wildcard, style=wx.FD_OPEN + ) + + if dlg.ShowModal() == wx.ID_OK: + path = dlg.GetPath() self._filename = path - dlg.Destroy() - self.update_title() + self.data = Data.load(path) + self.create_notebooks() + dlg.Destroy() + self.update_title() - def on_export(self, event): - overwrite = True - dlg = wx.DirDialog( - self, message="Export data...", defaultPath=os.getcwd(), - style=wx.DD_DEFAULT_STYLE) - - if dlg.ShowModal() == wx.ID_OK: - path = dlg.GetPath() - if os.listdir(path): - mbx = wx.MessageDialog(self, - ('This folder is not empty. ' - 'Exporting tour data here may ' - 'overwrite its content. Do you wish ' - 'to continue ?'), - 'Warning: Folder is not empty', - wx.YES_NO | wx.ICON_WARNING) - if mbx.ShowModal() == wx.ID_NO: - overwrite = False - mbx.Destroy() - self.data.export(path, overwrite) - dlg.Destroy() - - def on_viewdata(self, event): - dset = self.data[self._current_dset] - frame = _GridWindow(dset, parent=self) - frame.Show() - - def on_viewcluster(self, event): - win = wx.Frame(None, size=wx.Size(480, 340)) - cluster_viewer = ClusterViewer(win, size=wx.Size(480, 340)) - - dset = self.data[self._current_dset] - #s = StringIO() - #s.write(dset.get_parameter(group='Cluster', name='cluster')['value']) - #_s = dset.get_parameter(group='Cluster', name='cluster')['value'] - #print(_s) - # rewind to the begining of the string - #s.seek(0) - #atoms = ase.io.read(s, format='xyz') - atoms = dset.get_cluster() - cluster_viewer.set_atoms(atoms, rescale=True, center=True) - cluster_viewer.rotate_atoms(0., 180.) - cluster_viewer.rotate_atoms(-45., -45.) - #cluster_viewer.show_emitter(True) - win.Show() - - def on_viewparameters(self, event): - dset = self.data[self._current_dset] - frame = _ParametersWindow(dset, parent=self) - frame.Show() - - def on_close(self, event): - if self.data.is_dirty(): - mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do you ' - 'really want to quit ?'), - 'Warning: Unsaved data', - wx.YES_NO | wx.ICON_WARNING) - if mbx.ShowModal() == wx.ID_NO: - mbx.Destroy() - return - self.Destroy() - - - def on_menu_dataset(self, event): - menu_id = event.GetId() - dset_name = self.GetMenuBar().FindItemById(menu_id).GetItemLabelText() - self.show_dataset(dset_name) - - - def show_dataset(self, name): - for nb in list(self.notebooks.values()): - nb.Hide() - self.notebooks[name].Show() - self.Layout() - self.update_statusbar() - self._current_dset = name - - def create_page(self, nb, view): - # Get the matplotlib figure - figure = view.get_figure() - - # Create a panel - p = wx.Panel(nb, -1) - - # Create a matplotlib canvas for the figure - canvas = FigureCanvas(p, -1, figure) - sizer = wx.BoxSizer(wx.VERTICAL) - - toolbar = NavigationToolbar2WxAgg(canvas) - toolbar.Realize() - - #sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND) - sizer.Add(toolbar, proportion=0, flag=wx.ALL|wx.EXPAND) - toolbar.update() - - #sizer.Add(canvas, 5, wx.ALL|wx.EXPAND) - sizer.Add(canvas, proportion=1, flag=wx.ALL|wx.EXPAND) - - p.SetSizer(sizer) - p.Fit() - p.Show() - - # MPL events - figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion) - figure.canvas.mpl_connect('pick_event', self.on_mpl_pick) - - nb.AddPage(p, view.title) - canvas.draw() - - - def OLDcreate_page(self, nb, view): - opts = view._plotopts - p = wx.Panel(nb, -1) - - figure = Figure() - - axes = None - proj = opts['projection'] - scale = opts['scale'] - if proj == 'rectilinear': - axes = figure.add_subplot(111, projection='rectilinear') - elif proj in ('polar', 'ortho', 'stereo'): - axes = figure.add_subplot(111, projection='polar') - - canvas = FigureCanvas(p, -1, figure) - sizer = wx.BoxSizer(wx.VERTICAL) - - toolbar = NavigationToolbar2WxAgg(canvas) - toolbar.Realize() - - sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND) - toolbar.update() - - sizer.Add(canvas, 5, wx.ALL|wx.EXPAND) - - p.SetSizer(sizer) - p.Fit() - p.Show() - - - for values, label in zip(view.get_data(), opts['legend']): - # if we have only one column to plot, select a bar graph - if np.shape(values)[0] == 1: - xvalues = list(range(len(values[0]))) - axes.bar(xvalues, values[0], label=label, - picker=5) - axes.set_xticks(xvalues) + def on_save(self, event): + if self._filename: + if self.data.is_dirty(): + self.data.save(self._filename) else: - if proj in ('ortho', 'stereo'): - theta, phi, Xsec = cols2matrix(*values) - theta_ticks = np.arange(0, 91, 15) - 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) - im = axes.pcolormesh(X, Y, Xsec) - axes.set_yticks(R_ticks) - axes.set_yticklabels(theta_ticks) + self.on_saveas(event) - figure.colorbar(im) + def on_saveas(self, event): + overwrite = True + wildcard = "HDF5 files (*.hdf5)|*.hdf5|All files (*.*)|*.*" + dlg = wx.FileDialog( + self, message="Save file as ...", defaultDir=os.getcwd(), + defaultFile='{}.hdf5'.format(self.data.title.replace(' ','_')), + wildcard=wildcard, style=wx.FD_SAVE) + dlg.SetFilterIndex(0) - elif proj == 'polar': - values[0] = np.radians(values[0]) - axes.plot(*values, label=label, picker=5, - marker=opts['marker']) + if dlg.ShowModal() == wx.ID_OK: + path = dlg.GetPath() + if os.path.exists(path): + mbx = wx.MessageDialog(self, ('This file already exists. ' + 'Do you wish to overwrite it ?'), + 'Warning: File exists', + wx.YES_NO | wx.ICON_WARNING) + if mbx.ShowModal() == wx.ID_NO: + overwrite = False + mbx.Destroy() + if overwrite: + self.data.save(path) + self._filename = path + dlg.Destroy() + self.update_title() + + def on_export(self, event): + overwrite = True + dlg = wx.DirDialog( + self, message="Export data...", defaultPath=os.getcwd(), + style=wx.DD_DEFAULT_STYLE) + + if dlg.ShowModal() == wx.ID_OK: + path = dlg.GetPath() + if os.listdir(path): + mbx = wx.MessageDialog(self, + ('This folder is not empty. ' + 'Exporting tour data here may ' + 'overwrite its content. Do you wish ' + 'to continue ?'), + 'Warning: Folder is not empty', + wx.YES_NO | wx.ICON_WARNING) + if mbx.ShowModal() == wx.ID_NO: + overwrite = False + mbx.Destroy() + self.data.export(path, overwrite) + dlg.Destroy() + + def on_viewdata(self, event): + dset = self.data[self._current_dset] + frame = _GridWindow(dset, parent=self) + frame.Show() + + def on_viewcluster(self, event): + win = wx.Frame(None, size=wx.Size(480, 340)) + cluster_viewer = ClusterViewer(win, size=wx.Size(480, 340)) + + dset = self.data[self._current_dset] + #s = StringIO() + #s.write(dset.get_parameter(group='Cluster', name='cluster')['value']) + #_s = dset.get_parameter(group='Cluster', name='cluster')['value'] + #print(_s) + # rewind to the begining of the string + #s.seek(0) + #atoms = ase.io.read(s, format='xyz') + atoms = dset.get_cluster() + cluster_viewer.set_atoms(atoms, rescale=True, center=True) + cluster_viewer.rotate_atoms(0., 180.) + cluster_viewer.rotate_atoms(-45., -45.) + #cluster_viewer.show_emitter(True) + win.Show() + + def on_viewparameters(self, event): + dset = self.data[self._current_dset] + frame = _ParametersWindow(dset, parent=self) + frame.Show() + + def on_close(self, event): + if self.data.is_dirty(): + mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do you ' + 'really want to quit ?'), + 'Warning: Unsaved data', + wx.YES_NO | wx.ICON_WARNING) + if mbx.ShowModal() == wx.ID_NO: + mbx.Destroy() + return + self.Destroy() + + + def on_menu_dataset(self, event): + menu_id = event.GetId() + dset_name = self.GetMenuBar().FindItemById(menu_id).GetItemLabelText() + self.show_dataset(dset_name) + + + def show_dataset(self, name): + for nb in list(self.notebooks.values()): + nb.Hide() + self.notebooks[name].Show() + self.Layout() + self.update_statusbar() + self._current_dset = name + + def create_page(self, nb, view): + # Get the matplotlib figure + figure = view.get_figure() + + # Create a panel + p = wx.Panel(nb, -1) + + # Create a matplotlib canvas for the figure + canvas = FigureCanvas(p, -1, figure) + sizer = wx.BoxSizer(wx.VERTICAL) + + toolbar = NavigationToolbar2WxAgg(canvas) + toolbar.Realize() + + #sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND) + sizer.Add(toolbar, proportion=0, flag=wx.ALL|wx.EXPAND) + toolbar.update() + + #sizer.Add(canvas, 5, wx.ALL|wx.EXPAND) + sizer.Add(canvas, proportion=1, flag=wx.ALL|wx.EXPAND) + + p.SetSizer(sizer) + p.Fit() + p.Show() + + # MPL events + figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion) + figure.canvas.mpl_connect('pick_event', self.on_mpl_pick) + + nb.AddPage(p, view.title) + canvas.draw() + + + def OLDcreate_page(self, nb, view): + opts = view._plotopts + p = wx.Panel(nb, -1) + + figure = Figure() + + axes = None + proj = opts['projection'] + scale = opts['scale'] + if proj == 'rectilinear': + axes = figure.add_subplot(111, projection='rectilinear') + elif proj in ('polar', 'ortho', 'stereo'): + axes = figure.add_subplot(111, projection='polar') + + canvas = FigureCanvas(p, -1, figure) + sizer = wx.BoxSizer(wx.VERTICAL) + + toolbar = NavigationToolbar2WxAgg(canvas) + toolbar.Realize() + + sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND) + toolbar.update() + + sizer.Add(canvas, 5, wx.ALL|wx.EXPAND) + + p.SetSizer(sizer) + p.Fit() + p.Show() + + + for values, label in zip(view.get_data(), opts['legend']): + # if we have only one column to plot, select a bar graph + if np.shape(values)[0] == 1: + xvalues = list(range(len(values[0]))) + axes.bar(xvalues, values[0], label=label, + picker=5) + axes.set_xticks(xvalues) else: - if scale == 'semilogx': - pltcmd = axes.semilogx - elif scale == 'semilogy': - pltcmd = axes.semilogy - elif scale == 'log': - pltcmd = axes.loglog + if proj in ('ortho', 'stereo'): + theta, phi, Xsec = cols2matrix(*values) + theta_ticks = np.arange(0, 91, 15) + 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) + im = axes.pcolormesh(X, Y, Xsec) + axes.set_yticks(R_ticks) + axes.set_yticklabels(theta_ticks) + + figure.colorbar(im) + + elif proj == 'polar': + values[0] = np.radians(values[0]) + axes.plot(*values, label=label, picker=5, + marker=opts['marker']) else: - pltcmd = axes.plot - pltcmd(*values, label=label, picker=5, - marker=opts['marker']) - axes.grid(opts['grid']) - axes.set_title(opts['title']) - axes.set_xlabel(opts['xlabel']) - axes.set_ylabel(opts['ylabel']) - axes.set_xlim(*opts['xlim']) - axes.set_ylim(*opts['ylim']) - if label: - axes.legend() - axes.autoscale(enable=opts['autoscale']) + if scale == 'semilogx': + pltcmd = axes.semilogx + elif scale == 'semilogy': + pltcmd = axes.semilogy + elif scale == 'log': + pltcmd = axes.loglog + else: + pltcmd = axes.plot + pltcmd(*values, label=label, picker=5, + marker=opts['marker']) + axes.grid(opts['grid']) + axes.set_title(opts['title']) + axes.set_xlabel(opts['xlabel']) + axes.set_ylabel(opts['ylabel']) + axes.set_xlim(*opts['xlim']) + axes.set_ylim(*opts['ylim']) + if label: + axes.legend() + axes.autoscale(enable=opts['autoscale']) - # MPL events - figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion) - figure.canvas.mpl_connect('pick_event', self.on_mpl_pick) + # MPL events + figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion) + figure.canvas.mpl_connect('pick_event', self.on_mpl_pick) - nb.AddPage(p, view.title) + nb.AddPage(p, view.title) - def update_statusbar(self): - sb = self.GetStatusBar() - menu_id = self.GetMenuBar().FindMenu('Datasets') - menu = self.GetMenuBar().GetMenu(menu_id) - for item in menu.GetMenuItems(): - if item.IsChecked(): - sb.SetStatusText("%s" % item.GetItemLabelText(), 1) - break + def update_statusbar(self): + sb = self.GetStatusBar() + menu_id = self.GetMenuBar().FindMenu('Datasets') + menu = self.GetMenuBar().GetMenu(menu_id) + for item in menu.GetMenuItems(): + if item.IsChecked(): + sb.SetStatusText("%s" % item.GetItemLabelText(), 1) + break - def update_title(self): - title = "MsSpec Data Viewer" - if self.data.title: - title += ": " + self.data.title - if self._filename: - title += " [" + os.path.basename(self._filename) + "]" - self.SetTitle(title) + def update_title(self): + title = "MsSpec Data Viewer" + if self.data.title: + title += ": " + self.data.title + if self._filename: + title += " [" + os.path.basename(self._filename) + "]" + self.SetTitle(title) - def on_mpl_motion(self, event): - sb = self.GetStatusBar() - try: - txt = "[{:.3f}, {:.3f}]".format(event.xdata, event.ydata) - sb.SetStatusText(txt, 2) - except Exception: - pass + def on_mpl_motion(self, event): + sb = self.GetStatusBar() + try: + txt = "[{:.3f}, {:.3f}]".format(event.xdata, event.ydata) + sb.SetStatusText(txt, 2) + except Exception: + pass - def on_mpl_pick(self, event): - print(event.artist) + def on_mpl_pick(self, event): + print(event.artist) - def on_page_changed(self, event): - self.update_statusbar() + def on_page_changed(self, event): + self.update_statusbar() From 7ee9269c32bfcde2e872256aa954f1a36ffdb8f2 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 26 Feb 2025 11:12:54 +0100 Subject: [PATCH 41/43] Change the F2PY command F2PY was 'f2py3', but it is now 'f2py' to ensure using the Fortran to Python builder of the current virtualenv. --- src/options.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/options.mk b/src/options.mk index 5e08919..6c30220 100644 --- a/src/options.mk +++ b/src/options.mk @@ -3,7 +3,7 @@ PYMAJ = 3 PYMIN = 5 FC = gfortran -F2PY = f2py3 --f77exec=$(FC) --f90exec=$(FC) +F2PY = f2py --f77exec=$(FC) --f90exec=$(FC) NO_VENV = 0 DEBUG = 0 From db6ee27699eae46cf4046207ca6d9260a10ef9ca Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 26 Feb 2025 11:15:03 +0100 Subject: [PATCH 42/43] Add a shape_cluster function This function is meant to replace the hemispherical_cluster function dur to some bugs. --- src/msspec/utils.py | 102 +++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 97 insertions(+), 5 deletions(-) diff --git a/src/msspec/utils.py b/src/msspec/utils.py index b5f4843..1c37f92 100644 --- a/src/msspec/utils.py +++ b/src/msspec/utils.py @@ -19,8 +19,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/utils.py -# Last modified: Thu, 06 Oct 2022 18:27:24 +0200 -# Committed by : Sylvain Tricot 1665073644 +0200 +# Last modified: Wed, 26 Feb 2025 11:15:03 +0100 +# Committed by : Sylvain Tricot """ @@ -468,8 +468,12 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0, # the symbol of your emitter symbol = cluster[np.where(cluster.get_tags() == emitter_tag)[0][0]].symbol - assert (diameter != 0 or planes != 0), \ - "At least one of diameter or planes parameter must be use." + if shape.lower() in ('spherical'): + assert (diameter != 0 or planes != 0), \ + "At least one of diameter or planes parameter must be use." + elif shape.lower() in ('cylindrical'): + assert (diameter != 0 and planes != 0), \ + "Diameter and planes parameters must be defined for cylindrical shape." if diameter == 0: # calculate the minimal diameter according to the number of planes @@ -479,6 +483,7 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0, # number of repetition in each direction rep = int(3*min_diameter/min(a, c)) + #print("rep = ", rep) # repeat the cluster cluster = cluster.repeat((rep, rep, rep)) @@ -542,7 +547,7 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0, xplan, yplan = get_xypos(cluster, zplan) radius = np.sqrt(xplan**2 + yplan**2 + zplan**2) - if diameter != 0: + if diameter != 0 and shape in ('spherical'): assert (radius <= diameter/2), ("The number of planes is too high " "compared to the diameter.") radius = max(radius, diameter/2) @@ -575,3 +580,90 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0, Atoms.translate(cluster, [0, 0, -ze]) # put the emitter in (0,0,0) return cluster + +def shape_cluster(primitive, emitter_tag=0, emitter_plane=0, diameter=0, + planes=0, shape='spherical'): + + """Creates and returns a cluster based on an Atoms object and some + parameters. + + :param cluster: the Atoms object used to create the cluster + :type cluster: Atoms object + :param emitter_tag: the tag of your emitter + :type emitter_tag: integer + :param diameter: the diameter of your cluster in Angströms + :type diameter: float + :param planes: the number of planes of your cluster + :type planes: integer + :param emitter_plane: the plane where your emitter will be starting by 0 + for the first plane + :type emitter_plane: integer + + See :ref:`hemispherical_cluster_faq` for more informations. + """ + # We need the radius of the cluster and the number of planes + if shape.lower() in ('ispherical', 'cylindrical'): + assert (nplanes != 0 and diameter != 0), "nplanes and diameter cannot be zero for '{}' shape".format(shape) + elif shape.lower() in ('spherical'): + if diameter <= 0: + # find the diameter based on the number of planes + assert planes != 0, "planes should be > 0" + + + n = 3 + natoms = 0 + while True: + n += 2 + cluster = primitive.copy() + # Repeat the primitive cell + cluster = cluster.repeat((n, n, n)) + center_cluster(cluster) + + # Find the emitter closest to the origin + all_tags = cluster.get_tags() + are_emitters = all_tags == emitter_tag + _ie = np.linalg.norm(cluster[are_emitters].positions, axis=1).argmin() + ie = np.nonzero(are_emitters)[0][_ie] + # Translate the cluster to this emitter position + cluster.translate(-cluster[ie].position) + # cut plane at surface and at bottom + all_z = np.unique(cluster.positions[:,2]) + try: + zsurf = all_z[all_z >= 0][emitter_plane] + except IndexError: + # There are not enough planes above the emitter + zsurf = all_z.max() + try: + zbottom = all_z[all_z <= 0][::-1][planes - (emitter_plane+1)] + except IndexError: + # There are not enough planes below the emitter + zbottom = all_z.min() + cluster = cut_plane(cluster, z=[zbottom,zsurf]) + # spherical shape + if shape.lower() in ('spherical'): + cluster = cut_sphere(cluster, radius=diameter/2, center=(0,0,zsurf)) + if shape.lower() in ('ispherical'): + cluster = cut_sphere(cluster, radius=diameter/2, center=(0,0,0)) + elif shape.lower() in ('cylindrical'): + cluster = cut_cylinder(cluster, radius=diameter/2) + else: + raise NameError("Unknown shape") + cluster.set_cell(primitive.cell) + if len(cluster) <= natoms: + break + else: + natoms = len(cluster) + + + return cluster + + + + + + + + + + + From feaaabc9c4f817776e51eaaef7ee834d09a67135 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Wed, 26 Feb 2025 11:15:54 +0100 Subject: [PATCH 43/43] Add kwargs to the pipeline function The user can now provide a 'pipeline' function with only '**kwargs' in arguments. It is more flexible and easier to write. The 'sweep_index' keyword is always automatically added, so the 'passindex' option has been removed since it was redundant with the index of the final dataframe object. The user-defined 'pipeline' function can now return anything. It is no longer limited to ([x,],[y,]) format. --- src/msspec/looper.py | 85 +++++++++++++++++++++++--------------------- 1 file changed, 44 insertions(+), 41 deletions(-) diff --git a/src/msspec/looper.py b/src/msspec/looper.py index 0dbfdc4..4393022 100644 --- a/src/msspec/looper.py +++ b/src/msspec/looper.py @@ -17,8 +17,8 @@ # along with this msspec. If not, see . # # Source file : src/msspec/looper.py -# Last modified: Mon, 27 Sep 2021 17:49:48 +0200 -# Committed by : sylvain tricot +# Last modified: Wed, 26 Feb 2025 11:15:54 +0100 +# Committed by : Sylvain Tricot from collections import OrderedDict from functools import partial @@ -92,9 +92,8 @@ class Sweep: class SweepRange: - def __init__(self, *sweeps, passindex=False): + def __init__(self, *sweeps): self.sweeps = sweeps - self.passindex = passindex self.index = 0 # First check that sweeps that are linked to another on are all included @@ -158,17 +157,15 @@ class SweepRange: for s in [sweep,] + children: key, value = s[idx] row[key] = value - if self.passindex: - row['sweep_index'] = i + row['sweep_index'] = i return row else: raise StopIteration @property def columns(self): - cols = [sweep.key for sweep in self.sweeps] - if self.passindex: - cols.append('sweep_index') + cols = ['sweep_index'] + cols += [sweep.key for sweep in self.sweeps] return cols @property @@ -202,31 +199,27 @@ class Looper: logger.debug("Pipeline called with {}".format(x)) return self.pipeline(**x) - def run(self, *sweeps, ncpu=1, passindex=False): + def run(self, *sweeps, ncpu=1, **kwargs): logger.info("Loop starts...") # prepare the list of inputs - sr = SweepRange(*sweeps, passindex=passindex) + sr = SweepRange(*sweeps) items = sr.items data = [] + t0 = time.time() + if ncpu == 1: # serial processing... logger.info("serial processing...") - t0 = time.time() - for i, values in enumerate(items): + values.update(kwargs) result = self._wrapper(values) data.append(result) - - t1 = time.time() - dt = t1 - t0 - logger.info("Processed {:d} sets of inputs in {:.3f} seconds".format( - len(sr), dt)) - else: # Parallel processing... chunksize = 1 #int(nsets/ncpu) + [values.update(kwargs) for values in items] logger.info(("Parallel processing over {:d} cpu (chunksize={:d})..." "").format(ncpu, chunksize)) t0 = time.time() @@ -236,21 +229,23 @@ class Looper: pool.close() pool.join() - t1 = time.time() - dt = t1 - t0 - logger.info(("Processed {:d} sets of inputs in {:.3f} seconds" - "").format(len(sr), dt)) + t1 = time.time() + dt = t1 - t0 + logger.info(("Processed {:d} sets of inputs in {:.3f} seconds" + "").format(len(sr), dt)) # Create the DataFrame dfdata = [] - columns = sr.columns + ['output',] + columns = sr.columns + list(kwargs.keys()) + ['output',] for i in range(len(sr)): row = list(items[i].values()) row.append(data[i]) dfdata.append(row) + df = pd.DataFrame(dfdata, columns=columns) + df = df.drop(columns=['sweep_index']) self.data = df @@ -259,14 +254,14 @@ class Looper: # of corresponding dict of parameters {'keyA': [val0,...valn], # 'keyB': [val0,...valn], ...} - all_xy = [] - for irow, row in df.iterrows(): - all_xy.append(row.output[0]) - all_xy.append(row.output[1]) - parameters = df.to_dict() - parameters.pop('output') + # all_xy = [] + # for irow, row in df.iterrows(): + # all_xy.append(row.output[0]) + # all_xy.append(row.output[1]) + # parameters = df.to_dict() + # parameters.pop('output') - return all_xy, parameters + return self.data #all_xy, parameters @@ -276,17 +271,16 @@ class Looper: if __name__ == "__main__": import numpy as np import time + import logging + + + logging.basicConfig(level=logging.DEBUG) - logger.setLevel(logging.DEBUG) def bar(**kwargs): - return 0 - - def post_process(data): - x = data.x.unique() - y = data.y.unique() - + i = kwargs.get('sweep_index') + return np.linspace(0,i,10) theta = Sweep(key='theta', comments="The polar angle", start=-70, stop=70, num=3, @@ -314,7 +308,16 @@ if __name__ == "__main__": looper = Looper() looper.pipeline = bar - data = looper.run(emitter, emitter_plane, uij, theta, levels, ncpu=4, - passindex=True) + other_kws = {'un':1, 'deux':2} + data = looper.run(emitter, emitter_plane, uij, theta, levels, ncpu=4, **other_kws) + + # Print the dataframe print(data) - #print(data[data.emitter_plane.eq(0)].theta.unique()) + + # Accessing the parameters and ouput values for a given sweep (e.g the last one) + print(looper.data.iloc[-1]) + + # Post-process the output values. For example here, the output is a 1D-array, + # make the sum of sweeps with 'Sr' emitter + X = np.array([ x for x in data[data.emitter == 'Sr'].output]).sum(axis=0) + print(X)