Compare commits

..

10 Commits

Author SHA1 Message Date
Sylvain Tricot c9aa391634 Merge branch 'hotfix/1.7.post13' 2023-03-29 11:45:01 +02:00
Sylvain Tricot cf74431c31 Fix new dtype values for Numpy.
Numpy does not allow anylonger types np.int or np.float.
These are replaced simply by int and float python native types.
2023-03-29 11:41:52 +02:00
Sylvain Tricot 0699f193b3 Merge branch 'hotfix/1.7.post12' 2022-10-06 18:24:31 +02:00
Sylvain Tricot 2bdc9943b9 Fix numpy bug with alen()
* The numpy.alen() function is deprecated. We use len() instead
* The use of pkg_resources is discouraged. We use importlib.metadata
  instead. I also removed setuptools_scm get_version. I switch to
  a simple call to "git describe", easier now that we use git flow
* The build fails with python3.10 if compiling wx from sources.
  A fix in the Makefile will be proposed in a future commit.
2022-10-06 18:19:16 +02:00
Sylvain Tricot b6f2531999 Merge branch 'hotfix/1.7.post11' 2022-10-05 13:44:04 +02:00
Sylvain Tricot a4351f5606 Add a "light" installation of msspec
This is similar to a "devel" installation, but only the
virtualenv is created and the msspec package is installed
inside (not in edit mode). Bindings to the Fortran code
are not built.

It is intended to use msspec functions to create clusters but
without having to install wx.
2022-10-05 13:40:22 +02:00
Sylvain Tricot 74ca8f467f Removed malloc NPH_M parameter.
epsi-builds/msspec_python3/pipeline/head There was a failure building this commit Details
In get_theta_phi_scan, the malloc keyword was given
with NPH_M=8000. It was enough for most of calculations
but it was also impossible to change in cases where more
memory was needed. The keyword is now removed so that
it can be direclty specified by the user if needed.
The default value was increased to 8000 instead of 2000.
2021-12-13 18:51:12 +01:00
Sylvain Tricot 38023dcd52 Bug in matplotlib 3.5.0
epsi-builds/msspec_python3/pipeline/head This commit looks good Details
There is presumably a bug when using pcolormesh
with msspec in matplotlib 3.5.0. The stereo projection
does not work properly and the CPU is rising at 100% as
well as the memory usage. Meanwhile, the event loop of Wx
is affected freezing the GUI. Reverting to last stable 3.4.3
version fixes the problem for now. A true fix should be found
asap.
2021-12-02 12:20:40 +01:00
Sylvain Tricot 75c599de95 Added 'other_parameters' keyword in _get_scan.
epsi-builds/msspec_python3/pipeline/head This commit looks good Details
This allows to set or modify any option right before runing
Phagen and Spec. Mostly for debug purposes.
2021-11-30 17:53:47 +01:00
Sylvain Tricot e36373a576 Fixed bug in 'mean_free_path' option.
It was impossible to enter a numerical value.
The 'allowed_values' keyword was set in the definition
of the 'mean_free_path' parameter, I commented it to
allow any value for this option.
2021-11-30 16:56:20 +01:00
54 changed files with 131 additions and 16762 deletions

4
Jenkinsfile vendored
View File

@ -13,9 +13,9 @@ pipeline {
}
stage('Syncing website...') {
steps {
echo 'Syncing website only in master branch, not here in devel branch...'
// echo 'Syncing website...'
// sh 'rm -rf $HOME/www/*'
// sh 'cp -a ./doc/build/html/* $HOME/www/'
sh 'cp -a ./doc/build/html/* $HOME/www/'
}
}

View File

@ -32,10 +32,17 @@ devel: venv pybinding wx
@$(INSIDE_VENV) pip install -e src/
light: VENV_PATH = ./_venv
light: venv
@$(INSIDE_VENV) pip install src/
_build_wx/wxPython.target:
@$(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
# Build the source if a tar.gz was downloaded

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,8 +16,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/__init__.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: ven. 10 avril 2020 17:22:12
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
import ase

View File

@ -1,25 +1,5 @@
#!/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 <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/calcio.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# vim: set et ts=4 sw=4 fdm=indent mouse=a cc=+1 tw=80:
"""
Module calcio
@ -747,15 +727,15 @@ class SpecIO(object):
content += line
nat = p.extra_nat
nra_arr = np.ones((nat), dtype=np.int)
nra_arr = np.ones((nat), dtype=int)
thfwd_arr = np.ones((nat))
path_filtering = p.extra_parameters['calculation'].get_parameter(
'path_filtering').value
if (path_filtering is not None and
'backward_scattering' in path_filtering):
ibwd_arr = np.ones((nat), dtype=np.int)
ibwd_arr = np.ones((nat), dtype=int)
else:
ibwd_arr = np.zeros((nat), dtype=np.int)
ibwd_arr = np.zeros((nat), dtype=int)
thbwd_arr = np.ones((nat))
for at in p.extra_atoms:
i = at.get('proto_index') - 1
@ -930,7 +910,7 @@ class SpecIO(object):
if content != old_content:
with open(filename, 'w') as fd:
fd.write(content)
LOGGER.debug("Writing Spec input file written in {}".format(filename))
LOGGER.debug(f"Writing Spec input file written in {filename}")
modified = True
return modified
@ -1275,13 +1255,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 + '{:02d}'.format(i) + '.txt')
results = np.loadtxt(prefix + f'{i:02d}' + '.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',
'experiment_{}.txt'.format(suffix)))
f'experiment_{suffix}.txt'))
calc_ren = np.loadtxt(os.path.join('calc', 'div',
'calculation{:d}_{}.txt'.format(index,suffix)))
f'calculation{index:d}_{suffix}.txt'))
return data, exp_ren, calc_ren

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,8 +16,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/calculator.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: ven. 10 avril 2020 17:19:24
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -302,7 +301,7 @@ class _MSCALCULATOR(Calculator):
wf = 4.5
source_energy = self.source_parameters.get_parameter('energy').value
ke = source_energy - binding_energy - wf
#return np.array(ke, dtype=np.float).flatten()
#return np.array(ke, dtype=float).flatten()
return ke
@ -384,7 +383,7 @@ class _MSCALCULATOR(Calculator):
'NODES_EX_M' : 3,
'NSPIN_M' : 1, # to change for spin dependent
'NTH_M' : 2000,
'NPH_M' : 2000,
'NPH_M' : 8000,
'NDIM_M' : 100000,
'N_TILT_M' : 11, # to change see extdir.f
'N_ORD_M' : 250,
@ -616,7 +615,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 +650,13 @@ class _PED(_MSCALCULATOR):
self.spectroscopy_parameters.set_parameter('level', level)
# It is still possible to modify any option right before runing phagen
# and spec
for k, v in other_parameters.items():
grp_str, param_str = k.split('.')
grp = getattr(self, grp_str)
grp.set_parameter(param_str, v, force=True)
self.get_tmatrix()
self.run_spec(malloc)
@ -852,7 +858,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 +877,11 @@ 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 +898,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 +920,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 +943,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})
**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 +964,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
@ -1123,7 +1132,7 @@ class RFACTOR(object):
for i in range(noif):
X, Y = args[2*i], args[2*i+1]
fname = os.path.join('calc',
'calculation{:d}.txt'.format(self.stack_count))
f'calculation{self.stack_count:d}.txt')
# And save to the working space
np.savetxt(fname, np.transpose([X, Y]))
self.stack_count += 1
@ -1131,7 +1140,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', 'calculation{:d}.txt'.format(i))
fname = os.path.join('calc', f'calculation{i:d}.txt')
self._params.calc_filename.append(fname)
# Write the input file
@ -1226,23 +1235,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(**{"calc{:d}".format(i): ycalc})
dset_rfc.add_columns(**{'variable_set{:d}'.format(i): rfc})
dset_values.add_columns(**{f"calc{i:d}": ycalc})
dset_rfc.add_columns(**{f'variable_set{i:d}': rfc})
# Plot the curves
view_values.select('x', 'yref', legend='Reference values')
title = ''
for k,v in self.best_values.items():
title += '{}={} '.format(k, v)
view_values.select('x', "calc{:d}".format(self.index),
title += f'{k}={v} '
view_values.select('x', f"calc{self.index:d}",
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', 'variable_set{:d}'.format(i),
legend="variables set #{:d}".format(i))
view_rfc.select('rfactor_number', f'variable_set{i:d}',
legend=f"variables set #{i:d}")
# Save the parameters
for p in self.get_parameters():
bundle = {'group': str(p.group),

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -19,8 +18,8 @@
# along with msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/cli.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: jeu. 04 juin 2020 16:54:12
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
import sys

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -19,8 +18,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/create_tests_results.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: ven. 10 avril 2020 17:29:16
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
from msspec.tests import create_tests_results

View File

@ -1,24 +1,5 @@
#!/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 <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/data/__init__.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# -*- encoding: utf-8 -*-
# vim: set fdm=indent ts=4 sw=4 sts=4 et ai tw=80 cc=+0 mouse=a nu : #
from .electron_be import electron_be

View File

@ -1,24 +1,4 @@
#!/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 <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/data/electron_be.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
"""
Module electron_be

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,8 +16,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/iodata.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: ven. 10 avril 2020 17:23:11
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -443,24 +442,24 @@ class DataSet(object):
for k, v in parameters.items():
if k == 'Cluster':
continue
s += "# {}:\n".format(k)
s += f"# {k}:\n"
if not(isinstance(v, list)):
v = [v,]
for p in v:
s += "# {} = {} {}\n".format(p['name'], p['value'], p['unit'])
s += f"# {p['name']} = {p['value']} {p['unit']}\n"
return s
colnames = self.columns()
with open(filename, mode) as fd:
# write the date and time of export
now = datetime.now()
fd.write("# Data exported on {}\n".format(now))
fd.write(f"# Data exported on {now}\n")
fd.write(rule)
# Append notes
fd.write("# NOTES:\n")
for line in self.notes.split('\n'):
fd.write("# {}\n".format(line))
fd.write(f"# {line}\n")
fd.write(rule)
# Append parameters

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -16,9 +15,9 @@
# You should have received a copy of the GNU General Public License
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/iodata_gi.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Source file : src/msspec/iodata.py
# Last modified: ven. 10 avril 2020 17:23:11
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -492,24 +491,24 @@ class DataSet(object):
for k, v in parameters.items():
if k == 'Cluster':
continue
s += "# {}:\n".format(k)
s += f"# {k}:\n"
if not(isinstance(v, list)):
v = [v,]
for p in v:
s += "# {} = {} {}\n".format(p['name'], p['value'], p['unit'])
s += f"# {p['name']} = {p['value']} {p['unit']}\n"
return s
colnames = self.columns()
with open(filename, mode) as fd:
# write the date and time of export
now = datetime.now()
fd.write("# Data exported on {}\n".format(now))
fd.write(f"# Data exported on {now}\n")
fd.write(rule)
# Append notes
fd.write("# NOTES:\n")
for line in self.notes.split('\n'):
fd.write("# {}\n".format(line))
fd.write(f"# {line}\n")
fd.write(rule)
# Append parameters

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -16,9 +15,9 @@
# You should have received a copy of the GNU General Public License
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/iodata_wx.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Source file : src/msspec/iodata.py
# Last modified: ven. 10 avril 2020 17:23:11
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -438,24 +437,24 @@ class DataSet(object):
for k, v in parameters.items():
if k == 'Cluster':
continue
s += "# {}:\n".format(k)
s += f"# {k}:\n"
if not(isinstance(v, list)):
v = [v,]
for p in v:
s += "# {} = {} {}\n".format(p['name'], p['value'], p['unit'])
s += f"# {p['name']} = {p['value']} {p['unit']}\n"
return s
colnames = self.columns()
with open(filename, mode) as fd:
# write the date and time of export
now = datetime.now()
fd.write("# Data exported on {}\n".format(now))
fd.write(f"# Data exported on {now}\n")
fd.write(rule)
# Append notes
fd.write("# NOTES:\n")
for line in self.notes.split('\n'):
fd.write("# {}\n".format(line))
fd.write(f"# {line}\n")
fd.write(rule)
# Append parameters

View File

@ -1,24 +1,6 @@
#!/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 <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/looper.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# coding: utf8
# -*- encoding: future_fstrings -*-
# vim: set et sw=4 ts=4 nu tw=79 cc=+1:
from collections import OrderedDict
from functools import partial
@ -39,7 +21,7 @@ class Variable:
self.doc = doc
def __repr__(self):
return "<Variable(\'{}\')>".format(self.name)
return f"<Variable(\'{self.name}\')>"
class Sweep:
def __init__(self, key, comments="", unit=None,

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -19,8 +18,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/misc.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: ven. 10 avril 2020 17:30:42
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -19,8 +18,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/parameters.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: ven. 10 avril 2020 17:31:50
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -1311,8 +1310,8 @@ class ScanParameters(BaseParameters):
# LOGGER.error('Incompatible options!')
# raise ValueError(msg)
# p._value = np.array(p.value, dtype=np.float).flatten()
arr = np.array(p.value, dtype=np.float).flatten()
# p._value = np.array(p.value, dtype=float).flatten()
arr = np.array(p.value, dtype=float).flatten()
theta0 = arr[0]
theta1 = arr[-1]
@ -1346,7 +1345,7 @@ class ScanParameters(BaseParameters):
# LOGGER.error('Incompatible options')
# raise ValueError(msg)
arr = np.array(p.value, dtype=np.float).flatten()
arr = np.array(p.value, dtype=float).flatten()
phi0 = arr[0]
phi1 = arr[-1]
@ -1540,7 +1539,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
@ -2013,20 +2012,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 "
"\"{}\"".format(p.value))
f"\"{p.value}\"")
def bind_rescale(self, p):
self.compcurve_parameters.general_iscale = int(p.value)
state = "deactivated"
if p.value:
state = "activated"
LOGGER.info("Curve Comparison: Rescaling of data {}".format(state))
LOGGER.info(f"Curve Comparison: Rescaling of data {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 "
"set to \"{}\"".format(p.value))
f"set to \"{p.value}\"")

View File

@ -1,6 +1,6 @@
.PHONY: all phd_se phd_mi aed_se aed_mi eig_mi eig_pw comp_curve clean
.PHONY: all phd_se phd_mi eig_mi eig_pw comp_curve clean
all: phd_se phd_mi aed_se aed_mi eig_mi eig_pw comp_curve
all: phd_se phd_mi eig_mi eig_pw comp_curve
phd_se:
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk all
@ -8,12 +8,6 @@ phd_se:
phd_mi:
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk all
aed_se:
@+$(MAKE) -f aed_se_mu_noso_nosp_nosym.mk all
aed_mi:
@+$(MAKE) -f aed_mi_mu_noso_nosp_nosym.mk all
eig_mi:
@+$(MAKE) -f eig_mi.mk all
@ -26,8 +20,6 @@ comp_curve:
clean::
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk $@
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk $@
@+$(MAKE) -f aed_se_mu_noso_nosp_nosym.mk $@
@+$(MAKE) -f aed_mi_mu_noso_nosp_nosym.mk $@
@+$(MAKE) -f eig_mi.mk $@
@+$(MAKE) -f eig_pw.mk $@
@+$(MAKE) -f comp_curve.mk $@

View File

@ -1,12 +0,0 @@
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)
#aed_mi_mu_noso_nosp_nosym_src := $(wildcard aed_mi_mu_noso_nosp_nosym/*.f)
aed_mi_mu_noso_nosp_nosym_src := $(filter-out aed_mi_mu_noso_nosp_nosym/lapack_axb.f, $(wildcard aed_mi_mu_noso_nosp_nosym/*.f))
SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(aed_mi_mu_noso_nosp_nosym_src)
MAIN_F = aed_mi_mu_noso_nosp_nosym/main.f
SO = _aed_mi_mu_noso_nosp_nosym.so
include ../../../options.mk

View File

@ -1,789 +0,0 @@
C
C=======================================================================
C
SUBROUTINE AEDDIF_MI_MU(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,
1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
C
C This subroutine computes the AED formula in the spin-independent case
C from a multiplet resolved initial core state L1. The
C intermediate state that gives its energy is L2 while the
C core hole that is filled in the process is noted LC. The
C multiplet is characterized by the integer angular momentum
C variables (L_MUL,S_MUL,J_MUL)
C
C Alternatively, it can compute the AED amplitude for the APECS process.
C
C The calculation is performed using a matrix inversion for the
C expression of the scattering path operator
C
C The matrix inversion is performed using the LAPACK inversion
C routines for a general complex matrix
C
C Last modified : 26 Apr 2013
C
USE DIM_MOD
USE ALGORITHM_MOD
USE AMPLI_MOD
USE APPROX_MOD
USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP
USE DEBWAL_MOD
USE DIRECT_A_MOD, DIRANA => DIRANA_A, ANADIR => ANADIR_A,
& RTHETA => RTHEXT_A, RPHI => RPHI_A,
& THETAR => THETAR_A, PHIR => PHIR_A
USE EXTREM_MOD
USE FIXSCAN_A_MOD, N_FIXED => N_FIXED_A, N_SCAN => N_SCAN_A,
& IPH_1 => IPH_1_A, FIX0 => FIX0_A,
& FIX1 => FIX1_A, SCAN0 => SCAN0_A,
& SCAN1 => SCAN1_A
USE INFILES_MOD
USE INUNITS_MOD
USE INIT_J_MOD
USE INIT_L_MOD
USE INIT_M_MOD
USE LIMAMA_MOD
USE MOYEN_A_MOD, IMOY => IMOY_A, NDIR => NDIR_A,
& ACCEPT => ACCEPT_A, ICHKDIR => ICHKDIR_A
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_A_MOD, NPHI => NPHI_A, NE => NE_A,
& NTHETA => NTHETA_A, NFTHET => NFTHET_A
USE RESEAU_MOD
USE SPIN_MOD
USE TESTPB_MOD
USE TESTS_MOD
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A,
& IFTHET => IFTHET_A, IMOD => IMOD_A,
& I_CP => I_CP_A, I_EXT => I_EXT_A,
& I_TEST => I_TEST_A
USE TYPEM_MOD
USE TYPEXP_MOD
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
USE VALIN_MOD, P0 => PHI0, T0 => THETA0, TM => THLUM,
& PM => PHILUM, EM => ELUM
C
COMPLEX IC,ONEC,ZEROC,PW(0:NDIF_M)
COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLMR(0:NL_M,-NL_M:NL_M)
COMPLEX YLME(0:NL_M,-NL_M:NL_M)
COMPLEX R2,M_COUL(0:NL_M,-NL_M:NL_M,2,-LI_M:LI_M,2)
COMPLEX SJDIR_1,SJDIF_1
COMPLEX RHOK(0:NT_M,NATM,0:40,2,NSPIN2_M),COU
COMPLEX SLJDIF,ATT_M,SLE_1
COMPLEX SL0DIF,SMJDIF
C
DIMENSION VAL(NATCLU_M),NATYP(NATM)
DIMENSION EMET(3),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*24 INFILE
CHARACTER*24 OUTFILE
C
DATA PIS180 /0.017453/
DATA EV,SMALL /13.60583,0.0001/
DATA BOHR /0.529177/
C
ALGO1=' '
ALGO2='MI'
ALGO3=' '
ALGO4=' '
C
IC=(0.,1.)
ONEC=(1.,0.)
ZEROC=(0.,0.)
NSCAT=NATCLU-1
ATTSE=1.
ATTSJ=1.
ZSURF=VAL(1)
C
I_DIR=0
NSET=1
JEL=2
C
IF(SPECTRO.EQ.'AED') THEN
IOUT=IUO2
OUTFILE=OUTFILE2
STAT='UNKNOWN'
IF(ABS(I_EXT).GE.1) THEN
ISET=IUI6
INFILE=INFILE6
ENDIF
ELSEIF(SPECTRO.EQ.'APC') THEN
IOUT=IUSCR2
OUTFILE='res/auger.amp'
STAT='UNKNOWN'
IF(ABS(I_EXT).GE.1) THEN
ISET=IUI9
INFILE=INFILE9
ENDIF
ENDIF
C
LF1=LE_MIN
LF2=LE_MAX
ISTEP_LF=2
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
WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,
1 IPH_1,I_EXT
ENDIF
C
IF(ISOM.EQ.0) THEN
WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE
ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN
WRITE(IOUT,11) NTHETA,NPHI,NE
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)
JTE=IEMET(JEMET)
JATLEM=JNEM
C
C Loop over the energies
C
DO JE=1,NE
FMIN(0)=1.
FMAX(0)=1.
IF(I_TEST.NE.1) THEN
CST VKR=REAL(VK(JE))
VKR=ABS(VK(JE))
ELSE
VKR=1.
ENDIF
CST ECIN=VKR*VKR*BOHR*BOHR*EV/(A*A)+VINT
ECIN=E0_A/(A*A)+VINT
IF(I_TEST.NE.1) THEN
CFM=2.*VKR
ELSE
CFM=1.
ENDIF
CALL LPM(ECIN,XLPM,*6)
XLPM1=XLPM/A
GAMMA=1./(2.*XLPM1)
IF(IPOTC.EQ.0) THEN
VK(JE)=VK(JE)+IC*GAMMA
ENDIF
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((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_A(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=ISET, FILE=INFILE, STATUS='OLD')
READ(ISET,13) I_DIR,NSET,N_DUM1
READ(ISET,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 LE=LE_MIN,LE_MAX,2
ILE=LE*LE+LE+1
DO ME=-LE,LE
INDE=ILE+ME
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDE,JATL)=ZEROC
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C
C Storage of the coupling matrix elements M_COUL
C
DO MC=-LI,LI
DO ISC=1,2
SC=FLOAT(ISC)-1.5
DO LA=LE_MIN,LE_MAX,2
DO MA=-LA,LA
DO ISA=1,2
SA=FLOAT(ISA)-1.5
CALL COUMAT_AM(LA,MA,SA,MC,SC,JTE,RHOK,COU)
M_COUL(LA,MA,ISA,MC,ISC)=COU
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C
C Matrix inversion for the calculation of TAU
C
IF(I_TEST.EQ.2) GOTO 666
CALL INV_MAT_MS_A(JE,TAU)
666 CONTINUE
C
C Calculation of the Auger Electron 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(ISET,86) JSET,JLINE,THD,PHD
IF(I_EXT.EQ.-1) BACKSPACE ISET
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
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(ISET,86) JSET,JLINE,THD,PHD
BACKSPACE ISET
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.
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(ISET,86) JSET,JLINE,THD,PHD,W
DTHETA=THD
DPHI=PHD
RTHETA=DTHETA*PIS180
RPHI=DPHI*PIS180
ELSE
W=1.
ENDIF
C
IF(I_EXT.EQ.-1) PRINT 89
C
CALL DIRAN(VINT,ECIN,JEL)
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
WRITE(IUO1,61) (DIRANA(J,1),J=1,3)
C
SRDIF_1=0.
SRDIR_1=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
SSCDIR_1=0.
SSCDIF_1=0.
C
C Loop over the equiprobable quantum numbers MC,SC and SA
C corresponding respectively to the core hole (MC and spin SC)
C and to the outgoing Auger electron (SA). The sum over the
C equiprobable azimuthal quantum number MJ of the multiplet
C configuration is suppressed here as, because of the selection
C rules, one has MJ = MA + MC + SA + SC
C
LME=LMAX(1,JE)
CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME)
C
DO ISC=1,2
SC=FLOAT(ISC)-1.5
C
SMCDIR_1=0.
SMCDIF_1=0.
C
DO MC=-LI,LI
C
SSADIR_1=0.
SSADIF_1=0.
C
DO ISA=1,2
SA=FLOAT(ISA)-1.5
C
SMJMDIR_1=0.
SMJMDIF_1=0.
C
DO MJM=-J_MUL,J_MUL
C
SJDIR_1=ZEROC
SJDIF_1=ZEROC
C
C Calculation of the direct emission (used a a reference for the output)
C
DO L_E=LE_MIN,LE_MAX,2
ILE=L_E*L_E+L_E+1
IF(ISPEED.EQ.1) THEN
R2=TL(L_E,1,1,JE)
ELSE
R2=TLT(L_E,1,1,JE)
ENDIF
M_E=MJM-MC-ISA-ISC+3
IF(ABS(M_E).GT.L_E) GOTO 444
INDE=ILE+M_E
SJDIR_1=SJDIR_1+YLME(L_E,M_E)*ATTSE*
1 M_COUL(L_E,M_E,ISA,MC,ISC)*R2
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,INDE,1)
DO M0=1,L0
IND01=IL0+M0
IND02=IL0-M0
SL0DIF=SL0DIF+(YLME(L0,M0)*
1 TAU(IND01,INDE,1)+
2 YLME(L0,-M0)*
3 TAU(IND02,INDE,1))
ENDDO
ENDDO
SJDIF_1=SJDIF_1+SL0DIF*M_COUL(L_E,M_E,ISA,MC,ISC)
444 CONTINUE
ENDDO
SJDIF_1=SJDIF_1*ATTSE
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_A(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
SLE_1=ZEROC
DO L_E=LE_MIN,LE_MAX,2
ILE=L_E*L_E+L_E+1
M_E=MJM-MC-ISA-ISC+3
IF(ABS(M_E).GT.L_E) GOTO 555
INDE=ILE+M_E
SLJDIF=ZEROC
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDE,JATL)
IF(LJ.GT.0) THEN
DO MJ=1,LJ
INDJ1=ILJ+MJ
INDJ2=ILJ-MJ
SMJDIF=SMJDIF+(YLMR(LJ,MJ)*
1 TAU(INDJ1,INDE,JATL)+
2 YLMR(LJ,-MJ)*
3 TAU(INDJ2,INDE,JATL))
ENDDO
ENDIF
SLJDIF=SLJDIF+SMJDIF
ENDDO
SLE_1=SLE_1+SLJDIF*M_COUL(L_E,M_E,ISA,MC,ISC)
555 CONTINUE
ENDDO
SJDIF_1=SJDIF_1+SLE_1*ATT_M
C
C End of the loops over the last atom J
C
ENDDO
ENDDO
C
C Writing the amplitudes in file IOUT for APECS
C
111 IF(SPECTRO.EQ.'APC') THEN
IF(I_TEST.EQ.2) SJDIF_1=SJDIR_1
WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,
1 JDIR,ISC,MC,ISA,MJM,SJDIR_1,SJDIF_1
ELSE
C
C Computing the square modulus
C
SSADIF_1=SSADIF_1+CABS(SJDIF_1)*CABS(SJDIF_1)
SSADIR_1=SSADIR_1+CABS(SJDIR_1)*CABS(SJDIR_1)
C
ENDIF
C
C End of the loop over MJM
C
ENDDO
C
SMJMDIF_1=SMJMDIF_1+SSADIF_1
SMJMDIR_1=SMJMDIR_1+SSADIR_1
C
C End of the loop over SA
C
ENDDO
C
SMCDIF_1=SMCDIF_1+SMJMDIF_1
SMCDIR_1=SMCDIR_1+SMJMDIR_1
C
C End of the loop over MC
C
ENDDO
C
SSCDIF_1=SSCDIF_1+SMCDIF_1
SSCDIR_1=SSCDIR_1+SMCDIR_1
C
C End of the loop over SC
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 220
SRDIR_1=SRDIR_1+SSCDIR_1*VKR*CFM/NDIR
SRDIF_1=SRDIF_1+SSCDIF_1*VKR*CFM/NDIR
220 CONTINUE
C
C End of the loop on the directions of the analyzer
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 221
SSETDIR_1=SSETDIR_1+SRDIR_1*W
SSETDIF_1=SSETDIF_1+SRDIF_1*W
IF(ICHKDIR.EQ.2) THEN
IF(JSET.EQ.JREF) THEN
SSET2DIR_1=SRDIR_1
SSET2DIF_1=SRDIF_1
ENDIF
ENDIF
221 CONTINUE
C
C End of the loop on the set averaging
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 222
IF(ISOM.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,
1 SSETDIR_1,SSETDIF_1
IF(ICHKDIR.EQ.2) THEN
WRITE(IUO2,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(IUO2,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,
1 SSET2DIR_1,SSET2DIF_1
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(ISET)
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(ISET)
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_AED(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)
13 FORMAT(6X,I1,1X,I3,2X,I4)
14 FORMAT(6X,I1,1X,I3,3X,I3)
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,') ..........')
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',/)
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,I2,2X,I2,2X,I2,
1 2X,I2,2X,I2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =',
1 F6.2)
89 FORMAT(/,4X,'..........................................',
1 '.....................................')
C
7 RETURN
C
END

View File

@ -1,198 +0,0 @@
C
C=======================================================================
C
SUBROUTINE INV_MAT_MS_A(JE,TAU)
C
C This subroutine stores the multiple scattering matrix and computes
C the scattering path operator TAU^{j 0} exactly, without explicitely
C using the inverse matrix.
C
C (Auger electron case)
C
C Last modified : 31 Jul 2007
C
USE DIM_MOD
C
USE COOR_MOD
USE INIT_L_MOD
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, VK2 =>
& VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
C
C PARAMETER(NLTWO=2*NL_M)
C
COMPLEX*16 HL1(0:2*NL_M),SM(LINMAXA*NATCLU_M,LINMAXA*NATCLU_M)
COMPLEX*16 IN(LINMAXA*NATCLU_M,LINMAXA)
COMPLEX*16 SUM_L,ONEC,IC,ZEROC
COMPLEX*16 YLM(0:2*NL_M,-2*NL_M:2*NL_M),TLJ,TLK,EXPKJ
C
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
C
REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
C
INTEGER IPIV(LINMAXA*NATCLU_M)
C
CHARACTER*1 CH
C
DATA PI /3.1415926535898D0/
C
ONEC=(1.D0,0.D0)
IC=(0.D0,1.D0)
ZEROC=(0.D0,0.D0)
IBESS=3
CH='N'
C
C Construction of the multiple scattering matrix MS = (I-GoT).
C Elements are stored using a linear index LINJ representing
C (J,LJ)
C
JLIN=0
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
XJ=SYM_AT(1,JATL)
YJ=SYM_AT(2,JATL)
ZJ=SYM_AT(3,JATL)
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
TLJ=DCMPLX(TL(LJ,1,JTYP,JE))
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
JLIN=JLIN+1
C
KLIN=0
DO KTYP=1,N_PROT
NBTYPK=NATYP(KTYP)
LMK=LMAX(KTYP,JE)
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.NE.JATL) THEN
XKJ=DBLE(SYM_AT(1,KATL)-XJ)
YKJ=DBLE(SYM_AT(2,KATL)-YJ)
ZKJ=DBLE(SYM_AT(3,KATL)-ZJ)
RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
KRKJ=DBLE(VK(JE))*RKJ
ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*RKJ)
EXPKJ=(XKJ+IC*YKJ)/RKJ
ZDKJ=ZKJ/RKJ
CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,LMJ+LMK)
CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,HL1)
ENDIF
C
DO LK=0,LMK
ILK=LK*LK+LK+1
L_MIN=ABS(LK-LJ)
L_MAX=LK+LJ
TLK=DCMPLX(TL(LK,1,KTYP,JE))
DO MK=-LK,LK
INDK=ILK+MK
KLIN=KLIN+1
SM(KLIN,JLIN)=ZEROC
SUM_L=ZEROC
IF(KATL.NE.JATL) THEN
CALL GAUNT2(LK,MK,LJ,MJ,GNT)
C
DO L=L_MIN,L_MAX,2
M=MJ-MK
IF(ABS(M).LE.L) THEN
SUM_L=SUM_L+(IC**L)*HL1(L)*
1 YLM(L,M)*GNT(L)
ENDIF
ENDDO
SUM_L=SUM_L*ATTKJ*4.D0*PI*IC
ELSE
SUM_L=ZEROC
ENDIF
C
IF(KLIN.EQ.JLIN) THEN
SM(KLIN,JLIN)=ONEC-TLK*SUM_L
IF(JTYP.EQ.1) THEN
IN(KLIN,JLIN)=ONEC
ENDIF
ELSE
SM(KLIN,JLIN)=-TLK*SUM_L
IF(JTYP.EQ.1) THEN
IN(KLIN,JLIN)=ZEROC
ENDIF
ENDIF
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
LW2=(LMAX(1,JE)+1)*(LMAX(1,JE)+1)
C
C Partial inversion of the multiple scattering matrix MS and
C multiplication by T : the LAPACK subroutine performing
C
C A * x = b
C
C is used where b is the block column corresponding to
C the absorber 0 in the identity matrix. x is then TAU^{j 0}.
C
CALL ZGETRF(JLIN,JLIN,SM,LINMAXA*NATCLU_M,IPIV,INFO1)
IF(INFO1.NE.0) THEN
WRITE(6,*) ' ---> INFO1 =',INFO1
ELSE
CALL ZGETRS(CH,JLIN,LW2,SM,LINMAXA*NATCLU_M,IPIV,
1 IN,LINMAXA*NATCLU_M,INFO)
ENDIF
C
C Storage of the Tau matrix
C
JLIN=0
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
TLJ=DCMPLX(TL(LJ,1,JTYP,JE))
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
JLIN=JLIN+1
C
KLIN=0
DO KTYP=1,N_PROT
NBTYPK=NATYP(KTYP)
LMK=LMAX(KTYP,JE)
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
C
DO LK=0,LMK
ILK=LK*LK+LK+1
DO MK=-LK,LK
INDK=ILK+MK
KLIN=KLIN+1
IF((JATL.EQ.1).AND.(LJ.LE.LF2)) THEN
TAU(INDK,INDJ,KATL)=CMPLX(IN(KLIN,JLIN)*TLJ)
ENDIF
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
RETURN
C
END

View File

@ -1,140 +0,0 @@
C
C=======================================================================
C
SUBROUTINE COUMAT_AM(LA,MA,SA,MC,SC,JE,RHOK_A,MATRIX_AM)
C
C This routine calculates the multiplet-resolved spin-independent
C Coulomb matrix elements occuring in the Auger process. They
C are stored in MATRIX_AM. The multiplet component is characterized
C by the quantum numbers (L,S,J) which are read from the input
C data file.
C
C Here, the conventions are (direct process D):
C
C (LC,MC) : core hole filled by intermediate electron
C (L1,M1) : Auger electron before excitation
C (L2,M2) : intermediate electron that fills the core hole
C (LA,MA) : Auger electron after excitation
C
C In the exchange process E, the roles of (L1,M1) and (L2,M2)
C are interchanged.
C
C Note that the Clebsch-Gordan corresponding to the spin-orbit
C resolved core state is not included in the formula here. This
C is because in APECS, it appears also in the dipole matrix
C element and it is therefore useless to calculate it twice.
C Therefore, it must be implemented into the cross-section
C subroutine.
C
C The factor i**LA comes from the particular normalization used
C in the phagen code
C
C Last modified : 8 Dec 2008
C
USE DIM_MOD
C
USE C_G_M_MOD
USE INIT_A_MOD, LC => LI_C, L2 => LI_I, L1 => LI_A
USE TYPCAL_A_MOD, I1 => IPHI_A, I2 => IE_A, I3 => ITHETA_A,
1 I4 => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A,
2 I7 => I_EXT_A, I_TEST => I_TEST_A
USE INIT_M_MOD
C
COMPLEX RHOK_A(0:NT_M,NATM,0:40,2,NSPIN2_M)
COMPLEX ZEROC,ONEC,MATRIX_AM
COMPLEX SUM_LB,SUM_M1,IC,IL
C
REAL*4 CG1(0:N_GAUNT),CG2(0:N_GAUNT)
REAL*4 GNT1(0:N_GAUNT),GNT2(0:N_GAUNT),GNT3(0:N_GAUNT)
REAL*4 GNT4(0:N_GAUNT)
C
REAL*8 ZEROD
C
DATA PI4,ONEOSQ2,HALF /12.566371,0.707107,0.5/
C
ZEROC=(0.,0.)
ONEC=(1.,0.)
IC=(0.,1.)
ZEROD=0.D0
C
IF(I_TEST.EQ.1) GOTO 2
C
IF(MOD(LA,4).EQ.0) THEN
IL=ONEC
ELSEIF(MOD(LA,4).EQ.1) THEN
IL=IC
ELSEIF(MOD(LA,4).EQ.2) THEN
IL=-ONEC
ELSEIF(MOD(LA,4).EQ.3) THEN
IL=-IC
ENDIF
C
IF(I_SHELL.EQ.0) THEN
COEF1=ONEOSQ2*PI4
ELSEIF(I_SHELL.EQ.1) THEN
COEF1=HALF*PI4
ENDIF
C
IF(MOD(S_MUL,2).EQ.0) THEN
SIGN1=1.
ELSE
SIGN1=-1.
ENDIF
C
C Values of MJ, ML and MS given by the Clebsch-Gordan
C
ML=MA+MC
MS=INT(SA+SC+0.0001)
MJ=ML+MS
C
C Storage indices for the spin Clebsch-Gordan :
C
C ISA(C) = 1 for -1/2 and 2 for 1/2
C IS = 1 for S_MUL=0 and 2 for S_MUL=1
C
IS=S_MUL+1
ISA=INT(SA+1.5001)
ISC=INT(SC+1.5001)
C
C Bounds of the sum over LB
C
LB_MAX_D=MIN(L1+LA,L2+LC)
LB_MIN_D=MAX(ABS(L1-LA),ABS(L2-LC))
LB_MAX_E=MIN(L2+LA,L1+LC)
LB_MIN_E=MAX(ABS(L2-LA),ABS(L1-LC))
LB_MIN=MIN(LB_MIN_D,LB_MIN_E)
LB_MAX=MAX(LB_MAX_D,LB_MAX_E)
C
N_CG=2
CALL N_J(DFLOAT(L_MUL),DFLOAT(ML),DFLOAT(S_MUL),DFLOAT(MS),
1 ZEROD,CG1,I_INT1,N_CG)
C
SUM_M1=ZEROC
DO M1=-L1,L1
M2=ML-M1
C
CALL N_J(DFLOAT(L1),DFLOAT(M1),DFLOAT(L2),DFLOAT(ML-M1),
1 ZEROD,CG2,I_INT2,N_CG)
CALL GAUNT(L1,M1,LA,MA,GNT1)
CALL GAUNT(LC,MC,L2,M2,GNT2)
CALL GAUNT(L2,M2,LA,MA,GNT3)
CALL GAUNT(LC,MC,L1,M1,GNT4)
C
SUM_LB=ZEROC
DO LB=LB_MIN,LB_MAX
SUM_LB=SUM_LB+(RHOK_A(LA,JE,LB,1,1)*GNT1(LB)*GNT2(LB)+
1 RHOK_A(LA,JE,LB,2,1)*GNT3(LB)*GNT4(LB)*
2 SIGN1)/FLOAT(LB+LB+1)
ENDDO
SUM_M1=SUM_M1+SUM_LB*CG2(L_MUL)
ENDDO
C
MATRIX_AM=SUM_M1*CG1(J_MUL)*CG_S(ISA,ISC,IS)*COEF1*IL
C
GOTO 1
C
2 MATRIX_AM=ONEC
C
1 RETURN
C
END

View File

@ -1,88 +0,0 @@
C
C=======================================================================
C
SUBROUTINE DWSPH_A(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 TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, VK2 =>
& VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
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

View File

@ -1,115 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FACDIF1_A(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,
1 FSPH,JAT,JE,*)
C
C This routine computes a spherical wave scattering factor
C
C Last modified : 03/04/2006
C
USE DIM_MOD
C
USE APPROX_MOD
USE EXPFAC_MOD
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE TYPCAL_A_MOD, I2 => IPHI_A, I3 => IE_A, I4 => ITHETA_A,
& IFTHET => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A,
& I7 => I_EXT_A, I8 => I_TEST_A
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
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

View File

@ -1,28 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FACDIF_A(COSTH,JAT,JE,FTHETA)
C
C This routine computes the plane wave scattering factor
C
USE DIM_MOD
C
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
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

File diff suppressed because it is too large Load Diff

View File

@ -1,21 +0,0 @@
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_AED_MU_MI()
CALL CLOSE_ALL_FILES()
END SUBROUTINE RUN

View File

@ -1,106 +0,0 @@
C
C=======================================================================
C
SUBROUTINE PLOTFD_A(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 PARCAL_A_MOD, N3 => NPHI_A, N4 => NE_A, N5 => NTHETA_A,
& NFTHET => NFTHET_A
USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A,
& IFTHET => IFTHET_A, IMOD => IMOD_A,
& I_CP => I_CP_A, I_EXT => I_EXT_A,
& I_TEST => I_TEST_A
USE VALIN_MOD, PHI00 => PHI0, THETA00 => THETA0, U1 => THLUM,
& U2 => PHILUM, U3 => ELUM, N7 => NONVOL
USE VALFIN_MOD, PHI11 => PHI1, THETA11 => THETA1
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
C
DIMENSION LMX(NATM,NE_M)
C
COMPLEX FSPH,VKE
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_A(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,
1 FSPH,JAT,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,
1 1X,F6.2,1X,F8.2)
80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ',
1 'IS ZERO >>>>>')
100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',
1 ' : ',I2,' >>>>>')
C
RETURN
C
END

View File

@ -1,791 +0,0 @@
C
C=======================================================================
C
SUBROUTINE TREAT_AED(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
C
USE OUTUNITS_MOD
USE TYPEXP_MOD, DUMMY => SPECTRO
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
USE VALIN_MOD, P0 => PHI0, T0 => THETA0
USE VALFIN_MOD, P1 => PHI1, T1 => THETA1
C
PARAMETER(N_HEAD=5000,N_FILES=1000)
C
CHARACTER*3 SPECTRO
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
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,
1 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)/
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)*
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 +
1 (JEMET-1)*NE*N_FIXED*N_SCAN +
2 (JE-1)*N_FIXED*N_SCAN +
3 (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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
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),
1 ECIN(JE),TAB(JLIN2,1),TAB(JLIN2,2),
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 +
1 (JEMET-1)*NE*NTHETA*NPHI +
2 (JE-1)*NTHETA*NPHI +
3 (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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 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),
1 VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR2_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)/
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)*
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 +
1 (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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
2 TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
1 DPHI(JPHI2),ECIN(JE),
2 TAB(JLIN2,1),TAB(JLIN2,2),
3 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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
2 TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
1 DPHI(JPHI2),ECIN(JE),
2 TAB(JLIN2,1),TAB(JLIN2,2),
3 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 +
1 (JTHETA-1)*NPHI + JPHI
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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 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),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),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),
1 VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),VOLDIR2_1,VOLDIF2_1,
3 VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),TOTDIR2_1,TOTDIF2_1,
3 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 +
1 (JTHETA-1)*NPHI + JPHI
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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),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,
1 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 ',
1 'IN THE TREAT_AED SUBROUTINE - INCREASE NDIM_M ',
2 '>>>>>>>>>>')
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,
1 2X,E12.6,2X,E12.6,2X,E12.6)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,
1 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 ',
1 'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,
2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6,
3 ' >>>>>>>>>>')
38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ',
1 'IN THE INCLUDE FILE >>>>>>>>>>',/,8X,
2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6,
3 ' >>>>>>>>>>')
888 FORMAT(A72)
C
6 RETURN
C
END

View File

@ -1,335 +0,0 @@
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

View File

@ -1,11 +0,0 @@
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)
aed_se_mu_noso_nosp_nosym_src := $(wildcard aed_se_mu_noso_nosp_nosym/*.f)
SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(aed_se_mu_noso_nosp_nosym_src)
MAIN_F = aed_se_mu_noso_nosp_nosym/main.f
SO = _aed_se_mu_noso_nosp_nosym.so
include ../../../options.mk

View File

@ -1,998 +0,0 @@
C
C=======================================================================
C
SUBROUTINE AEDDIF_SE_MU(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,
1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
C
C This subroutine computes the AED formula in the spin-independent case
C from a multiplet resolved initial core state L1. The
C intermediate state that gives its energy is L2 while the
C core hole that is filled in the process is noted LC. The
C multiplet is characterized by the integer angular momentum
C variables (L_MUL,S_MUL,J_MUL)
C
C Alternatively, it can compute the AED amplitude for the APECS process.
C
C The calculation is performed using a series expansion for the
C expression of the scattering path operator
C
C Last modified : 26 Apr 2013
C
USE DIM_MOD
C
USE ALGORITHM_MOD
USE AMPLI_MOD
USE APPROX_MOD
USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP
USE DEBWAL_MOD
USE DIRECT_A_MOD, DIRANA => DIRANA_A, ANADIR => ANADIR_A,
& RTHETA => RTHEXT_A, RPHI => RPHI_A,
& THETAR => THETAR_A, PHIR => PHIR_A
USE EXTREM_MOD
USE FIXSCAN_A_MOD, N_FIXED => N_FIXED_A, N_SCAN => N_SCAN_A,
& IPH_1 => IPH_1_A, FIX0 => FIX0_A,
& FIX1 => FIX1_A, SCAN0 => SCAN0_A,
& SCAN1 => SCAN1_A
USE INFILES_MOD
USE INUNITS_MOD
USE INIT_J_MOD
USE INIT_L_MOD
USE INIT_M_MOD
USE LIMAMA_MOD
USE LINLBD_MOD
USE MOYEN_A_MOD, IMOY => IMOY_A, NDIR => NDIR_A,
& ACCEPT => ACCEPT_A, ICHKDIR => ICHKDIR_A
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_A_MOD, NPHI => NPHI_A, NE => NE_A,
& NTHETA => NTHETA_A, NFTHET => NFTHET_A
USE PATH_MOD
USE PRINTP_MOD
USE RESEAU_MOD
USE SPIN_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TESTS_MOD
USE TL_AED_MOD, DLT = > DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A,
& IFTHET => IFTHET_A, IMOD => IMOD_A,
& I_CP => I_CP_A, I_EXT => I_EXT_A,
& I_TEST => I_TEST_A
USE TYPEM_MOD
USE TYPEXP_MOD
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
USE VALIN_MOD, P0 => PHI0, T0 => THETA0, TM => THLUM,
& PM => PHILUM, EM => ELUM
C
REAL NPATH1(0:NDIF_M),NOPA
C
COMPLEX IC,ONEC,ZEROC,PW(0:NDIF_M)
COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLMR(0:NL_M,-NL_M:NL_M)
COMPLEX YLME(0:NL_M,-NL_M:NL_M)
COMPLEX R2,M_COUL(0:NL_M,-NL_M:NL_M,2,-LI_M:LI_M,2)
COMPLEX SJDIR_1,SJDIF_1
COMPLEX RHOK(0:NT_M,NATM,0:40,2,NSPIN2_M),COU
COMPLEX SLJDIF,ATT_M,SLE_1
COMPLEX SL0DIF,SMJDIF
C
DIMENSION VAL(NATCLU_M),NATYP(NATM)
DIMENSION EMET(3),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*24 INFILE
CHARACTER*24 OUTFILE
C
DATA PIS180 /0.017453/
DATA EV,SMALL /13.60583,0.0001/
DATA BOHR /0.529177/
C
ALGO1=' '
ALGO2='SE'
ALGO3=' '
ALGO4=' '
C
IC=(0.,1.)
ONEC=(1.,0.)
ZEROC=(0.,0.)
NSCAT=NATCLU-1
ATTSE=1.
ATTSJ=1.
NPATH2(0)=1.
NPATH(0)=1.
NPMA(0)=1.
NPMI(0)=1.
ZSURF=VAL(1)
C
I_DIR=0
NSET=1
JEL=2
C
IF(SPECTRO.EQ.'AED') THEN
IOUT=IUO2
OUTFILE=OUTFILE2
STAT='UNKNOWN'
IF(ABS(I_EXT).GE.1) THEN
ISET=IUI6
INFILE=INFILE6
ENDIF
ELSEIF(SPECTRO.EQ.'APC') THEN
IOUT=IUSCR2
OUTFILE='res/auger.amp'
STAT='UNKNOWN'
IF(ABS(I_EXT).GE.1) THEN
ISET=IUI9
INFILE=INFILE9
ENDIF
ENDIF
C
LF1=LE_MIN
LF2=LE_MAX
ISTEP_LF=2
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
WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,
1 IPH_1,I_EXT
ENDIF
C
IF(ISOM.EQ.0) THEN
WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE
ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN
WRITE(IOUT,11) NTHETA,NPHI,NE
ENDIF
C
C Construction of the linear index LAMBDA=(MU,NU)
C
LAMBDA0=0
DO N_O=0,NO
NMX=N_O/2
DO NU=0,NMX
DO MU=-N_O,N_O
NMU=2*NU+ABS(MU)
IF(NMU.EQ.N_O) THEN
LAMBDA0=LAMBDA0+1
LBD(MU,NU)=LAMBDA0
ENDIF
ENDDO
ENDDO
ENDDO
LBDMAX=LAMBDA0
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)
JTE=IEMET(JEMET)
C
C Loop over the energies
C
DO JE=1,NE
FMIN(0)=1.
FMAX(0)=1.
IF(I_TEST.NE.1) THEN
VKR=REAL(VK(JE))
ELSE
VKR=1.
ENDIF
ECIN=VKR*VKR*BOHR*BOHR*EV/(A*A)+VINT
IF(I_TEST.NE.1) THEN
CFM=2.*VKR
ELSE
CFM=1.
ENDIF
CALL LPM(ECIN,XLPM,*6)
XLPM1=XLPM/A
GAMMA=1./(2.*XLPM1)
IF(IPOTC.EQ.0) THEN
VK(JE)=VK(JE)+IC*GAMMA
ENDIF
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((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_A(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=ISET, FILE=INFILE, STATUS='OLD')
READ(ISET,13) I_DIR,NSET,N_DUM1
READ(ISET,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 LE=LE_MIN,LE_MAX,2
ILE=LE*LE+LE+1
DO ME=-LE,LE
INDE=ILE+ME
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDE,JATL)=ZEROC
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C
C Storage of the coupling matrix elements M_COUL
C
DO MC=-LI,LI
DO ISC=1,2
SC=FLOAT(ISC)-1.5
DO LA=LE_MIN,LE_MAX,2
DO MA=-LA,LA
DO ISA=1,2
SA=FLOAT(ISA)-1.5
CALL COUMAT_AM(LA,MA,SA,MC,SC,JTE,RHOK,COU)
M_COUL(LA,MA,ISA,MC,ISC)=COU
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C
C Calculation of the scattering path operator TAU
C
IF(I_TEST.EQ.2) GOTO 666
PW(0)=ONEC
PW(1)=ONEC
ND=0
TH01=0.
PHI01=0.
RHO01=ZEROC
THMI=0.
PHMI=0.
RHOMI=ZEROC
JATLEM=JNEM
IF(NTYPEM.GT.1) THEN
DO JAEM=NTYPEM-1,1,-1
JATLEM=JATLEM+NATYP(JAEM)
ENDDO
ENDIF
DO JD=1,NDIF
NPATH2(JD)=0.
NPATH(JD)=0.
IT(JD)=0
IN(JD)=0
FMIN(JD)=1.E+20
FMAX(JD)=0.
ENDDO
NTHOF=0
C
C Calculation of the maximal intensity for the paths of order NCUT
C (plane waves). This will be taken as a reference for the IPW filter.
C
IF(IPW.EQ.1) THEN
NDIFOLD=NDIF
NOOLD=NO
ISPHEROLD=ISPHER
NDIF=NCUT
NO=0
ISPHER=0
IREF=1
IPW=0
IJ=0
DIJ=0.
FREF=0.
CALL FINDPATHS_A(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,
1 THMI,PHMI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
NDIF=NDIFOLD
NO=NOOLD
ISPHER=ISPHEROLD
PW(0)=ONEC
PW(1)=ONEC
IPW=1
ND=0
TH01=0.
PHI01=0.
RHO01=ZEROC
THMI=0.
PHMI=0.
RHOMI=ZEROC
JATLEM=JNEM
IF(NTYPEM.GT.1) THEN
DO JAEM=NTYPEM-1,1,-1
JATLEM=JATLEM+NATYP(JAEM)
ENDDO
ENDIF
DO JD=1,NDIF
NPATH2(JD)=0.
NPATH(JD)=0.
IT(JD)=0
IN(JD)=0
FMIN(JD)=1.E+20
FMAX(JD)=0.
ENDDO
NTHOF=0
C
C New initialization of TAU(INDJ,INDF,JATL) after the PW calculation
C
JATL=0
DO JTYP=1,N_PROT
NBTYP=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYP
JATL=JATL+1
DO LE=LE_MIN,LE_MAX,2
ILE=LE*LE+LE+1
DO ME=-LE,LE
INDE=ILE+ME
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDE,JATL)=ZEROC
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDIF
C
C Generation and print-out of the paths
C
IF (NPATHP.GT.0) THEN
DO JP=1,NPATHP-1
FMN(JP)=0.
PATH(JP)=0.
JON(JP)=0
ENDDO
FMN(NPATHP)=-1.
PATH(NPATHP)=0.
JON(NPATHP)=0
ENDIF
IREF=0
IJ=1
IF(IPRINT.EQ.3) THEN
OPEN(UNIT=IUSCR, STATUS='SCRATCH')
ENDIF
DIJ=0.
CALL FINDPATHS_A(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,
1 THMI,PHMI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
IF(NPATHP.EQ.0) GOTO 15
IF(NSCAT.GT.1) THEN
XPATOT=REAL((DFLOAT(NSCAT)**DFLOAT(NDIF+1) -1.D0)/
1 DFLOAT(NSCAT-1))
ELSE
XPATOT=FLOAT(NDIF+1)
ENDIF
IF(XPATOT.LT.2.14748E+09) THEN
NPATOT=INT(XPATOT)
IF(NPATOT.LT.NPATHP) NPATHP=NPATOT-1
ENDIF
WRITE(IUO1,84) NPATHP
WRITE(IUO1,81)
DO JPT=1,NPATHP
IF(PATH(NPATHP).GT.2.14E+09) THEN
WRITE(IUO1,82) JPT,JON(JPT),PATH(JPT),FMN(JPT),DMN(JPT),
1 JNEM,(JPON(JPT,KD),KD=1,JON(JPT))
ELSE
WRITE(IUO1,83) JPT,JON(JPT),INT(PATH(JPT)),FMN(JPT),
1 DMN(JPT),JNEM,(JPON(JPT,KD),KD=1,JON(JPT))
ENDIF
ENDDO
IF(IPRINT.EQ.3) THEN
IF(XPATOT.GT.2.14748E+09) GOTO 172
WRITE(IUO1,85)
WRITE(IUO1,71)
NPATOT=INT(XPATOT)
DO JOP=0,NDIF
IF(JOP.EQ.0) THEN
XINT0=FMAX(0)
DIST0=0.
WRITE(IUO1,70) JOP,JOP+1,XINT0,DIST0,JNEM
GOTO 75
ENDIF
WRITE(IUO1,77)
DO JLINE=1,NPATOT-1
READ(IUSCR,69,ERR=75,END=75) JOPA,NOPA,XMAX,DIST0,
1 (JPA(KD),KD=1,JOPA)
IF(JOPA.EQ.JOP) THEN
IF(NOPA.GT.2.14E+09) THEN
WRITE(IUO1,76) JOPA,NOPA,XMAX,DIST0,JNEM,
1 (JPA(KD),KD=1,JOPA)
ELSE
WRITE(IUO1,70) JOPA,INT(NOPA),XMAX,DIST0,JNEM,
1 (JPA(KD),KD=1,JOPA)
ENDIF
ENDIF
ENDDO
IF(JOP.EQ.NDIF) WRITE(IUO1,80)
75 REWIND IUSCR
ENDDO
GOTO 73
172 WRITE(IUO1,74)
CLOSE(IUSCR,STATUS='DELETE')
73 ENDIF
DO JD=0,NDIF
NPATH1(JD)=REAL(DFLOAT(NSCAT)**DFLOAT(JD))
IF(NPATH1(JD).GT.2.14E+09) THEN
IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
WRITE(IUO1,53) JD,NPATH1(JD),NPATH2(JD),FMIN(JD),NPMI(JD),
1 FMAX(JD),NPMA(JD)
IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
ELSE
IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
WRITE(IUO1,58) JD,INT(NPATH1(JD)+0.1),
1 INT(NPATH2(JD)+0.1),FMIN(JD),
2 INT(NPMI(JD)+0.1),FMAX(JD),
3 INT(NPMA(JD)+0.1)
IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
ENDIF
ENDDO
666 CONTINUE
C
C Calculation of the Auger Electron 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(ISET,86) JSET,JLINE,THD,PHD
IF(I_EXT.EQ.-1) BACKSPACE ISET
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
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(ISET,86) JSET,JLINE,THD,PHD
BACKSPACE ISET
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.
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(ISET,86) JSET,JLINE,THD,PHD,W
DTHETA=THD
DPHI=PHD
RTHETA=DTHETA*PIS180
RPHI=DPHI*PIS180
ELSE
W=1.
ENDIF
C
IF(I_EXT.EQ.-1) PRINT 89
C
CALL DIRAN(VINT,ECIN,JEL)
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
WRITE(IUO1,61) (DIRANA(J,1),J=1,3)
C
SRDIF_1=0.
SRDIR_1=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
SSCDIR_1=0.
SSCDIF_1=0.
C
C Loop over the equiprobable quantum numbers MC,SC and SA
C corresponding respectively to the core hole (MC and spin SC)
C and to the outgoing Auger electron (SA). The sum over the
C equiprobable azimuthal quantum number MJ of the multiplet
C configuration is suppressed here as, because of the selection
C rules, one has MJ = MA + MC + SA + SC
C
LME=LMAX(1,JE)
CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME)
C
DO ISC=1,2
SC=FLOAT(ISC)-1.5
C
SMCDIR_1=0.
SMCDIF_1=0.
C
DO MC=-LI,LI
C
SSADIR_1=0.
SSADIF_1=0.
C
DO ISA=1,2
SA=FLOAT(ISA)-1.5
C
SMJMDIR_1=0.
SMJMDIF_1=0.
C
DO MJM=-J_MUL,J_MUL
C
SJDIR_1=ZEROC
SJDIF_1=ZEROC
C
C Calculation of the direct emission (used a a reference for the
C output), which is not contained in the calculation of TAU
C
DO L_E=LE_MIN,LE_MAX,2
ILE=L_E*L_E+L_E+1
IF(ISPEED.EQ.1) THEN
R2=TL(L_E,1,1,JE)
ELSE
R2=TLT(L_E,1,1,JE)
ENDIF
M_E=MJM-MC-ISA-ISC+3
IF(ABS(M_E).GT.L_E) GOTO 444
INDE=ILE+M_E
SJDIR_1=SJDIR_1+YLME(L_E,M_E)*ATTSE*
1 M_COUL(L_E,M_E,ISA,MC,ISC)*R2
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,INDE,1)
DO M0=1,L0
IND01=IL0+M0
IND02=IL0-M0
SL0DIF=SL0DIF+(YLME(L0,M0)*
1 TAU(IND01,INDE,1)+
2 YLME(L0,-M0)*
3 TAU(IND02,INDE,1))
ENDDO
ENDDO
SJDIF_1=SJDIF_1+SL0DIF*M_COUL(L_E,M_E,ISA,MC,ISC)
444 CONTINUE
ENDDO
SJDIF_1=SJDIF_1*ATTSE
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_A(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
SLE_1=ZEROC
DO L_E=LE_MIN,LE_MAX,2
ILE=L_E*L_E+L_E+1
M_E=MJM-MC-ISA-ISC+3
IF(ABS(M_E).GT.L_E) GOTO 555
INDE=ILE+M_E
SLJDIF=ZEROC
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDE,JATL)
IF(LJ.GT.0) THEN
DO MJ=1,LJ
INDJ1=ILJ+MJ
INDJ2=ILJ-MJ
SMJDIF=SMJDIF+(YLMR(LJ,MJ)*
1 TAU(INDJ1,INDE,JATL)+
2 YLMR(LJ,-MJ)*
3 TAU(INDJ2,INDE,JATL))
ENDDO
ENDIF
SLJDIF=SLJDIF+SMJDIF
ENDDO
SLE_1=SLE_1+SLJDIF*M_COUL(L_E,M_E,ISA,MC,ISC)
555 CONTINUE
ENDDO
SJDIF_1=SJDIF_1+SLE_1*ATT_M
C
C End of the loops over the last atom J
C
ENDDO
ENDDO
C
C Writing the amplitudes in file IOUT for APECS
C
111 IF(SPECTRO.EQ.'APC') THEN
WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,
1 JDIR,ISC,MC,ISA,MJM,SJDIR_1,
2 SJDIR_1+SJDIF_1
ELSE
C
C Computing the square modulus
C
SSADIF_1=SSADIF_1+CABS(SJDIR_1+SJDIF_1)*
1 CABS(SJDIR_1+SJDIF_1)
SSADIR_1=SSADIR_1+CABS(SJDIR_1)*CABS(SJDIR_1)
C
ENDIF
C
C End of the loop over MJM
C
ENDDO
C
SMJMDIF_1=SMJMDIF_1+SSADIF_1
SMJMDIR_1=SMJMDIR_1+SSADIR_1
C
C End of the loop over SA
C
ENDDO
C
SMCDIF_1=SMCDIF_1+SMJMDIF_1
SMCDIR_1=SMCDIR_1+SMJMDIR_1
C
C End of the loop over MC
C
ENDDO
C
SSCDIF_1=SSCDIF_1+SMCDIF_1
SSCDIR_1=SSCDIR_1+SMCDIR_1
C
C End of the loop over SC
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 220
SRDIR_1=SRDIR_1+SSCDIR_1*VKR*CFM/NDIR
SRDIF_1=SRDIF_1+SSCDIF_1*VKR*CFM/NDIR
220 CONTINUE
C
C End of the loop on the directions of the analyzer
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 221
SSETDIR_1=SSETDIR_1+SRDIR_1*W
SSETDIF_1=SSETDIF_1+SRDIF_1*W
IF(ICHKDIR.EQ.2) THEN
IF(JSET.EQ.JREF) THEN
SSET2DIR_1=SRDIR_1
SSET2DIF_1=SRDIF_1
ENDIF
ENDIF
221 CONTINUE
C
C End of the loop on the set averaging
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 222
IF(ISOM.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,
1 SSETDIR_1,SSETDIF_1
IF(ICHKDIR.EQ.2) THEN
WRITE(IUO2,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(IUO2,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,
1 SSET2DIR_1,SSET2DIF_1
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(ISET)
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(ISET)
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_AED(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)
13 FORMAT(6X,I1,1X,I3,2X,I4)
14 FORMAT(6X,I1,1X,I3,3X,I3)
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,') ..........')
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',/)
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,I2,2X,I2,2X,I2,
1 2X,I2,2X,I2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =',
1 F6.2)
89 FORMAT(/,4X,'..........................................',
1 '.....................................')
C
7 RETURN
C
END

View File

@ -1,140 +0,0 @@
C
C=======================================================================
C
SUBROUTINE COUMAT_AM(LA,MA,SA,MC,SC,JE,RHOK_A,MATRIX_AM)
C
C This routine calculates the multiplet-resolved spin-independent
C Coulomb matrix elements occuring in the Auger process. They
C are stored in MATRIX_AM. The multiplet component is characterized
C by the quantum numbers (L,S,J) which are read from the input
C data file.
C
C Here, the conventions are (direct process D):
C
C (LC,MC) : core hole filled by intermediate electron
C (L1,M1) : Auger electron before excitation
C (L2,M2) : intermediate electron that fills the core hole
C (LA,MA) : Auger electron after excitation
C
C In the exchange process E, the roles of (L1,M1) and (L2,M2)
C are interchanged.
C
C Note that the Clebsch-Gordan corresponding to the spin-orbit
C resolved core state is not included in the formula here. This
C is because in APECS, it appears also in the dipole matrix
C element and it is therefore useless to calculate it twice.
C Therefore, it must be implemented into the cross-section
C subroutine.
C
C The factor i**LA comes from the particular normalization used
C in the phagen code
C
C Last modified : 8 Dec 2008
C
USE DIM_MOD
C
USE C_G_M_MOD
USE INIT_A_MOD, LC => LI_C, L2 => LI_I, L1 => LI_A
USE TYPCAL_A_MOD, I1 => IPHI_A, I2 => IE_A, I3 => ITHETA_A,
1 I4 => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A,
2 I7 => I_EXT_A, I_TEST => I_TEST_A
USE INIT_M_MOD
C
COMPLEX RHOK_A(0:NT_M,NATM,0:40,2,NSPIN2_M)
COMPLEX ZEROC,ONEC,MATRIX_AM
COMPLEX SUM_LB,SUM_M1,IC,IL
C
REAL*4 CG1(0:N_GAUNT),CG2(0:N_GAUNT)
REAL*4 GNT1(0:N_GAUNT),GNT2(0:N_GAUNT),GNT3(0:N_GAUNT)
REAL*4 GNT4(0:N_GAUNT)
C
REAL*8 ZEROD
C
DATA PI4,ONEOSQ2,HALF /12.566371,0.707107,0.5/
C
ZEROC=(0.,0.)
ONEC=(1.,0.)
IC=(0.,1.)
ZEROD=0.D0
C
IF(I_TEST.EQ.1) GOTO 2
C
IF(MOD(LA,4).EQ.0) THEN
IL=ONEC
ELSEIF(MOD(LA,4).EQ.1) THEN
IL=IC
ELSEIF(MOD(LA,4).EQ.2) THEN
IL=-ONEC
ELSEIF(MOD(LA,4).EQ.3) THEN
IL=-IC
ENDIF
C
IF(I_SHELL.EQ.0) THEN
COEF1=ONEOSQ2*PI4
ELSEIF(I_SHELL.EQ.1) THEN
COEF1=HALF*PI4
ENDIF
C
IF(MOD(S_MUL,2).EQ.0) THEN
SIGN1=1.
ELSE
SIGN1=-1.
ENDIF
C
C Values of MJ, ML and MS given by the Clebsch-Gordan
C
ML=MA+MC
MS=INT(SA+SC+0.0001)
MJ=ML+MS
C
C Storage indices for the spin Clebsch-Gordan :
C
C ISA(C) = 1 for -1/2 and 2 for 1/2
C IS = 1 for S_MUL=0 and 2 for S_MUL=1
C
IS=S_MUL+1
ISA=INT(SA+1.5001)
ISC=INT(SC+1.5001)
C
C Bounds of the sum over LB
C
LB_MAX_D=MIN(L1+LA,L2+LC)
LB_MIN_D=MAX(ABS(L1-LA),ABS(L2-LC))
LB_MAX_E=MIN(L2+LA,L1+LC)
LB_MIN_E=MAX(ABS(L2-LA),ABS(L1-LC))
LB_MIN=MIN(LB_MIN_D,LB_MIN_E)
LB_MAX=MAX(LB_MAX_D,LB_MAX_E)
C
N_CG=2
CALL N_J(DFLOAT(L_MUL),DFLOAT(ML),DFLOAT(S_MUL),DFLOAT(MS),
1 ZEROD,CG1,I_INT1,N_CG)
C
SUM_M1=ZEROC
DO M1=-L1,L1
M2=ML-M1
C
CALL N_J(DFLOAT(L1),DFLOAT(M1),DFLOAT(L2),DFLOAT(ML-M1),
1 ZEROD,CG2,I_INT2,N_CG)
CALL GAUNT(L1,M1,LA,MA,GNT1)
CALL GAUNT(LC,MC,L2,M2,GNT2)
CALL GAUNT(L2,M2,LA,MA,GNT3)
CALL GAUNT(LC,MC,L1,M1,GNT4)
C
SUM_LB=ZEROC
DO LB=LB_MIN,LB_MAX
SUM_LB=SUM_LB+(RHOK_A(LA,JE,LB,1,1)*GNT1(LB)*GNT2(LB)+
1 RHOK_A(LA,JE,LB,2,1)*GNT3(LB)*GNT4(LB)*
2 SIGN1)/FLOAT(LB+LB+1)
ENDDO
SUM_M1=SUM_M1+SUM_LB*CG2(L_MUL)
ENDDO
C
MATRIX_AM=SUM_M1*CG1(J_MUL)*CG_S(ISA,ISC,IS)*COEF1*IL
C
GOTO 1
C
2 MATRIX_AM=ONEC
C
1 RETURN
C
END

View File

@ -1,88 +0,0 @@
C
C=======================================================================
C
SUBROUTINE DWSPH_A(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 TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, VK2 =>
& VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
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

View File

@ -1,115 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FACDIF1_A(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,
1 FSPH,JAT,JE,*)
C
C This routine computes a spherical wave scattering factor
C
C Last modified : 03/04/2006
C
USE DIM_MOD
C
USE APPROX_MOD
USE EXPFAC_MOD
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE TYPCAL_A_MOD, I2 => IPHI_A, I3 => IE_A, I4 => ITHETA_A,
& IFTHET => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A,
& I7 => I_EXT_A, I8 => I_TEST_A
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
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

View File

@ -1,28 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FACDIF_A(COSTH,JAT,JE,FTHETA)
C
C This routine computes the plane wave scattering factor
C
USE DIM_MOD
C
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
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

View File

@ -1,369 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 PHIMI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 31 Jul 2007
C
USE DIM_MOD
C
USE APPROX_MOD, ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.
1 (COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.
1 -2.*COSTHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH_A(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
CALL MATDIF_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 AMIJ,BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND.
1 (COSTHIJK.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))
1 THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.
1 -2.*COSTHIJK)
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_A(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHIJK,JPOS(ND-1,1),
1 JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS2_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END

View File

@ -1,370 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS2_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 PHIMI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 31 Jul 2007
C
USE DIM_MOD
C
USE APPROX_MOD, ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.
1 (COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.
1 -2.*COSTHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH_A(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 AMIJ,BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND.
1 (COSTHIJK.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))
1 THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.
1 -2.*COSTHIJK)
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_A(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHIJK,JPOS(ND-1,1),
1 JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS3_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END

View File

@ -1,370 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS3_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 PHIMI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 31 Jul 2007
C
USE DIM_MOD
C
USE APPROX_MOD, ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.
1 (COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.
1 -2.*COSTHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH_A(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 AMIJ,BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND.
1 (COSTHIJK.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))
1 THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.
1 -2.*COSTHIJK)
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_A(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHIJK,JPOS(ND-1,1),
1 JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS4_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END

View File

@ -1,370 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS4_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 PHIMI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 31 Jul 2007
C
USE DIM_MOD
C
USE APPROX_MOD, ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.
1 (COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.
1 -2.*COSTHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH_A(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 AMIJ,BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND.
1 (COSTHIJK.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))
1 THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.
1 -2.*COSTHIJK)
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_A(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHIJK,JPOS(ND-1,1),
1 JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS5_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END

View File

@ -1,370 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS5_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 PHIMI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 31 Jul 2007
C
USE DIM_MOD
C
USE APPROX_MOD, ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.
1 (COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.
1 -2.*COSTHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH_A(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 AMIJ,BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+
1 ZR(ND)*ZR(ND-1))/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND.
1 (COSTHIJK.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))
1 THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.
1 -2.*COSTHIJK)
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_A(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF_A(COSTHIJK,JPOS(ND-1,1),
1 JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
1 IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
c CALL FINDPATHS_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
c 1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END

View File

@ -1,21 +0,0 @@
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_AED_MU_SE()
CALL CLOSE_ALL_FILES()
END SUBROUTINE RUN

View File

@ -1,349 +0,0 @@
C
C=======================================================================
C
SUBROUTINE MATDIF_A(NO,ND,LF,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,
1 A21,B21,C21,RHO1,RHO2)
C
C This routine calculates the Rehr-Albers scattering matrix
C F_{LAMBDA1,LAMBDA2}. The result is stored in the COMMON block
C /SCATMAT/ as F21(NSPIN2_M,NLAMBDA_M,NLAMBDA_M,NDIF_M). It is more
C specifically designed for the Auger electron.
C
C Last modified : 3 Aug 2007
C
USE DIM_MOD
C
USE EXPFAC_MOD
USE LBD_MOD
USE LINLBD_MOD
USE RA_MOD
USE SCATMAT_MOD
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE TLDW_MOD
C
REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX HLM1(0:NO_ST_M,0:NL_M-1),HLM2(0:NO_ST_M,0:NL_M-1)
COMPLEX SL,RHO1,RHO2,IC,ZEROC,ONEC,ONEOVK
COMPLEX SL_2_1,SL_2_2
COMPLEX EXP1,EXP2,PROD1,PROD2
C
DATA PI,SMALL /3.141593,0.0001/
C
IC=(0.,1.)
ZEROC=(0.,0.)
ONEC=(1.,0.)
ONEOVK=1./VK(JE)
IB=0
LMJ=LMAX(JTYP,JE)
IF(ABS(ABS(B21)-PI).LT.SMALL) IB=-1
IF(ABS(B21).LT.SMALL) IB=1
IF(NO.EQ.8) THEN
NN2=LMAX(JTYP,JE)+1
ELSE
NN2=NO
ENDIF
C
C NO is atom-dependent and is decreased with the rank of the scatterer
C in the path when I_NO > 0. Here LAMBDA1 depends on the scatterer JTYP
C while LAMBDA2 depends on the next atom (KTYP) in the path
C
IF(I_NO.EQ.0) THEN
NO1=N_RA(JTYP)
NO2=N_RA(KTYP)
ELSE
NO1=MAX(N_RA(JTYP)-(ND-1)/I_NO,0)
NO2=MAX(N_RA(KTYP)-ND/I_NO,0)
ENDIF
IF(I_ABS.EQ.0) THEN
NUMAX1=NO1/2
NUMAX2=NO2/2
ELSEIF(I_ABS.EQ.1) THEN
NUMAX1=MIN0(LF,NO1/2)
NUMAX2=NO2/2
ELSEIF(I_ABS.EQ.2) THEN
NUMAX1=NO1/2
NUMAX2=MIN0(LF,NO2/2)
ENDIF
LBDM(1,ND)=(NO1+1)*(NO1+2)/2
LBDM(2,ND)=(NO2+1)*(NO2+2)/2
C
EXP2=-EXP(-IC*A21)
EXP1=EXP(-IC*C21)
C
DO LAMBDA1=1,LBDMAX
DO LAMBDA2=1,LBDMAX
F21(1,LAMBDA2,LAMBDA1,ND)=ZEROC
ENDDO
ENDDO
C
IF(ABS(RHO1-RHO2).GT.SMALL) THEN
CALL POLHAN(ISPHER,NUMAX1,LMJ,RHO1,HLM1)
CALL POLHAN(ISPHER,NN2,LMJ,RHO2,HLM2)
NEQUAL=0
ELSE
CALL POLHAN(ISPHER,NN2,LMJ,RHO1,HLM1)
NEQUAL=1
ENDIF
C
C Calculation of the scattering matrix when the scattering angle
C is different from 0 and pi
C
IF(IB.EQ.0) THEN
CALL DJMN(B21,RLM,LMJ)
DO NU1=0,NUMAX1
MUMAX1=NO1-2*NU1
IF(I_ABS.EQ.1) MUMAX1=MIN(LF-NU1,MUMAX1)
DO NU2=0,NUMAX2
MUMAX2=NO2-2*NU2
C
C Case MU1 = 0
C
LAMBDA1=LBD(0,NU1)
C
C Case MU2 = 0
C
LAMBDA2=LBD(0,NU2)
LMIN=MAX(NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*
1 TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
C
C Case MU2 > 0
C
PROD2=ONEC
SIG2=1.
DO MU2=1,MUMAX2
LAMBDA2_1=LBD(MU2,NU2)
LAMBDA2_2=LBD(-MU2,NU2)
PROD2=PROD2*EXP2
SIG2=-SIG2
LMIN=MAX(NU1,MU2+NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
ENDIF
C1=EXPF(0,L)/EXPF(MU2,L)
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU2+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*
1 TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU2+NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2_1,LAMBDA1,ND)=SL*PROD2*ONEOVK*SIG2
F21(1,LAMBDA2_2,LAMBDA1,ND)=SL*ONEOVK/PROD2
ENDDO
C
C Case MU1 > 0
C
PROD1=ONEC
SIG1=1.
DO MU1=1,MUMAX1
LAMBDA1_1=LBD(MU1,NU1)
LAMBDA1_2=LBD(-MU1,NU1)
PROD1=PROD1*EXP1
SIG1=-SIG1
C
C Case MU2 = 0
C
LAMBDA2=LBD(0,NU2)
LMIN=MAX(MU1,NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
C1=EXPF(MU1,L)/EXPF(0,L)
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*
1 TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1_1,ND)=SL*PROD1*ONEOVK*SIG1
F21(1,LAMBDA2,LAMBDA1_2,ND)=SL*ONEOVK/PROD1
C
C Case MU2 > 0
C
PROD2=ONEC
SIG2=SIG1
DO MU2=1,MUMAX2
LAMBDA2_1=LBD(MU2,NU2)
LAMBDA2_2=LBD(-MU2,NU2)
PROD2=PROD2*EXP2
SIG2=-SIG2
LMIN=MAX(MU1,NU1,MU2+NU2)
SL_2_1=ZEROC
SL_2_2=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
ENDIF
C1=EXPF(MU1,L)/EXPF(MU2,L)
IF(ISPEED.EQ.1) THEN
SL=FLOAT(L+L+1)*C1*TL(L,1,JTYP,JE)*
1 HLM1(NU1,L)*HLM2(MU2+NU2,L)
ELSE
SL=FLOAT(L+L+1)*C1*TLT(L,1,JTYP,JE)*
1 HLM1(NU1,L)*HLM2(MU2+NU2,L)
ENDIF
SL_2_1=SL_2_1+SL*RLM(MU2,-MU1,L)
SL_2_2=SL_2_2+SL*RLM(MU2,MU1,L)
ENDDO
F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL_2_2*PROD1*PROD2*
1 ONEOVK*SIG2
F21(1,LAMBDA2_2,LAMBDA1_1,ND)=SL_2_1*PROD1
1 *ONEOVK/PROD2
F21(1,LAMBDA2_1,LAMBDA1_2,ND)=SL_2_1*ONEOVK*PROD2*SIG2/
1 PROD1
F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL_2_2*ONEOVK/
1 (PROD1*PROD2)
ENDDO
ENDDO
ENDDO
ENDDO
C
C Calculation of the scattering matrix when the scattering angle
C is equal to 0 (forward scattering) or pi (backscattering)
C
ELSEIF(IB.EQ.1) THEN
DO NU1=0,NUMAX1
DO NU2=0,NUMAX2
MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
C
C Case MU = 0
C
LAMBDA1=LBD(0,NU1)
LAMBDA2=LBD(0,NU2)
LMIN=MAX(NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*
1 TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
C
C Case MU > 0
C
CST1=1.
DO MU=1,MUMAX1
LAMBDA1=LBD(MU,NU2)
LAMBDA2=LBD(-MU,NU2)
CST1=-CST1
LMIN=MAX(NU1,MU+NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*CST1
1 *TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST1
1 *TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU+NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA1,LAMBDA1,ND)=SL*ONEOVK
F21(1,LAMBDA2,LAMBDA2,ND)=SL*ONEOVK
ENDDO
ENDDO
ENDDO
ELSEIF(IB.EQ.-1) THEN
DO NU1=0,NUMAX1
DO NU2=0,NUMAX2
MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
C
C Case MU = 0
C
LAMBDA1=LBD(0,NU1)
LAMBDA2=LBD(0,NU2)
LMIN=MAX(NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
IF(MOD(L,2).EQ.0) THEN
CST2=1.0
ELSE
CST2=-1.0
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*CST2
1 *TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST2
1 *TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
C
C Case MU > 0
C
CST1=1.
DO MU=1,MUMAX1
MUP=-MU
LAMBDA1_1=LBD(MUP,NU1)
LAMBDA1_2=LBD(-MUP,NU1)
LAMBDA2_1=LBD(MU,NU2)
LAMBDA2_2=LBD(-MU,NU2)
CST1=-CST1
LMIN=MAX(NU1,MU+NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
ENDIF
IF(MOD(L,2).EQ.0) THEN
CST2=CST1
ELSE
CST2=-CST1
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*CST2
1 *TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST2
1 *TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU+NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL*ONEOVK
F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL*ONEOVK
ENDDO
ENDDO
ENDDO
ENDIF
C
RETURN
C
END

View File

@ -1,551 +0,0 @@
C
C=======================================================================
C
SUBROUTINE PATHOP_A(JPOS,JORDP,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,IJ,D,TAU)
C
C This subroutine calculates the contribution of a given path to
C the scattering path operator TAU. It is designed for the Auger
C electron
C
C Last modified : 3 Aug 2007
C
USE DIM_MOD
C
USE APPROX_MOD
USE EXPFAC_MOD
USE EXTREM_MOD
USE INIT_L_MOD
USE INIT_J_MOD
USE LBD_MOD
USE LINLBD_MOD
USE OUTUNITS_MOD
USE PATH_MOD
USE PRINTP_MOD
USE RA_MOD
USE ROT_MOD
USE SCATMAT_MOD, F => F21
USE TESTS_MOD
USE TLDW_MOD
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE VARIA_MOD
C
INTEGER JPOS(NDIF_M,3),AMU1
C
REAL RLMIJ(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX H(NLAMBDA_M,NLAMBDA_M)
COMPLEX G(NLAMBDA_M,NLAMBDA_M)
COMPLEX HLM01(0:NO_ST_M,0:NL_M-1),HLMIJ(0:NO_ST_M,0:NL_M-1)
COMPLEX SUM_NUJ_0,SUM_MUJ_0,SUM_NU1_0
COMPLEX SUM_NUJ_1,SUM_MUJ_1,SUM_NU1_1
COMPLEX SUM_NU1_2,SUM_NU1_3
COMPLEX RHO01,RHOIJ
COMPLEX RLMF_0,RLMF_1
COMPLEX CF,CJ,OVK
COMPLEX EXP_J,EXP_F,SUM_1
COMPLEX TL_J
COMPLEX COEF,ONEC,ZEROC
C
DATA PI,XCOMP /3.141593,1.E-10/
C
ZEROC=(0.,0.)
ONEC=(1.,0.)
C
OVK=(1.,0.)/VK(JE)
IF(NPATHP.GT.0) THEN
FM1=FMIN(JORDP)
XMAX=0.
ENDIF
EXP_J=CEXP((0.,-1.)*(PHIIJ-PI))
EXP_F=CEXP((0.,1.)*PHI01)
JTYP=JPOS(JORDP,1)
ITYP=JPOS(1,1)
JATL=JPOS(JORDP,3)
IF(I_CP.EQ.0) THEN
LMJ=LMAX(JTYP,JE)
ELSE
LMJ=LF2
ENDIF
IF(NO.EQ.8) THEN
NN2=LMJ+1
ELSE
NN2=NO
ENDIF
IF(NO.GT.LF2) THEN
NN=LF2
ELSE
NN=NO
ENDIF
C
C NO is atom-dependent and is decreased with the rank of the scatterer
C in the path when I_NO > 0 (except for the first scatterer ITYP for
C which there is no such decrease)
C
NO1=N_RA(ITYP)
IF(I_NO.EQ.0) THEN
IF(IJ.EQ.1) THEN
NOJ=N_RA(JTYP)
ELSE
NOJ=0
ENDIF
ELSE
IF(IJ.EQ.1) THEN
NOJ= MAX(N_RA(JTYP)-(JORDP-1)/I_NO,0)
ELSE
NOJ=0
ENDIF
ENDIF
NUMX=NO1/2
NUMAXJ=NOJ/2
C
C Calculation of the attenuation coefficients along the path
C
COEF=CEX(1)*OVK
DO JSC=2,JORDP
COEF=COEF*CEXDW(JSC)
ENDDO
C
C Call of the subroutines used for the R-A termination matrix
C This termination matrix is now merged into PATHOP
C
CALL DJMN2(-THIJ,RLMIJ,LMJ,1)
CALL POLHAN(ISPHER,NN,LF2,RHO01,HLM01)
CALL POLHAN(ISPHER,NN2,LMJ,RHOIJ,HLMIJ)
C
LBD1M1=LBDM(1,1)
LBD1M2=LBDM(2,1)
C
C Calculation of the L-independent part of TAU, called H
C
IF(JORDP.GE.3) THEN
DO JPAT=2,JORDP-1
LBD2M=LBDM(1,JPAT)
LBD3M=LBDM(2,JPAT)
DO LAMBDA1=1,LBD1M1
DO LAMBDA3=1,LBD3M
SUM_1=ZEROC
DO LAMBDA2=1,LBD2M
IF(JPAT.GT.2) THEN
SUM_1=SUM_1+H(LAMBDA2,LAMBDA1)*
1 F(1,LAMBDA3,LAMBDA2,JPAT)
ELSE
SUM_1=SUM_1+F(1,LAMBDA2,LAMBDA1,1)*
1 F(1,LAMBDA3,LAMBDA2,2)
ENDIF
ENDDO
G(LAMBDA3,LAMBDA1)=SUM_1
ENDDO
ENDDO
DO LAMBDA1=1,LBD1M1
DO LAMBDA2=1,LBD3M
H(LAMBDA2,LAMBDA1)=G(LAMBDA2,LAMBDA1)
ENDDO
ENDDO
ENDDO
ELSEIF(JORDP.EQ.2) THEN
DO LAMBDA1=1,LBD1M1
DO LAMBDA2=1,LBD1M2
H(LAMBDA2,LAMBDA1)=F(1,LAMBDA2,LAMBDA1,1)
ENDDO
ENDDO
ELSEIF(JORDP.EQ.1) THEN
DO LAMBDA1=1,LBD1M1
DO LAMBDA2=1,LBD1M1
H(LAMBDA2,LAMBDA1)=ONEC
ENDDO
ENDDO
ENDIF
C
C Calculation of the path operator TAU
C
DO LF=LF1,LF2,ISTEP_LF
ILF=LF*LF+LF+1
C
NU1MAX1=MIN(LF,NUMX)
C
C Case MF = 0
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
NUJMAX=MIN(LJ,NUMAXJ)
IF(JORDP.EQ.1) THEN
NU1MAX=MIN(NU1MAX1,LJ)
ELSE
NU1MAX=NU1MAX1
ENDIF
C
IF(ISPEED.EQ.1) THEN
TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
ELSE
TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
ENDIF
C
C Case MJ = 0
C
SUM_NU1_0=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
C
SUM_NUJ_0=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*
1 RLMIJ(MUJ,0,LJ)
ENDDO
C
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
C
ENDDO
C
ENDDO
C
TAU(ILJ,ILF,JATL)=TAU(ILJ,ILF,JATL)+
1 TL_J*SUM_NU1_0
C
IF(NPATHP.EQ.0) GOTO 35
C
FM2=FMAX(JORDP)
XINT=CABS(TL_J*SUM_NU1_0)
XMAX=AMAX1(XINT,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=
1 NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
35 CONTINUE
C
C Case MJ > 0
C
CJ=ONEC
DO MJ=1,LJ
INDJ=ILJ+MJ
INDJP=ILJ-MJ
CJ=CJ*EXP_J
C
SUM_NU1_0=ZEROC
SUM_NU1_1=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
C
SUM_NUJ_0=ZEROC
SUM_NUJ_1=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
SUM_MUJ_1=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*
1 RLMIJ(MUJ,-MJ,LJ)
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*
1 RLMIJ(MUJ,MJ,LJ)
C
ENDDO
C
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
C
ENDDO
C
ENDDO
C
TAU(INDJP,ILF,JATL)=TAU(INDJP,ILF,JATL)+
1 CONJG(CJ)*TL_J*SUM_NU1_1
TAU(INDJ,ILF,JATL)=TAU(INDJ,ILF,JATL)+
1 CJ*TL_J*SUM_NU1_0
C
IF(NPATHP.EQ.0) GOTO 45
C
FM2=FMAX(JORDP)
XINT1=CABS(CJ*TL_J*SUM_NU1_0)
XINT2=CABS(CONJG(CJ)*TL_J*SUM_NU1_1)
XMAX=AMAX1(XINT1,XINT2,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=
1 NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
45 CONTINUE
ENDDO
ENDDO
C
C Case MF > 0
C
CF=ONEC
DO MF=1,LF
INDF=ILF+MF
INDFP=ILF-MF
CF=CF*EXP_F
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
NUJMAX=MIN(LJ,NUMAXJ)
IF(JORDP.EQ.1) THEN
NU1MAX=MIN(NU1MAX1,LJ)
ELSE
NU1MAX=NU1MAX1
ENDIF
C
IF(ISPEED.EQ.1) THEN
TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
ELSE
TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
ENDIF
C
C Case MJ = 0
C
SUM_NU1_0=ZEROC
SUM_NU1_1=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
C
SUM_NUJ_0=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*
1 RLMIJ(MUJ,0,LJ)
C
ENDDO
C
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
SUM_NU1_1=SUM_NU1_1+RLMF_1*SUM_NUJ_0
C
ENDDO
C
ENDDO
C
TAU(ILJ,INDF,JATL)=TAU(ILJ,INDF,JATL)+
1 CF*TL_J*
2 SUM_NU1_0
TAU(ILJ,INDFP,JATL)=TAU(ILJ,INDFP,JATL)+
1 CONJG(CF)*TL_J*
2 SUM_NU1_1
C
IF(NPATHP.EQ.0) GOTO 25
C
FM2=FMAX(JORDP)
XINT1=CABS(CF*TL_J*SUM_NU1_0)
XINT2=CABS(CONJG(CF)*TL_J*SUM_NU1_1)
XMAX=AMAX1(XINT1,XINT2,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=
1 NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
25 CONTINUE
C
C Case MJ > 0
C
CJ=ONEC
DO MJ=1,LJ
INDJ=ILJ+MJ
INDJP=ILJ-MJ
CJ=CJ*EXP_J
C
SUM_NU1_0=ZEROC
SUM_NU1_1=ZEROC
SUM_NU1_2=ZEROC
SUM_NU1_3=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
C
SUM_NUJ_0=ZEROC
SUM_NUJ_1=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
SUM_MUJ_1=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*
1 RLMIJ(MUJ,-MJ,LJ)
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*
1 RLMIJ(MUJ,MJ,LJ)
C
ENDDO
C
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
SUM_NU1_2=SUM_NU1_2+RLMF_1*SUM_NUJ_0
SUM_NU1_3=SUM_NU1_3+RLMF_1*SUM_NUJ_1
C
ENDDO
C
ENDDO
C
TAU(INDJP,INDF,JATL)=TAU(INDJP,INDF,JATL)+
1 CF*CONJG(CJ)*TL_J*SUM_NU1_1
TAU(INDJP,INDFP,JATL)=TAU(INDJP,INDFP,JATL)+
1 CONJG(CF*CJ)*TL_J*SUM_NU1_3
TAU(INDJ,INDF,JATL)=TAU(INDJ,INDF,JATL)+
1 CF*CJ*TL_J*SUM_NU1_0
TAU(INDJ,INDFP,JATL)=TAU(INDJ,INDFP,JATL)+
1 CONJG(CF)*CJ*TL_J*SUM_NU1_2
C
IF(NPATHP.EQ.0) GOTO 15
C
FM2=FMAX(JORDP)
XINT1=CABS(CF*CJ*TL_J*SUM_NU1_0)
XINT2=CABS(CF*CONJG(CJ)*TL_J*SUM_NU1_1)
XINT3=CABS(CONJG(CF)*CJ*TL_J*SUM_NU1_2)
XINT4=CABS(CONJG(CF*CJ)*TL_J*SUM_NU1_3)
XMAX=AMAX1(XINT1,XINT2,XINT3,XINT4,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2,XINT3,XINT4)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=
1 NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
15 CONTINUE
ENDDO
ENDDO
ENDDO
ENDDO
C
IF(NPATHP.EQ.0) GOTO 16
FMIN(JORDP)=AMIN1(FM1,XMAX)
IF(XMAX.GT.FMN(NPATHP)) THEN
CALL LOCATE(FMN,NPATHP,XMAX,JMX)
DO KF=NPATHP,JMX+2,-1
FMN(KF)=FMN(KF-1)
JON(KF)=JON(KF-1)
PATH(KF)=PATH(KF-1)
DMN(KF)=DMN(KF-1)
DO KD=1,10
JPON(KF,KD)=JPON(KF-1,KD)
ENDDO
ENDDO
FMN(JMX+1)=XMAX
JON(JMX+1)=JORDP
PATH(JMX+1)=NPATH(JORDP)
DMN(JMX+1)=D
DO KD=1,JORDP
JPON(JMX+1,KD)=JPOS(KD,3)
ENDDO
ENDIF
IF((FMIN(JORDP)-FM1).LT.-XCOMP) NPMI(JORDP)=NPATH(JORDP)
IF((IPRINT.EQ.3).AND.(IJ.EQ.1)) THEN
WRITE(IUSCR,1) JORDP,NPATH(JORDP),XMAX,D,(JPOS(KD,3),KD=1,JORDP)
ENDIF
C
16 RETURN
C
1 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
C
END

View File

@ -1,106 +0,0 @@
C
C=======================================================================
C
SUBROUTINE PLOTFD_A(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 PARCAL_A_MOD, N3 => NPHI_A, N4 => NE_A, N5 => NTHETA_A,
& NFTHET => NFTHET_A
USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A,
& IFTHET => IFTHET_A, IMOD => IMOD_A,
& I_CP => I_CP_A, I_EXT => I_EXT_A,
& I_TEST => I_TEST_A
USE VALIN_MOD, PHI00 => PHI0, THETA00 => THETA0, U1 => THLUM,
& U2 => PHILUM, U3 => ELUM, N7 => NONVOL
USE VALFIN_MOD, PHI11 => PHI1, THETA11 => THETA1
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
C
DIMENSION LMX(NATM,NE_M)
C
COMPLEX FSPH,VKE
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_A(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,
1 FSPH,JAT,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,
1 1X,F6.2,1X,F8.2)
80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ',
1 'IS ZERO >>>>>')
100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',
1 ' : ',I2,' >>>>>')
C
RETURN
C
END

View File

@ -1,791 +0,0 @@
C
C=======================================================================
C
SUBROUTINE TREAT_AED(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
C
USE OUTUNITS_MOD
USE TYPEXP_MOD, DUMMY => SPECTRO
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
USE VALIN_MOD, P0 => PHI0, T0 => THETA0
USE VALFIN_MOD, P1 => PHI1, T1 => THETA1
C
PARAMETER(N_HEAD=5000,N_FILES=1000)
C
CHARACTER*3 SPECTRO
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
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,
1 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)/
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)*
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 +
1 (JEMET-1)*NE*N_FIXED*N_SCAN +
2 (JE-1)*N_FIXED*N_SCAN +
3 (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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
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),
1 ECIN(JE),TAB(JLIN2,1),TAB(JLIN2,2),
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 +
1 (JEMET-1)*NE*NTHETA*NPHI +
2 (JE-1)*NTHETA*NPHI +
3 (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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 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),
1 VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR2_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)/
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)*
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 +
1 (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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
2 TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
1 DPHI(JPHI2),ECIN(JE),
2 TAB(JLIN2,1),TAB(JLIN2,2),
3 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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
2 TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
1 DPHI(JPHI2),ECIN(JE),
2 TAB(JLIN2,1),TAB(JLIN2,2),
3 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 +
1 (JTHETA-1)*NPHI + JPHI
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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 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),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),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),
1 VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),VOLDIR2_1,VOLDIF2_1,
3 VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),TOTDIR2_1,TOTDIF2_1,
3 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 +
1 (JTHETA-1)*NPHI + JPHI
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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),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,
1 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 ',
1 'IN THE TREAT_AED SUBROUTINE - INCREASE NDIM_M ',
2 '>>>>>>>>>>')
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,
1 2X,E12.6,2X,E12.6,2X,E12.6)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,
1 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 ',
1 'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,
2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6,
3 ' >>>>>>>>>>')
38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ',
1 'IN THE INCLUDE FILE >>>>>>>>>>',/,8X,
2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6,
3 ' >>>>>>>>>>')
888 FORMAT(A72)
C
6 RETURN
C
END

View File

@ -1,335 +0,0 @@
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

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,8 +16,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/tests.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: ven. 10 avril 2020 17:33:28
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
import os

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -19,8 +18,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/utils.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: Thu, 06 Oct 2022 18:19:16 +0200
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr> 1665073156 +0200
"""
@ -39,7 +38,11 @@ import ase.atom
from ase import Atom
from ase import Atoms
try:
from msspec.iodata import Data
except ImportError as err:
print(err)
from msspec.misc import LOGGER
@ -67,7 +70,7 @@ class ForeignPotential(object):
self.phagen_data = {'types': []}
def write(self, filename, prototypical_atoms):
LOGGER.debug("Writing Phagen input potential file: {}".format(filename))
LOGGER.debug(f"Writing Phagen input potential file: {filename}")
def DEPRECATEDappend_atom_potential(atom):
Z = atom.number
@ -78,8 +81,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, "Cannot find the data for atom with Z={}".format(Z)
assert len(itypes) == 1, "Too many datasets for atom with Z={}".format(Z)
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}"
# So far so good, let's write the block
t = self.phagen_data['types'][itypes[0]]
s = "{:<7d}{:<10d}{:1.4f}\n".format(
@ -92,7 +95,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, "Unable get the atom type!"
assert atom_type != None, f"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(
@ -135,7 +138,7 @@ class SPRKKRPotential(ForeignPotential):
self.potfile = potfile
self.load_sprkkr_atom_types()
for f in exported_files:
LOGGER.info("Loading file {}...".format(f))
LOGGER.info(f"Loading file {f}...")
# get the IT from the filename
m=re.match('SPRKKR-IT_(?P<IT>\d+)-PHAGEN.*', os.path.basename(f))
it = int(m.group('IT'))
@ -189,7 +192,7 @@ class SPRKKRPotential(ForeignPotential):
return data
# load info in *.pot file
LOGGER.info("Loading SPRKKR *.pot file {}...".format(self.potfile))
LOGGER.info(f"Loading SPRKKR *.pot file {self.potfile}...")
with open(self.potfile, 'r') as fd:
content = fd.read()
@ -230,7 +233,7 @@ class SPRKKRPotential(ForeignPotential):
IT = occupation['ITOQ']
atom = self.atoms[i]
atom.set('atom_type', IT)
LOGGER.debug("Site #{} is type #{}, atom {}".format(IQ, IT, atom))
LOGGER.debug(f"Site #{IQ} is type #{IT}, atom {atom}")
@ -477,7 +480,7 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0,
a = cell[:, 0].max() # a lattice parameter
# the number of planes in the cluster
p = np.alen(np.unique(np.round(cluster.get_positions()[:, 2], 4)))
p = len(np.unique(np.round(cluster.get_positions()[:, 2], 4)))
# the symbol of your emitter
symbol = cluster[np.where(cluster.get_tags() == emitter_tag)[0][0]].symbol
@ -582,7 +585,7 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0,
# an array of all unique remaining z
all_z = np.sort(np.unique(np.round(cluster.get_positions()[:, 2], 4)))
assert emitter_plane < np.alen(all_z), ("There are not enough existing "
assert emitter_plane < len(all_z), ("There are not enough existing "
"plans.")
ze = all_z[- emitter_plane - 1] # the z-coordinate of the emitter
Atoms.translate(cluster, [0, 0, -ze]) # put the emitter in (0,0,0)

View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,39 +16,38 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/version.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: Thu, 06 Oct 2022 18:19:16 +0200
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr> 1665073156 +0200
import os
from pkg_resources import DistributionNotFound
from pkg_resources import get_distribution
from pkg_resources import parse_version
from importlib.metadata import version
import subprocess
# find the version number
# 1- Try to read it from the git info
# 2- If it fails, try to read it from the distribution file
# 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
PKGNAME = 'msspec'
try:
from setuptools_scm import get_version
v = get_version(root='../../', relative_to=__file__, version_scheme="post-release")
v = parse_version(v)
if v._version.post[-1] == 0:
__version__ = v.base_version
else:
__version__ = v.public
__version__ = version(PKGNAME)
except Exception as err:
try:
__version__ = get_distribution(__name__.strip('.version')).version
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!")
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()
__version__ = fd.readline().strip()
except Exception as err:
print("Unable to get the version number!")
__version__ = "9.9.9"

View File

@ -1,6 +1,6 @@
PYTHON = python
PYMAJ = 3
PYMIN = 5
PYMIN = 6
FC = gfortran
F2PY = f2py3 --f77exec=$(FC) --f90exec=$(FC)
@ -41,8 +41,7 @@ F2PYFLAGS_DBG = --debug-capi --debug
# /!\ DO NOT EDIT BELOW THAT LINE (unlesss you know what you're doing...) #
# CORE CONFIGURATION #
################################################################################
#VERSION:=$(shell python -c "import msspec; print(msspec.__version__)")
VERSION:=$(shell git describe|sed 's/-\([[:digit:]]\+\)-.*/\.post\1/')
VERSION:=$(shell git describe)
VENV_PATH := $(INSTALL_PREFIX)/src/msspec_venv_$(VERSION)

View File

@ -2,7 +2,7 @@ ase
h5py
ipython
lxml
matplotlib
matplotlib==3.4.3
numpy
Pint
pandas

View File

@ -1,83 +0,0 @@
# coding: utf8
import numpy as np
from ase.build import bulk
from ase.lattice.tetragonal import SimpleTetragonalFactory
from msspec.calculator import MSSPEC, XRaySource
from msspec.utils import hemispherical_cluster, get_atom_index
import logging
logging.basicConfig(level=logging.INFO)
do_ped = False
# Define a Rocksalt Factory class (to tetragonalize the unit cell)
class RocksaltFactory(SimpleTetragonalFactory):
bravais_basis = [[0, 0, 0], [0.5, 0.5, 0], [0.5, 0, 0.5], [0, 0.5, 0.5],
[0, 0, 0.5], [0.5, 0, 0], [0, 0.5, 0], [0.5, 0.5, 0.5]]
element_basis = (0, 0, 0, 0, 1, 1, 1, 1)
Rocksalt = RocksaltFactory()
a0 = 4.09
a_perp = 4.25
MgO = Rocksalt(('Mg', 'O'),
latticeconstant={'a': a0, 'c/a': a_perp/a0},
size=(1,1,1))
for atom in MgO:
atom.set('mean_square_vibration', 0.01)
atom.set('forward_angle', 20.)
if atom.symbol == 'Mg':
atom.tag = 1
atom.set('mt_radius', 0.63)
else:
atom.tag = 2
atom.set('mt_radius', 1.415)
#cluster = hemispherical_cluster(MgO, emitter_tag=1, emitter_plane=1, planes=4, diameter=4.5*a0)
cluster = hemispherical_cluster(MgO, emitter_tag=1, emitter_plane=1, planes=2)
cluster.absorber = get_atom_index(cluster, 0, 0, 0)
#cluster.edit()
#exit()
if do_ped:
calc = MSSPEC(spectroscopy='PED', algorithm='inversion')
else:
calc = MSSPEC(spectroscopy='AED', algorithm='inversion')
calc.set_atoms(cluster)
calc.muffintin_parameters.ionicity = {'Mg': 0.1, 'O': -0.1}
calc.tmatrix_parameters.exchange_correlation = 'hedin_lundqvist_complex'
calc.tmatrix_parameters.lmax_mode = 'true_ke'
#calc.tmatrix_parameters.tl_threshold = 1e-6
calc.source_parameters.energy = XRaySource.AL_KALPHA
calc.source_parameters.theta = -55.
calc.source_parameters.phi = 0
calc.detector_parameters.angular_acceptance = 2.
calc.detector_parameters.average_sampling = 'high'
calc.calculation_parameters.scattering_order = 4
calc.calculation_parameters.RA_cutoff = 2
calc.calculation_parameters.path_filtering = 'forward_scattering'
calc.calculation_parameters.off_cone_events = 1
calc.calculation_parameters.vibrational_damping = 'averaged_tl'
calc.calculation_parameters.vibration_scaling = 3.
if do_ped:
calc.muffintin_parameters.interstitial_potential = 14
data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5),
level='2p',
kinetic_energy=1200)
else:
data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5),
edge='KL2L2', multiplet='1D2',
kinetic_energy=1200)
data.save('results.hdf5')

0
utils/dockerized/linux/msspec Normal file → Executable file
View File