epsi
/
msspec_python3
3
0
Fork 0
Code Issues 6 Pull Requests Releases Wiki Activity

Compare commits

base: epsi:master
Branches Tags
epsi:master
epsi:devel
epsi:feature/LEED
epsi:feature/arnoldi
epsi:feature/aed
epsi:1.7.post14
epsi:1.7.post13
epsi:1.7.post12
epsi:1.7.post11
epsi:1.7
epsi:1.6
epsi:1.5
epsi:1.4
epsi:1.3
..
compare: epsi:feature/aed
Branches Tags
epsi:devel
epsi:master
epsi:feature/LEED
epsi:feature/arnoldi
epsi:feature/aed
epsi:1.7.post14
epsi:1.7.post13
epsi:1.7.post12
epsi:1.7.post11
epsi:1.7
epsi:1.6
epsi:1.5
epsi:1.4
epsi:1.3

3 Commits
master ... feature/ae

Author SHA1 Message Date
Sylvain Tricot e17a4525cc Added AED with series expansion.
epsi-builds/msspec_python3/pipeline/head There was a failure building this commit Details 
WIP
 2021-11-30 16:54:04 +01:00
Sylvain Tricot 8983368e97 Added compilation target for AED
epsi-builds/msspec_python3/pipeline/head This commit looks good Details
2021-11-17 11:09:45 +01:00
Sylvain Tricot 9f6306675f Added AED support with Matrix Inversion and test script for AED
epsi-builds/msspec_python3/pipeline/head This commit looks good Details
2021-10-27 09:38:15 +02:00
73 changed files with 9135 additions and 3238 deletions
Show Stats Expand all files Collapse all files

110
Dockerfile
View File

@ -1,112 +1,24 @@
# Get the base Python image
FROM alpine:edge AS builder
# Variables
ARG branch="devel"
ARG login="" password=""
ARG folder=/opt/msspec user=msspec
FROM python:latest
# Install system dependencies
# tools
RUN apk add bash git make gfortran python3 py3-numpy-f2py
# headers
RUN apk add python3-dev lapack-dev musl-dev hdf5-dev cairo-dev
# python packages
RUN apk add py3-virtualenv py3-pip py3-numpy-dev py3-h5py py3-lxml py3-matplotlib \
py3-numpy py3-pandas py3-cairo py3-scipy py3-setuptools_scm \
py3-terminaltables ipython
RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/community py3-wxpython
#RUN pip install ase pint terminaltables ipython
# for GUI
RUN apk add ttf-droid adwaita-icon-theme
RUN apk add build-base
# Fetch the code
RUN mkdir -p ${folder}/code
WORKDIR ${folder}/code
RUN git clone --branch ${branch} https://${login}:${password}@git.ipr.univ-rennes1.fr/epsi/msspec_python3.git .
RUN virtualenv --system-site-packages ${folder}/.local/src/msspec_venv
RUN make pybinding PYTHON=python3 VENV_PATH=${folder}/.local/src/msspec_venv VERBOSE=1
RUN make -C src sdist PYTHON=python3 VENV_PATH=${folder}/.local/src/msspec_venv VERBOSE=1
RUN make -C src frontend PYTHON=python3 VENV_PATH=${folder}/.local/src/msspec_venv VERBOSE=1
RUN source ${folder}/.local/src/msspec_venv/bin/activate && pip install src/dist/msspec*tar.gz
# Build
#RUN make pybinding NO_VENV=1 PYTHON=python3 VERBOSE=1
#RUN make -C src sdist PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv
#&& \
# pip install src/dist/msspec*tar.gz
RUN apt-get update && apt-get install -y virtualenv gfortran libgtk-3-dev nano
# Add a non-privileged user
#RUN adduser -D -s /bin/bash -h ${folder} ${user}
RUN useradd -ms /bin/bash -d /opt/msspec msspec
# Set the working directory in the container
#USER ${user}
USER msspec
RUN mkdir -p /opt/msspec/code
WORKDIR /opt/msspec/code
#RUN virtualenv --system-site-packages ${folder}/.local/src/msspec_venv
#RUN source ${folder}/.local/src/msspec_venv/bin/activate && pip install src/dist/msspec*.tar.gz
#RUN make -C src frontend PYTHON=python3 NO_VENV=1 VENV_PATH=${folder}/.local/src/msspec_venv
# Fetch the code
RUN git clone https://git.ipr.univ-rennes1.fr/epsi/msspec_python3.git .
#COPY --chown=msspec:msspec . .
FROM alpine:edge
# Variables
ARG folder=/opt/msspec user=msspec
# Install system dependencies
RUN apk add --no-cache -X http://dl-cdn.alpinelinux.org/alpine/edge/community \
# hdf5-hl cairo openblas lapack libxml2 libxslt libzlf wxwidgets-gtk3 openjpeg libimagequant \
nano \
py3-virtualenv \
lapack \
bash \
# git \
# make \
# gfortran \
python3 \
# ttf-droid \
ttf-liberation \
adwaita-xfce-icon-theme \
# python3-dev \
# lapack-dev \
# musl-dev \
# py3-virtualenv \
py3-pip \
# py3-numpy-dev \
py3-h5py \
py3-lxml \
py3-matplotlib \
py3-numpy \
py3-pandas \
py3-cairo \
py3-scipy \
py3-setuptools_scm \
py3-wxpython \
py3-terminaltables \
py3-bayesian-optimization \
# Add a non-privileged user
&& adduser -D -s /bin/bash -h ${folder} ${user}
# Set the working directory in the container
USER ${user}
WORKDIR ${folder}
# Install msspec
#COPY --from=builder ${folder}/.local ${folder}/.local
#COPY --from=builder /usr/lib/python3.10/site-packages /usr/lib/python3.10/site-packages
COPY --from=builder ${folder}/code/src/dist/msspec*tar.gz msspec.tar.gz
RUN virtualenv --system-site-packages .local/src/msspec_venv && \
. .local/src/msspec_venv/bin/activate && \
pip install msspec.tar.gz && \
pip install ipython && \
pip cache purge && \
rm -f msspec.tar.gz && \
mkdir -p .local/bin
COPY --from=builder /root/.local/bin/msspec .local/bin/msspec
ENV PATH=${folder}/.local/bin:$PATH
ENV PATH=/opt/msspec/.local/bin:$PATH
RUN make install VERBOSE=1
# Run the msspec frontend command on startup
ENTRYPOINT ["msspec"]

42
Makefile
View File

@ -1,7 +1,7 @@
include src/options.mk
.PHONY: pybinding install devel venv doc clean _attrdict
.PHONY: pybinding install devel venv doc clean
pybinding:
@ -11,20 +11,19 @@ pybinding:
venv:
ifeq ($(NO_VENV),0)
@virtualenv --python=$(PYTHON_EXE) --prompt="(msspec-$(VERSION)) " $(VENV_PATH)
$(INSIDE_VENV) python -m ensurepip --upgrade
$(INSIDE_VENV) \
wget https://bootstrap.pypa.io/get-pip.py && \
python get-pip.py && \
pip install --upgrade setuptools && \
pip install -r src/pip.freeze && \
rm -f get-pip.py
endif
# wget https://bootstrap.pypa.io/get-pip.py && \
# python get-pip.py && \
# rm -f get-pip.py
# pip install --upgrade setuptools && \
# pip install -r src/pip.freeze && \
install: venv pybinding wx
@+$(INSIDE_VENV) $(MAKE) -C src sdist
@+$(INSIDE_VENV) $(MAKE) -C src frontend
@+$(INSIDE_VENV) pip install src/dist/msspec-$(VERSION)*.whl
@+$(INSIDE_VENV) pip install src/dist/msspec-$(VERSION).tar.gz
@echo "Do not forget to check that $(INSTALL_PREFIX)/bin is set in your \$$PATH"
@ -33,37 +32,18 @@ devel: venv pybinding wx
@$(INSIDE_VENV) pip install -e src/
light: VENV_PATH = ./_venv
light: venv
@$(INSIDE_VENV) pip install src/
nogui: VENV_PATH = ./_venv
nogui: venv pybinding
@$(INSIDE_VENV) pip install -e src/
_attrdict:
# Check if virtualenv python version > 3.3.0
# If so, install the patched version of attrdict used to build the version 4.2.0 of wxPython
@$(INSIDE_VENV) if `python -c "import sys; exit(sys.version_info > (3,3))"`; then \
pip install --no-cache attrdict; \
else \
pip install thirdparty/attrdict-2.0.1.tar.gz; \
fi
_build_wx/wxPython.target: _attrdict
_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
# download the wheel or the source if it cannot find a wheel
$(INSIDE_VENV) cd _build_wx && pip download -f https://extras.wxpython.org/wxPython4/extras/linux/gtk3/$(DISTRO_RELEASE) wxPython
@$(INSIDE_VENV) cd _build_wx && pip download -f https://extras.wxpython.org/wxPython4/extras/linux/gtk3/$(DISTRO_RELEASE) wxPython
# Build the source if a tar.gz was downloaded
@$(INSIDE_VENV) cd _build_wx && \
if [ -e wxPython*.tar.gz ]; then \
tar -x --skip-old-files -vzf wxPython*.tar.gz; \
cd `ls -d wxPython*/`; \
pip install requests sip; \
pip install requests; \
python build.py dox etg --nodoc sip build bdist_wheel; \
ln -sf `readlink -f dist/wxPython*.whl` ../; \
fi;

3
doc/source/tutorials/RhO/RhO.py
View File

@ -18,8 +18,7 @@ for zi, z0 in enumerate(all_z):
calc.set_atoms(cluster)
# Compute
data = calc.get_theta_phi_scan(level='1s', kinetic_energy=723, data=data,
malloc={'NPH_M': 8000})
data = calc.get_theta_phi_scan(level='1s', kinetic_energy=723, data=data)
dset = data[-1]
dset.title = "{:d}) z = {:.2f} angstroms".format(zi, z0)

6
src/MANIFEST.in Normal file
View File

@ -0,0 +1,6 @@
recursive-include msspec *.so
recursive-include . SConstruct
include setup_requirements.txt
include requirements.txt
include pip.freeze
include VERSION

13
src/Makefile
View File

@ -9,15 +9,16 @@ sdist: dist/msspec-$(VERSION).tar.gz
frontend: $(INSTALL_PREFIX)/bin/msspec
dist/msspec-$(VERSION).tar.gz: msspec/VERSION
dist/msspec-$(VERSION).tar.gz: VERSION
@echo "Creating Python source distribution..."
@+$(INSIDE_VENV) pip install build && python -m build
@python setup.py sdist
$(INSTALL_PREFIX)/bin/msspec: msspec.sh.template msspec/VERSION
$(INSTALL_PREFIX)/bin/msspec: msspec.sh.template VERSION
@echo "Installing frontend command..."
@mkdir -p $(dir $@)
@cat $< | sed -e 's#__VENV_PATH__#$(VENV_PATH)#' > $@
@cat $< | sed -e 's/__VERSION__/$(VERSION)/' -e 's#__VENV_PATH__#$(VENV_PATH)#' > $@
#@cat $< | sed 's/__VERSION__/$(VERSION)/' > $@
@chmod 755 $@
@ -25,7 +26,7 @@ pybinding:
@echo "Building Python binding for phagen and spec..."
@+$(MAKE) -C msspec/phagen/fortran all
@+$(MAKE) -C msspec/spec/fortran all
@echo "$(VERSION)" > msspec/VERSION
@echo "$(VERSION)" > VERSION
results: msspec/results.txt
@ -53,7 +54,7 @@ clean::
# remove previous sdist
@rm -rf dist
@rm -rf *.egg*
@rm -f msspec/VERSION
@rm -f VERSION
help:

9
src/msspec.sh.template
View File

@ -2,11 +2,12 @@
SCRIPT_PATH="$0"
SCRIPT_NAME=$(basename "$SCRIPT_PATH")
VERSION="__VERSION__"
VENV_PATH="__VENV_PATH__"
# Check venv path
if ! [ -d "$VENV_PATH" ]; then
echo "ERROR: Unable to find msspec!!"
echo "ERROR: Unable to find version $VERSION of msspec!!"
exit 1
fi
@ -14,10 +15,6 @@ launch_script() {
. "$VENV_PATH/bin/activate" && python "$@"
}
show_version () {
. "$VENV_PATH/bin/activate" && python -c "import msspec; print(msspec.__version__)"
}
show_help () {
echo "Usage: 1) $SCRIPT_NAME -p [PYTHON OPTIONS] SCRIPT [ARGUMENTS...]"
echo " 2) $SCRIPT_NAME [-l FILE | -i | -h]"
@ -95,7 +92,7 @@ while getopts "hvil:p:eu" option; do
;;
u) uninstall
;;
v) show_version
v) echo $VERSION
;;
*|h) show_help
;;

6
src/msspec/calcio.py
View File

@ -747,15 +747,15 @@ class SpecIO(object):
content += line
nat = p.extra_nat
nra_arr = np.ones((nat), dtype=int)
nra_arr = np.ones((nat), dtype=np.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=int)
ibwd_arr = np.ones((nat), dtype=np.int)
else:
ibwd_arr = np.zeros((nat), dtype=int)
ibwd_arr = np.zeros((nat), dtype=np.int)
thbwd_arr = np.ones((nat))
for at in p.extra_atoms:
i = at.get('proto_index') - 1

45
src/msspec/calculator.py
View File

@ -17,8 +17,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/calculator.py
# Last modified: Tue, 25 Oct 2022 16:21:38 +0200
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr> 1666707698 +0200
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
"""
@ -97,7 +97,6 @@ from msspec.spec.fortran import _eig_mi
from msspec.spec.fortran import _eig_pw
from msspec.spec.fortran import _phd_mi_noso_nosp_nosym
from msspec.spec.fortran import _phd_se_noso_nosp_nosym
from msspec.spec.fortran import _phd_ce_noso_nosp_nosym
from msspec.spec.fortran import _comp_curves
from msspec.utils import get_atom_index
@ -303,7 +302,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=float).flatten()
#return np.array(ke, dtype=np.float).flatten()
return ke
@ -385,7 +384,7 @@ class _MSCALCULATOR(Calculator):
'NODES_EX_M' : 3,
'NSPIN_M' : 1, # to change for spin dependent
'NTH_M' : 2000,
'NPH_M' : 8000,
'NPH_M' : 2000,
'NDIM_M' : 100000,
'N_TILT_M' : 11, # to change see extdir.f
'N_ORD_M' : 250,
@ -406,8 +405,6 @@ class _MSCALCULATOR(Calculator):
do_spec = _phd_se_noso_nosp_nosym.run
elif self.global_parameters.algorithm == 'inversion':
do_spec = _phd_mi_noso_nosp_nosym.run
elif self.global_parameters.algorithm == 'correlation':
do_spec = _phd_ce_noso_nosp_nosym.run
else:
LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not "
"an allowed combination.".format(self.global_parameters.spectroscopy,
@ -619,7 +616,7 @@ class _PED(_MSCALCULATOR):
def _get_scan(self, scan_type='theta', phi=0,
theta=np.linspace(-70, 70, 141), level=None,
kinetic_energy=None, data=None,
malloc={}, other_parameters={}):
malloc={}):
LOGGER.info("Computting the %s scan...", scan_type)
if data:
self.iodata = data
@ -654,13 +651,6 @@ 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)
@ -749,7 +739,7 @@ class _PED(_MSCALCULATOR):
view = dset.add_view("E = {:.2f} eV".format(ke), title=title,
xlabel=xlabel, ylabel=ylabel,
projection='stereo', colorbar=True, autoscale=False)
projection='stereo', colorbar=True, autoscale=True)
view.select('theta', 'phi', 'cross_section')
@ -862,7 +852,7 @@ class _PED(_MSCALCULATOR):
return self.iodata
def get_scattering_factors(self, level='1s', kinetic_energy=None,
data=None, **kwargs):
data=None):
"""Computes the scattering factors of all prototypical atoms in the
cluster.
@ -881,11 +871,11 @@ class _PED(_MSCALCULATOR):
"""
data = self._get_scan(scan_type='scatf', level=level, data=data,
kinetic_energy=kinetic_energy, **kwargs)
kinetic_energy=kinetic_energy)
return data
def get_theta_scan(self, phi=0, theta=np.linspace(-70, 70, 141),
level=None, kinetic_energy=None, data=None, **kwargs):
level=None, kinetic_energy=None, data=None):
"""Computes a polar scan of the emitted photoelectrons.
:param phi: The azimuthal angle in degrees. See
@ -902,12 +892,11 @@ class _PED(_MSCALCULATOR):
"""
data = self._get_scan(scan_type='theta', level=level, theta=theta,
phi=phi, kinetic_energy=kinetic_energy,
data=data, **kwargs)
phi=phi, kinetic_energy=kinetic_energy, data=data)
return data
def get_phi_scan(self, phi=np.linspace(0, 359, 359), theta=0,
level=None, kinetic_energy=None, data=None, **kwargs):
level=None, kinetic_energy=None, data=None):
"""Computes an azimuthal scan of the emitted photoelectrons.
:param phi: All the values of the azimuthal angle to be computed. See
@ -924,13 +913,12 @@ class _PED(_MSCALCULATOR):
"""
data = self._get_scan(scan_type='phi', level=level, theta=theta,
phi=phi, kinetic_energy=kinetic_energy,
data=data, **kwargs)
phi=phi, kinetic_energy=kinetic_energy, data=data)
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, **kwargs):
kinetic_energy=None, data=None):
"""Computes a stereographic scan of the emitted photoelectrons.
The azimuth ranges from 0 to 360° and the polar angle ranges from 0 to
@ -947,11 +935,11 @@ class _PED(_MSCALCULATOR):
"""
data = self._get_scan(scan_type='theta_phi', level=level, theta=theta,
phi=phi, kinetic_energy=kinetic_energy, data=data,
**kwargs)
malloc={'NPH_M': 8000})
return data
def get_energy_scan(self, phi=0, theta=0,
level=None, kinetic_energy=None, data=None, **kwargs):
level=None, kinetic_energy=None, data=None):
"""Computes an energy scan of the emitted photoelectrons.
:param phi: All the values of the azimuthal angle to be computed. See
@ -968,8 +956,7 @@ class _PED(_MSCALCULATOR):
"""
data = self._get_scan(scan_type='energy', level=level, theta=theta,
phi=phi, kinetic_energy=kinetic_energy,
data=data, **kwargs)
phi=phi, kinetic_energy=kinetic_energy, data=data)
return data

776
src/msspec/iodata.py
View File

@ -17,8 +17,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/iodata.py
# Last modified: Wed, 26 Feb 2025 11:10:17 +0100
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes.fr>
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
"""
@ -79,26 +79,19 @@ import ase.io
from ase.io.extxyz import read_xyz, write_xyz
import h5py
import numpy as np
import wx.grid
from lxml import etree
from matplotlib.backends.backend_wxagg import FigureCanvasWxAgg as FigureCanvas
#from matplotlib.backends.backend_wxagg import FigureCanvasWx as FigureCanvas
from matplotlib.backends.backend_agg import FigureCanvasAgg
#from matplotlib.backends.backend_cairo import FigureCanvasCairo as FigureCanvasAgg
from matplotlib.backends.backend_wxagg import NavigationToolbar2WxAgg
from matplotlib.figure import Figure
from terminaltables import AsciiTable
import msspec
from msspec.msspecgui.msspec.gui.clusterviewer import ClusterViewer
from msspec.misc import LOGGER
try:
import wx.grid
from matplotlib.backends.backend_wxagg import FigureCanvasWxAgg as FigureCanvas
from matplotlib.backends.backend_wxagg import NavigationToolbar2WxAgg
from msspec.msspecgui.msspec.gui.clusterviewer import ClusterViewer
has_gui = True
except ImportError:
LOGGER.warning('No modules for GUI')
has_gui = False
def cols2matrix(x, y, z, nx=88*1+1, ny=360*1+1):
# mix the values of existing theta and new theta and return the
@ -803,17 +796,11 @@ class Data(object):
"""Pops up a grphical window to show all the defined views of the Data object.
"""
if has_gui:
app = wx.App(False)
app.SetAppName('MsSpec Data Viewer')
frame = _DataWindow(self)
frame.Show(True)
app.MainLoop()
else:
print('**** INFORMATION ****')
print('You can not use the Data.view() method since ther is no')
print('graphical user interface available in this version of MsSpec.')
print("Install WxPython if you need it or use Data.export(...) method instead.")
app = wx.App(False)
app.SetAppName('MsSpec Data Viewer')
frame = _DataWindow(self)
frame.Show(True)
app.MainLoop()
class _DataSetView(object):
@ -898,18 +885,15 @@ class _DataSetView(object):
R = np.sin(np.radians(theta))
R_ticks = np.sin(np.radians(theta_ticks))
elif proj == 'stereo':
#R = 2 * np.tan(np.radians(theta/2.))
#R_ticks = 2 * np.tan(np.radians(theta_ticks/2.))
R = theta/90.
R_ticks = theta_ticks/90.
R = 2 * np.tan(np.radians(theta/2.))
R_ticks = 2 * np.tan(np.radians(theta_ticks/2.))
#R = np.tan(np.radians(theta/2.))
X, Y = np.meshgrid(np.radians(phi), R)
im = axes.pcolormesh(X, Y, Xsec, shading='gouraud')
im = axes.pcolormesh(X, Y, Xsec)
axes.set_yticks(R_ticks)
axes.set_yticklabels(theta_ticks)
cbar = figure.colorbar(im)
#im.set_clim(0, 0.0275)
figure.colorbar(im)
elif proj == 'polar':
values[0] = np.radians(values[0])
@ -932,7 +916,6 @@ class _DataSetView(object):
axes.set_ylabel(opts['ylabel'])
axes.set_xlim(*opts['xlim'])
axes.set_ylim(*opts['ylim'])
#axes.set_axis_off()
#axes.set_pickradius(5)
if label:
axes.legend()
@ -1023,426 +1006,425 @@ class _DataSetView(object):
s += '\tconditions : %s\n' % str(self._selection_conditions)
return s
if has_gui:
class _GridWindow(wx.Frame):
def __init__(self, dset, parent=None):
title = 'Data: ' + dset.title
wx.Frame.__init__(self, parent, title=title, size=(640, 480))
self.create_grid(dset)
class _GridWindow(wx.Frame):
def __init__(self, dset, parent=None):
title = 'Data: ' + dset.title
wx.Frame.__init__(self, parent, title=title, size=(640, 480))
self.create_grid(dset)
def create_grid(self, dset):
grid = wx.grid.Grid(self, -1)
grid.CreateGrid(len(dset), len(dset.columns()))
for ic, c in enumerate(dset.columns()):
grid.SetColLabelValue(ic, c)
for iv, v in enumerate(dset[c]):
grid.SetCellValue(iv, ic, str(v))
def create_grid(self, dset):
grid = wx.grid.Grid(self, -1)
grid.CreateGrid(len(dset), len(dset.columns()))
for ic, c in enumerate(dset.columns()):
grid.SetColLabelValue(ic, c)
for iv, v in enumerate(dset[c]):
grid.SetCellValue(iv, ic, str(v))
class _ParametersWindow(wx.Frame):
def __init__(self, dset, parent=None):
title = 'Parameters: ' + dset.title
wx.Frame.__init__(self, parent, title=title, size=(400, 480))
self.create_tree(dset)
class _ParametersWindow(wx.Frame):
def __init__(self, dset, parent=None):
title = 'Parameters: ' + dset.title
wx.Frame.__init__(self, parent, title=title, size=(400, 480))
self.create_tree(dset)
def create_tree(self, dset):
datatree = {}
for p in dset.parameters():
is_hidden = p.get('hidden', "False")
if is_hidden == "True":
continue
group = datatree.get(p['group'], [])
#strval = str(p['value'] * p['unit'] if p['unit'] else p['value'])
#group.append("{:s} = {:s}".format(p['name'], strval))
group.append("{} = {} {}".format(p['name'], p['value'], p['unit']))
datatree[p['group']] = group
def create_tree(self, dset):
datatree = {}
for p in dset.parameters():
is_hidden = p.get('hidden', "False")
if is_hidden == "True":
continue
group = datatree.get(p['group'], [])
#strval = str(p['value'] * p['unit'] if p['unit'] else p['value'])
#group.append("{:s} = {:s}".format(p['name'], strval))
group.append("{} = {} {}".format(p['name'], p['value'], p['unit']))
datatree[p['group']] = group
tree = wx.TreeCtrl(self, -1)
root = tree.AddRoot('Parameters')
tree = wx.TreeCtrl(self, -1)
root = tree.AddRoot('Parameters')
for key in list(datatree.keys()):
item0 = tree.AppendItem(root, key)
for item in datatree[key]:
tree.AppendItem(item0, item)
tree.ExpandAll()
tree.SelectItem(root)
for key in list(datatree.keys()):
item0 = tree.AppendItem(root, key)
for item in datatree[key]:
tree.AppendItem(item0, item)
tree.ExpandAll()
tree.SelectItem(root)
class _DataWindow(wx.Frame):
def __init__(self, data):
assert isinstance(data, (Data, DataSet))
class _DataWindow(wx.Frame):
def __init__(self, data):
assert isinstance(data, (Data, DataSet))
if isinstance(data, DataSet):
dset = data
data = Data()
data.first = dset
self.data = data
self._filename = None
self._current_dset = None
if isinstance(data, DataSet):
dset = data
data = Data()
data.first = dset
self.data = data
self._filename = None
self._current_dset = None
wx.Frame.__init__(self, None, title="", size=(640, 480))
wx.Frame.__init__(self, None, title="", size=(640, 480))
self.Bind(wx.EVT_CLOSE, self.on_close)
self.Bind(wx.EVT_CLOSE, self.on_close)
# Populate the menu bar
self.create_menu()
# Populate the menu bar
self.create_menu()
# Create the status bar
statusbar = wx.StatusBar(self, -1)
statusbar.SetFieldsCount(3)
statusbar.SetStatusWidths([-2, -1, -1])
self.SetStatusBar(statusbar)
# Create the status bar
statusbar = wx.StatusBar(self, -1)
statusbar.SetFieldsCount(3)
statusbar.SetStatusWidths([-2, -1, -1])
self.SetStatusBar(statusbar)
# Add the notebook to hold all graphs
self.notebooks = {}
sizer = wx.BoxSizer(wx.VERTICAL)
#sizer.Add(self.notebook)
self.SetSizer(sizer)
# Add the notebook to hold all graphs
self.notebooks = {}
sizer = wx.BoxSizer(wx.VERTICAL)
#sizer.Add(self.notebook)
self.SetSizer(sizer)
self.Bind(wx.EVT_NOTEBOOK_PAGE_CHANGED, self.on_page_changed)
self.Bind(wx.EVT_NOTEBOOK_PAGE_CHANGED, self.on_page_changed)
self.create_notebooks()
self.update_title()
def create_notebooks(self):
for key in list(self.notebooks.keys()):
nb = self.notebooks.pop(key)
nb.Destroy()
for dset in self.data:
nb = wx.Notebook(self, -1)
self.notebooks[dset.title] = nb
#self.GetSizer().Add(nb, 1, wx.ALL|wx.EXPAND)
self.GetSizer().Add(nb, proportion=1, flag=wx.ALL|wx.EXPAND)
for view in dset.views():
self.create_page(nb, view)
self.create_menu()
self.show_dataset(self.data[0].title)
def create_menu(self):
menubar = wx.MenuBar()
menu1 = wx.Menu()
menu1.Append(110, "Open\tCtrl+O")
menu1.Append(120, "Save\tCtrl+S")
menu1.Append(130, "Save as...")
menu1.Append(140, "Export\tCtrl+E")
menu1.AppendSeparator()
menu1.Append(199, "Close\tCtrl+Q")
menu2 = wx.Menu()
for i, dset in enumerate(self.data):
menu_id = 201 + i
menu2.AppendRadioItem(menu_id, dset.title)
self.Bind(wx.EVT_MENU, self.on_menu_dataset, id=menu_id)
self.Bind(wx.EVT_MENU, self.on_open, id=110)
self.Bind(wx.EVT_MENU, self.on_save, id=120)
self.Bind(wx.EVT_MENU, self.on_saveas, id=130)
self.Bind(wx.EVT_MENU, self.on_export, id=140)
self.Bind(wx.EVT_MENU, self.on_close, id=199)
menu3 = wx.Menu()
menu3.Append(301, "Data")
menu3.Append(302, "Cluster")
menu3.Append(303, "Parameters")
self.Bind(wx.EVT_MENU, self.on_viewdata, id=301)
self.Bind(wx.EVT_MENU, self.on_viewcluster, id=302)
self.Bind(wx.EVT_MENU, self.on_viewparameters, id=303)
menubar.Append(menu1, "&File")
menubar.Append(menu2, "&Datasets")
menubar.Append(menu3, "&View")
self.SetMenuBar(menubar)
def on_open(self, event):
if self.data.is_dirty():
mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do '
'you wish to save before opening'
'another file ?'),
'Warning: Unsaved data',
wx.YES_NO | wx.ICON_WARNING)
if mbx.ShowModal() == wx.ID_YES:
self.on_saveas(wx.Event())
mbx.Destroy()
wildcard = "HDF5 files (*.hdf5)|*.hdf5"
dlg = wx.FileDialog(
self, message="Open a file...", defaultDir=os.getcwd(),
defaultFile="", wildcard=wildcard, style=wx.FD_OPEN
)
if dlg.ShowModal() == wx.ID_OK:
path = dlg.GetPath()
self._filename = path
self.data = Data.load(path)
self.create_notebooks()
dlg.Destroy()
self.update_title()
self.update_title()
def create_notebooks(self):
for key in list(self.notebooks.keys()):
nb = self.notebooks.pop(key)
nb.Destroy()
for dset in self.data:
nb = wx.Notebook(self, -1)
self.notebooks[dset.title] = nb
#self.GetSizer().Add(nb, 1, wx.ALL|wx.EXPAND)
self.GetSizer().Add(nb, proportion=1, flag=wx.ALL|wx.EXPAND)
for view in dset.views():
self.create_page(nb, view)
self.create_menu()
self.show_dataset(self.data[0].title)
def create_menu(self):
menubar = wx.MenuBar()
menu1 = wx.Menu()
menu1.Append(110, "Open\tCtrl+O")
menu1.Append(120, "Save\tCtrl+S")
menu1.Append(130, "Save as...")
menu1.Append(140, "Export\tCtrl+E")
menu1.AppendSeparator()
menu1.Append(199, "Close\tCtrl+Q")
menu2 = wx.Menu()
for i, dset in enumerate(self.data):
menu_id = 201 + i
menu2.AppendRadioItem(menu_id, dset.title)
self.Bind(wx.EVT_MENU, self.on_menu_dataset, id=menu_id)
self.Bind(wx.EVT_MENU, self.on_open, id=110)
self.Bind(wx.EVT_MENU, self.on_save, id=120)
self.Bind(wx.EVT_MENU, self.on_saveas, id=130)
self.Bind(wx.EVT_MENU, self.on_export, id=140)
self.Bind(wx.EVT_MENU, self.on_close, id=199)
menu3 = wx.Menu()
menu3.Append(301, "Data")
menu3.Append(302, "Cluster")
menu3.Append(303, "Parameters")
self.Bind(wx.EVT_MENU, self.on_viewdata, id=301)
self.Bind(wx.EVT_MENU, self.on_viewcluster, id=302)
self.Bind(wx.EVT_MENU, self.on_viewparameters, id=303)
menubar.Append(menu1, "&File")
menubar.Append(menu2, "&Datasets")
menubar.Append(menu3, "&View")
self.SetMenuBar(menubar)
def on_open(self, event):
def on_save(self, event):
if self._filename:
if self.data.is_dirty():
mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do '
'you wish to save before opening'
'another file ?'),
'Warning: Unsaved data',
wx.YES_NO | wx.ICON_WARNING)
if mbx.ShowModal() == wx.ID_YES:
self.on_saveas(wx.Event())
mbx.Destroy()
self.data.save(self._filename)
else:
self.on_saveas(event)
wildcard = "HDF5 files (*.hdf5)|*.hdf5"
dlg = wx.FileDialog(
self, message="Open a file...", defaultDir=os.getcwd(),
defaultFile="", wildcard=wildcard, style=wx.FD_OPEN
)
def on_saveas(self, event):
overwrite = True
wildcard = "HDF5 files (*.hdf5)|*.hdf5|All files (*.*)|*.*"
dlg = wx.FileDialog(
self, message="Save file as ...", defaultDir=os.getcwd(),
defaultFile='{}.hdf5'.format(self.data.title.replace(' ','_')),
wildcard=wildcard, style=wx.FD_SAVE)
dlg.SetFilterIndex(0)
if dlg.ShowModal() == wx.ID_OK:
path = dlg.GetPath()
self._filename = path
self.data = Data.load(path)
self.create_notebooks()
dlg.Destroy()
self.update_title()
def on_save(self, event):
if self._filename:
if self.data.is_dirty():
self.data.save(self._filename)
else:
self.on_saveas(event)
def on_saveas(self, event):
overwrite = True
wildcard = "HDF5 files (*.hdf5)|*.hdf5|All files (*.*)|*.*"
dlg = wx.FileDialog(
self, message="Save file as ...", defaultDir=os.getcwd(),
defaultFile='{}.hdf5'.format(self.data.title.replace(' ','_')),
wildcard=wildcard, style=wx.FD_SAVE)
dlg.SetFilterIndex(0)
if dlg.ShowModal() == wx.ID_OK:
path = dlg.GetPath()
if os.path.exists(path):
mbx = wx.MessageDialog(self, ('This file already exists. '
'Do you wish to overwrite it ?'),
'Warning: File exists',
wx.YES_NO | wx.ICON_WARNING)
if mbx.ShowModal() == wx.ID_NO:
overwrite = False
mbx.Destroy()
if overwrite:
self.data.save(path)
self._filename = path
dlg.Destroy()
self.update_title()
def on_export(self, event):
overwrite = True
dlg = wx.DirDialog(
self, message="Export data...", defaultPath=os.getcwd(),
style=wx.DD_DEFAULT_STYLE)
if dlg.ShowModal() == wx.ID_OK:
path = dlg.GetPath()
if os.listdir(path):
mbx = wx.MessageDialog(self,
('This folder is not empty. '
'Exporting tour data here may '
'overwrite its content. Do you wish '
'to continue ?'),
'Warning: Folder is not empty',
wx.YES_NO | wx.ICON_WARNING)
if mbx.ShowModal() == wx.ID_NO:
overwrite = False
mbx.Destroy()
self.data.export(path, overwrite)
dlg.Destroy()
def on_viewdata(self, event):
dset = self.data[self._current_dset]
frame = _GridWindow(dset, parent=self)
frame.Show()
def on_viewcluster(self, event):
win = wx.Frame(None, size=wx.Size(480, 340))
cluster_viewer = ClusterViewer(win, size=wx.Size(480, 340))
dset = self.data[self._current_dset]
#s = StringIO()
#s.write(dset.get_parameter(group='Cluster', name='cluster')['value'])
#_s = dset.get_parameter(group='Cluster', name='cluster')['value']
#print(_s)
# rewind to the begining of the string
#s.seek(0)
#atoms = ase.io.read(s, format='xyz')
atoms = dset.get_cluster()
cluster_viewer.set_atoms(atoms, rescale=True, center=True)
cluster_viewer.rotate_atoms(0., 180.)
cluster_viewer.rotate_atoms(-45., -45.)
#cluster_viewer.show_emitter(True)
win.Show()
def on_viewparameters(self, event):
dset = self.data[self._current_dset]
frame = _ParametersWindow(dset, parent=self)
frame.Show()
def on_close(self, event):
if self.data.is_dirty():
mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do you '
'really want to quit ?'),
'Warning: Unsaved data',
wx.YES_NO | wx.ICON_WARNING)
if dlg.ShowModal() == wx.ID_OK:
path = dlg.GetPath()
if os.path.exists(path):
mbx = wx.MessageDialog(self, ('This file already exists. '
'Do you wish to overwrite it ?'),
'Warning: File exists',
wx.YES_NO | wx.ICON_WARNING)
if mbx.ShowModal() == wx.ID_NO:
mbx.Destroy()
return
self.Destroy()
overwrite = False
mbx.Destroy()
if overwrite:
self.data.save(path)
self._filename = path
dlg.Destroy()
self.update_title()
def on_export(self, event):
overwrite = True
dlg = wx.DirDialog(
self, message="Export data...", defaultPath=os.getcwd(),
style=wx.DD_DEFAULT_STYLE)
if dlg.ShowModal() == wx.ID_OK:
path = dlg.GetPath()
if os.listdir(path):
mbx = wx.MessageDialog(self,
('This folder is not empty. '
'Exporting tour data here may '
'overwrite its content. Do you wish '
'to continue ?'),
'Warning: Folder is not empty',
wx.YES_NO | wx.ICON_WARNING)
if mbx.ShowModal() == wx.ID_NO:
overwrite = False
mbx.Destroy()
self.data.export(path, overwrite)
dlg.Destroy()
def on_viewdata(self, event):
dset = self.data[self._current_dset]
frame = _GridWindow(dset, parent=self)
frame.Show()
def on_viewcluster(self, event):
win = wx.Frame(None, size=wx.Size(480, 340))
cluster_viewer = ClusterViewer(win, size=wx.Size(480, 340))
dset = self.data[self._current_dset]
#s = StringIO()
#s.write(dset.get_parameter(group='Cluster', name='cluster')['value'])
#_s = dset.get_parameter(group='Cluster', name='cluster')['value']
#print(_s)
# rewind to the begining of the string
#s.seek(0)
#atoms = ase.io.read(s, format='xyz')
atoms = dset.get_cluster()
cluster_viewer.set_atoms(atoms, rescale=True, center=True)
cluster_viewer.rotate_atoms(0., 180.)
cluster_viewer.rotate_atoms(-45., -45.)
#cluster_viewer.show_emitter(True)
win.Show()
def on_viewparameters(self, event):
dset = self.data[self._current_dset]
frame = _ParametersWindow(dset, parent=self)
frame.Show()
def on_close(self, event):
if self.data.is_dirty():
mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do you '
'really want to quit ?'),
'Warning: Unsaved data',
wx.YES_NO | wx.ICON_WARNING)
if mbx.ShowModal() == wx.ID_NO:
mbx.Destroy()
return
self.Destroy()
def on_menu_dataset(self, event):
menu_id = event.GetId()
dset_name = self.GetMenuBar().FindItemById(menu_id).GetItemLabelText()
self.show_dataset(dset_name)
def on_menu_dataset(self, event):
menu_id = event.GetId()
dset_name = self.GetMenuBar().FindItemById(menu_id).GetItemLabelText()
self.show_dataset(dset_name)
def show_dataset(self, name):
for nb in list(self.notebooks.values()):
nb.Hide()
self.notebooks[name].Show()
self.Layout()
self.update_statusbar()
self._current_dset = name
def show_dataset(self, name):
for nb in list(self.notebooks.values()):
nb.Hide()
self.notebooks[name].Show()
self.Layout()
self.update_statusbar()
self._current_dset = name
def create_page(self, nb, view):
# Get the matplotlib figure
figure = view.get_figure()
def create_page(self, nb, view):
# Get the matplotlib figure
figure = view.get_figure()
# Create a panel
p = wx.Panel(nb, -1)
# Create a panel
p = wx.Panel(nb, -1)
# Create a matplotlib canvas for the figure
canvas = FigureCanvas(p, -1, figure)
sizer = wx.BoxSizer(wx.VERTICAL)
# Create a matplotlib canvas for the figure
canvas = FigureCanvas(p, -1, figure)
sizer = wx.BoxSizer(wx.VERTICAL)
toolbar = NavigationToolbar2WxAgg(canvas)
toolbar.Realize()
toolbar = NavigationToolbar2WxAgg(canvas)
toolbar.Realize()
#sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND)
sizer.Add(toolbar, proportion=0, flag=wx.ALL|wx.EXPAND)
toolbar.update()
#sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND)
sizer.Add(toolbar, proportion=0, flag=wx.ALL|wx.EXPAND)
toolbar.update()
#sizer.Add(canvas, 5, wx.ALL|wx.EXPAND)
sizer.Add(canvas, proportion=1, flag=wx.ALL|wx.EXPAND)
#sizer.Add(canvas, 5, wx.ALL|wx.EXPAND)
sizer.Add(canvas, proportion=1, flag=wx.ALL|wx.EXPAND)
p.SetSizer(sizer)
p.Fit()
p.Show()
p.SetSizer(sizer)
p.Fit()
p.Show()
# MPL events
figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion)
figure.canvas.mpl_connect('pick_event', self.on_mpl_pick)
# MPL events
figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion)
figure.canvas.mpl_connect('pick_event', self.on_mpl_pick)
nb.AddPage(p, view.title)
canvas.draw()
nb.AddPage(p, view.title)
canvas.draw()
def OLDcreate_page(self, nb, view):
opts = view._plotopts
p = wx.Panel(nb, -1)
def OLDcreate_page(self, nb, view):
opts = view._plotopts
p = wx.Panel(nb, -1)
figure = Figure()
figure = Figure()
axes = None
proj = opts['projection']
scale = opts['scale']
if proj == 'rectilinear':
axes = figure.add_subplot(111, projection='rectilinear')
elif proj in ('polar', 'ortho', 'stereo'):
axes = figure.add_subplot(111, projection='polar')
axes = None
proj = opts['projection']
scale = opts['scale']
if proj == 'rectilinear':
axes = figure.add_subplot(111, projection='rectilinear')
elif proj in ('polar', 'ortho', 'stereo'):
axes = figure.add_subplot(111, projection='polar')
canvas = FigureCanvas(p, -1, figure)
sizer = wx.BoxSizer(wx.VERTICAL)
canvas = FigureCanvas(p, -1, figure)
sizer = wx.BoxSizer(wx.VERTICAL)
toolbar = NavigationToolbar2WxAgg(canvas)
toolbar.Realize()
toolbar = NavigationToolbar2WxAgg(canvas)
toolbar.Realize()
sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND)
toolbar.update()
sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND)
toolbar.update()
sizer.Add(canvas, 5, wx.ALL|wx.EXPAND)
sizer.Add(canvas, 5, wx.ALL|wx.EXPAND)
p.SetSizer(sizer)
p.Fit()
p.Show()
p.SetSizer(sizer)
p.Fit()
p.Show()
for values, label in zip(view.get_data(), opts['legend']):
# if we have only one column to plot, select a bar graph
if np.shape(values)[0] == 1:
xvalues = list(range(len(values[0])))
axes.bar(xvalues, values[0], label=label,
picker=5)
axes.set_xticks(xvalues)
for values, label in zip(view.get_data(), opts['legend']):
# if we have only one column to plot, select a bar graph
if np.shape(values)[0] == 1:
xvalues = list(range(len(values[0])))
axes.bar(xvalues, values[0], label=label,
picker=5)
axes.set_xticks(xvalues)
else:
if proj in ('ortho', 'stereo'):
theta, phi, Xsec = cols2matrix(*values)
theta_ticks = np.arange(0, 91, 15)
if proj == 'ortho':
R = np.sin(np.radians(theta))
R_ticks = np.sin(np.radians(theta_ticks))
elif proj == 'stereo':
R = 2 * np.tan(np.radians(theta/2.))
R_ticks = 2 * np.tan(np.radians(theta_ticks/2.))
#R = np.tan(np.radians(theta/2.))
X, Y = np.meshgrid(np.radians(phi), R)
im = axes.pcolormesh(X, Y, Xsec)
axes.set_yticks(R_ticks)
axes.set_yticklabels(theta_ticks)
figure.colorbar(im)
elif proj == 'polar':
values[0] = np.radians(values[0])
axes.plot(*values, label=label, picker=5,
marker=opts['marker'])
else:
if proj in ('ortho', 'stereo'):
theta, phi, Xsec = cols2matrix(*values)
theta_ticks = np.arange(0, 91, 15)
if proj == 'ortho':
R = np.sin(np.radians(theta))
R_ticks = np.sin(np.radians(theta_ticks))
elif proj == 'stereo':
R = 2 * np.tan(np.radians(theta/2.))
R_ticks = 2 * np.tan(np.radians(theta_ticks/2.))
#R = np.tan(np.radians(theta/2.))
X, Y = np.meshgrid(np.radians(phi), R)
im = axes.pcolormesh(X, Y, Xsec)
axes.set_yticks(R_ticks)
axes.set_yticklabels(theta_ticks)
figure.colorbar(im)
elif proj == 'polar':
values[0] = np.radians(values[0])
axes.plot(*values, label=label, picker=5,
marker=opts['marker'])
if scale == 'semilogx':
pltcmd = axes.semilogx
elif scale == 'semilogy':
pltcmd = axes.semilogy
elif scale == 'log':
pltcmd = axes.loglog
else:
if scale == 'semilogx':
pltcmd = axes.semilogx
elif scale == 'semilogy':
pltcmd = axes.semilogy
elif scale == 'log':
pltcmd = axes.loglog
else:
pltcmd = axes.plot
pltcmd(*values, label=label, picker=5,
marker=opts['marker'])
axes.grid(opts['grid'])
axes.set_title(opts['title'])
axes.set_xlabel(opts['xlabel'])
axes.set_ylabel(opts['ylabel'])
axes.set_xlim(*opts['xlim'])
axes.set_ylim(*opts['ylim'])
if label:
axes.legend()
axes.autoscale(enable=opts['autoscale'])
pltcmd = axes.plot
pltcmd(*values, label=label, picker=5,
marker=opts['marker'])
axes.grid(opts['grid'])
axes.set_title(opts['title'])
axes.set_xlabel(opts['xlabel'])
axes.set_ylabel(opts['ylabel'])
axes.set_xlim(*opts['xlim'])
axes.set_ylim(*opts['ylim'])
if label:
axes.legend()
axes.autoscale(enable=opts['autoscale'])
# MPL events
figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion)
figure.canvas.mpl_connect('pick_event', self.on_mpl_pick)
# MPL events
figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion)
figure.canvas.mpl_connect('pick_event', self.on_mpl_pick)
nb.AddPage(p, view.title)
nb.AddPage(p, view.title)
def update_statusbar(self):
sb = self.GetStatusBar()
menu_id = self.GetMenuBar().FindMenu('Datasets')
menu = self.GetMenuBar().GetMenu(menu_id)
for item in menu.GetMenuItems():
if item.IsChecked():
sb.SetStatusText("%s" % item.GetItemLabelText(), 1)
break
def update_statusbar(self):
sb = self.GetStatusBar()
menu_id = self.GetMenuBar().FindMenu('Datasets')
menu = self.GetMenuBar().GetMenu(menu_id)
for item in menu.GetMenuItems():
if item.IsChecked():
sb.SetStatusText("%s" % item.GetItemLabelText(), 1)
break
def update_title(self):
title = "MsSpec Data Viewer"
if self.data.title:
title += ": " + self.data.title
if self._filename:
title += " [" + os.path.basename(self._filename) + "]"
self.SetTitle(title)
def update_title(self):
title = "MsSpec Data Viewer"
if self.data.title:
title += ": " + self.data.title
if self._filename:
title += " [" + os.path.basename(self._filename) + "]"
self.SetTitle(title)
def on_mpl_motion(self, event):
sb = self.GetStatusBar()
try:
txt = "[{:.3f}, {:.3f}]".format(event.xdata, event.ydata)
sb.SetStatusText(txt, 2)
except Exception:
pass
def on_mpl_motion(self, event):
sb = self.GetStatusBar()
try:
txt = "[{:.3f}, {:.3f}]".format(event.xdata, event.ydata)
sb.SetStatusText(txt, 2)
except Exception:
pass
def on_mpl_pick(self, event):
print(event.artist)
def on_mpl_pick(self, event):
print(event.artist)
def on_page_changed(self, event):
self.update_statusbar()
def on_page_changed(self, event):
self.update_statusbar()

48
src/msspec/iodata_gi.py
View File

@ -235,8 +235,8 @@ class DataSet(object):
float: '{:<20.10e}', complex: 's'}
self._formats = ((np.integer, '{:<20d}'),
(np.floating, '{:<20.10e}'),
(complex, '({0.real:<.10e} {0.imag:<.10e}j)'),
(bool, '{:s}'),
(np.complex, '({0.real:<.10e} {0.imag:<.10e}j)'),
(np.bool, '{:s}'),
(str, '{:s}'))
@ -450,13 +450,9 @@ class DataSet(object):
:return: The cluster
:rtype: :py:class:`ase.Atoms`
"""
p = self.get_parameter(group='Cluster', name='cluster')['value']
s = StringIO()
s.write(self.get_parameter(group='Cluster', name='cluster')['value'])
s.seek(0)
#return ase.io.read(s, format='xyz')
cluster = list(read_xyz(s))[-1]
return cluster
return ase.io.read(s, format='xyz')
def select(self, *args, **kwargs):
@ -789,13 +785,13 @@ class Data(object):
dset = output.add_dset(dset_name)
dset.notes = fd['DATA'][dset_name].attrs['notes']
for h5dset in fd['DATA'][dset_name]:
dset.add_columns(**{h5dset: fd['DATA'][dset_name][h5dset][...]})
dset.add_columns(**{h5dset: fd['DATA'][dset_name][h5dset].value})
try:
vfile = LooseVersion(fd['MsSpec viewer metainfo'].attrs['version'])
if vfile > LooseVersion(msspec.__version__):
raise NameError('File was saved with a more recent format')
xml = fd['MsSpec viewer metainfo']['info'][...].tobytes()
xml = fd['MsSpec viewer metainfo']['info'].value.tostring()
root = etree.fromstring(xml)
for elt0 in root.iter('parameters'):
dset_name = elt0.attrib['dataset']
@ -858,7 +854,7 @@ class Data(object):
#win.show()
#Gtk.main()
app = _Application(self)
exit_status = app.run()#sys.argv)
exit_status = app.run(sys.argv)
sys.exit(exit_status)
class _Application(Gtk.Application):
@ -951,8 +947,7 @@ class _DataSetView(object):
if np.shape(values)[0] == 1:
xvalues = list(range(len(values[0])))
axes.bar(xvalues, values[0], label=label,
# picker=5
)
picker=5)
axes.set_xticks(xvalues)
else:
if proj in ('ortho', 'stereo'):
@ -966,7 +961,7 @@ class _DataSetView(object):
R_ticks = 2 * np.tan(np.radians(theta_ticks/2.))
#R = np.tan(np.radians(theta/2.))
X, Y = np.meshgrid(np.radians(phi), R)
im = axes.pcolormesh(X, Y, Xsec, shading='gouraud')
im = axes.pcolormesh(X, Y, Xsec)
axes.set_yticks(R_ticks)
axes.set_yticklabels(theta_ticks)
@ -974,7 +969,7 @@ class _DataSetView(object):
elif proj == 'polar':
values[0] = np.radians(values[0])
axes.plot(*values, label=label, #picker=5,
axes.plot(*values, label=label, picker=5,
marker=opts['marker'])
else:
if scale == 'semilogx':
@ -985,7 +980,7 @@ class _DataSetView(object):
pltcmd = axes.loglog
else:
pltcmd = axes.plot
pltcmd(*values, label=label, #picker=5,
pltcmd(*values, label=label, picker=5,
marker=opts['marker'])
axes.grid(opts['grid'])
axes.set_title(opts['title'])
@ -993,7 +988,6 @@ class _DataSetView(object):
axes.set_ylabel(opts['ylabel'])
axes.set_xlim(*opts['xlim'])
axes.set_ylim(*opts['ylim'])
#axes.set_pickradius(5)
if label:
axes.legend()
axes.autoscale(enable=opts['autoscale'])
@ -1248,7 +1242,7 @@ class _DataWindow(Gtk.ApplicationWindow):
def on_close(self, action, param):
if self.data.is_dirty():
dlg = Gtk.Dialog(title="Warning: Unsaved data",
transient_for=self, modal=True)
transient_for=self, flags=Gtk.DialogFlags.MODAL)
dlg.add_buttons(Gtk.STOCK_YES, Gtk.ResponseType.YES,
Gtk.STOCK_NO, Gtk.ResponseType.NO)
dlg.set_default_size(150, 100)
@ -1480,14 +1474,9 @@ class OLD_DataWindow(wx.Frame):
cluster_viewer = ClusterViewer(win, size=wx.Size(480, 340))
dset = self.data[self._current_dset]
#s = StringIO()
#s.write(dset.get_parameter(group='Cluster', name='cluster')['value'])
#_s = dset.get_parameter(group='Cluster', name='cluster')['value']
#print(_s)
# rewind to the begining of the string
#s.seek(0)
#atoms = ase.io.read(s, format='xyz')
atoms = dset.get_cluster()
s = StringIO()
s.write(dset.get_parameter(group='Cluster', name='cluster')['value'])
atoms = ase.io.read(s, format='xyz')
cluster_viewer.set_atoms(atoms, rescale=True, center=True)
cluster_viewer.rotate_atoms(0., 180.)
cluster_viewer.rotate_atoms(-45., -45.)
@ -1688,7 +1677,7 @@ class OLD_DataWindow(wx.Frame):
if __name__ == "__main__":
if False:
if True:
data = Data('all my data')
dset = data.add_dset('Dataset 0')
X = np.arange(0, 20)
@ -1724,7 +1713,6 @@ if __name__ == "__main__":
view.select('x', 'y')
data.view()
exit()
import sys
data = Data.load(sys.argv[1])
data.view()
#import sys
#data = Data.load(sys.argv[1])
#data.view()

85
src/msspec/looper.py
View File

@ -17,8 +17,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/looper.py
# Last modified: Wed, 26 Feb 2025 11:15:54 +0100
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes.fr>
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
from collections import OrderedDict
from functools import partial
@ -92,8 +92,9 @@ class Sweep:
class SweepRange:
def __init__(self, *sweeps):
def __init__(self, *sweeps, passindex=False):
self.sweeps = sweeps
self.passindex = passindex
self.index = 0
# First check that sweeps that are linked to another on are all included
@ -157,15 +158,17 @@ class SweepRange:
for s in [sweep,] + children:
key, value = s[idx]
row[key] = value
row['sweep_index'] = i
if self.passindex:
row['sweep_index'] = i
return row
else:
raise StopIteration
@property
def columns(self):
cols = ['sweep_index']
cols += [sweep.key for sweep in self.sweeps]
cols = [sweep.key for sweep in self.sweeps]
if self.passindex:
cols.append('sweep_index')
return cols
@property
@ -199,27 +202,31 @@ class Looper:
logger.debug("Pipeline called with {}".format(x))
return self.pipeline(**x)
def run(self, *sweeps, ncpu=1, **kwargs):
def run(self, *sweeps, ncpu=1, passindex=False):
logger.info("Loop starts...")
# prepare the list of inputs
sr = SweepRange(*sweeps)
sr = SweepRange(*sweeps, passindex=passindex)
items = sr.items
data = []
t0 = time.time()
if ncpu == 1:
# serial processing...
logger.info("serial processing...")
t0 = time.time()
for i, values in enumerate(items):
values.update(kwargs)
result = self._wrapper(values)
data.append(result)
t1 = time.time()
dt = t1 - t0
logger.info("Processed {:d} sets of inputs in {:.3f} seconds".format(
len(sr), dt))
else:
# Parallel processing...
chunksize = 1 #int(nsets/ncpu)
[values.update(kwargs) for values in items]
logger.info(("Parallel processing over {:d} cpu (chunksize={:d})..."
"").format(ncpu, chunksize))
t0 = time.time()
@ -229,23 +236,21 @@ class Looper:
pool.close()
pool.join()
t1 = time.time()
dt = t1 - t0
logger.info(("Processed {:d} sets of inputs in {:.3f} seconds"
"").format(len(sr), dt))
t1 = time.time()
dt = t1 - t0
logger.info(("Processed {:d} sets of inputs in {:.3f} seconds"
"").format(len(sr), dt))
# Create the DataFrame
dfdata = []
columns = sr.columns + list(kwargs.keys()) + ['output',]
columns = sr.columns + ['output',]
for i in range(len(sr)):
row = list(items[i].values())
row.append(data[i])
dfdata.append(row)
df = pd.DataFrame(dfdata, columns=columns)
df = df.drop(columns=['sweep_index'])
self.data = df
@ -254,14 +259,14 @@ class Looper:
# of corresponding dict of parameters {'keyA': [val0,...valn],
# 'keyB': [val0,...valn], ...}
# all_xy = []
# for irow, row in df.iterrows():
# all_xy.append(row.output[0])
# all_xy.append(row.output[1])
# parameters = df.to_dict()
# parameters.pop('output')
all_xy = []
for irow, row in df.iterrows():
all_xy.append(row.output[0])
all_xy.append(row.output[1])
parameters = df.to_dict()
parameters.pop('output')
return self.data #all_xy, parameters
return all_xy, parameters
@ -271,16 +276,17 @@ class Looper:
if __name__ == "__main__":
import numpy as np
import time
import logging
logging.basicConfig(level=logging.DEBUG)
logger.setLevel(logging.DEBUG)
def bar(**kwargs):
i = kwargs.get('sweep_index')
return np.linspace(0,i,10)
return 0
def post_process(data):
x = data.x.unique()
y = data.y.unique()
theta = Sweep(key='theta', comments="The polar angle",
start=-70, stop=70, num=3,
@ -308,16 +314,7 @@ if __name__ == "__main__":
looper = Looper()
looper.pipeline = bar
other_kws = {'un':1, 'deux':2}
data = looper.run(emitter, emitter_plane, uij, theta, levels, ncpu=4, **other_kws)
# Print the dataframe
data = looper.run(emitter, emitter_plane, uij, theta, levels, ncpu=4,
passindex=True)
print(data)
# Accessing the parameters and ouput values for a given sweep (e.g the last one)
print(looper.data.iloc[-1])
# Post-process the output values. For example here, the output is a 1D-array,
# make the sum of sweeps with 'Sr' emitter
X = np.array([ x for x in data[data.emitter == 'Sr'].output]).sum(axis=0)
print(X)
#print(data[data.emitter_plane.eq(0)].theta.unique())

23
src/msspec/parameters.py
View File

@ -19,8 +19,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/parameters.py
# Last modified: Tue, 15 Feb 2022 15:37:28 +0100
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
"""
@ -839,17 +839,6 @@ class GlobalParameters(BaseParameters):
self.phagen_parameters.calctype = phagen_calctype
self.spec_parameters.calctype_spectro = spec_calctype
def bind_polarization(self, p):
if p.value is None:
ipol = 0
elif p.value == 'linear_qOz':
ipol = 1
elif p.value == 'linear_xOy':
ipol = -1
elif p.value == 'circular':
ipol = 2
self.spec_parameters.calctype_ipol = ipol
def bind_spinpol(self, p):
if p.value == True:
LOGGER.error('Spin polarization is not yet enabled in the Python version.')
@ -1322,8 +1311,8 @@ class ScanParameters(BaseParameters):
# LOGGER.error('Incompatible options!')
# raise ValueError(msg)
# p._value = np.array(p.value, dtype=float).flatten()
arr = np.array(p.value, dtype=float).flatten()
# p._value = np.array(p.value, dtype=np.float).flatten()
arr = np.array(p.value, dtype=np.float).flatten()
theta0 = arr[0]
theta1 = arr[-1]
@ -1357,7 +1346,7 @@ class ScanParameters(BaseParameters):
# LOGGER.error('Incompatible options')
# raise ValueError(msg)
arr = np.array(p.value, dtype=float).flatten()
arr = np.array(p.value, dtype=np.float).flatten()
phi0 = arr[0]
phi1 = arr[-1]
@ -1551,7 +1540,7 @@ class CalculationParameters(BaseParameters):
Parameter('cutoff_factor', types=(int, float),
limits=(1e-4, 999.9999), default=0.01, private=False),
Parameter('mean_free_path', types=(int, float, str),
default='SeahDench', #allowed_values=('mono', 'SeahDench'),
default='SeahDench', allowed_values=('mono', 'SeahDench'),
doc="""
The electron mean free path value. You can either:
- Enter a value (in Angströms), in this case any value <=0 will disable the damping

2
src/msspec/phagen/fortran/phagen_2.2_dp/msxas3.inc
View File

@ -28,7 +28,7 @@ c
integer fl_, rdx_
c
parameter ( rdx_ = 1600,
$ lmax_ = 80,
$ lmax_ = 50,
$ npss = lmax_ + 2,
$ fl_ = 2*npss + 1,
$ nef_ = 10,

2
src/msspec/phagen/fortran/phagen_2.2_dp/phagen_scf_2.2_dp.f
View File

@ -14625,7 +14625,7 @@ c check = .true.
!
do
!
if (( r_real ( i ) > r_in ) .or. ( i .ge. size(r_real) )) then
if ( r_real ( i ) > r_in ) then
exit

14
src/msspec/spec/fortran/Makefile
View File

@ -1,6 +1,6 @@
.PHONY: all phd_se phd_mi phd_ce eig_mi eig_pw comp_curve clean
.PHONY: all phd_se phd_mi aed_se aed_mi eig_mi eig_pw comp_curve clean
all: phd_se phd_mi phd_ce eig_mi eig_pw comp_curve
all: phd_se phd_mi aed_se aed_mi eig_mi eig_pw comp_curve
phd_se:
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk all
@ -8,8 +8,11 @@ phd_se:
phd_mi:
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk all
phd_ce:
@+$(MAKE) -f phd_ce_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
@ -23,7 +26,8 @@ comp_curve:
clean::
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk $@
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk $@
@+$(MAKE) -f phd_ce_noso_nosp_nosym.mk $@
@+$(MAKE) -f 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 $@

12
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym.mk Normal file
View File

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

789
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/aeddif_mi_mu.f Normal file
View File

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

198
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/axb_mat_ms_la_a.f Normal file
View File

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

140
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/coumat_am.f Normal file
View File

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

7
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/dwsph.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/dwsph_a.f
View File

@ -1,7 +1,7 @@
C
C=======================================================================
C
SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
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.
@ -12,7 +12,9 @@ C Last modified : 25 Apr 2013
C
USE DIM_MOD
C
USE TRANS_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
DIMENSION GNT(0:N_GAUNT)
C
@ -83,3 +85,4 @@ C
RETURN
C
END

20
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/facdif1.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif1_a.f
View File

@ -1,19 +1,23 @@
C
C=======================================================================
C
SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J
&E,*)
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 Last modified : 03/04/2006
C
USE DIM_MOD
C
USE APPROX_MOD
USE EXPFAC_MOD
USE TRANS_MOD
USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I
&6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
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)
@ -21,7 +25,6 @@ C
COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
COMPLEX RHOJK
C
C
DATA PI/3.141593/
C
@ -59,7 +62,6 @@ C
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.)
@ -72,7 +74,7 @@ C
A=-1.
ENDIF
ENDIF
IF(ISPHER.LE.1) THEN
IF(ISPHER.LE.1) THEN
ALMU=(1.,0.)
C=1.
ENDIF

28
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif_a.f Normal file
View File

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

0
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/lapack_axb.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/lapack_axb.f
View File

2
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main.f
View File

@ -15,7 +15,7 @@ CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_
& NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
& N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
CALL MAIN_PHD_NS_CE()
CALL MAIN_AED_MU_MI()
CALL CLOSE_ALL_FILES()
END SUBROUTINE RUN

139
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f
View File

@ -4,8 +4,8 @@ C ************************************************************
C * ******************************************************** *
C * * * *
C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * *
C * * PHOTOELECTRON DIFFRACTION CODE * *
C * * BASED ON CORRELATION EXPANSION * *
C * * AUGER ELECTRON DIFFRACTION CODE * *
C * * USING MATRIX INVERSION * *
C * * * *
C * ******************************************************** *
C ************************************************************
@ -43,6 +43,14 @@ C
C * AEDDIF : computes the Auger electron diffraction
C formula
C
C * FINDPATHS : generates the multiple scattering
C paths the electron will follow
C
C * PATHOP : calculates the contribution of a given
C path to the scattering path operator
C
C * MATDIF : computes the Rehr-Albers scattering
C matrices
C
C A subroutine called NAME_A is the Auger equivalent of subroutine
C NAME. The essentail difference between NAME and NAME_A is that
@ -69,12 +77,13 @@ C Last modified : 10 Jan 2016
C
C=======================================================================
C
SUBROUTINE MAIN_PHD_NS_CE()
SUBROUTINE MAIN_AED_MU_MI()
C
C This routine reads the various input files and calls the subroutine
C performing the requested calculation
C
USE DIM_MOD
C
USE ADSORB_MOD
USE APPROX_MOD
USE ATOMS_MOD
@ -115,52 +124,45 @@ C
DIMENSION ROT(3,3),EMET(3)
DIMENSION VAL2(NATCLU_M)
DIMENSION IRE(NATCLU_M,2)
DIMENSION REL(NATCLU_M),RHOT(NATM)
DIMENSION REL(NATCLU_M),RHOT(NATM)
DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M)
DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM)
DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M)
DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M)
DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM)
C
COMPLEX TLSTAR
COMPLEX RHOR(NE_M,NATM,0:18,5,NSPIN2_M)
COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M)
COMPLEX TLSTAR_A
COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E
COMPLEX RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHOR5STAR
COMPLEX RHOR1STAR,RHOR2STAR
C
INTEGER INV(2)
C
CHARACTER RIEN
CHARACTER*1 B
CHARACTER*2 R
C
C
C
C
C
C
CHARACTER*30 TUNIT,DUMMY
C
DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/
DATA INV /0,0/
DATA INV /1,0/
C
LE_MAX=0
C
C! READ(*,776) NFICHLEC
C! READ(*,776) ICOM
C! DO JF=1,NFICHLEC
C! READ(*,777) INDATA(JF)
C! ENDDO
CST READ(*,776) NFICHLEC
CST READ(*,776) ICOM
CST DO JF=1,NFICHLEC
CST READ(*,777) INDATA(JF)
CST ENDDO
C
C.......... Loop on the data files ..........
C
C
NFICHLEC=1
ICOM = 5
ICOM=5
DO JFICH=1,NFICHLEC
C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
CST OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD')
CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*5
&20,*540,*550,*570,*580,*590,*630)
CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,
1 *520,*540,*550,*570,*580,*590,*630)
C
C.......... Atomic case index ..........
C
@ -188,13 +190,13 @@ C
N_EL=1
ENDIF
IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
IF(I_MULT.EQ.0) THEN
c IF(I_MULT.EQ.0) THEN
LE_MIN=ABS(LI_C-ABS(LI_I-LI_A))
LE_MAX=LI_C+LI_A+LI_I
ELSE
LE_MIN=ABS(LI_C-L_MUL)
LE_MAX=LI_C+L_MUL
ENDIF
c ELSE
c LE_MIN=ABS(LI_C-L_MUL)
c LE_MAX=LI_C+L_MUL
c ENDIF
ENDIF
C
C.......... Test of the dimensions against the input values ..........
@ -332,25 +334,12 @@ C
READ(IUI3,102) RIEN
ENDDO
ENDIF
C
C Reading or regular (RHOR) and irregular (RHOI) radial integrals
C
C 1-2 : dipole terms
C 3-5 : quadrupole terms
C
DO JEMET=1,NEMET
C
JM=IEMET(JEMET)
READ(IUI3,105) RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,
1 RHOR5STAR
READ(IUI3,105) RHOR1STAR,RHOR2STAR
RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR)
RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR)
RHOR(JE,JM,NNL,3,1)=CONJG(RHOR3STAR)
RHOR(JE,JM,NNL,4,1)=CONJG(RHOR4STAR)
RHOR(JE,JM,NNL,5,1)=CONJG(RHOR5STAR)
C
ENDDO
C
333 VK(JE)=VK(JE)*A
VK2(JE)=CABS(VK(JE)*VK(JE))
ENDDO
@ -394,6 +383,9 @@ C
READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A
ENDIF
IF(ITL_A.EQ.1) THEN
READ(IRD2, *) RIEN
READ(IRD2, *) RIEN
READ(IRD2, *) RIEN
READ(IRD2,107) LI_C2,LI_I2,LI_A2
READ(IRD2,117) LE_MIN1,N_CHANNEL
LE_MAX1=LE_MIN1+N_CHANNEL-1
@ -470,7 +462,8 @@ C
IF(LMAX_MODE_A.EQ.0) THEN
READ(IRD1,9) VK_A(JE),TLSTAR
ELSE
READ(IRD1,7) VK_A(JE),TLSTAR
CST READ(IRD1,7) VK_A(JE),TLSTAR
READ(IRD1,9) VK_A(JE),TLSTAR
ENDIF
TL_A(L,1,JAT,JE)=CONJG(TLSTAR)
VK_A(JE)=CONJG(VK_A(JE))
@ -525,27 +518,6 @@ C
C
ENDIF
C
C.......... Checking maximum value for l_max ..........
C.......... and storage of Gaunt coefficients ..........
C
LM_PE=0
DO JAT=1,NAT2
DO JE=1,NE
LM_PE=MAX(LM_PE,LMAX(JAT,JE))
ENDDO
ENDDO
C
LM_AE=0
DO JAT=1,NAT2_A
DO JE=1,NE_A
LM_AE=MAX(LM_AE,LMAX_A(JAT,JE))
ENDDO
ENDDO
C
LM_PA=MAX(LM_PE,LM_AE)
CALL GAUNT_ST(LM_PA)
CALL COEFPQ(MAX(NAT2,NAT2_A),NDIF)
C
C.......... Check of the consistency of the two TL and radial ..........
C.......... matrix elements for APECS ..........
C
@ -573,13 +545,13 @@ C.......... Calculation of the scattering factor (only) ..........
C
IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8
IF(IFTHET.EQ.1) THEN
CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
c CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
ELSEIF(IFTHET_A.EQ.1) THEN
c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A)
ENDIF
WRITE(IUO1,57)
CST STOP
GO TO 999
WRITE(IUO1,57)
CST STOP
GOTO 999
C
8 IF(IBAS.EQ.0) THEN
C
@ -1214,22 +1186,23 @@ C.......... the PhD, LEED, AED, EXAFS or APECS calculation ..........
C
566 IF(ISPIN.EQ.0) THEN
IF(SPECTRO.EQ.'PHD') THEN
CALL PHDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
1 NATCLU,NFICHLEC,JFICH,NP)
c CALL PHDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c 1 NATCLU,NFICHLEC,JFICH,NP)
ELSEIF(SPECTRO.EQ.'LED') THEN
c CALL LEDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c CALL LEDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c 1 NATCLU,NFICHLEC,JFICH,NP)
ELSEIF(SPECTRO.EQ.'AED') THEN
c CALL AEDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
CALL AEDDIF_MI_MU(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,
1 RHOR_A,NATCLU,NFICHLEC,JFICH,NP,LE_MIN,
2 LE_MAX)
ELSEIF(SPECTRO.EQ.'XAS') THEN
c CALL XASDIF_CE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
c CALL XASDIF_MI(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
ELSEIF(SPECTRO.EQ.'APC') THEN
c IF(J_EL.EQ.1) THEN
c CALL PHDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c CALL PHDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c 1 NATCLU,NFICHLEC,JFICH,NP)
c ELSEIF(J_EL.EQ.2) THEN
c CALL AEDDIF_CE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
c CALL AEDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
c ENDIF
ENDIF
@ -1300,7 +1273,7 @@ C
WRITE(IUO1,562)
ENDIF
IF(ISOM.EQ.0) CLOSE(IUO2)
IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
CST IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
C
C.......... End of the loop on the data files ..........
C
@ -1310,7 +1283,7 @@ C
JFF=1
IF(ISPIN.EQ.0) THEN
IF(SPECTRO.NE.'XAS') THEN
CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP)
CALL TREAT_AED(ISOM,NFICHLEC,JFF,NP)
ELSE
c CALL TREAT_XAS(ISOM,NFICHLEC,NP)
ENDIF
@ -1324,10 +1297,10 @@ c ENDIF
ENDIF
ENDIF
C
IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
CST IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
IF(ISOM.NE.0) CLOSE(IUO2)
CST STOP
GO TO 999
CST STOP
GOTO 999
C
1 WRITE(IUO1,60)
STOP
@ -1395,7 +1368,7 @@ C
3 FORMAT(5(5X,I4))
7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9)
CST 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6)
9 FORMAT(3X,F9.4,1X,F9.4,E18.6,5X,E18.6)
9 FORMAT(3X,F9.4,1X,F9.4,E18.6,E18.6)
17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',
1': (',I3,',',I3,',',I3,')')
18 FORMAT(' ',/)

48
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/plotfd.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/plotfd_a.f
View File

@ -1,7 +1,7 @@
C
C=======================================================================
C
SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
SUBROUTINE PLOTFD_A(A,LMX,ITL,NL,NAT,NE)
C
C This routine prepares the output for a plot of the scattering factor
C
@ -9,25 +9,25 @@ C
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_L_MOD, L => LI, I2 => INITL, I3 => NNL, I4 => LF1,
& I5 => LF2, I10 => ISTEP_LF
USE INIT_J_MOD
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP
&, I13 => I_EXT, I14 => I_TEST
USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO
&L
USE VALFIN_MOD
C
C
C
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
C
C
DATA PI,CONV/3.141593,0.512314/
C
@ -76,11 +76,11 @@ C
DO 40 JAT=1,NAT
IF(L.GT.LMX(JAT,JE)) GOTO 90
DO 50 M=-LMAX,LMAX
CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J
&AT,JE,*60)
CALL FACDIF1_A(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,
1 FSPH,JAT,JE,*60)
GOTO 70
60 WRITE(IUO1,80)
STOP
STOP
70 REFTH=REAL(FSPH)
XIMFTH=AIMAG(FSPH)
WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN
@ -94,12 +94,12 @@ C
10 CONTINUE
CLOSE(IUO3)
1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X,
&F8.2)
80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z
&ERO >>>>>')
100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : '
&,I2,' >>>>>')
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

286
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/treat_phd.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/treat_aed.f
View File

@ -1,33 +1,34 @@
C
C=======================================================================
C
SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
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 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 VALIN_MOD
USE VALFIN_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
C
CHARACTER*13 OUTDATA
CHARACTER*72 HEAD(N_HEAD,N_FILES)
C
REAL TAB(NDIM_M,4)
REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M)
C
C
C
DATA JVOL,JTOT/0,-1/
C
C
REWIND IUO2
C
C Reading and storing the headers:
@ -42,8 +43,8 @@ C
333 CONTINUE
C
READ(IUO2,15) SPECTRO,OUTDATA
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IPH_1
&,I_EXT
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
@ -61,12 +62,12 @@ C
FIX1=PHI1
N_SCAN=NTHETA
ELSE
N_FIXED=NTHETA
N_FIXED=NTHETA
FIX0=THETA0
FIX1=THETA1
IF(STEREO.EQ.'YES') THEN
NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
&+1
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
@ -96,7 +97,8 @@ C
C
DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
XINCRF=FLOAT(J_FIXED-1)*
1 (FIX1-FIX0)/FLOAT(N_FIXED-1)
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
@ -122,8 +124,10 @@ C
JPHI=J_SCAN
ENDIF
C
JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN + (JE-1)*N
&_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI
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
@ -139,19 +143,21 @@ C
IF(JPLAN.EQ.JPL) THEN
BACKSPACE IUO2
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
&),TAB(JLIN,1),TAB(JLIN,2)
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),ECIN(J
&E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
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),ECIN
&(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
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
@ -162,8 +168,8 @@ C
TAB(JL,3)=0.0
TAB(JL,4)=0.0
ENDDO
GOTO 10
ENDIF
GOTO 10
ENDIF
ENDDO
ENDDO
11 CONTINUE
@ -174,7 +180,7 @@ C
C
REWIND IUO2
C
C Skipping the NHEAD lines of headers before rewriting:
C Skipping the NHEAD lines of headers before rewriting:
C
DO JLINE=1,NHEAD
READ(IUO2,888) HEAD(JLINE,JFICH)
@ -228,8 +234,10 @@ C
ENDIF
C
DO JEMET=1,NEMET
JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (JE-1)*NTHE
&TA*NPHI +(JTHETA-1)*NPHI + JPHI
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
@ -246,7 +254,7 @@ C
SR2_2=SR2_2+TAB(JLIN2,3)
ENDIF
ENDIF
ENDDO
ENDDO
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
@ -257,18 +265,18 @@ C
JPHI2=JTHETA
ENDIF
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
&_1,SF_1
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),ECIN(JE),
&SR2_1,SF2_1
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),ECIN(JE),S
&R_1,SF_1,SR_2,SF_2
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),ECIN(JE)
&,SR2_1,SF2_1,SR2_2,SF2_2
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
@ -285,7 +293,7 @@ C
VOLDIF2_2=VOLDIF2_2+SF2_2
VOLDIR2_2=VOLDIR2_1+SR2_2
ENDIF
ENDIF
ENDIF
ENDIF
TOTDIF_1=TOTDIF_1+SF_1
TOTDIR_1=TOTDIR_1+SR_1
@ -303,41 +311,41 @@ C
ENDIF
ENDDO
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOLD
&IR_1,VOLDIF_1
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),VO
&LDIR2_1,VOLDIF2_1
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),TOTD
&IR_1,TOTDIF_1
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),TO
&TDIR2_1,TOTDIF2_1
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),VOL
&DIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
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),V
&OLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
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),TOT
&DIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
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),T
&OTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
C
ELSE
C
C........ ISOM not= 0 : multiple input files to be summed up ..........
C
READ(IUO2,7) NTHETA,NPHI,NE
READ(IUO2,7) NTHETA,NPHI,NE
C
IF(IPH_1.EQ.1) THEN
N_FIXED=NPHI
@ -345,12 +353,12 @@ C
FIX1=PHI1
N_SCAN=NTHETA
ELSE
N_FIXED=NTHETA
N_FIXED=NTHETA
FIX0=THETA0
FIX1=THETA1
IF(STEREO.EQ.'YES') THEN
NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
&+1
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
@ -370,7 +378,7 @@ C
N_SCAN=NPHI
IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
ENDIF
C
C
NTT=NFICHLEC*NDP
IF(NTT.GT.NDIM_M) GOTO 5
C
@ -385,7 +393,7 @@ C
C
DO JF=1,NF
C
C Reading the headers for each file:
C Reading the headers for each file:
C
IF(JF.GT.1) THEN
DO JLINE=1,NHEAD
@ -397,7 +405,8 @@ C
C
DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
XINCRF=FLOAT(J_FIXED-1)*
1 (FIX1-FIX0)/FLOAT(N_FIXED-1)
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
@ -423,8 +432,9 @@ C
JPHI=J_SCAN
ENDIF
C
JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI +
&JPHI
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
@ -440,21 +450,24 @@ C
IF(JF.EQ.JPL) THEN
BACKSPACE IUO2
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(
&JE),TAB(JLIN,1),TAB(JLIN,2)
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),ECIN
&(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
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),EC
&IN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
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
ELSE
BACKSPACE IUO2
DO JLINE=1,NHEAD
@ -466,23 +479,26 @@ C
TAB(JL,3)=0.0
TAB(JL,4)=0.0
ENDDO
GOTO 13
ENDIF
GOTO 13
ENDIF
ELSEIF(ISOM.EQ.2) THEN
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
&),TAB(JLIN,1),TAB(JLIN,2)
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),ECIN(J
&E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
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),ECIN
&(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
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
@ -551,8 +567,8 @@ C
DO JPLAN=1,NPLAN
JF=JPLAN
C
JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JP
&HI
JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +
1 (JTHETA-1)*NPHI + JPHI
C
SR_1=TAB(JLIN,1)
SF_1=TAB(JLIN,2)
@ -571,11 +587,11 @@ C
JPHI2=JTHETA
ENDIF
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
&SR_1,SF_1
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),ECIN(JE
&),SR2_1,SF2_1
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
SR_2=TAB(JLIN,3)
@ -585,11 +601,11 @@ C
SF2_2=TAB(JLIN2,4)
SR2_2=TAB(JLIN2,3)
ENDIF
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
&,SR_1,SF_1,SR_2,SF_2
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),ECIN(J
&E),SR2_1,SF2_1,SR2_2,SF2_2
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
@ -621,41 +637,43 @@ C
TOTDIF2_2=TOTDIF2_2+SF2_2
TOTDIR2_2=TOTDIR2_2+SR2_2
ENDIF
ENDIF
ENDIF
ENDDO
C
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO
&LDIR_1,VOLDIF_1
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),
&VOLDIR2_1,VOLDIF2_1
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),TO
&TDIR_1,TOTDIF_1
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),
&TOTDIR2_1,TOTDIF2_1
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),V
&OLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
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)
&,VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
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),T
&OTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
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)
&,TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
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
ELSEIF(ISOM.EQ.2) THEN
DO JE=1,NE
C
DO JTHETA=1,NTHETA
@ -683,8 +701,8 @@ C
DO JEMET=1,NEMET
JF=JEMET
C
JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + J
&PHI
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)
@ -702,7 +720,7 @@ C
SR2_2=SR2_2+TAB(JLIN2,3)
ENDIF
ENDIF
ENDDO
ENDDO
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
@ -713,18 +731,18 @@ C
JPHI2=JTHETA
ENDIF
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
&_1,SF_1
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),ECIN(JE
&),SR2_1,SF2_1
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),ECIN(JE),S
&R_1,SF_1,SR_2,SF_2
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),ECIN(J
&E),SR2_1,SF2_1,SR2_2,SF2_2
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1,SR2_2,SF2_2
ENDIF
ENDIF
ENDDO
@ -743,25 +761,29 @@ C
STOP
C
1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
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 ','IN
&THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>')
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,2X,E12.6,2X,E1
&2.6,2X,E12.6)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
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 ',
&'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<<
&SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE I
&NCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE AT
&LEAST ',I6,' >>>>>>>>>>')
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

0
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/weight_sum.f → src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/weight_sum.f
View File

11
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym.mk Normal file
View File

@ -0,0 +1,11 @@
memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/allocation.f
cluster_gen_src := $(wildcard cluster_gen/*.f)
common_sub_src := $(wildcard common_sub/*.f)
renormalization_src := $(wildcard renormalization/*.f)
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

998
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/aeddif_se_mu.f Normal file
View File

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

140
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/coumat_am.f Normal file
View File

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

88
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/dwsph_a.f Normal file
View File

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

115
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif1_a.f Normal file
View File

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

28
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif_a.f Normal file
View File

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

369
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths1_a.f Normal file
View File

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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths2_a.f Normal file
View File

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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths3_a.f Normal file
View File

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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths4_a.f Normal file
View File

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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths5_a.f Normal file
View File

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

21
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main.f Normal file
View File

@ -0,0 +1,21 @@
SUBROUTINE RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
& NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
& NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
& N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
USE DIM_MOD
IMPLICIT INTEGER (A-Z)
CF2PY INTEGER, INTENT(IN,COPY) :: NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_
CF2PY INTEGER, INTENT(IN,COPY) :: NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_
CF2PY INTEGER, INTENT(IN,COPY) :: NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_
CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_
CALL ALLOCATION(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
& NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
& NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
& N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
CALL MAIN_AED_MU_SE()
CALL CLOSE_ALL_FILES()
END SUBROUTINE RUN

1669
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main_aed_mu_se.f Normal file
View File

File diff suppressed because it is too large Load Diff

349
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/matdif_a.f Normal file
View File

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

551
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/pathop_a.f Normal file
View File

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

106
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/plotfd_a.f Normal file
View File

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

791
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/treat_aed.f Normal file
View File

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

335
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/weight_sum.f Normal file
View File

@ -0,0 +1,335 @@
C
C=======================================================================
C
SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL)
C
C This subroutine performs a weighted sum of the results
C corresponding to different directions of the detector.
C The directions and weights are read from an external input file
C
C JEL is the electron undetected (i.e. for which the outgoing
C directions are integrated over the unit sphere). It is always
C 1 for one electron spectroscopies (PHD). For APECS, It can be
C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron
C detected)
C
C Last modified : 31 Jan 2007
C
USE DIM_MOD
USE INFILES_MOD
USE INUNITS_MOD
USE OUTUNITS_MOD
C
C
PARAMETER(N_MAX=5810,NPM=20)
C
REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M)
REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX)
REAL*4 SR_1,SF_1,SR_2,SF_2
REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX)
REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX)
C
CHARACTER*3 SPECTRO,SPECTRO2
CHARACTER*5 LIKE
CHARACTER*13 OUTDATA
C
C
C
C
DATA JVOL,JTOT/0,-1/
DATA LIKE /'-like'/
C
REWIND IUO2
C
READ(IUO2,15) SPECTRO,OUTDATA
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
SPECTRO2='XAS'
ELSE
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I
&THETA_A,IE_A
READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
READ(IUO2,8) NPHI_A,NTHETA_A
IF(JEL.EQ.1) THEN
SPECTRO2='AED'
ELSEIF(JEL.EQ.2) THEN
SPECTRO2='PHD'
ELSEIF(JEL.EQ.0) THEN
SPECTRO2='XAS'
ENDIF
ENDIF
C
IF(NPLAN.GT.NPM) THEN
WRITE(IUO1,4) NPLAN+2
STOP
ENDIF
C
C Reading the number of angular points
C
IF(SPECTRO.NE.'APC') THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
N_POINTS_A=1
ELSE
IF(JEL.EQ.1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
IF(I_EXT_A.EQ.0) THEN
N_POINTS_A=NTHETA_A*NPHI_A
ELSE
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,1) N_POINTS_A
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
ENDIF
NTHETA0=NTHETA_A
NPHI0=NPHI_A
ELSEIF(JEL.EQ.2) THEN
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,1) N_POINTS_A
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
IF(I_EXT.EQ.0) THEN
N_POINTS=NTHETA*NPHI
ELSE
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
ENDIF
NTHETA0=NTHETA
NPHI0=NPHI
ELSEIF(JEL.EQ.0) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI9,1) N_POINTS_A
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
ENDIF
ENDIF
C
IF(SPECTRO.NE.'APC') THEN
NANGLE=1
ELSE
IF(JEL.EQ.1) THEN
NANGLE=N_POINTS_A
ELSEIF(JEL.EQ.2) THEN
NANGLE=N_POINTS
ELSEIF(JEL.EQ.0) THEN
NANGLE=1
ENDIF
ENDIF
C
C Initialization of the arrays
C
DO JE=1,NE
DO JANGLE=1,NANGLE
DO JPLAN=1,NPLAN+2
SUMR_1(JPLAN,JE,JANGLE)=0.
SUMF_1(JPLAN,JE,JANGLE)=0.
IF(IDICHR.GT.0) THEN
SUMR_2(JPLAN,JE,JANGLE)=0.
SUMF_2(JPLAN,JE,JANGLE)=0.
ENDIF
ENDDO
ENDDO
ENDDO
C
C Reading of the data to be angle integrated
C
DO JE=1,NE
C
DO JANGLE=1,N_POINTS
IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE)
DO JANGLE_A=1,N_POINTS_A
IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN
READ(IUI9,2) THA,PHA,W_A(JANGLE_A)
ENDIF
C
DO JPLAN=1,NPLAN+2
C
IF(IDICHR.EQ.0) THEN
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE)
&,SR_1,SF_1
ELSE
READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1
ENDIF
ELSE
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),SR_1,SF_1,SR_2,SF_2
ELSE
READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2
ENDIF
ENDIF
C
IF(JEL.EQ.1) THEN
SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1
&*W(JANGLE)
SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1
&*W(JANGLE)
ELSEIF(JEL.EQ.2) THEN
SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A
&(JANGLE_A)
SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A
&(JANGLE_A)
ELSEIF(JEL.EQ.0) THEN
SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A
&(JANGLE_A)
SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A
&(JANGLE_A)
ENDIF
IF(IDICHR.GT.0) THEN
IF(JEL.EQ.1) THEN
SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR
&_2*W(JANGLE)
SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF
&_2*W(JANGLE)
ELSEIF(JEL.EQ.2) THEN
SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W
&_A(JANGLE_A)
SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W
&_A(JANGLE_A)
ELSEIF(JEL.EQ.0) THEN
SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W
&_A(JANGLE_A)
SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W
&_A(JANGLE_A)
ENDIF
ENDIF
C
ENDDO
C
ENDDO
IF(I_EXT_A.NE.0) THEN
REWIND IUI9
READ(IUI9,1) NDUM
READ(IUI9,1) NDUM
ENDIF
ENDDO
C
IF(I_EXT.NE.0) THEN
REWIND IUI6
READ(IUI6,1) NDUM
READ(IUI6,1) NDUM
ENDIF
ENDDO
C
CLOSE(IUI6)
CLOSE(IUI9)
REWIND IUO2
C
WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP
WRITE(IUO2,18) NE,NPLAN,ISOM
ELSEIF(JEL.EQ.1) THEN
WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A
&,ITHETA_A,IE_A
WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
ELSEIF(JEL.EQ.2) THEN
WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
ENDIF
C
DO JE=1,NE
DO JANGLE=1,NANGLE
IF(SPECTRO.EQ.'APC') THEN
IF(JEL.EQ.1) THEN
THETA=DTHETAA(JANGLE)
PHI=DPHIA(JANGLE)
ELSEIF(JEL.EQ.2) THEN
THETA=DTHETA(JANGLE)
PHI=DPHI(JANGLE)
ENDIF
ENDIF
C
DO JPLAN=1,NPLAN
IF(IDICHR.EQ.0) THEN
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
&MF_1(JPLAN,JE,JANGLE)
ELSE
WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
&JANGLE),SUMF_1(JPLAN,JE,JANGLE)
ENDIF
ELSE
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
&MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG
&LE)
ELSE
WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
&JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL
&AN,JE,JANGLE)
ENDIF
ENDIF
ENDDO
C
IF(IDICHR.EQ.0) THEN
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
&F_1(NPLAN+1,JE,JANGLE)
WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
&F_1(NPLAN+2,JE,JANGLE)
ELSE
WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
&ANGLE),SUMF_1(NPLAN+1,JE,JANGLE)
WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
&ANGLE),SUMF_1(NPLAN+2,JE,JANGLE)
ENDIF
ELSE
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
&F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE
&,JANGLE)
WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
&F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE
&,JANGLE)
ELSE
WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
&ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(
&NPLAN+1,JE,JANGLE)
WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
&ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(
&NPLAN+2,JE,JANGLE)
ENDIF
ENDIF
C
ENDDO
ENDDO
C
1 FORMAT(13X,I4)
2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6)
3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
&THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>')
5 FORMAT(6X,I1,1X,I3,3X,I3)
8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
9 FORMAT(9(2X,I1),2X,I2)
13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
&12.6)
15 FORMAT(2X,A3,11X,A13)
16 FORMAT(2X,A3,A5,1X,A3,2X,A13)
18 FORMAT(I4,2X,I3,2X,I1)
19 FORMAT(4(2X,I1))
20 FORMAT(8(2X,I1))
21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
&12.6,2X,E12.6,2X,E12.6)
33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6)
34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
C
RETURN
C
END

4
src/msspec/spec/fortran/eig/common/eig_mat_ms.f
View File

@ -178,10 +178,6 @@ CKMD WRITE(IUO1,*) ' '
CKMD WRITE(IUO1,*) ' ---> WORK(1),INFO =',WORK(1),INFO
CKMD WRITE(IUO1,*) ' '
CKMD ENDIF
C
CKMD Save eigenvalues to unformatted stream file eigenvalues.dat
C
call save_eigenvalues(w, jlin, e_kin)
C
N_EIG=0
C

37
src/msspec/spec/fortran/eig/common/save_eigenvalues.f
View File

@ -1,37 +0,0 @@
c
c=======================================================================
c
subroutine save_eigenvalues (evalues, n, ke)
c
implicit none
c
integer, intent(in) :: n
real, intent(in) :: ke
complex*16, intent(in) :: evalues(n)
c
c Local variables
c
integer :: io
logical :: exists
c
c
inquire(file='eigenvalues.dat', exist=exists)
c
if (exists) then
open(newunit=io, file='eigenvalues.dat', status='old',
+ form='unformatted', access='stream', action='write',
+ position='append')
else
open(newunit=io, file='eigenvalues.dat', status='new',
+ form='unformatted', access='stream', action='write')
end if
c
write(io) ke, n, evalues(1:n)
c
close(io)
c
return
end subroutine save_eigenvalues
c
c=======================================================================
c

3
src/msspec/spec/fortran/eig_mi.mk
View File

@ -2,8 +2,7 @@ memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/all
cluster_gen_src := $(wildcard cluster_gen/*.f)
common_sub_src := $(wildcard common_sub/*.f)
renormalization_src := $(wildcard renormalization/*.f)
#eig_common_src := $(wildcard eig/common/*.f)
eig_common_src := $(filter-out eig/common/lapack_eig.f, $(wildcard eig/common/*.f))
eig_common_src := $(wildcard eig/common/*.f)
eig_mi_src := $(wildcard eig/mi/*.f)
SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(eig_common_src) $(eig_mi_src)

6
src/msspec/spec/fortran/memalloc/allocation.f
View File

@ -25,9 +25,6 @@
USE OUTUNITS_MOD
USE PARCAL_MOD
USE PARCAL_A_MOD
USE CORREXP_MOD
USE GAUNT_C_MOD
USE Q_ARRAY_MOD
USE RELADS_MOD
USE RELAX_MOD
USE RESEAU_MOD
@ -139,7 +136,6 @@
CALL ALLOC_OUTUNITS()
CALL ALLOC_PARCAL()
CALL ALLOC_PARCAL_A()
CALL ALLOC_Q_ARRAY()
CALL ALLOC_RELADS()
CALL ALLOC_RELAX()
CALL ALLOC_RENORM()
@ -177,7 +173,6 @@
CALL ALLOC_C_G()
CALL ALLOC_C_G_A()
CALL ALLOC_C_G_M()
CALL ALLOC_CORREXP()
CALL ALLOC_DEXPFAC2()
CALL ALLOC_DFACTSQ()
CALL ALLOC_EIGEN()
@ -191,7 +186,6 @@
CALL ALLOC_SPECTRUM()
CALL ALLOC_DIRECT()
CALL ALLOC_DIRECT_A()
CALL ALLOC_GAUNT_C()
CALL ALLOC_PATH()
CALL ALLOC_ROT()
CALL ALLOC_ROT_CUB()

4
src/msspec/spec/fortran/memalloc/dim_mod.f
View File

@ -34,7 +34,6 @@ C ===============================================================
INTEGER NCG_M
INTEGER N_BESS, N_GAUNT
INTEGER NLTWO
INTEGER NLMM
C ===============================================================
CONTAINS
SUBROUTINE INIT_DIM()
@ -61,10 +60,9 @@ C ===============================================================
C N_BESS=100*NL_M
C N_GAUNT=5*NL_M
N_BESS=300*NL_M
N_BESS=200*NL_M
N_GAUNT=10*NL_M
NLTWO=2*NL_M
NLMM=LINMAX*NGR_M
END SUBROUTINE INIT_DIM
END MODULE DIM_MOD

42
src/msspec/spec/fortran/memalloc/modules.f
View File

@ -192,20 +192,6 @@ C=======================================================================
END SUBROUTINE ALLOC_COOR
END MODULE COOR_MOD
C=======================================================================
MODULE CORREXP_MOD
IMPLICIT NONE
COMPLEX*16, ALLOCATABLE, DIMENSION(:,:) :: A
CONTAINS
SUBROUTINE ALLOC_CORREXP()
USE DIM_MOD
IF (ALLOCATED(A)) THEN
DEALLOCATE(A)
ENDIF
ALLOCATE(A(NLMM,NLMM))
END SUBROUTINE ALLOC_CORREXP
END MODULE CORREXP_MOD
C=======================================================================
MODULE DEBWAL_MOD
IMPLICIT NONE
@ -431,20 +417,6 @@ C=======================================================================
END SUBROUTINE ALLOC_PARCAL_A
END MODULE PARCAL_A_MOD
C=======================================================================
MODULE Q_ARRAY_MOD
IMPLICIT NONE
REAL, ALLOCATABLE, DIMENSION(:) :: Q
CONTAINS
SUBROUTINE ALLOC_Q_ARRAY()
USE DIM_MOD
IF (ALLOCATED(Q)) THEN
DEALLOCATE(Q)
ENDIF
ALLOCATE(Q(NGR_M))
END SUBROUTINE ALLOC_Q_ARRAY
END MODULE Q_ARRAY_MOD
C=======================================================================
MODULE RELADS_MOD
IMPLICIT NONE
@ -806,20 +778,6 @@ C=======================================================================
END SUBROUTINE ALLOC_DEXPFAC
END MODULE DEXPFAC_MOD
C=======================================================================
MODULE GAUNT_C_MOD
IMPLICIT NONE
REAL*8, ALLOCATABLE, DIMENSION(:,:,:) :: GNT
CONTAINS
SUBROUTINE ALLOC_GAUNT_C()
USE DIM_MOD
IF (ALLOCATED(GNT)) THEN
DEALLOCATE(GNT)
ENDIF
ALLOCATE(GNT(0:N_GAUNT,LINMAX,LINMAX))
END SUBROUTINE ALLOC_GAUNT_C
END MODULE GAUNT_C_MOD
C=======================================================================
MODULE LOGAMAD_MOD
IMPLICIT NONE

11
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym.mk
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)
phd_ce_noso_nosp_nosym_src := $(filter-out phd_ce_noso_nosp_nosym/lapack_axb.f, $(wildcard phd_ce_noso_nosp_nosym/*.f))
SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(phd_ce_noso_nosp_nosym_src)
MAIN_F = phd_ce_noso_nosp_nosym/main.f
SO = _phd_ce_noso_nosp_nosym.so
include ../../../options.mk

41
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/cmngr.f
View File

@ -1,41 +0,0 @@
C
C======================================================================
C
SUBROUTINE CMNGR(NAT,NGR,CMN)
C
C input : NAT,NGR
C output : CMN
C
C This subroutine calculate C(NAT-N,M-N) where,
C 1<=M<=NGR<=NAT,1<=N<=M
C C(NAT-N,M-N) is stored as CMN(N,M)
C
C H.-F. Zhao 2007
C
USE DIM_MOD
C
INTEGER NAT,NGR
C
REAL CMN(NGR_M,NGR_M)
C
IF(NGR.GT.NAT) THEN
WRITE(6,*) 'NGR is larger than NAT, which is wrong'
STOP
ENDIF
C
DO M=1,NGR
DO N=1,NGR
CMN(N,M)=0.
ENDDO
CMN(M,M)=1.
ENDDO
C
DO M=1,NGR
DO N=M-1,1,-1
CMN(N,M)=CMN(N+1,M)*FLOAT(NAT-N)/FLOAT(M-N)
ENDDO
ENDDO
C
RETURN
C
END

46
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coefpq.f
View File

@ -1,46 +0,0 @@
C
C======================================================================
C
SUBROUTINE COEFPQ(NAT,NGR)
C
C This subroutine computes the P(n,m) and Q(n) coefficients
C involved in the correlation expansion formulation
C
C Reference : equations (2.15) and (2.16) of
C H. Zhao, D. Sebilleau and Z. Wu,
C J. Phys.: Condens. Matter 20, 275241 (2008)
C
C H.-F. Zhao 2007
C
USE DIM_MOD
USE Q_ARRAY_MOD
C
INTEGER NAT,NGR
C
REAL CMN(NGR_M,NGR_M),P(NGR_M,NGR_M)
C
C
IF(NGR.GT.NAT) THEN
WRITE(6,*) 'NGR is larger than NAT, which is wrong'
STOP
ENDIF
C
CALL CMNGR(NAT,NGR,CMN)
C
DO N=1,NGR
P(N,N)=1.
Q(N)=P(N,N)
DO M=N+1,NGR
P(N,M)=0.
DO I=N,M-1
P(N,M)=P(N,M)-P(N,I)*CMN(I,M)
ENDDO
Q(N)=Q(N)+P(N,M)
C
ENDDO
C
ENDDO
C
RETURN
C
END

47
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp.f
View File

@ -1,47 +0,0 @@
C
C======================================================================
C
SUBROUTINE COREXP_SAVM(JE,IGR,NGR,NLM,ITYPE,IGS,TAU)
C
C This subroutine call the correlation matrices calculations
C for a given order IGR
C
C H.-F. Zhao : 2007
C
USE DIM_MOD
USE COOR_MOD
USE Q_ARRAY_MOD
USE TRANS_MOD
C
INTEGER NLM(NGR_M),ITYPE(NGR_M),IGS(NGR_M)
C
REAL QI
C
COMPLEX*16 TAU(LINMAX,LINFMAX,NATCLU_M)
C
C
DO ITYP=1,N_PROT
NBTYP=NATYP(ITYP)
NLM(IGR)=LMAX(ITYP,JE)
ITYPE(IGR)=ITYP
DO NUM=1,NBTYP
IGS(IGR)=NCORR(NUM,ITYP)
C
IF(IGS(IGR).GT.IGS(IGR-1)) THEN
QI=Q(IGR)
CALL MPIS(IGR,NLM,ITYPE,IGS,JE,QI,TAU)
C
IGR=IGR+1
IF(IGR.LE.NGR) THEN
CALL COREXP_SAVM1(JE,IGR,NGR,NLM,ITYPE,IGS,TAU)
ENDIF
IGR=IGR-1
C
ENDIF
C
ENDDO
ENDDO
C
RETURN
C
END

19
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/corexp1.f
View File

@ -1,19 +0,0 @@
C
C======================================================================
C
SUBROUTINE COREXP_SAVM1(JE,IGR,NGR,NLM,ITYPE,IGS,TAU)
C
C This subroutine allows a recursive use of COREXP_SAVM
C
C H.-F. Zhao : 2007
C
USE DIM_MOD
C
INTEGER NLM(NGR_M),ITYPE(NGR_M),IGS(NGR_M)
COMPLEX*16 TAU(LINMAX,LINFMAX,NATCLU_M)
C
CALL COREXP_SAVM(JE,IGR,NGR,NLM,ITYPE,IGS,TAU)
C
RETURN
C
END

121
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/coumat.f
View File

@ -1,121 +0,0 @@
C
C=======================================================================
C
SUBROUTINE COUMAT(ITL,MI,LF,MF,DELTA,RADIAL,MATRIX)
C
C This routine calculates the spin-independent PhD optical matrix
C elements for dipolar excitations. It is stored in
C MATRIX(JDIR,JPOL)
C
C Here, the conventions are :
C
C IPOL=1 : linearly polarized light
C IPOL=2 : circularly polarized light
C
C JPOL=1 : +/x polarization for circular/linear light
C JPOL=2 : -/y polarization for circular/linear light
C
C When IDICHR=0, JDIR = 1,2 and 3 correspond respectively to the x,y
C and z directions for the linear polarization. But for IDICHR=1,
C these basis directions are those of the position of the light.
C
C Last modified : 8 Dec 2008
C
USE DIM_MOD
C
USE INIT_L_MOD , L2 => NNL, L3 => LF1, L4 => LF2, L5 => ISTEP_LF
USE SPIN_MOD , I1 => ISPIN, N1 => NSPIN, N2 => NSPIN2, I2 => ISFLI
&P, I8 => IR_DIA, N3 => NSTEP
USE TYPCAL_MOD , I3 => IPHI, I4 => IE, I5 => ITHETA, I6 => IFTHET,
& I7 => IMOD, I9 => I_CP, I10 => I_EXT
C
COMPLEX MATRIX(3,2),SUM_1,SUM_2,DELTA,YLM(3,-1:1),RADIAL
COMPLEX ONEC,IC,IL,COEF,PROD
C
REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1),GNT(0:N_GAUNT)
REAL THETA(3),PHI(3)
C
DATA PI4S3,C_LIN,SQR2 /4.188790,1.447202,1.414214/
DATA PIS2 /1.570796/
C
ONEC=(1.,0.)
IC=(0.,1.)
C
IF(INITL.EQ.0) GOTO 2
C
M=MF-MI
C
IF(MOD(LF,4).EQ.0) THEN
IL=ONEC
ELSEIF(MOD(LF,4).EQ.1) THEN
IL=IC
ELSEIF(MOD(LF,4).EQ.2) THEN
IL=-ONEC
ELSEIF(MOD(LF,4).EQ.3) THEN
IL=-IC
ENDIF
C
CALL GAUNT(LI,MI,LF,MF,GNT)
C
IF(ITL.EQ.0) THEN
c COEF=CEXP(IC*DELTA)*CONJG(IL)
COEF=CEXP(IC*DELTA)*IL
ELSE
IF(IDICHR.EQ.0) THEN
c COEF=PI4S3*CONJG(IL)
COEF=PI4S3*IL
ELSE
c COEF=C_LIN*CONJG(IL)
COEF=C_LIN*IL
ENDIF
ENDIF
C
PROD=COEF*RADIAL*GNT(1)
C
IF(IDICHR.EQ.0) THEN
YLM(1,-1)=(0.345494,0.)
YLM(1,0)=(0.,0.)
YLM(1,1)=(-0.345494,0.)
YLM(2,-1)=(0.,-0.345494)
YLM(2,0)=(0.,0.)
YLM(2,1)=(0.,-0.345494)
YLM(3,-1)=(0.,0.)
YLM(3,0)=(0.488602,0.)
YLM(3,1)=(0.,0.)
C
DO JDIR=1,3
MATRIX(JDIR,1)=PROD*CONJG(YLM(JDIR,M))
ENDDO
C
ELSEIF(IDICHR.GE.1) THEN
C
THETA(1)=PIS2
PHI(1)=0.
THETA(2)=PIS2
PHI(2)=PIS2
THETA(3)=0.
PHI(3)=0.
C
DO JDIR=1,3
CALL DJMN(THETA(JDIR),RLM,1)
SUM_1=RLM(-1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
SUM_2=RLM(1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
IF(IPOL.EQ.2) THEN
MATRIX(JDIR,1)=SQR2*SUM_1
MATRIX(JDIR,2)=SQR2*SUM_2
ELSEIF(ABS(IPOL).EQ.1) THEN
MATRIX(JDIR,1)=(SUM_2-SUM_1)
MATRIX(JDIR,2)=(SUM_2+SUM_1)*IC
ENDIF
ENDDO
ENDIF
GOTO 1
C
2 DO JDIR=1,3
MATRIX(JDIR,1)=ONEC
MATRIX(JDIR,2)=ONEC
ENDDO
C
1 RETURN
C
END

26
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/facdif.f
View File

@ -1,26 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FACDIF(COSTH,JAT,JE,FTHETA)
C
C This routine computes the plane wave scattering factor
C
USE DIM_MOD
C
USE TRANS_MOD
C
DIMENSION PL(0:100)
C
COMPLEX FTHETA
C
FTHETA=(0.,0.)
NL=LMAX(JAT,JE)+1
CALL POLLEG(NL,COSTH,PL)
DO 20 L=0,NL-1
FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L)
20 CONTINUE
FTHETA=FTHETA/VK(JE)
C
RETURN
C
END

126
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/gaunt_st.f
View File

@ -1,126 +0,0 @@
C
C=======================================================================
C
SUBROUTINE GAUNT_ST(LMAX_T)
C
C This subroutine calculates the Gaunt coefficient G(L2,L3|L1)
C using a downward recursion scheme due to Schulten and Gordon
C for the Wigner's 3j symbols. The result is stored as GNT(L3),
C making use of the selection rule M3 = M1 - M2.
C
C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
C
C This is the double precision version where the values are stored
C
C Last modified : 14 May 2009
C
C
USE DIM_MOD
USE LOGAMAD_MOD
USE GAUNT_C_MOD
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
INTEGER LMAX_T
C
REAL*8 F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT),A1(0:N_GAUNT)
REAL*8 B(0:N_GAUNT)
C
DATA PI4/12.566370614359D0/
C
DO L1=0,LMAX_T
IL1=L1*L1+L1+1
DO M1=-L1,L1
IND1=IL1+M1
LM1=L1+M1
KM1=L1-M1
DO L2=0,LMAX_T
IL2=L2*L2+L2+1
C
IF(MOD(M1,2).EQ.0) THEN
COEF=DSQRT(DFLOAT((L1+L1+1)*(L2+L2+1))/PI4)
ELSE
COEF=-DSQRT(DFLOAT((L1+L1+1)*(L2+L2+1))/PI4)
ENDIF
C
L12=L1+L2
K12=L1-L2
L12_1=L12+L12+1
L12_2=L12*L12
L12_21=L12*L12+L12+L12+1
K12_2=K12*K12
C
F(L12+1)=0.D0
G(L12+1)=0.D0
A(L12+1)=0.D0
A1(L12+1)=0.D0
A1(L12)=2.D0*DSQRT(DFLOAT(L1*L2*L12_1*L12_2))
D1=GLD(L2+L2+1,1)-GLD(L12_1+1,1)
D5=0.5D0*(GLD(L1+L1+1,1)+GLD(L2+L2+1,1)-GLD(L12_1+1,1))
D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1)
C
IF(MOD(K12,2).EQ.0) THEN
G(L12)=DEXP(D5+D6)
ELSE
G(L12)=-DEXP(D5+D6)
ENDIF
C
DO M2=-L2,L2
IND2=IL2+M2
C
M3=M1-M2
LM2=L2+M2
KM2=L2-M2
C
DO J=1,N_GAUNT
GNT(J,IND2,IND1)=0.D0
ENDDO
C
IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10
C
D2=GLD(L1+L1+1,1)-GLD(LM2+1,1)
D3=GLD(L12+M3+1,1)-GLD(KM2+1,1)
D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
C
IF(MOD(KM1-KM2,2).EQ.0) THEN
F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
ELSE
F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
ENDIF
C
A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*L12_1*(L12_2-M3*M3)))
B(L12)=-DFLOAT(L12_1*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)
1 *(M2+M1)))
C
IF(ABS(M3).LE.L12) THEN
GNT(L12,IND2,IND1)=COEF*F(L12)*G(L12)*
1 DSQRT(DFLOAT(L12_1))
ENDIF
C
JMIN=MAX0(ABS(K12),ABS(M3))
C
DO J=L12-1,JMIN,-1
J1=J+1
J2=J+2
JJ=J*J
A1(J)=DSQRT(DFLOAT(JJ*(JJ-K12_2)*(L12_21-JJ)))
A(J)=DSQRT(DFLOAT((JJ-K12_2)*(L12_21-JJ)*(JJ-M3*M3)))
B(J)=-DFLOAT((J+J1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*
1 (M2+M1)))
F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*
1 A(J1))
G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1))
C
IF(ABS(M3).LE.J) THEN
GNT(J,IND2,IND1)=COEF*F(J)*G(J)*DSQRT(DFLOAT(J+J1))
ENDIF
ENDDO
C
ENDDO
ENDDO
ENDDO
ENDDO
C
10 RETURN
C
END

280
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/mpis.f
View File

@ -1,280 +0,0 @@
C
C
C======================================================================
C
SUBROUTINE MPIS(N,NLM,ITYP,IGS,JE,QI,TAU)
C
C
C This subroutine construct the correlation matrices and uses
C LU decomposition method to do the matrix inversion.
C The inverse matrix which is the contribution of a small atom group
C is kept for further use.
C
C H. -F. Zhao : 2007
C
C Last modified (DS) : 13 May 2009
C
USE DIM_MOD
USE COOR_MOD
USE INIT_L_MOD
USE GAUNT_C_MOD
USE TRANS_MOD
USE CORREXP_MOD
C
INTEGER NLM(NGR_M),ITYP(NGR_M),IGS(NGR_M)
COMPLEX*16 TAU(LINMAX,LINFMAX,NATCLU_M)
C
REAL QI
C
COMPLEX*16 ZEROC,ONEC,IC
C
COMPLEX*16 ATTL(0:NT_M,NATM)
COMPLEX*16 EXPJN,ATTJN
COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO)
COMPLEX*16 HL1(0:NLTWO)
COMPLEX*16 SUM_L,SUM_L2
COMPLEX*16 SUM_L_A,SUM_L2_A,SUM_L_B,SUM_L2_B
C
REAL*8 FOURPI
REAL*8 XJN,YJN,ZJN,RJN,KRJN,ZDJN
REAL*8 IM_VK,RE_VK
C
INTEGER IPIV(NLMM),ONE_L,IN1
C
COMPLEX*16 FOURPI_IC,IC_L,IC_REF,TEMP,TEMP1,TEMP2,CN1
COMPLEX*16 AINV(NLMM,NLMM),IN(NLMM,LINFMAX)
C
DATA FOURPI /12.566370614359D0/
C
ZEROC=(0.D0,0.D0)
ONEC=(1.D0,0.D0)
IC=(0.D0,1.D0)
IBESS=3
FOURPI_IC=-IC*FOURPI
C
LM0=LMAX(1,JE)
LM0=MIN(LM0,LF2)
NRHS=(LM0+1)*(LM0+1)
INDJ=0
C
NM=0
DO I=1,N-1
J=NLM(I)+1
NM=NM+J*J
ENDDO
L=NLM(N)
LNMAX=L
L=(L+1)*(L+1)
NM1=NM+1
NML=NM+L
NTYP=ITYP(N)
C
DO L=0,LNMAX
ATTL(L,N)=DCMPLX(TL(L,1,NTYP,JE))
ENDDO
IM_VK=-DIMAG(DCMPLX(VK(JE)))
RE_VK=DBLE(VK(JE))
C
C set up matrix blocks C((N-1)*1) and D(1*(N-1))
C
I=IGS(N)
XN=SYM_AT(1,I)
YN=SYM_AT(2,I)
ZN=SYM_AT(3,I)
C
DO J=1,N-1
JATL=IGS(J)
LJMAX=NLM(J)
JTYP=ITYP(J)
J1=J-1
C
XJN=DBLE(SYM_AT(1,JATL)-XN)
YJN=DBLE(SYM_AT(2,JATL)-YN)
ZJN=DBLE(SYM_AT(3,JATL)-ZN)
RJN=DSQRT(XJN*XJN+YJN*YJN+ZJN*ZJN)
KRJN=RE_VK*RJN
ATTJN=FOURPI_IC*DEXP(IM_VK*RJN)
EXPJN=(XJN+IC*YJN)/RJN
ZDJN=ZJN/RJN
CALL SPH_HAR2(2*NL_M,ZDJN,EXPJN,YLM,LNMAX+LJMAX)
CALL BESPHE2(LNMAX+LJMAX+1,IBESS,KRJN,HL1)
DO L=0,LJMAX
ATTL(L,J)=ATTJN*DCMPLX(TL(L,1,JTYP,JE))
ENDDO
C
II=NM
IN1=-1
CN1=IC
JJ=0
C
DO LN=0,LNMAX
ILN=LN*LN+LN+1
IN1=-IN1
CN1=-CN1*IC
C
DO MLN=-LN,LN
INDN=ILN+MLN
II=II+1
JJ0=J1*INDJ
ONE_L=-IN1
IC_REF=-CN1*IC
C
DO LJ=0,LJMAX
ILJ=LJ*LJ+LJ+1
L_MIN=ABS(LJ-LN)
L_MAX=LJ+LN
ONE_L=-ONE_L
IC_REF=IC_REF*IC
C
C Case MLJ equal to zero
C
JJ1=JJ0+ILJ
IF(LJ.GE.LN) THEN
IC_L=-IC_REF
ELSE
IC_L=-ONEC/IC_REF
ENDIF
C
SUM_L=ZEROC
SUM_L2=ZEROC
C
DO L=L_MIN,L_MAX,2
IC_L=-IC_L
IF(ABS(MLN).LE.L) THEN
TEMP=IC_L*HL1(L)*GNT(L,ILJ,INDN)
SUM_L=SUM_L+YLM(L,MLN)*TEMP
SUM_L2=SUM_L2+DCONJG(YLM(L,MLN))*TEMP
ENDIF
ENDDO
C
IF(ONE_L.EQ.-1) SUM_L2=-SUM_L2
A(JJ1,II)=ATTL(LJ,J)*SUM_L
A(II,JJ1)=ATTJN*ATTL(LN,N)*SUM_L2
C
C
C Case MLJ not equal to zero
C
DO MLJ=1,LJ
INDJ=ILJ+MLJ
INDJN=ILJ-MLJ
JJ1=JJ0+INDJ
JJ1N=JJ0+INDJN
MA=MLN-MLJ
MB=MLN+MLJ
IF(LJ.GE.LN) THEN
IC_L=-IC_REF
ELSE
IC_L=-ONEC/IC_REF
ENDIF
C
SUM_L_A=ZEROC
SUM_L2_A=ZEROC
SUM_L_B=ZEROC
SUM_L2_B=ZEROC
C
DO L=L_MIN,L_MAX,2
IC_L=-IC_L
IF(ABS(MA).LE.L) THEN
TEMP1=IC_L*HL1(L)*GNT(L,INDJ,INDN)
SUM_L_A=SUM_L_A+YLM(L,MA)*TEMP1
SUM_L2_A=SUM_L2_A+DCONJG(YLM(L,MA))*TEMP1
ENDIF
IF(ABS(MB).LE.L) THEN
TEMP2=IC_L*HL1(L)*GNT(L,INDJN,INDN)
SUM_L_B=SUM_L_B+YLM(L,MB)*TEMP2
SUM_L2_B=SUM_L2_B+DCONJG(YLM(L,MB))*TEMP2
ENDIF
ENDDO
C
IF(ONE_L.EQ.-1) THEN
SUM_L2_A=-SUM_L2_A
SUM_L2_B=-SUM_L2_B
ENDIF
A(JJ1,II)=ATTL(LJ,J)*SUM_L_A
A(II,JJ1)=ATTJN*ATTL(LN,N)*SUM_L2_A
A(JJ1N,II)=ATTL(LJ,J)*SUM_L_B
A(II,JJ1N)=ATTJN*ATTL(LN,N)*SUM_L2_B
ENDDO
C
C
ENDDO
JJ=JJ0+INDJ
C
ENDDO
ENDDO
C
JJ=JJ-INDN
C
ENDDO
C
C add B to A
C
DO I=NM1,NML
DO J=NM1,NML
IF(J.EQ.I) THEN
A(J,I)=ONEC
ELSE
A(J,I)=ZEROC
ENDIF
ENDDO
ENDDO
C
C construct AINV
C
DO I=1,NML
DO J=1,NML
AINV(J,I)=A(J,I)
ENDDO
ENDDO
C
C
C matrix inversion(ax=b)
C
CALL ZGETRF(NML,NML,AINV,NLMM,IPIV,INFO1)
IF(INFO1.NE.0) THEN
WRITE(6,*) ' ---> INFO1 =',INFO1
ELSE
C
DO I=1,NRHS
DO J=1,NML
IF(J.EQ.I) THEN
IN(J,I)=(1.D0,0.D0)
ELSE
IN(J,I)=(0.D0,0.D0)
ENDIF
ENDDO
ENDDO
C
CALL ZGETRS('N',NML,NRHS,AINV,NLMM,IPIV,IN,NLMM,INFO)
IF(INFO.NE.0) THEN
WRITE(6,*) ' ---> INFO =',INFO
ENDIF
ENDIF
C
C sum of tau
C
KLIN=0
DO K=1,N
KATL=IGS(K)
LMK=NLM(K)
INDKM=(LMK+1)*(LMK+1)
C
DO INDJ=1,NRHS
C
DO INDK=1,INDKM
KLIN=KLIN+1
C
TAU(INDK,INDJ,KATL)=TAU(INDK,INDJ,KATL)
1 +DBLE(QI)*IN(KLIN,INDJ)
C
ENDDO
KLIN=KLIN-INDKM
C
ENDDO
KLIN=KLIN+INDKM
C
ENDDO
C
RETURN
C
END

165
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/ms_cor.f
View File

@ -1,165 +0,0 @@
C
C
C======================================================================
C
SUBROUTINE MS_COR(JE,TAU)
C
C
C This subroutine calculates the scattering path operator by
C the correlation expansion method.
C
C The scattering path operator matrix of each small atom group
C is obtained by using LU decomposition method.
C
C The running time of matrix inversion subroutine used in this program
C scales with N^3, the memory occupied scales with N^2. We advise user to
C use full MS method to get the scattering path operator, i.e. directly
C with matrix inversion method if NGR is larger than 3. If NGR is less
C than 4 (i.e <=3) this subroutine will gain time.
C
C This subroutine never gain memory comparing to the subrourine INV_MAT_MS
C as I use three large matrices stored in common, each matrix is larger or
C as large as the matrix used in INV_MAT_MS.
C
C As I don't find a good way to solve the group problem, where all the contribution
C of group IGR<=NGR are collected and each small contribution has to be stored
C for the further larger-atom-group contribution, it's better that users change the
C parameter NGR_M which is set in included file 'spec.inc' to be NGR or NGR+1
C where NGR is the cut-off.user insterested. this subrouitne works for NGR is less
C than 6(<=5), if users want to calculate larger NGR, they should modify the code here
C to make them workable, the code is marked by 'C' in each lines (about 300 lines
C below here), users just release them until to the desired cut-off, the maximum is
C 9, however, users can enlarge it if they want to. Warning ! NGR_M set in
C included file should be larger than NGR and the figure listed below, don't forget
C to compile the code after modification.
C
C Users can modify the code to make it less memory-occupied, however, no matter they
C do, the memories that used are more than full MS method used, so the only advantage
C that this code has is to gain time when NGR<=3, with command 'common' used here,
C the code will run faster.
C
C H.-F. Zhao : 2007
C
C (Photoelectron case)
C
C Last modified : 31 Jan 2008
C
C
C
USE DIM_MOD
USE COOR_MOD
USE INIT_L_MOD
USE TRANS_MOD
USE APPROX_MOD
USE CORREXP_MOD
USE Q_ARRAY_MOD
C
COMPLEX*16 TAU1(LINMAX,LINFMAX,NATCLU_M),ONEC,ZEROC
C
INTEGER NLM(NGR_M),ITYP(NGR_M),IGS(NGR_M)
C
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M),TLJ
C
C
ONEC=(1.D0,0.D0)
ZEROC=(0.D0,0.D0)
C
LM0=LMAX(1,JE)
LM0=MIN(LM0,LF2)
NRHS=(LM0+1)*(LM0+1)
C
NGR_MAX=NGR_M
NGR=NDIF
C
IF(NGR_M.GT.NATCLU) THEN
WRITE(6,*) ' ---> NGR_M should be smaller than NATCLU'
WRITE(6,*) ' ---> it is reduced to NATCLU=',NATCLU
NGR_MAX=NATCLU
ENDIF
C
IF(NGR.LT.1) THEN
WRITE(6,*) ' ---> NGR < 1, no expansion is done'
STOP
ELSE
IF(NGR.GT.NGR_MAX) THEN
WRITE(6,*) ' ---> NGR is too large, reduce to NGR_M=',
& NGR_MAX
NGR=NGR_MAX
ENDIF
ENDIF
C
C Case NGR = 1
C
IF(NGR.EQ.1) THEN
DO LJ=0,LM0
ILJ=LJ*LJ+LJ+1
TLJ=TL(LJ,1,1,JE)
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDJ,1)=TLJ
ENDDO
ENDDO
C
GOTO 100
ENDIF
C
C NGR >=2 case
C
C
DO INDJ=1,NRHS
TAU1(INDJ,INDJ,1)=DBLE(Q(1))*ONEC
ENDDO
C
C Constructs the group matrix and inverses it
C
IGR=1
LMJ=LMAX(1,JE)
NLM(IGR)=LMJ
INDJM=(LMJ+1)*(LMJ+1)
ITYP(IGR)=1
IGS(IGR)=1
C
DO I=1,INDJM
DO J=1,INDJM
IF (J.EQ.I) THEN
A(J,I)=ONEC
ELSE
A(J,I)=ZEROC
ENDIF
ENDDO
ENDDO
C
IGR=IGR+1
CALL COREXP_SAVM(JE,IGR,NGR,NLM,ITYP,IGS,TAU1)
IGR=IGR-1
C
C TAU=TAU*tj
C
DO KTYP=1,N_PROT
NBTYPK=NATYP(KTYP)
LMK=LMAX(KTYP,JE)
INDKM=(LMK+1)*(LMK+1)
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
C
DO LJ=0,LM0
ILJ=LJ*LJ+LJ+1
TLJ=TL(LJ,1,1,JE)
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
C
DO INDK=1,INDKM
TAU(INDK,INDJ,KATL)=CMPLX(TAU1(INDK,INDJ,KATL))*TLJ
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
100 CONTINUE
C
RETURN
C
END

1136
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/phddif_ce.f
View File

File diff suppressed because it is too large Load Diff

2
src/msspec/spec/fortran/phd_mi_noso_nosp_nosym.mk
View File

@ -2,7 +2,7 @@ memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/all
cluster_gen_src := $(wildcard cluster_gen/*.f)
common_sub_src := $(wildcard common_sub/*.f)
renormalization_src := $(wildcard renormalization/*.f)
phd_mi_noso_nosp_nosym_src := $(filter-out phd_mi_noso_nosp_nosym/lapack_axb.f, $(wildcard phd_mi_noso_nosp_nosym/*.f))
phd_mi_noso_nosp_nosym_src := $(wildcard phd_mi_noso_nosp_nosym/*.f)
SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(phd_mi_noso_nosp_nosym_src)
MAIN_F = phd_mi_noso_nosp_nosym/main.f

2
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f
View File

@ -115,7 +115,7 @@ C Renormalization of the path
C
IF(I_REN.GE.1) THEN
COEF=COEF*C_REN(JORDP)
C write(354,*) JORDP,C_REN(JORDP)
write(354,*) JORDP,C_REN(JORDP)
ENDIF
C
C Call of the subroutines used for the R-A termination matrix

159
src/msspec/utils.py
View File

@ -19,8 +19,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/utils.py
# Last modified: Wed, 26 Feb 2025 11:15:03 +0100
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes.fr>
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
"""
@ -39,11 +39,7 @@ 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.iodata import Data
from msspec.misc import LOGGER
@ -315,13 +311,34 @@ def cut_cylinder(atoms, axis="z", radius=None):
:return: The modified atom cluster
:rtype: ase.Atoms
"""
if axis not in ('z',):
raise ValueError("axis value != 'z' is not supported yet.")
X, Y, Z = atoms.positions.T
R = np.sqrt(X**2 + Y **2)
T = np.arctan2(Y, X)
i = np.where(R <= radius)[0]
return atoms[i]
if radius is None:
raise ValueError("radius not set")
new_atoms = atoms.copy()
dims = {"x": 0, "y": 1, "z": 2}
if axis in dims:
axis = dims[axis]
else:
raise ValueError("axis not valid, must be 'x','y', or 'z'")
del_list = []
for index, position in enumerate(new_atoms.positions):
# calculating the distance of the atom to the given axis
r = 0
for dim in range(3):
if dim != axis:
r = r + position[dim]**2
r = np.sqrt(r)
if r > radius:
del_list.append(index)
del_list.reverse()
for index in del_list:
del new_atoms[index]
return new_atoms
def cut_cone(atoms, radius, z=0):
@ -409,15 +426,11 @@ def cut_plane(atoms, x=None, y=None, z=None):
dim_values = np.array(dim_values)
X, Y, Z = atoms.positions.T
i0 = np.where(X >= dim_values[0, 0])[0]
i1 = np.where(X[i0] <= dim_values[0, 1])[0]
i2 = np.where(Y[i0][i1] >= dim_values[1, 0])[0]
i3 = np.where(Y[i0][i1][i2] <= dim_values[1, 1])[0]
i4 = np.where(Z[i0][i1][i2][i3] >= dim_values[2, 0])[0]
i5 = np.where(Z[i0][i1][i2][i3][i4] <= dim_values[2, 1])[0]
indices = np.arange(len(atoms))[i0][i1][i2][i3][i4][i5]
def constraint(coordinates):
return np.all(np.logical_and(coordinates >= dim_values[:, 0],
coordinates <= dim_values[:, 1]))
indices = np.where(list(map(constraint, atoms.positions)))[0]
return atoms[indices]
@ -464,16 +477,12 @@ 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 = len(np.unique(np.round(cluster.get_positions()[:, 2], 4)))
p = np.alen(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
if shape.lower() in ('spherical'):
assert (diameter != 0 or planes != 0), \
"At least one of diameter or planes parameter must be use."
elif shape.lower() in ('cylindrical'):
assert (diameter != 0 and planes != 0), \
"Diameter and planes parameters must be defined for cylindrical shape."
assert (diameter != 0 or planes != 0), \
"At least one of diameter or planes parameter must be use."
if diameter == 0:
# calculate the minimal diameter according to the number of planes
@ -483,7 +492,6 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0,
# number of repetition in each direction
rep = int(3*min_diameter/min(a, c))
#print("rep = ", rep)
# repeat the cluster
cluster = cluster.repeat((rep, rep, rep))
@ -547,7 +555,7 @@ def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0,
xplan, yplan = get_xypos(cluster, zplan)
radius = np.sqrt(xplan**2 + yplan**2 + zplan**2)
if diameter != 0 and shape in ('spherical'):
if diameter != 0:
assert (radius <= diameter/2), ("The number of planes is too high "
"compared to the diameter.")
radius = max(radius, diameter/2)
@ -574,96 +582,9 @@ 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 < len(all_z), ("There are not enough existing "
assert emitter_plane < np.alen(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)
return cluster
def shape_cluster(primitive, emitter_tag=0, emitter_plane=0, diameter=0,
planes=0, shape='spherical'):
"""Creates and returns a cluster based on an Atoms object and some
parameters.
:param cluster: the Atoms object used to create the cluster
:type cluster: Atoms object
:param emitter_tag: the tag of your emitter
:type emitter_tag: integer
:param diameter: the diameter of your cluster in Angströms
:type diameter: float
:param planes: the number of planes of your cluster
:type planes: integer
:param emitter_plane: the plane where your emitter will be starting by 0
for the first plane
:type emitter_plane: integer
See :ref:`hemispherical_cluster_faq` for more informations.
"""
# We need the radius of the cluster and the number of planes
if shape.lower() in ('ispherical', 'cylindrical'):
assert (nplanes != 0 and diameter != 0), "nplanes and diameter cannot be zero for '{}' shape".format(shape)
elif shape.lower() in ('spherical'):
if diameter <= 0:
# find the diameter based on the number of planes
assert planes != 0, "planes should be > 0"
n = 3
natoms = 0
while True:
n += 2
cluster = primitive.copy()
# Repeat the primitive cell
cluster = cluster.repeat((n, n, n))
center_cluster(cluster)
# Find the emitter closest to the origin
all_tags = cluster.get_tags()
are_emitters = all_tags == emitter_tag
_ie = np.linalg.norm(cluster[are_emitters].positions, axis=1).argmin()
ie = np.nonzero(are_emitters)[0][_ie]
# Translate the cluster to this emitter position
cluster.translate(-cluster[ie].position)
# cut plane at surface and at bottom
all_z = np.unique(cluster.positions[:,2])
try:
zsurf = all_z[all_z >= 0][emitter_plane]
except IndexError:
# There are not enough planes above the emitter
zsurf = all_z.max()
try:
zbottom = all_z[all_z <= 0][::-1][planes - (emitter_plane+1)]
except IndexError:
# There are not enough planes below the emitter
zbottom = all_z.min()
cluster = cut_plane(cluster, z=[zbottom,zsurf])
# spherical shape
if shape.lower() in ('spherical'):
cluster = cut_sphere(cluster, radius=diameter/2, center=(0,0,zsurf))
if shape.lower() in ('ispherical'):
cluster = cut_sphere(cluster, radius=diameter/2, center=(0,0,0))
elif shape.lower() in ('cylindrical'):
cluster = cut_cylinder(cluster, radius=diameter/2)
else:
raise NameError("Unknown shape")
cluster.set_cell(primitive.cell)
if len(cluster) <= natoms:
break
else:
natoms = len(cluster)
return cluster

44
src/msspec/version.py
View File

@ -17,39 +17,39 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/version.py
# Last modified: Wed, 26 Oct 2022 17:15:24 +0200
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr> 1666797324 +0200
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
import os
from importlib.metadata import version
import subprocess
from pkg_resources import DistributionNotFound
from pkg_resources import get_distribution
from pkg_resources import parse_version
# find the version number
# 1- Try to read it from the git info
# 2- If it fails, try to read it from the VERSION file
# 3- If it fails, try to read it from the distribution file
PKGNAME = 'msspec'
thisfile_path = os.path.abspath(__file__)
thisfile_dir = os.path.dirname(thisfile_path)
# 2- If it fails, try to read it from the distribution file
# 3- If it fails, try to read it from the VERSION file
try:
cmd = ["git describe|sed 's/-\([0-9]\+\)-.*/.dev\\1/g'"]
result = subprocess.run(cmd, stdout=subprocess.PIPE, stderr=subprocess.DEVNULL,
shell=True, cwd=thisfile_dir)
__version__ = result.stdout.decode('utf-8').strip()
if __version__ == "":
raise
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
except Exception as err:
try:
versionfile = os.path.join(thisfile_dir, "./VERSION")
with open(versionfile, "r") as fd:
__version__ = fd.readline().strip()
__version__ = get_distribution(__name__.strip('.version')).version
except Exception as err:
try:
__version__ = version(PKGNAME)
thisfile_path = os.path.abspath(__file__)
thisfile_dir = os.path.dirname(thisfile_path)
versionfile = os.path.join(thisfile_dir, "../VERSION")
with open(versionfile, "r") as fd:
__version__ = fd.readline()
except Exception as err:
__version__ = "0.0.0"
print("Unable to get the version number!")
__version__ = "9.9.9"

7
src/options.mk
View File

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

3
src/pyproject.toml
View File

@ -1,3 +0,0 @@
[build-system]
requires = ["setuptools>=45", "setuptools_scm[toml]>=6.2"]
build-backend = "setuptools.build_meta"

55
src/setup.cfg
View File

@ -1,55 +0,0 @@
[metadata]
name = msspec
version = attr: msspec.version.__version__
author = Didier Sébilleau, Sylvain Tricot
author_email = sylvain.tricot@univ-rennes1.fr
url = https://msspec.cnrs.fr
description = A multiple scattering package for sepectroscopies using electrons to probe materials
long_description = MsSpec is a Fortran package to compute the
cross-section of several spectroscopies involving one (or more)
electron(s) as the probe. This package provides a python interface to
control all the steps of the calculation.
Available spectroscopies:
* Photoelectron diffraction
* Auger electron diffraction
* Low energy electron diffraction
* X-Ray absorption spectroscopy
* Auger Photoelectron coincidence spectroscopy
* Computation of the spectral radius""",
keywords = spectroscopy atom electron photon multiple scattering
license = GPL
classifiers =
Development Status :: 3 - Alpha
Environment :: Console
Intended Audience :: Science/Research
License :: OSI Approved :: GNU General Public License (GPL)
Natural Language :: English
Operating System :: Microsoft :: Windows :: Windows 10
Operating System :: POSIX :: Linux
Operating System :: MacOS :: MacOS X
Programming Language :: Fortran
Programming Language :: Python :: 3 :: Only
Topic :: Scientific/Engineering :: Physics
[options]
packages = find:
zip_safe = False
install_requires =
setuptools_scm
ase
h5py
ipython
lxml
matplotlib
numpy
Pint
pandas
pycairo
scipy
terminaltables
[options.package_data]
msspec.phagen = fortran/*.so
msspec.spec = fortran/*.so
msspec = VERSION

83
tests/aed/test.py Normal file
View File

@ -0,0 +1,83 @@
# 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')

BIN
thirdparty/attrdict-2.0.1.tar.gz vendored
View File

Binary file not shown.

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