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

Compare commits

base: epsi:feature/LEED
Branches Tags
epsi:master
epsi:devel
epsi:feature/LEED
epsi:feature/arnoldi
epsi:feature/aed
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:master
Branches Tags
epsi:devel
epsi:feature/LEED
epsi:feature/arnoldi
epsi:master
epsi:feature/aed
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

No commits in common. "feature/LEED" and "master" have entirely different histories.
feature/LE ... master

71 changed files with 206 additions and 23343 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"]

4
Jenkinsfile vendored
View File

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

35
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"
@ -38,28 +37,20 @@ light: venv
@$(INSIDE_VENV) pip install 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
@$(INSIDE_VENV) pip install attrdict sip
# TODO: attrdict is no longer compatible with collections package. The build will fail
# download the wheel or the source if it cannot find a wheel
$(INSIDE_VENV) cd _build_wx && pip download -f https://extras.wxpython.org/wxPython4/extras/linux/gtk3/$(DISTRO_RELEASE) wxPython
@$(INSIDE_VENV) cd _build_wx && pip download -f https://extras.wxpython.org/wxPython4/extras/linux/gtk3/$(DISTRO_RELEASE) wxPython
# Build the source if a tar.gz was downloaded
@$(INSIDE_VENV) cd _build_wx && \
if [ -e wxPython*.tar.gz ]; then \
tar -x --skip-old-files -vzf wxPython*.tar.gz; \
cd `ls -d wxPython*/`; \
pip install requests 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
;;

5
src/msspec/__init__.py
View File

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

30
src/msspec/calcio.py
View File

@ -1,25 +1,5 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
# This file is part of msspec.
#
# msspec is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# msspec is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/calcio.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# vim: set et ts=4 sw=4 fdm=indent mouse=a cc=+1 tw=80:
"""
Module calcio
@ -930,7 +910,7 @@ class SpecIO(object):
if content != old_content:
with open(filename, 'w') as fd:
fd.write(content)
LOGGER.debug("Writing Spec input file written in {}".format(filename))
LOGGER.debug(f"Writing Spec input file written in {filename}")
modified = True
return modified
@ -1275,13 +1255,13 @@ class CompCurveIO(object):
data = []
for i in range(1, 13):
#data.append(np.loadtxt(prefix + f'{i:02d}' + '.txt')[-1])
results = np.loadtxt(prefix + '{:02d}'.format(i) + '.txt')
results = np.loadtxt(prefix + f'{i:02d}' + '.txt')
results = results.reshape((-1, 2))
data.append(results[index,1])
suffix = 'ren'
exp = {'int': None, 'ren': None, 'chi': None, 'cdf': None}
exp_ren = np.loadtxt(os.path.join('exp', 'div',
'experiment_{}.txt'.format(suffix)))
f'experiment_{suffix}.txt'))
calc_ren = np.loadtxt(os.path.join('calc', 'div',
'calculation{:d}_{}.txt'.format(index,suffix)))
f'calculation{index:d}_{suffix}.txt'))
return data, exp_ren, calc_ren

435
src/msspec/calculator.py
View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,8 +16,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/calculator.py
# Last modified: Thu, 25 Jan 2024 09:48:44 +0100
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes.fr>
# Last modified: ven. 10 avril 2020 17:19:24
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -83,7 +82,6 @@ from msspec.parameters import CompCurveGeneralParameters
from msspec.parameters import DetectorParameters
from msspec.parameters import EIGParameters
from msspec.parameters import GlobalParameters
from msspec.parameters import LEEDParameters
from msspec.parameters import MuffintinParameters
from msspec.parameters import PEDParameters
from msspec.parameters import PhagenMallocParameters
@ -98,8 +96,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 _led_mi_noso_nosp_nosym
from msspec.spec.fortran import _comp_curves
from msspec.utils import get_atom_index
@ -152,9 +148,6 @@ class _MSCALCULATOR(Calculator):
if spectroscopy == 'PED':
self.spectroscopy_parameters = PEDParameters(self.phagen_parameters,
self.spec_parameters)
elif spectroscopy == 'LEED':
self.spectroscopy_parameters = LEEDParameters(self.phagen_parameters,
self.spec_parameters)
elif spectroscopy == 'EIG':
self.spectroscopy_parameters = EIGParameters(self.phagen_parameters,
self.spec_parameters)
@ -411,16 +404,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,
self.global_parameters.algorithm))
raise ValueError
elif self.global_parameters.spectroscopy == 'LEED':
if self.global_parameters.algorithm == 'inversion':
do_spec = _led_mi_noso_nosp_nosym.run
else:
LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not "
"an allowed combination.".format(self.global_parameters.spectroscopy,
@ -762,7 +745,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')
@ -1060,400 +1043,6 @@ class _EIG(_MSCALCULATOR):
return self.iodata
class _LEED(_MSCALCULATOR):
"""This class creates a calculator object for Low Electron Energy Diffraction
spectroscopy.
:param algorithm: The algorithm to use for the computation. See
:ref:`globalparameters-algorithm` for more details about the allowed
values and the type.
:param polarization: The incoming light polarization (see
:ref:`globalparameters-polarization`)
:param dichroism: Wether to enable or not the dichroism (see
:ref:`globalparameters-dichroism`)
:param spinpol: Enable or disable the spin polarization in the calculation
(see :ref:`globalparameters-spinpol`)
:param folder: The path to the temporary folder for the calculations. See
:ref:`globalparameters-folder`
:param txt: The name of a file where to redirect standard output. The string
'-' will redirect the standard output to the screen (default).
:type txt: str
.. note::
This class constructor is not meant to be called directly by the user.
Use the :py:func:`MSSPEC` to instanciate any calculator.
"""
def __init__(self, algorithm='inversion', polarization=None, dichroism=None,
spinpol=False, folder='./calc', txt='-'):
_MSCALCULATOR.__init__(self, spectroscopy='LEED', algorithm=algorithm,
polarization=polarization, dichroism=dichroism,
spinpol=spinpol, folder=folder, txt=txt)
self.source_parameters.theta = 0
self.source_parameters.phi = 0
self.iodata = iodata.Data('LEED Simulation')
def _get_scan(self, scan_type='theta', phi=0,
theta=np.linspace(-70, 70, 141),
kinetic_energy=None, data=None,
malloc={}, other_parameters={}):
LOGGER.info("Computting the %s scan...", scan_type)
# Force absorber to be 0.
self.atoms.absorber = get_atom_index(self.atoms, 0, 0, 0)
self.detector_parameters.rotate = True
self.source_parameters.theta = 0
self.source_parameters.phi = 0
if data:
self.iodata = data
if kinetic_energy is None:
LOGGER.error('The kinetic energy is not specified!')
raise ValueError('You must define a kinetic_energy value.')
# update the parameters
self.scan_parameters.set_parameter('kinetic_energy', kinetic_energy)
all_ke = self.scan_parameters.get_parameter('ke_array')
if np.any(all_ke.value < 0):
LOGGER.error('Source energy is not high enough or level too deep!')
raise ValueError('Kinetic energy is < 0! ({})'.format(
kinetic_energy))
self.scan_parameters.set_parameter('type', scan_type)
# make sure there is only one energy point in scatf scan
if scan_type == 'scatf':
assert len(all_ke) == 1, ('kinetic_energy should not be an array '
'in scatf scan')
if scan_type != 'scatf':
self.scan_parameters.set_parameter('phi', phi)
self.scan_parameters.set_parameter('theta', theta)
#self.spectroscopy_parameters.set_parameter('level', level)
# It is still possible to modify any option right before runing phagen
# and spec
for k, v in other_parameters.items():
grp_str, param_str = k.split('.')
grp = getattr(self, grp_str)
grp.set_parameter(param_str, v, force=True)
self.get_tmatrix()
self.run_spec(malloc)
# Now load the data
ndset = len(self.iodata)
dset = self.iodata.add_dset('{} scan [{:d}]'.format(scan_type, ndset))
for p in self.get_parameters():
bundle = {'group': str(p.group),
'name': str(p.name),
'value': str(p.value),
'unit': '' if p.unit is None else str(p.unit)}
dset.add_parameter(**bundle)
if scan_type in ('theta', 'phi', 'energy'):
results_fname = os.path.join(self.tmp_folder, 'output/results.dat')
data = self.specio.load_results(results_fname)
for _plane, _theta, _phi, _energy, _dirsig, _cs in data.T:
if _plane == -1:
dset.add_row(theta=_theta, phi=_phi, energy=_energy, cross_section=_cs, direct_signal=_dirsig)
elif scan_type in ('scatf',):
results_fname = os.path.join(self.tmp_folder, 'output/facdif1.dat')
data = self.specio.load_facdif(results_fname)
data = data[:, [1, 4, 5, 6, 8]].T
_proto, _sf_real, _sf_imag, _theta, _energy = data
_sf = _sf_real + _sf_imag * 1j
dset.add_columns(proto_index=_proto, sf_real=np.real(_sf),
sf_imag=np.imag(_sf), sf_module=np.abs(_sf),
theta=_theta, energy=_energy)
elif scan_type in ('theta_phi',):
results_fname = os.path.join(self.tmp_folder, 'output/results.dat')
data = self.specio.load_results(results_fname)
#theta_c, phi_c = data[[2, 3], :]
#xsec_c = data[-1, :]
#dirsig_c = data[-2, :]
#dset.add_columns(theta=theta_c)
#dset.add_columns(phi=phi_c)
#dset.add_columns(cross_section=xsec_c)
#dset.add_columns(direct_signal=dirsig_c)
for _plane, _theta, _phi, _energy, _dirsig, _cs in data.T:
if _plane == -1:
dset.add_row(theta=_theta, phi=_phi, energy=_energy, cross_section=_cs,
direct_signal=_dirsig)
# create a view
title = ''
for ke in all_ke.value:
if scan_type == 'theta':
title = 'Polar scan at {:.2f} eV'.format(ke)
xlabel = r'Angle $\theta$($\degree$)'
ylabel = r'Signal (a. u.)'
view = dset.add_view("E = {:.2f} eV".format(ke), title=title,
xlabel=xlabel, ylabel=ylabel, autoscale=True)
for angle_phi in self.scan_parameters.get_parameter(
'phi').value:
where = ("energy=={:.2f} and phi=={:.2f}"
"").format(ke, angle_phi)
legend = r'$\phi$ = {:.1f} $\degree$'.format(angle_phi)
view.select('theta', 'cross_section', where=where,
legend=legend)
if scan_type == 'phi':
title = 'Azimuthal scan at {:.2f} eV'.format(ke)
xlabel = r'Angle $\phi$($\degree$)'
ylabel = r'Signal (a. u.)'
view = dset.add_view("E = {:.2f} eV".format(ke), title=title,
xlabel=xlabel, ylabel=ylabel)
for angle_theta in self.scan_parameters.get_parameter(
'theta').value:
where = ("energy=={:.2f} and theta=={:.2f}"
"").format(ke, angle_theta)
legend = r'$\theta$ = {:.1f} $\degree$'.format(angle_theta)
view.select('phi', 'cross_section', where=where,
legend=legend)
if scan_type == 'theta_phi':
absorber_symbol = self.atoms[self.atoms.absorber].symbol
title = ('Stereographic projection at {:.2f} eV'
'').format(ke)
xlabel = r'Angle $\phi$($\degree$)'
ylabel = r'Signal (a. u.)'
view = dset.add_view("E = {:.2f} eV".format(ke), title=title,
xlabel=xlabel, ylabel=ylabel,
projection='stereo', colorbar=True, autoscale=True)
view.select('theta', 'phi', 'cross_section')
if scan_type == 'scatf':
for i in range(self.phagenio.nat):
proto_index = i+1
title = 'Scattering factor at {:.3f} eV'.format(kinetic_energy)
mini = min(map(np.min, [dset.sf_real, dset.sf_imag, dset.sf_module]))
maxi = max(map(np.max, [dset.sf_real, dset.sf_imag, dset.sf_module]))
view = dset.add_view("Proto. atom #{:d}".format(proto_index),
title=title, projection='polar',
ylim=[mini, maxi])
where = "proto_index=={:d}".format(proto_index)
view.select('theta', 'sf_module', where=where,
legend=r'$|f(\theta)|$')
view.select('theta', 'sf_real', where=where,
legend=r'$\Re(f(\theta))$')
view.select('theta', 'sf_imag', where=where,
legend=r'$\Im(f(\theta))$')
if scan_type == 'energy':
absorber_symbol = self.atoms[self.atoms.absorber].symbol
title = (r'Energy scan of {}({}) at $\theta$={:.2f}$\degree$ and '
'$\phi$={:.2f}$\degree$').format(
absorber_symbol, level, theta, phi)
xlabel = r'Photoelectron kinetic energy (eV)'
ylabel = r'Signal (a. u.)'
view = dset.add_view("EnergyScan".format(ke), title=title,
xlabel=xlabel, ylabel=ylabel)
view.select('energy', 'cross_section')
# save the cluster
#clusbuf = StringIO()
#self.atoms.info['absorber'] = self.atoms.absorber
#self.atoms.write(clusbuf, format='xyz')
#dset.add_parameter(group='Cluster', name='cluster', value=clusbuf.getvalue(), hidden="True")
self.add_cluster_to_dset(dset)
LOGGER.info('%s scan computing done!', scan_type)
return self.iodata
def get_potential(self, atom_index=None, data=None, units={'energy': 'eV', 'space': 'angstrom'}):
"""Computes the coulombic part of the atomic potential.
:param atom_index: The atom indices to get the potential of, either as a list or as a single integer
:param data: The data object to store the results to
:param units: The units to be used. A dictionary with the keys 'energy' and 'space'
:return: A Data object
"""
LOGGER.info("Getting the Potential...")
LOGGER.debug(get_call_info(inspect.currentframe()))
_units = {'energy': 'eV', 'space': 'angstrom'}
_units.update(units)
if data:
self.iodata = data
self.run_phagen()
filename = os.path.join(self.tmp_folder, 'output/tmatrix.tl')
tl = self.phagenio.load_tl_file(filename)
filename = os.path.join(self.tmp_folder, 'output/cluster.clu')
self.phagenio.load_cluster_file(filename)
if self.phagen_parameters.potgen in ('in'):
filename = os.path.join(self.tmp_folder, 'output/plot/plot_vc.dat')
else:
filename = os.path.join(self.tmp_folder, 'output/plot/plot_v.dat')
pot_data = self.phagenio.load_potential_file(filename)
cluster = self.phagen_parameters.get_parameter('atoms').value
dset = self.iodata.add_dset('Potential [{:d}]'.format(len(self.iodata)))
r = []
v = []
index = np.empty((0,1), dtype=int)
absorber_position = cluster[cluster.absorber].position
for _pot_data in pot_data:
# find the proto index of these data
at_position = (_pot_data['coord'] * UREG.bohr_radius).to('angstrom').magnitude + absorber_position
at_index = get_atom_index(cluster, *at_position)
at_proto_index = cluster[at_index].get('proto_index')
#values = np.asarray(_pot_data['values'])
values = _pot_data['values']
index = np.append(index, np.ones(values.shape[0], dtype=int) * at_proto_index)
r = np.append(r, (values[:, 0] * UREG.bohr_radius).to(_units['space']).magnitude)
v = np.append(v, (values[:, 1] * UREG.rydberg).to(_units['energy']).magnitude)
dset.add_columns(distance=r, potential=v, index=index)
view = dset.add_view('potential data', title='Potential energy of atoms',
xlabel='distance from atomic center [{:s}]'.format(_units['space']),
ylabel='energy [{:s}]'.format(_units['energy']), scale='linear',
autoscale=True)
if atom_index == None:
for i in range(pot_data[len(pot_data) - 1]['index']):
view.select('distance', 'potential', where="index=={:d}".format(i),
legend="Atom index #{:d}".format(i + 1))
else:
for i in atom_index:
view.select('distance', 'potential', where="index=={:d}".format(cluster[i].get('proto_index') - 1),
legend="Atom index #{:d}".format(i))
return self.iodata
def get_scattering_factors(self, level='1s', kinetic_energy=None,
data=None, **kwargs):
"""Computes the scattering factors of all prototypical atoms in the
cluster.
This function computes the real and imaginery parts of the scattering
factor as well as its modulus for each non symetrically equivalent atom
in the cluster. The results are stored in the *data* object if provided
as a parameter.
:param level: The electronic level. See :ref:`pedparameters-level`.
:param kinetic_energy: see :ref:`scanparameters-kinetic_energy`.
:param data: a :py:class:`iodata.Data` object to append the results to
or None.
:returns: The modified :py:class:`iodata.Data` object passed as an
argument or a new :py:class:`iodata.Data` object.
"""
data = self._get_scan(scan_type='scatf', level=level, data=data,
kinetic_energy=kinetic_energy, **kwargs)
return data
def get_theta_scan(self, phi=0, theta=np.linspace(-70, 70, 141),
kinetic_energy=None, data=None, **kwargs):
"""Computes a polar scan of the emitted photoelectrons.
:param phi: The azimuthal angle in degrees. See
:ref:`scanparameters-phi`.
:param theta: All the values of the polar angle to be computed. See
:ref:`scanparameters-theta`.
:param level: The electronic level. See :ref:`pedparameters-level`.
:param kinetic_energy: see :ref:`scanparameters-kinetic_energy`.
:param data: a :py:class:`iodata.Data` object to append the results to
or None.
:returns: The modified :py:class:`iodata.Data` object passed as an
argument or a new :py:class:`iodata.Data` object.
"""
data = self._get_scan(scan_type='theta', theta=theta,
phi=phi, kinetic_energy=kinetic_energy,
data=data, **kwargs)
return data
def get_phi_scan(self, phi=np.linspace(0, 359, 359), theta=0,
kinetic_energy=None, data=None, **kwargs):
"""Computes an azimuthal scan of the emitted photoelectrons.
:param phi: All the values of the azimuthal angle to be computed. See
:ref:`scanparameters-phi`.
:param theta: The polar angle in degrees. See
:ref:`scanparameters-theta`.
:param level: The electronic level. See :ref:`pedparameters-level`.
:param kinetic_energy: see :ref:`scanparameters-kinetic_energy`.
:param data: a :py:class:`iodata.Data` object to append the results to
or None.
:returns: The modified :py:class:`iodata.Data` object passed as an
argument or a new :py:class:`iodata.Data` object.
"""
data = self._get_scan(scan_type='phi', theta=theta,
phi=phi, kinetic_energy=kinetic_energy,
data=data, **kwargs)
return data
def get_theta_phi_scan(self, phi=np.linspace(0, 360),
theta=np.linspace(0, 90, 45),
kinetic_energy=None, data=None, **kwargs):
"""Computes a stereographic scan of the emitted photoelectrons.
The azimuth ranges from 0 to 360° and the polar angle ranges from 0 to
90°.
:param level: The electronic level. See :ref:`pedparameters-level`.
:param kinetic_energy: see :ref:`scanparameters-kinetic_energy`.
:param data: a :py:class:`iodata.Data` object to append the results to
or None.
:returns: The modified :py:class:`iodata.Data` object passed as an
argument or a new :py:class:`iodata.Data` object.
"""
data = self._get_scan(scan_type='theta_phi', theta=theta,
phi=phi, kinetic_energy=kinetic_energy, data=data,
**kwargs)
return data
def get_energy_scan(self, phi=0, theta=0,
level=None, kinetic_energy=None, data=None, **kwargs):
"""Computes an energy scan of the emitted photoelectrons.
:param phi: All the values of the azimuthal angle to be computed. See
:ref:`scanparameters-phi`.
:param theta: The polar angle in degrees. See
:ref:`scanparameters-theta`.
:param level: The electronic level. See :ref:`pedparameters-level`.
:param kinetic_energy: see :ref:`scanparameters-kinetic_energy`.
:param data: a :py:class:`iodata.Data` object to append the results to
or None.
:returns: The modified :py:class:`iodata.Data` object passed as an
argument or a new :py:class:`iodata.Data` object.
"""
data = self._get_scan(scan_type='energy', level=level, theta=theta,
phi=phi, kinetic_energy=kinetic_energy,
data=data, **kwargs)
return data
def MSSPEC(spectroscopy='PED', **kwargs):
""" The MsSpec calculator constructor.
@ -1543,7 +1132,7 @@ class RFACTOR(object):
for i in range(noif):
X, Y = args[2*i], args[2*i+1]
fname = os.path.join('calc',
'calculation{:d}.txt'.format(self.stack_count))
f'calculation{self.stack_count:d}.txt')
# And save to the working space
np.savetxt(fname, np.transpose([X, Y]))
self.stack_count += 1
@ -1551,7 +1140,7 @@ class RFACTOR(object):
# Update the list of input calculation files
self._params.calc_filename = []
for i in range(self.stack_count):
fname = os.path.join('calc', 'calculation{:d}.txt'.format(i))
fname = os.path.join('calc', f'calculation{i:d}.txt')
self._params.calc_filename.append(fname)
# Write the input file
@ -1646,23 +1235,23 @@ class RFACTOR(object):
dset_values.x, dset_values.yref = exp_data.T
# Append the calculated values
ycalc = calc_data[:,1]
dset_values.add_columns(**{"calc{:d}".format(i): ycalc})
dset_rfc.add_columns(**{'variable_set{:d}'.format(i): rfc})
dset_values.add_columns(**{f"calc{i:d}": ycalc})
dset_rfc.add_columns(**{f'variable_set{i:d}': rfc})
# Plot the curves
view_values.select('x', 'yref', legend='Reference values')
title = ''
for k,v in self.best_values.items():
title += '{}={} '.format(k, v)
view_values.select('x', "calc{:d}".format(self.index),
title += f'{k}={v} '
view_values.select('x', f"calc{self.index:d}",
legend="Best calculated values")
view_values.set_plot_options(title=title)
view_results.select('counts')
for i in range(self.stack_count):
view_rfc.select('rfactor_number', 'variable_set{:d}'.format(i),
legend="variables set #{:d}".format(i))
view_rfc.select('rfactor_number', f'variable_set{i:d}',
legend=f"variables set #{i:d}")
# Save the parameters
for p in self.get_parameters():
bundle = {'group': str(p.group),
@ -1692,7 +1281,5 @@ class RFACTOR(object):
if __name__ == "__main__":
pass

5
src/msspec/cli.py
View File

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

5
src/msspec/create_tests_results.py
View File

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

23
src/msspec/data/__init__.py
View File

@ -1,24 +1,5 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
# This file is part of msspec.
#
# msspec is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# msspec is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/data/__init__.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# -*- encoding: utf-8 -*-
# vim: set fdm=indent ts=4 sw=4 sts=4 et ai tw=80 cc=+0 mouse=a nu : #
from .electron_be import electron_be

20
src/msspec/data/electron_be.py
View File

@ -1,24 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
# This file is part of msspec.
#
# msspec is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# msspec is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/data/electron_be.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
"""
Module electron_be

48
src/msspec/iodata.py
View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,8 +16,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/iodata.py
# Last modified: Thu, 25 Jan 2024 09:48:44 +0100
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes.fr>
# Last modified: ven. 10 avril 2020 17:23:11
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -86,7 +85,6 @@ from matplotlib.backends.backend_wxagg import FigureCanvasWxAgg as FigureCanvas
from matplotlib.backends.backend_agg import FigureCanvasAgg
from matplotlib.backends.backend_wxagg import NavigationToolbar2WxAgg
from matplotlib.figure import Figure
from matplotlib.ticker import FormatStrFormatter
from terminaltables import AsciiTable
import msspec
@ -94,17 +92,13 @@ from msspec.msspecgui.msspec.gui.clusterviewer import ClusterViewer
from msspec.misc import LOGGER
def cols2matrix(x, y, z, nx=88*1+1, ny=360*1+1, xlim=[None, None], ylim=[None, None]):
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
# unique values
xmin = xlim[0] if xlim[0] is not None else np.min(x)
xmax = xlim[1] if xlim[1] is not None else np.max(x)
ymin = ylim[0] if ylim[0] is not None else np.min(y)
ymax = ylim[1] if ylim[1] is not None else np.max(y)
newx = np.linspace(xmin, xmax, nx)
newx = np.linspace(np.min(x), np.max(x), nx)
newy = np.linspace(np.min(y), np.max(y), ny)
ux = np.unique(np.sort(np.append(x, newx)).clip(xmin, xmax))
uy = np.unique(np.sort(np.append(y, newy)).clip(ymin, ymax))
ux = np.unique(np.append(x, newx))
uy = np.unique(np.append(y, newy))
# create an empty matrix to hold the results
zz = np.empty((len(ux), len(uy)))
@ -448,24 +442,24 @@ class DataSet(object):
for k, v in parameters.items():
if k == 'Cluster':
continue
s += "# {}:\n".format(k)
s += f"# {k}:\n"
if not(isinstance(v, list)):
v = [v,]
for p in v:
s += "# {} = {} {}\n".format(p['name'], p['value'], p['unit'])
s += f"# {p['name']} = {p['value']} {p['unit']}\n"
return s
colnames = self.columns()
with open(filename, mode) as fd:
# write the date and time of export
now = datetime.now()
fd.write("# Data exported on {}\n".format(now))
fd.write(f"# Data exported on {now}\n")
fd.write(rule)
# Append notes
fd.write("# NOTES:\n")
for line in self.notes.split('\n'):
fd.write("# {}\n".format(line))
fd.write(f"# {line}\n")
fd.write(rule)
# Append parameters
@ -818,8 +812,7 @@ class _DataSetView(object):
xlabel='', ylabel='', grid=True, legend=[], colorbar=False,
projection='rectilinear', xlim=[None, None], ylim=[None, None],
scale='linear',
specular=None,
marker=None, autoscale=True)
marker=None, autoscale=False)
self._plotopts.update(plotopts)
self._selection_tags = []
self._selection_conditions = []
@ -885,26 +878,19 @@ class _DataSetView(object):
axes.set_xticks(xvalues)
else:
if proj in ('ortho', 'stereo'):
theta, phi, Xsec = cols2matrix(*values, xlim=opts['xlim'], ylim=opts['ylim'])
#theta_ticks = np.arange(0, 91, 15)
theta_ticks = np.linspace(np.min(theta), np.max(theta), 7)
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)
if opts['specular'] is not None:
Xsec[Y<np.radians(opts['specular'])] = np.nan
im = axes.pcolormesh(X, Y, Xsec, shading='gouraud')
im = axes.pcolormesh(X, Y, Xsec)
axes.set_yticks(R_ticks)
axes.set_yticklabels([ '{:.1f}'.format(_) for _ in theta_ticks ])
#print(R_ticks)
print(theta_ticks)
#exit()
axes.set_yticklabels(theta_ticks)
figure.colorbar(im)
@ -927,6 +913,8 @@ class _DataSetView(object):
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'])
#axes.set_pickradius(5)
if label:
axes.legend()

63
src/msspec/iodata_gi.py
View File

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

15
src/msspec/iodata_wx.py
View File

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

26
src/msspec/looper.py
View File

@ -1,24 +1,6 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
# This file is part of msspec.
#
# msspec is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# msspec is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/looper.py
# Last modified: Mon, 27 Sep 2021 17:49:48 +0200
# Committed by : sylvain tricot <sylvain.tricot@univ-rennes1.fr>
# coding: utf8
# -*- encoding: future_fstrings -*-
# vim: set et sw=4 ts=4 nu tw=79 cc=+1:
from collections import OrderedDict
from functools import partial
@ -39,7 +21,7 @@ class Variable:
self.doc = doc
def __repr__(self):
return "<Variable(\'{}\')>".format(self.name)
return f"<Variable(\'{self.name}\')>"
class Sweep:
def __init__(self, key, comments="", unit=None,

5
src/msspec/misc.py
View File

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

87
src/msspec/parameters.py
View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -19,8 +18,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/parameters.py
# Last modified: Thu, 25 Jan 2024 09:48:45 +0100
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes.fr>
# Last modified: ven. 10 avril 2020 17:31:50
# Committed by : "Sylvain Tricot <sylvain.tricot@univ-rennes1.fr>"
"""
@ -488,11 +487,11 @@ class SpecParameters(BaseParameters):
fmt='.2f'),
Parameter('leed_r1', types=float, default=-1.0,
fmt='.3f'),
Parameter('leed_thini', types=float, default=0.,
Parameter('leed_thini', types=float, default=-55.0,
fmt='.2f'),
Parameter('leed_phiini', types=float, default=0.,
fmt='.2f'),
Parameter('leed_imod', types=int, default=0,
Parameter('leed_imod', types=int, default=1,
fmt='d'),
Parameter('leed_imoy', types=int, default=0,
fmt='d'),
@ -833,23 +832,12 @@ class GlobalParameters(BaseParameters):
'AED': ('aed', 'AED'),
'LEED': ('led', 'LED'),
'EXAFS': ('xas', 'XAS'),
'EIG': ('led', 'EIG'),
'EIG': ('xpd', 'EIG'),
}
phagen_calctype, spec_calctype = mapping[p.value]
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.')
@ -1154,7 +1142,7 @@ class DetectorParameters(BaseParameters):
default=None, doc="""
Used to averaged the signal over directions lying in the
cone of half-angle *angular_acceptance*. The number of
directions to take into account depends on the chosen
directions to take into account depends on the choosen
value:
- **None**, for no averaging at all
@ -1307,7 +1295,7 @@ class ScanParameters(BaseParameters):
calculation_parameters.set_parameter('basis_functions',
'spherical', force=True)
LOGGER.info('\'%s\' scan type chosen.', p.value)
LOGGER.info('\'%s\' scan type choosen.', p.value)
def bind_theta(self, p):
spectro = self.global_parameters.spectroscopy
@ -1422,10 +1410,6 @@ class ScanParameters(BaseParameters):
self.spec_parameters.ped_e1 = energies[1]
self.spec_parameters.ped_ne = energies[2]
self.spec_parameters.leed_e0 = energies[0]
self.spec_parameters.leed_e1 = energies[1]
self.spec_parameters.leed_ne = energies[2]
self.spec_parameters.eigval_ekini = energies[0]
self.spec_parameters.eigval_ekfin = energies[1]
self.spec_parameters.eigval_ne = energies[2]
@ -1833,57 +1817,6 @@ class PEDParameters(BaseParameters):
self.spec_parameters.ped_iso = somap[p.value]
class LEEDParameters(BaseParameters):
def __init__(self, phagen_parameters, spec_parameters):
# parameters = (
# Parameter('level', types=str, pattern=r'\d+[spdfgSPDFG](\d/2)?$',
# default='1s', doc="""
# The level is the electronic level where the electron comes from.
# It is written: *nlJ*
# where:
# - *n* is the principal quantum number
# - *l* is the orbital quantum number
# - *J* is the spin-orbit component
# Example::
# >>> calc.spectroscopy_parameters.level = '2p3/2'
# >>> calc.spectroscopy_parameters.level = '2p' # is equivalent to '2p1/2'
# """),
# Parameter('final_state', types=int, limits=(-1, 2), default=2),
# Parameter('spin_orbit', types=(type(None), str),
# allowed_values=(None, 'single', 'both'), default=None),
# )
BaseParameters.__init__(self)
#self.add_parameters(*parameters)
self.phagen_parameters = phagen_parameters
self.spec_parameters = spec_parameters
# def bind_level(self, p):
# edge = get_level_from_electron_configuration(p.value)
# self.phagen_parameters.edge = edge
# li, so = re.match(r'(^\d+[spdfg])(.*$)', p.value).groups()
# if so == '':
# so = '1/2'
# self.spec_parameters.ped_li = li
# self.spec_parameters.ped_so = so
# self.spec_parameters.extra_level = p.value
# def bind_final_state(self, p):
# self.spec_parameters.ped_initl = p.value
# def bind_spin_orbit(self, p):
# somap = {
# None: 0,
# 'single': 1,
# 'both': 2}
# self.spec_parameters.ped_iso = somap[p.value]
class EIGParameters(BaseParameters):
def __init__(self, phagen_parameters, spec_parameters):
parameters = (
@ -2079,20 +2012,20 @@ class CompCurveGeneralParameters(BaseParameters):
value = p.allowed_values.index(p.value)
self.compcurve_parameters.general_norm = value
LOGGER.info("Curve Comparison: Normalization mode set to "
"\"{}\"".format(p.value))
f"\"{p.value}\"")
def bind_rescale(self, p):
self.compcurve_parameters.general_iscale = int(p.value)
state = "deactivated"
if p.value:
state = "activated"
LOGGER.info("Curve Comparison: Rescaling of data {}".format(state))
LOGGER.info(f"Curve Comparison: Rescaling of data {state}")
def bind_function(self, p):
value = p.allowed_values.index(p.value)
self.compcurve_parameters.general_icur = value
LOGGER.info("Curve Comparison: Type of data used for comparison "
"set to \"{}\"".format(p.value))
f"set to \"{p.value}\"")

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

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

@ -1,6 +1,6 @@
.PHONY: all phd_se phd_mi phd_ce led_mi eig_mi eig_pw comp_curve clean
.PHONY: all phd_se phd_mi eig_mi eig_pw comp_curve clean
all: phd_se phd_mi phd_ce led_mi eig_mi eig_pw comp_curve
all: phd_se phd_mi eig_mi eig_pw comp_curve
phd_se:
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk all
@ -8,12 +8,6 @@ phd_se:
phd_mi:
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk all
phd_ce:
@+$(MAKE) -f phd_ce_noso_nosp_nosym.mk all
led_mi:
@+$(MAKE) -f led_mi_noso_nosp_nosym.mk all
eig_mi:
@+$(MAKE) -f eig_mi.mk all
@ -26,8 +20,6 @@ comp_curve:
clean::
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk $@
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk $@
@+$(MAKE) -f phd_ce_noso_nosp_nosym.mk $@
@+$(MAKE) -f led_mi_noso_nosp_nosym.mk $@
@+$(MAKE) -f eig_mi.mk $@
@+$(MAKE) -f eig_pw.mk $@
@+$(MAKE) -f comp_curve.mk $@

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)

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

85
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/dwsph.f
View File

@ -1,85 +0,0 @@
C
C=======================================================================
C
SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
C
C This routine recomputes the T-matrix elements taking into account the
C mean square displacements.
C
C When the argument X is tiny, no vibrations are taken into account
C
C Last modified : 25 Apr 2013
C
USE DIM_MOD
C
USE TRANS_MOD
C
DIMENSION GNT(0:N_GAUNT)
C
COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC
C
COMPLEX*16 FFL(0:2*NL_M)
C
DATA PI4,EPS /12.566371,1.0E-10/
C
ZEROC=(0.,0.)
C
IF(X.GT.EPS) THEN
C
C Standard case: vibrations
C
IF(ISPEED.LT.0) THEN
NSUM_LB=ABS(ISPEED)
ENDIF
C
COEF=PI4*EXP(-X)
NL2=2*LMAX(JTYP,JE)+2
IBESP=5
MG1=0
MG2=0
C
CALL BESPHE(NL2,IBESP,X,FFL)
C
DO L=0,LMAX(JTYP,JE)
XL=FLOAT(L+L+1)
SL1=ZEROC
C
DO L1=0,LMAX(JTYP,JE)
XL1=FLOAT(L1+L1+1)
CALL GAUNT(L,MG1,L1,MG2,GNT)
L2MIN=ABS(L1-L)
IF(ISPEED.GE.0) THEN
L2MAX=L1+L
ELSEIF(ISPEED.LT.0) THEN
L2MAX=L2MIN+2*(NSUM_LB-1)
ENDIF
SL2=0.
C
DO L2=L2MIN,L2MAX,2
XL2=FLOAT(L2+L2+1)
C=SQRT(XL1*XL2/(PI4*XL))
SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2)))
ENDDO
C
SL1=SL1+SL2*TL(L1,1,JTYP,JE)
ENDDO
C
TLT(L,1,JTYP,JE)=COEF*SL1
C
ENDDO
C
ELSE
C
C Argument X tiny: no vibrations
C
DO L=0,LMAX(JTYP,JE)
C
TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE)
C
ENDDO
C
ENDIF
C
RETURN
C
END

26
src/msspec/spec/fortran/led_mi_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

113
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/facdif1.f
View File

@ -1,113 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J
&E,*)
C
C This routine computes a spherical wave scattering factor
C
C Last modified : 03/04/2006
C
USE DIM_MOD
USE APPROX_MOD
USE EXPFAC_MOD
USE TRANS_MOD
USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I
&6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
C
DIMENSION PLMM(0:100,0:100)
DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
COMPLEX RHOJK
C
C
DATA PI/3.141593/
C
A=1.
INTER=0
IF(ITL.EQ.1) VKE=VK(JE)
RHOJ=VKE*RJ
RHOJK=VKE*RJK
HLM1=(1.,0.)
HLM2=(1.,0.)
HLM3=(1.,0.)
HLM4=(1.,0.)
IEM=1
CSTH=COS(BETA)
IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN
INTER=1
BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI))
ENDIF
CALL PLM(CSTH,PLMM,LMAX(JAT,JE))
IF(ISPHER.EQ.0) NO1=0
IF(ISPHER.EQ.1) THEN
IF(NO.EQ.8) THEN
NO1=LMAX(JAT,JE)+1
ELSE
NO1=NO
ENDIF
CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM)
IF(IEM.EQ.0) THEN
HLM4=HLM(0,L)
ENDIF
IF(RJK.GT.0.0001) THEN
NDUM=0
CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN)
ENDIF
CALL DJMN(THRJ,D,L)
A1=ABS(D(0,M,L))
IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1
&
ENDIF
MUMAX=MIN0(L,NO1)
SMU=(0.,0.)
DO 10 MU=0,MUMAX
IF(MOD(MU,2).EQ.0) THEN
B=1.
ELSE
B=-1.
IF(SIN(BETA).LT.0.) THEN
A=-1.
ENDIF
ENDIF
IF(ISPHER.LE.1) THEN
ALMU=(1.,0.)
C=1.
ENDIF
IF(ISPHER.EQ.0) GOTO 40
IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L))
IF(MU.GT.0) THEN
C=B*FLOAT(L+L+1)/EXPF(MU,L)
ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B*
* CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU
ELSE
C=1.
ALMU=CMPLX(D(M,0,L))/BLMU
ENDIF
40 SNU=(0.,0.)
NU1=INT(0.5*(NO1-MU)+0.0001)
NUMAX=MIN0(NU1,L-MU)
DO 20 NU=0,NUMAX
SLP=(0.,0.)
LPMIN=MAX0(MU,NU)
DO 30 LP=LPMIN,LMAX(JAT,JE)
IF(ISPHER.EQ.1) THEN
HLM1=HLM(NU,LP)
IF(RJK.GT.0.0001) HLM3=HLN(0,LP)
ENDIF
SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3
30 CONTINUE
IF(ISPHER.EQ.1) THEN
HLM2=HLM(MU+NU,L)
ENDIF
SNU=SNU+SLP*HLM2
20 CONTINUE
SMU=SMU+SNU*C*ALMU*A*B
10 CONTINUE
FSPH=SMU/(VKE*HLM4)
C
RETURN
C
END

192
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/inv_mat_ms2_la.f
View File

@ -1,192 +0,0 @@
C
C=======================================================================
C
SUBROUTINE INV_MAT_MS(JE,TAU)
C
C This subroutine stores the multiple scattering matrix and invert
C it to obtain the scattering path operator exactly.
C
C (Photoelectron case)
C
C Last modified : 24 Apr 2007
C
C INCLUDE 'spec.inc'
USE DIM_MOD
USE COOR_MOD
USE INIT_L_MOD
USE TRANS_MOD
C
C PARAMETER(NLTWO=2*NL_M)
C
COMPLEX*16 HL1(0:2*NL_M),SM(LINMAX*NATCLU_M,LINMAX*NATCLU_M)
COMPLEX*16 SUM_L,ONEC,IC,ZEROC,WORK(4*LINMAX*NATCLU_M)
COMPLEX*16 YLM(0:2*NL_M,-2*NL_M:2*NL_M),TLJ,TLK,EXPKJ
C
COMPLEX TAU(LINMAX*LINMAX*NATCLU_M*NATCLU_M)
C
C
REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
C
INTEGER IPIV(LINMAX*NATCLU_M)
C
C
DATA PI /3.1415926535898D0/
C
ONEC=(1.D0,0.D0)
IC=(0.D0,1.D0)
ZEROC=(0.D0,0.D0)
IBESS=3
C
C Construction of the multiple scattering matrix MS = (I-GoT).
C Elements are stored using a linear index LINJ representing
C (J,LJ)
C
JLIN=0
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
XJ=SYM_AT(1,JATL)
YJ=SYM_AT(2,JATL)
ZJ=SYM_AT(3,JATL)
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
TLJ=DCMPLX(TL(LJ,1,JTYP,JE))
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
JLIN=JLIN+1
C
KLIN=0
DO KTYP=1,N_PROT
NBTYPK=NATYP(KTYP)
LMK=LMAX(KTYP,JE)
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.NE.JATL) THEN
XKJ=DBLE(SYM_AT(1,KATL)-XJ)
YKJ=DBLE(SYM_AT(2,KATL)-YJ)
ZKJ=DBLE(SYM_AT(3,KATL)-ZJ)
RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
KRKJ=DBLE(VK(JE))*RKJ
ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*
& RKJ)
EXPKJ=(XKJ+IC*YKJ)/RKJ
ZDKJ=ZKJ/RKJ
CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,
& LMJ+LMK)
CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,
& HL1)
ENDIF
C
DO LK=0,LMK
ILK=LK*LK+LK+1
L_MIN=ABS(LK-LJ)
L_MAX=LK+LJ
TLK=DCMPLX(TL(LK,1,KTYP,JE))
DO MK=-LK,LK
INDK=ILK+MK
KLIN=KLIN+1
SM(KLIN,JLIN)=ZEROC
SUM_L=ZEROC
IF(KATL.NE.JATL) THEN
CALL GAUNT2(LK,MK,LJ,MJ,GNT)
C
DO L=L_MIN,L_MAX,2
M=MJ-MK
IF(ABS(M).LE.L) THEN
SUM_L=SUM_L+(IC**L)*
& HL1(L)*YLM(L,M)*GNT(L)
ENDIF
ENDDO
SUM_L=SUM_L*ATTKJ*4.D0*PI*IC
ELSE
SUM_L=ZEROC
ENDIF
C
IF(KLIN.EQ.JLIN) THEN
SM(KLIN,JLIN)=ONEC-TLK*
& SUM_L
ELSE
SM(KLIN,JLIN)=-TLK*SUM_L
ENDIF
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
LWORK=JLIN
C
C Inversion of the multiple scattering matrix MS and
C multiplication by T
C
CALL ZGETRF(JLIN,JLIN,SM,LINMAX*NATCLU_M,IPIV,INFO1)
IF(INFO1.NE.0) THEN
WRITE(6,*) ' ---> INFO1 =',INFO1
ELSE
CALL ZGETRI(JLIN,SM,LINMAX*NATCLU_M,IPIV,WORK,LWORK,INFO)
IF(INFO.NE.0) THEN
WRITE(6,*) ' ---> WORK(1),INFO =',WORK(1),INFO
ENDIF
ENDIF
C
C Storage of the Tau matrix
C
LIN=0
C
JLIN=0
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
C
KLIN=0
DO KTYP=1,N_PROT
NBTYPK=NATYP(KTYP)
LMK=LMAX(KTYP,JE)
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
TLJ=DCMPLX(TL(LJ,1,JTYP,JE))
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
JLIN=JLIN+1
C
DO LK=0,LMK
ILK=LK*LK+LK+1
DO MK=-LK,LK
INDK=ILK+MK
KLIN=KLIN+1
LIN=LIN+1
TAU(LIN)=CMPLX(SM(KLIN,JLIN)*TLJ)
ENDDO
ENDDO
KLIN=KLIN-INDK
C
ENDDO
ENDDO
KLIN=KLIN+INDK
JLIN=JLIN-INDJ
C
ENDDO
ENDDO
JLIN=JLIN+INDJ
C
ENDDO
ENDDO
C
RETURN
C
END

6809
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/lapack_inv.f
View File

File diff suppressed because it is too large Load Diff

915
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/leddif_mi.f
View File

@ -1,915 +0,0 @@
C
C
C=======================================================================
C
SUBROUTINE LEDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,
&NATCLU,NFICHLEC,JFICH,NP)
C
C This subroutine computes the LEED formula in the spin-independent
C case.
C
C The calculation is performed using a matrix inversion for the
C expression of the scattering path operator
C
C The matrix inversion is performed using the LAPACK inversion
C routines for a general complex matrix
C
C Last modified : 26 Apr 2013
C
C INCLUDE 'spec.inc'
USE DIM_MOD
USE ALGORITHM_MOD
USE AMPLI_MOD
USE APPROX_MOD
USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP
USE DEBWAL_MOD
USE DIRECT_MOD, RTHETA => RTHEXT
USE EXTREM_MOD
USE FIXSCAN_MOD
USE INFILES_MOD
USE INUNITS_MOD
USE INIT_L_MOD
USE INIT_J_MOD
USE LIMAMA_MOD
USE MOYEN_MOD
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD
USE RESEAU_MOD
USE SPIN_MOD
USE TESTPB_MOD
USE TESTS_MOD
USE TRANS_MOD
USE TYPCAL_MOD
USE TYPEM_MOD
USE TYPEXP_MOD
USE VALIN_MOD
USE VALIN_AV_MOD
USE VALFIN_MOD
C
REAL BEAM(3),AXE(3),EPS(3),DIRBEAM(3),BEAMDIR(3),EMET(3)
C
COMPLEX IC,ONEC,ZEROC,COEF
COMPLEX TLT(0:NT_M,4,NATM,NE_M)
COMPLEX TAU(LINMAX*LINMAX*NATCLU_M*NATCLU_M)
COMPLEX YLMI(LINMAX)
COMPLEX YLMJ(LINMAX)
COMPLEX SLJDIF,SJDIF
COMPLEX SLIDIF,SLIDIR,SIDIF,SIDIR
COMPLEX RHOK(NE_M,NATM,0:18,2,NSPIN2_M),RD
COMPLEX ATT_MI,ATT_MI2,ATT_MJ
C
DIMENSION VAL(NATCLU_M),NATYP(NATM)
DIMENSION R_L(9),COORD(3,NATCLU_M)
C
C
C
CHARACTER*7 STAT
CHARACTER*13 OUTDATA1,OUTDATA2
C
C
CHARACTER*24 OUTFILE
CHARACTER*24 AMPFILE
C
C
DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/
DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/
C
ALGO1='MI'
ALGO2=' '
ALGO3=' '
ALGO4=' '
C
I_DIR=0
NSET=1
JEL=1
JEMET=1
OUTDATA1='CROSS-SECTION'
IF(I_AMP.EQ.1) THEN
I_MI=1
OUTDATA2='MS AMPLITUDES'
ELSE
I_MI=0
ENDIF
C
C The first atom in the list taken as the origin
C
EMET(1)=SYM_AT(1,1)
EMET(2)=SYM_AT(2,1)
EMET(3)=SYM_AT(3,1)
C
IF(SPECTRO.EQ.'LED') THEN
IOUT=IUO2
OUTFILE=OUTFILE2
STAT='UNKNOWN'
IF(I_MI.EQ.1) THEN
IOUT2=IUSCR2+1
N_DOT=1
DO J_CHAR=1,24
IF(OUTFILE(J_CHAR:J_CHAR).EQ.'.') GOTO 888
N_DOT=N_DOT+1
ENDDO
888 CONTINUE
AMPFILE=OUTFILE(1:N_DOT)//'amp'
OPEN(UNIT=IOUT2, FILE=AMPFILE, STATUS=STAT)
ENDIF
ENDIF
C
C Position of the initial beam when the analyzer is along the z axis :
C (X_BEAM_Z,Y_BEAM_Z,Z_BEAM_Z)
C
RTHBEAM=THBEAM*PIS180
RPHBEAM=PHBEAM*PIS180
X_BEAM_Z=SIN(RTHBEAM)*COS(RPHBEAM)
Y_BEAM_Z=SIN(RTHBEAM)*SIN(RPHBEAM)
Z_BEAM_Z=COS(RTHBEAM)
C
IF(IMOD.EQ.0) THEN
C
C The analyzer is rotated
C
DIRBEAM(1)=X_BEAM_Z
DIRBEAM(2)=Y_BEAM_Z
DIRBEAM(3)=Z_BEAM_Z
ELSE
C
C The sample is rotated ---> beam and analyzer rotated
C
IF(I_EXT.EQ.0) THEN
RTH0=THETA0*PIS180
RPH0=PHI0*PIS180
RTH=RTH0
RPH=RPH0
C
C R_L is the rotation matrix from 0z to (THETA0,PHI0) expressed as
C a function of the Euler angles ALPHA=PHI0, BETA=THETA0, GAMMA=-PHI0
C It is stored as (1 2 3)
C (4 5 6)
C (7 8 9)
C
R_L(1)=COS(RTH0)*COS(RPH0)*COS(RPH0)+SIN(RPH0)*SIN(RPH0)
R_L(2)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
R_L(3)=SIN(RTH0)*COS(RPH0)
R_L(4)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
R_L(5)=COS(RTH0)*SIN(RPH0)*SIN(RPH0)+COS(RPH0)*COS(RPH0)
R_L(6)=SIN(RTH0)*SIN(RPH0)
R_L(7)=-SIN(RTH0)*COS(RPH0)
R_L(8)=-SIN(RTH0)*SIN(RPH0)
R_L(9)=COS(RTH0)
C
C Position of the beam when the analyzer is along (THETA0,PHI0) : BEAM(3)
C
BEAM(1)=X_BEAM_Z*R_L(1)+Y_BEAM_Z*R_L(2)+Z_BEAM_Z*R_L(3)
BEAM(2)=X_BEAM_Z*R_L(4)+Y_BEAM_Z*R_L(5)+Z_BEAM_Z*R_L(6)
BEAM(3)=X_BEAM_Z*R_L(7)+Y_BEAM_Z*R_L(8)+Z_BEAM_Z*R_L(9)
C
ENDIF
ENDIF
C
IC=(0.,1.)
ONEC=(1.,0.)
ZEROC=(0.,0.)
ATTSJ=1.
ATTSI=1.
ZSURF=VAL(1)
C
IF((ISOM.EQ.0).OR.(JFICH.EQ.1)) THEN
OPEN(UNIT=IOUT, FILE=OUTFILE, STATUS=STAT)
ENDIF
C
C Writing the headers in the output file
C
CALL HEADERS(IOUT)
C
IF((ISOM.EQ.0).OR.((ISOM.GT.0).AND.(JFICH.EQ.1))) THEN
WRITE(IOUT,12) SPECTRO,OUTDATA1
WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,
& IE,IPH_1,I_EXT
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,12) SPECTRO,OUTDATA2
WRITE(IOUT2,12) STEREO
WRITE(IOUT2,19) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,
& ITHETA,IE,IPH_1,I_EXT
WRITE(IOUT2,20) PHI0,THETA0,PHI1,THETA1,NONVOL(1)
ENDIF
ENDIF
C
IF(ISOM.EQ.0) THEN
WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,79) NPLAN,NEMET,NTHETA,NPHI,NE
ENDIF
ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN
WRITE(IOUT,11) NTHETA,NPHI,NE
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,11) NTHETA,NPHI,NE
ENDIF
ENDIF
IJK=0
C
C Loop over the planes
C
DO JPLAN=1,NPLAN
Z=VAL(JPLAN)
IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN
DZZEM=ABS(Z-ZEM)
IF(DZZEM.LT.SMALL) GOTO 10
GOTO 1
ENDIF
10 CONTINUE
C
IF(ISOM.EQ.1) NP=JPLAN
C
C Loop over the energies
C
DO JE=1,NE
FMIN(0)=1.
FMAX(0)=1.
IF(NE.GT.1) THEN
ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
ELSEIF(NE.EQ.1) THEN
ECIN=E0
ENDIF
IF(I_TEST.NE.1) THEN
CFM=16.*PI*PI
ELSE
CFM=1.
ENDIF
CALL LPM(ECIN,XLPM,*6)
XLPM1=XLPM/A
IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN
IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR
ENDIF
IF(ITL.EQ.0) THEN
VK(JE)=SQRT(ECIN+VINT)*CONV*A*(1.,0.)
VK2(JE)=CABS(VK(JE)*VK(JE))
ENDIF
GAMMA=1./(2.*XLPM1)
IF(IPOTC.EQ.0) THEN
VK(JE)=VK(JE)+IC*GAMMA
ENDIF
IF(I_TEST.NE.1) THEN
VKR=REAL(VK(JE))
ELSE
VKR=1.
ENDIF
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,21) ECIN,VKR*CFM
ENDIF
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN
IF(IDCM.GE.1) WRITE(IUO1,22)
DO JAT=1,N_PROT
IF(IDCM.EQ.0) THEN
XK2UJ2=VK2(JE)*UJ2(JAT)
ELSE
XK2UJ2=VK2(JE)*UJ_SQ(JAT)
WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
ENDIF
CALL DWSPH(JAT,JE,XK2UJ2,TLT,ISPEED)
DO LAT=0,LMAX(JAT,JE)
TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
ENDDO
ENDDO
ENDIF
IF(ABS(I_EXT).GE.1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,13) I_DIR,NSET,N_DUM1
READ(IUI6,14) I_DUM1,N_DUM2,N_DUM3
ENDIF
C
C Largest angular momenum value (used to compute
C the spherical harmonics)
C
LM_MAX=0
DO JTYP=1,N_PROT
LMJ=LMAX(JTYP,JE)
LM_MAX=MAX(LM_MAX,LMJ)
ENDDO
C
C Initialization of TAU(LIN)
C
LIN=0
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYPJ
DO LJ=0,LMJ
DO MJ=-LJ,LJ
DO ITYP=1,N_PROT
NBTYPI=NATYP(ITYP)
LMI=LMAX(ITYP,JE)
DO INUM=1,NBTYPI
DO LI=0,LMI
DO MI=-LI,LI
LIN=LIN+1
TAU(LIN)=ZEROC
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C
C Matrix inversion for the calculation of TAU
C
IF(I_TEST.EQ.2) GOTO 666
CALL INV_MAT_MS(JE,TAU)
666 CONTINUE
C
C Calculation of the LEED formula
C
C
C Loop over the 'fixed' angle
C
15 DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
IF(I_EXT.EQ.0) THEN
FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
XINCRF=FLOAT(J_FIXED-1)*FIX_STEP
ELSE
XINCRF=0.
ENDIF
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
IF(ABS(I_EXT).GE.1) THEN
READ(IUI6,86) JSET,JLINE,THD,PHD
IF(I_EXT.EQ.-1) BACKSPACE IUI6
THETA0=THD
PHI0=PHD
ENDIF
IF(IPH_1.EQ.1) THEN
IF(I_EXT.EQ.0) THEN
DPHI=PHI0+XINCRF
ELSE
DPHI=PHD
ENDIF
RPHI=DPHI*PIS180
IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
ELSE
ISAUT=0
IF(I_EXT.EQ.0) THEN
DTHETA=THETA0+XINCRF
ELSE
DTHETA=THD
ENDIF
RTHETA=DTHETA*PIS180
IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
IF(I_EXT.GE.1) ISAUT=0
IF(I_TEST.EQ.2) ISAUT=0
IF(ISAUT.GT.0) GOTO 8
IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
C
C THETA-dependent number of PHI points for stereographic
C representation (to obtain a uniform sampling density).
C (Courtesy of J. Osterwalder - University of Zurich)
C
IF(STEREO.EQ.'YES') THEN
N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+
& SMALL)+1
ENDIF
C
ENDIF
IF((N_FIXED.GT.1).AND.(IMOD.EQ.1)) THEN
C
C When there are several sets of scans (N_FIXED > 1),
C the initial position BEAM of the beam is recalculated
C for each initial position (RTH,RPH) of the analyzer
C
IF(IPH_1.EQ.1) THEN
RTH=THETA0*PIS180
RPH=RPHI
ELSE
RTH=RTHETA
RPH=PHI0*PIS180
ENDIF
C
R_L(1)=COS(RTH)*COS(RPH)
R_L(2)=-SIN(RPH)
R_L(3)=SIN(RTH)*COS(RPH)
R_L(4)=COS(RTH)*SIN(RPH)
R_L(5)=COS(RPH)
R_L(6)=SIN(RTH)*SIN(RPH)
R_L(7)=-SIN(RTH)
R_L(8)=0.
R_L(9)=COS(RTH)
C
BEAM(1)=X_BEAM_Z*R_L(1)+Y_BEAM_Z*R_L(2)+Z_BEAM_Z*R_L(3)
BEAM(2)=X_BEAM_Z*R_L(4)+Y_BEAM_Z*R_L(5)+Z_BEAM_Z*R_L(6)
BEAM(3)=X_BEAM_Z*R_L(7)+Y_BEAM_Z*R_L(8)+Z_BEAM_Z*R_L(9)
ENDIF
C
C Loop over the scanned angle
C
DO J_SCAN=1,N_SCAN
IF(N_SCAN.GT.1) THEN
XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1)
ELSEIF(N_SCAN.EQ.1) THEN
XINCRS=0.
ENDIF
IF(I_EXT.EQ.-1) THEN
READ(IUI6,86) JSET,JLINE,THD,PHD
BACKSPACE IUI6
ENDIF
IF(IPH_1.EQ.1) THEN
ISAUT=0
IF(I_EXT.EQ.0) THEN
DTHETA=THETA0+XINCRS
ELSE
DTHETA=THD
ENDIF
RTHETA=DTHETA*PIS180
IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
IF(I_EXT.GE.1) ISAUT=0
IF(I_TEST.EQ.2) ISAUT=0
IF(ISAUT.GT.0) GOTO 8
IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
ELSE
IF(I_EXT.EQ.0) THEN
DPHI=PHI0+XINCRS
ELSE
DPHI=PHD
ENDIF
RPHI=DPHI*PIS180
IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
ENDIF
C
C Loop over the sets of directions to average over (for gaussian average)
C
C
SSETDIF=0.
SSETDIR=0.
C
SSET2DIF=0.
SSET2DIR=0.
C
IF(I_EXT.EQ.-1) THEN
JREF=INT(NSET)/2+1
ELSE
JREF=1
ENDIF
C
DO J_SET=1,NSET
IF(I_EXT.EQ.-1) THEN
READ(IUI6,86) JSET,JLINE,THD,PHD,W
DTHETA=THD
DPHI=PHD
RTHETA=DTHETA*PIS180
RPHI=DPHI*PIS180
C
C Here, there are several sets of scans (NSET > 1), so
C the initial position BEAM of the beam must be
C recalculated for each initial position of the analyzer
C
RTH=TH_0(J_SET)*PIS180
RPH=PH_0(J_SET)*PIS180
C
IF(IMOD.EQ.1) THEN
R_L(1)=COS(RTH)*COS(RPH)
R_L(2)=-SIN(RPH)
R_L(3)=SIN(RTH)*COS(RPH)
R_L(4)=COS(RTH)*SIN(RPH)
R_L(5)=COS(RPH)
R_L(6)=SIN(RTH)*SIN(RPH)
R_L(7)=-SIN(RTH)
R_L(8)=0.
R_L(9)=COS(RTH)
C
BEAM(1)=X_BEAM_Z*R_L(1)+Y_BEAM_Z*R_L(2)+
& Z_BEAM_Z*R_L(3)
BEAM(2)=X_BEAM_Z*R_L(4)+Y_BEAM_Z*R_L(5)+
& Z_BEAM_Z*R_L(6)
BEAM(3)=X_BEAM_Z*R_L(7)+Y_BEAM_Z*R_L(8)+
& Z_BEAM_Z*R_L(9)
C
ENDIF
ELSE
W=1.
ENDIF
C
IF(I_EXT.EQ.-1) PRINT 89
C
CALL DIRAN(VINT,ECIN,JEL)
C
IF(J_SET.EQ.JREF) THEN
DTHETAP=DTHETA
DPHIP=DPHI
ENDIF
C
IF(I_EXT.EQ.-1) THEN
WRITE(IUO1,88) DTHETA,DPHI
ENDIF
C
C .......... Case IMOD=1 only ..........
C
C Calculation of the position of the beam when the analyzer is at
C (THETA,PHI). DIRBEAM is the direction of the beam and its initial
C value (at (THETA0,PHI0)) is BEAM. AXE is the direction of the theta
C rotation axis and EPS is defined so that (AXE,DIRBEAM,EPS) is a
C direct orthonormal basis. The transform of a vector R by a rotation
C of OMEGA about AXE is then given by
C
C R' = R COS(OMEGA) + (AXE.R)(1-COS(OMEGA)) AXE + (AXE^R) SIN(OMEGA)
C
C Here, DIRANA is the internal direction of the analyzer and ANADIR
C its external position
C
C Note that when the initial position of the analyzer is (RTH,RPH)
C which coincides with (RTH0,RPH0) only for the first fixed angle
C
IF(IMOD.EQ.1) THEN
IF(ITHETA.EQ.1) THEN
AXE(1)=-SIN(RPH)
AXE(2)=COS(RPH)
AXE(3)=0.
RANGLE=RTHETA-RTH
ELSEIF(IPHI.EQ.1) THEN
AXE(1)=0.
AXE(2)=0.
AXE(3)=1.
RANGLE=RPHI-RPH
ENDIF
CALL PRVECT(AXE,BEAM,EPS,CVECT)
PRS=PRSCAL(AXE,BEAM)
IF(J_SCAN.EQ.1) THEN
DIRBEAM(1)=BEAM(1)
DIRBEAM(2)=BEAM(2)
DIRBEAM(3)=BEAM(3)
ELSE
DIRBEAM(1)=BEAM(1)*COS(RANGLE)+PRS*(1.-COS(
& RANGLE))*AXE(1)+SIN(RANGLE)*EPS(1)
DIRBEAM(2)=BEAM(2)*COS(RANGLE)+PRS*(1.-COS(
& RANGLE))*AXE(2)+SIN(RANGLE)*EPS(2)
DIRBEAM(3)=BEAM(3)*COS(RANGLE)+PRS*(1.-COS(
& RANGLE))*AXE(3)+SIN(RANGLE)*EPS(3)
ENDIF
ENDIF
IF(DIRBEAM(3).GT.1.) DIRBEAM(3)=1.
IF(DIRBEAM(3).LT.-1.) DIRBEAM(3)=-1.
THETABEAM=ACOS(DIRBEAM(3))
IF(I_TEST.EQ.2) THETABEAM=-THETABEAM
COEF=DIRBEAM(1)+IC*DIRBEAM(2)
CALL ARCSIN(COEF,DIRBEAM(3),PHIBEAM)
C
C Internal direction of the incoming beam BEAMDIR
C (DIRBEAM is the external direction)
C
CALL REFRAC(VINT,ECIN,THETABEAM,BEAMTHETA)
BEAMDIR(1)=SIN(BEAMTHETA)*COS(PHIBEAM)
BEAMDIR(2)=SIN(BEAMTHETA)*SIN(PHIBEAM)
BEAMDIR(3)=COS(BEAMTHETA)
C
CALL HARSPH3(NL_M,BEAMTHETA,-PHIBEAM,YLMI,LM_MAX)
C
ANABEAM=ANADIR(1,1)*DIRBEAM(1) + ANADIR(2,1)*DIRBEAM(2)
& +ANADIR(3,1)*DIRBEAM(3)
C
IF(IPRINT.GT.0) THEN
WRITE(IUO1,63) (DIRANA(J,1),J=1,3),(BEAMDIR(K),
& K=1,3),ANABEAM
ENDIF
IF(I_EXT.EQ.-1) PRINT 89
C
SRDIF=0.
SRDIR=0.
C
C Loop over the different directions of the analyzer contained in a cone
C
DO JDIR=1,NDIR
SIDIF=ZEROC
SIDIR=ZEROC
CALL HARSPH3(NL_M,THETAR(JDIR),PHIR(JDIR),YLMJ,
& LM_MAX)
C
C Loop over the first atom I encountered by the electron beam
C when entering the solid
C
LIN=0
DO ITYP=1,N_PROT
NBTYPI=NATYP(ITYP)
LMI=LMAX(ITYP,JE)
INDI_M=(LMI+1)*(LMI+1)
DO INUM=1,NBTYPI
IATL=NCORR(INUM,ITYP)
XOI=SYM_AT(1,IATL)-EMET(1)
YOI=SYM_AT(2,IATL)-EMET(2)
ZOI=SYM_AT(3,IATL)-EMET(3)
ROI=SQRT(XOI*XOI+YOI*YOI+ZOI*ZOI)
ZSURFI=VAL(1)-SYM_AT(3,IATL)
IF(IATTS.EQ.1) THEN
ATTSI=EXP(-ZSURFI*GAMMA/COS(BEAMTHETA))
ENDIF
IF(ROI.GT.SMALL) THEN
CSTHIR=(XOI*BEAMDIR(1)+YOI*BEAMDIR(2)+ZOI*
& BEAMDIR(3))/ROI
CTROIS1=ZOI/ROI
CSTHIR2=(XOI*(DIRANA(1,JDIR)-BEAMDIR(1))+YOI*
& (DIRANA(2,JDIR)-BEAMDIR(2))+ZOI*(DIRANA(3,JDIR)-
& BEAMDIR(3)))/ROI
ELSE
CSTHIR=0.
CTROIS1=0.
CSTHIR2=0.
ENDIF
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
IF(IDCM.GE.1) THEN
UJ2(ITYP)=UJ_SQ(ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(CSTHIR-1.).GT.SMALL) THEN
CSKZ2I=(BEAMDIR(3)-CTROIS1)*(BEAMDIR(3)-
& CTROIS1)/(2.-2.*CSTHIR)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
78 IF(IDWSPH.EQ.1) THEN
DWTER=1.
DWTER2=1.
ELSE
DWTER=EXP(-VK2(JE)*UII*(1.-CSTHIR))
DWTER2=EXP(-VK2(JE)*UII*(1.-CSTHIR2))
ENDIF
ATT_MI=ATTSI*DWTER*CEXP(IC*VK(JE)*ROI*CSTHIR)
ATT_MI2=ATTSI*DWTER2*CEXP(-IC*VK(JE)*ROI*CSTHIR2)
C
C Kinematic term
C
SLIDIR=ZEROC
DO LI=0,LMI
ILI=LI*LI+LI+1
DO MI=-LI,LI
INDI=ILI+MI
SLIDIR=SLIDIR+TL(LI,1,ITYP,JE)*YLMJ(INDI)
& *YLMI(INDI)
ENDDO
ENDDO
C
C Loop over the last atom J encountered by the electron beam
C when exiting the solid
C
SJDIF=ZEROC
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
INDJ_M=(LMJ+1)*(LMJ+1)
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
XOJ=SYM_AT(1,JATL)-EMET(1)
YOJ=SYM_AT(2,JATL)-EMET(2)
ZOJ=SYM_AT(3,JATL)-EMET(3)
ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ)
ZSURFJ=VAL(1)-SYM_AT(3,JATL)
IF(IATTS.EQ.1) THEN
ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR))
ENDIF
IF(ROJ.GT.SMALL) THEN
CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,
& JDIR)+ZOJ*DIRANA(3,JDIR))/ROJ
CTROIS1=ZOJ/ROJ
ELSE
CSTHJR=0.
CTROIS1=0.
ENDIF
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 90
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=UJ_SQ(JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(CSTHJR-1.).GT.SMALL) THEN
CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)*(
& DIRANA(3,JDIR)-CTROIS1)/(2.-2.*CSTHJR)
ELSE
CSKZ2J=1.
ENDIF
UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
ELSE
UJJ=UJ2(JTYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UJ2=VK2(JE)*UJJ
CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
90 IF(IDWSPH.EQ.1) THEN
DWTER=1.
ELSE
DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR))
ENDIF
ATT_MJ=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*
& CSTHJR)
C
C Loop over the angular momentum of atom I
C
SLIDIF=ZEROC
DO INDI=1,INDI_M
C
C Loop over the angular momentum of atom J
C
SLJDIF=ZEROC
DO INDJ=1,INDJ_M
LIN=LIN+1
SLJDIF=SLJDIF+YLMJ(INDJ)*TAU(LIN)
ENDDO
C
SLIDIF=SLIDIF+SLJDIF*YLMI(INDI)
ENDDO
C
C End of the loops over the last atom J
C
SJDIF=SJDIF+SLIDIF*ATT_MJ
C
ENDDO
ENDDO
SIDIF=SIDIF+SJDIF*ATT_MI
SIDIR=SIDIR+SLIDIR*ATT_MI2
C
C End of the loops over the first atom I
C
ENDDO
ENDDO
C
C Computing the square modulus
C
SRDIF=SRDIF+CABS(SIDIF)*CABS(SIDIF)
SRDIR=SRDIR+CABS(SIDIR)*CABS(SIDIR)
C
C End of the loop on the directions of the analyzer
C
ENDDO
C
SSETDIF=SSETDIF+SRDIF*CFM*W/NDIR
SSETDIR=SSETDIR+SRDIR*CFM*W/NDIR
IF(ICHKDIR.EQ.2) THEN
IF(JSET.EQ.JREF) THEN
SSET2DIF=SRDIF*CFM/NDIR
SSET2DIR=SRDIR*CFM/NDIR
ENDIF
ENDIF
C
C End of the loop on the set averaging
C
ENDDO
C
IF(ISOM.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,
& SSETDIR,SSETDIF
IF(ICHKDIR.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,
& SSET2DIR,SSET2DIF
ENDIF
ELSE
WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,
& SSETDIR,SSETDIF
IF(ICHKDIR.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,
& SSET2DIR,SSET2DIF
ENDIF
ENDIF
C
C End of the loop on the scanned angle
C
ENDDO
C
8 CONTINUE
C
C End of the loop on the fixed angle
C
ENDDO
C
C End of the loop on the energy
C
CLOSE(IUI6)
ENDDO
C
3 CONTINUE
C
GO TO 1
5 IPLAN=JPLAN-1
IJK=IJK+1
IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN
IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN
ENDIF
1 CONTINUE
C
C End of the loop on the planes
C
ENDDO
C
IF(ABS(I_EXT).GE.1) CLOSE(IUI6)
IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*)
IF(SPECTRO.EQ.'APC') CLOSE(IOUT)
IF(SPECTRO.EQ.'APC') GOTO 7
c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN
IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN
NP=0
CALL TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
ENDIF
IF(I_EXT.EQ.2) THEN
CALL WEIGHT_SUM(ISOM,I_EXT,0,1)
ENDIF
GOTO 7
6 WRITE(IUO1,55)
C
9 FORMAT(9(2X,I1),2X,I2)
11 FORMAT(I4,2X,I4,2X,I4)
12 FORMAT(2X,A3,11X,A13)
13 FORMAT(6X,I1,1X,I3,2X,I4)
14 FORMAT(6X,I1,1X,I3,3X,I3)
19 FORMAT(2(2X,I1),1X,I2,6(2X,I1),2X,I2)
20 FORMAT(2(5X,F6.2,2X,F6.2),2X,I1)
21 FORMAT(10X,E12.6,3X,E12.6)
22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,
&25X,' BY DEBYE UNCORRELATED MODEL:',/)
23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
51 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' DOES NOT CONTAIN ',
*'ANY ABSORBER OF TYPE ',I2,' *******')
52 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' POSITION OF ','THE
&ABSORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X,'******* ',
&19X,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******')
53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1,/
&,10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1,/,10X,' MINIMAL
&INTENSITY : ',E12.6,2X,'No OF THE PATH : ',F15.1,
& /,10X,' MAXIMAL INTENSITY : ',E12.6,2X,
&'No OF THE PATH : ',F15.1)
54 FORMAT(//,7X,'DUE TO THE SIZE OF THE CLUSTER, THE SUMMATION',
*' HAS BEEN TRUNCATED TO THE ',I2,' TH PLANE')
55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
*'AVAILABLE >>>>>>>>>>')
56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
*'MEAN FREE PATH = ',F6.3,' * A',//)
57 FORMAT(25X,'CLUSTER RADIUS = ',F6.3,' *A')
58 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',I10,/,
&10X,' EFFECTIVE NUMBER OF PATHS : ',I10, /,10X,'
& MINIMAL INTENSITY : ',E12.6,2X,'No OF THE PATH : ',I10,
& /,10X,' MAXIMAL INTENSITY : ',
&E12.6, 2X,'No OF THE PATH : ',I10)
59 FORMAT(//,15X,'THE SCATTERING DIRECTION IS GIVEN INSIDE ',
*'THE CRYSTAL')
60 FORMAT(7X,'THE POSITIONS OF THE ATOMS ARE GIVEN WITH RESPECT ',
*'TO THE ABSORBER')
63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',
&F6.3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF
&THE BEAM ', ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X,
&'ANALYZER.BEAM : ',F7.4)
65 FORMAT(////,3X,'++++++++++++++++++',9X,
*'THETA = ',F6.2,' DEGREES',9X,'++++++++',
*'++++++++++',///)
66 FORMAT(////,3X,'++++++++++++++++++',9X,
*'PHI = ',F6.2,' DEGREES',9X,'++++++++++',
*'++++++++++',///)
67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
68 FORMAT(10X,' CUT-OFF INTENSITY : ',E12.6)
69 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
70 FORMAT(2X,I2,2X,I10,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
71 FORMAT(//,1X,'JDIF',4X,'No OF THE PATH',2X,'INTENSITY',3X,
&'LENGTH',4X,'ABSORBER',2X,'ORDER OF THE SCATTERERS',/)
72 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,
&E12.6,2X,E12.6)
74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ','====
&=>')
76 FORMAT(2X,I2,2X,E12.6,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
77 FORMAT(' ')
79 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
80 FORMAT(///)
81 FORMAT(//,1X,'RANK',1X,'ORDER',4X,'No PATH',3X,'INTENSITY',3X,
&'LENGTH',4X,'ABS',3X,'ORDER OF THE SCATTERERS',/)
82 FORMAT(I3,4X,I2,1X,E12.6,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X))
83 FORMAT(I3,4X,I2,1X,I10,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X))
84 FORMAT(/////,18X,'THE ',I3,' MORE INTENSE PATHS BY DECREASING','
&ORDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ','OF A)')
85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ',/,24X,'(THE
&LENGTH IS GIVEN IN UNITS OF A)')
86 FORMAT(2X,I3,1X,I4,5X,F8.3,3X,F8.3,3X,E12.6)
87 FORMAT(2X,I2,2X,I3,2X,I2,2X,I3,2X,I3,2X,I3,2X,I1,2X,I2,2X,I2,2X,
&E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =', F6.2)
89 FORMAT(/,4X,'..........................................','.......
&..............................')
C
7 RETURN
C
END

21
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main.f
View File

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

1648
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/main_led_ns_mi.f
View File

File diff suppressed because it is too large Load Diff

106
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/plotfd.f
View File

@ -1,106 +0,0 @@
C
C=======================================================================
C
SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
C
C This routine prepares the output for a plot of the scattering factor
C
USE DIM_MOD
C
USE APPROX_MOD
USE FDIF_MOD
USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 =>
& LF2, I10 => ISTEP_LF
USE INIT_J_MOD
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP
&, I13 => I_EXT, I14 => I_TEST
USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO
&L
USE VALFIN_MOD
C
C
C
DIMENSION LMX(NATM,NE_M)
C
COMPLEX FSPH,VKE
C
C
C
DATA PI,CONV/3.141593,0.512314/
C
OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
IF(ISPHER.EQ.0) THEN
L=0
LMAX=0
ELSE
LMAX=L
ENDIF
PHITOT=360.
THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
NPHI=(NFTHET+1)*IPHI+(1-IPHI)
NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
* (1-ITHETA)
NE=NFTHET*IE + (1-IE)
WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
DO 10 JT=1,NTHT
DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
RTHETA=DTHETA*PI/180.
TEST=SIN(RTHETA)
IF(TEST.GE.0.) THEN
POZ=PI
EPS=1.
ELSE
POZ=0.
EPS=-1.
ENDIF
BETA=RTHETA*EPS
IF(ABS(TEST).LT.0.0001) THEN
NPHIM=1
ELSE
NPHIM=NPHI
ENDIF
DO 20 JP=1,NPHIM
DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
RPHI=DPHI*PI/180.
GAMMA=POZ-RPHI
DO 30 JE=1,NE
IF(NE.EQ.1) THEN
ECIN=E0
ELSE
ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
ENDIF
IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
DO 40 JAT=1,NAT
IF(L.GT.LMX(JAT,JE)) GOTO 90
DO 50 M=-LMAX,LMAX
CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J
&AT,JE,*60)
GOTO 70
60 WRITE(IUO1,80)
STOP
70 REFTH=REAL(FSPH)
XIMFTH=AIMAG(FSPH)
WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN
50 CONTINUE
GOTO 40
90 WRITE(IUO1,100) JAT
STOP
40 CONTINUE
30 CONTINUE
20 CONTINUE
10 CONTINUE
CLOSE(IUO3)
1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X,
&F8.2)
80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z
&ERO >>>>>')
100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : '
&,I2,' >>>>>')
C
RETURN
C
END

995
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/process.py
View File

@ -1,995 +0,0 @@
# vim: set et ts=4 sw=4 fdm=indent:
# coding: utf-8
import re
import sys
import os
import textwrap
class Patterns(object):
col = '(?P<comment> |C|\*)'
col += '(?P<label>(?: |\d){1,5})'
col += '(?P<cont> |\d|&)'
typ = '(?P<type>'
typ += 'BYTE|'
typ += 'CHARACTER(?:\*\(\*\)|\*\d+)?|'
typ += 'COMPLEX(?:\*8|\*16|\*32)|'
typ += 'DOUBLE\s+(?:COMPLEX|PRECISION)|'
typ += 'INTEGER(?:\*2|\*4|\*8)?|'
typ += 'LOGICAL(?:\*1|\*2|\*4|\*8)?|'
typ += 'REAL(?:\*4|\*8|\*16)?|'
typ += 'AUTOMATIC|STATIC)'
nam = '[a-z][a-z0-9_]*'
dim = '(?:,?.*?(?::.*?)?)+'
axs = '[^:]+(:[^:]+)?'
class BaseInfo(object):
def __init__(self, **kwargs):
self._attrs = kwargs.keys()
for kw,val in kwargs.items():
setattr(self, '_' + kw, val)
@property
def info(self):
s = '=== {}:\n'.format(self.__class__.__name__)
for attr in self._attrs:
s += ' {}: {}\n'.format(attr, repr(getattr(self, attr)))
return s
def __repr__(self):
return '<{}>'.format(self.__class__.__name__)
class DimensionInfo(BaseInfo):
def __init__(self, **kwargs):
opts = {'rank': None,
'extents': None,
'variable': None}
opts.update(**kwargs)
BaseInfo.__init__(self, **opts)
@property
def rank(self):
return len(self.extents)
@property
def extents(self):
return self._extents
@property
def variable(self):
return self._variable
@variable.setter
def variable(self, value):
assert isinstance(value, VariableInfo)
self._variable = value
def __str__(self):
s = ''
for d in self.extents:
s += d[0]
if d[1] is not None:
s += ':' + d[1]
s += ','
s = s.strip(',')
return s
class VariableInfo(BaseInfo):
def __init__(self, **kwargs):
opts = {'name': None, 'type': None,
'dimension': None, 'subprogram': None}
opts.update(**kwargs)
BaseInfo.__init__(self, **opts)
@property
def name(self):
return self._name
@property
def type(self):
return self._type
@type.setter
def type(self, value):
self._type = value
@property
def dimension(self):
return self._dimension
@dimension.setter
def dimension(self, value):
self._dimension = value
@property
def subprogram(self):
return self._subprogram
@subprogram.setter
def subprogram(self, value):
self._subprogram = value
def __str__(self):
s = self.name
if self.dimension is not None:
s += '(' + str(self.dimension) + ')'
return s
class FileInfo(BaseInfo):
def __init__(self, **kwargs):
opts = {'filename': None, 'content': None, 'subprograms': None}
opts.update(**kwargs)
BaseInfo.__init__(self, **opts)
self._subprograms = find_subprograms('\n'.join(self.content))
for sp in self._subprograms:
sp.file = self
#self._subprograms = None
@property
def filename(self):
return os.path.abspath(self._filename)
@property
def content(self):
with open(self.filename, 'r') as fd:
lines = fd.readlines()
pat = re.compile(' (?:\d|&)\s*(.*)$')
c = []
for line in lines:
line = line.strip('\n')
m = pat.match(line)
if m:
c[-1] += m.group(1)
else:
c.append(line)
return c
@property
def subprograms(self):
return self._subprograms
def __str__(self):
return content2str(self.content)
class SubProgramInfo(BaseInfo):
def __init__(self, **kwargs):
opts = {'name': None, 'content': None, 'type': None, 'file': None,
'l0': None, 'l1': None, 'commons': None}
opts.update(**kwargs)
BaseInfo.__init__(self, **opts)
@property
def name(self):
return self._name
@property
def content(self):
return self._file.content[self.l0:self.l1]
@property
def type(self):
return self._type
@property
def file(self):
return self._file
@property
def l0(self):
return self._l0
@property
def l1(self):
return self._l1
@file.setter
def file(self, value):
self._file = value
@property
def commons(self):
self._commons = find_commons('\n'.join(self.content))
for c in self._commons:
c.subprogram = self
return self._commons
def __str__(self):
return content2str(self.content)
def __repr__(self):
s = "{}<{}>".format(self.name, self.type)
return s
class CommonBlockInfo(BaseInfo):
def __init__(self, **kwargs):
opts = {'name': None, 'content': None, 'subprogram': None, 'variables': None}
opts.update(**kwargs)
BaseInfo.__init__(self, **opts)
def __str__(self):
return content2str(self.content)
def __repr__(self):
s = "{}<{:d} variables>".format(self.name, len(self.variables))
return s
@property
def subprogram(self):
return self._subprogram
@subprogram.setter
def subprogram(self, value):
self._subprogram = value
@property
def name(self):
return self._name
@property
def content(self):
return self._content
@property
def variables(self):
# string to analyse
s = self.content[0]
m = re.match("^.*COMMON\s*/{}/\s*(.*)$".format(self.name),s, re.I)
self._variables = find_variables(m.groups()[0])
for v in self._variables:
v.subprogram = self.subprogram
# If the dimension of a variable is None, try to search if a DIMENSION
# statement exists in the subprogram
dim_defs = [] # list of variables defined in a DIMENSION statement
for line in self.subprogram.content:
m = re.match("^[^C]\s+DIMENSION\s+(.*)$", line, re.I)
if m is not None:
s = m.groups()[0]
var_list = find_variables(s)
for v in var_list:
dim_defs.append(v)
dim_defs = Variables(dim_defs)
# Now for each variable of the common, if there is no dimension, try to find it in
# the dim_defs list
for v in self._variables:
if v.dimension is None:
dim = dim_defs[v.name]
if dim is not None:
#print(self.subprogram.name)
#print(v.name, dim)
v.dimension = dim.dimension
#exit()
# if the type of the variable is None, try to find it in a declaration statement
type_defs = [] # list of variables defined with their type
for line in self.subprogram.content:
var_list = find_type(line)
if var_list is not None:
for v in var_list:
type_defs.append(v)
type_defs = Variables(type_defs)
# Now for each variable with no type, try to find it in the type_defs list
for v in self._variables:
if v.type is None:
typ = type_defs[v.name]
if typ is not None:
#print(self.subprogram.name)
#print(v.name, typ)
v.type = typ.type
#exit()
else:
if re.match("^[A-HO-Z].*", v.name, re.I):
v.type = "REAL"
else:
v.type = "INTEGER"
return self._variables
class _CommonBlockInfo(BaseInfo):
def __init__(self, **kwargs):
self.name = kwargs.get('name', None)
self.subprogram = kwargs.get('subprogram', None)
def __init__(self, **kwargs):
opts = {'name': None, 'content': None, 'type': None, 'file': None,
'l0': None, 'l1': None}
opts.update(**kwargs)
BaseInfo.__init__(self, **opts)
def __str__(self):
s = "Common block name: {}\n".format(self.name)
for var in self.variables:
s += str(var)
return s
def __repr__(self):
s = '{}'.format(self.name)
return s
def _find_variables(self):
content = self.content[0].rstrip()
pat = re.compile('^\s*COMMON\s+/{}/\s+(.*)$'.format(self.name), re.IGNORECASE)
m = pat.match(content)
var_loc = m.group(1)
p0 = re.compile(r'\(.*[^\)]$')
p1 = re.compile('^[a-zA-Z0-9_\*]*\)$')
var_list = []
var_loc_list = var_loc.split(',')
for i, _ in enumerate(var_loc_list):
_ = _.strip()
if i > 0:
if p0.search(var_list[-1]):
var_list[-1] += ',' + _
else:
var_list.append(_)
else:
var_list.append(_)
variables = []
for var in var_list:
m = re.match("([a-zA-Z0-9_]+)(\((.*)\))?", var)
var_name = m.group(1)
v = VariableInfo(name=var_name, subprogram=self.subprogram)
#dim_loc = m.groups()[-1]
#if dim_loc is not None:
# dim_list = dim_loc.split(',')
# v.dimension = dim_list
variables.append(v)
return variables
@property
def content(self):
pat = re.compile('\s+.*COMMON\s+/{}/.*$'.format(self.name), re.IGNORECASE)
for line in self.subprogram.content:
if pat.match(line):
return [line.rstrip(),]
@property
def variables(self):
variables_list = self._find_variables()
return Variables(variables_list)
class InfoList(object):
def __init__(self, elements):
self._elements = elements
for element in self._elements:
setattr(self, element.name, element)
def __getitem__(self, item):
if isinstance(item, str):
for element in self._elements:
if element.name == item:
return element
return None
elif isinstance(item, int):
return self._elements[item]
else:
raise NameError('Unable to retrieve item!')
def __str__(self):
s = "nb of {}: {:d}\n".format(self.__class__.__name__, len(self._elements))
#s += str([_.name for _ in self._elements])
for _ in self._elements:
s += _.info
return s
def __len__(self):
return len(self._elements)
class Subprograms(InfoList):
def __init__(self, *args, **kwargs):
InfoList.__init__(self, *args, **kwargs)
class Commons(InfoList):
def __init__(self, *args, **kwargs):
InfoList.__init__(self, *args, **kwargs)
class Variables(InfoList):
def __init__(self, *args, **kwargs):
InfoList.__init__(self, *args, **kwargs)
"""
class Subprograms(BaseInfo):
def __init__(self, subprograms_list):
self._subprograms = subprograms_list
for sp in self._subprograms:
setattr(self, sp.name, sp)
def __getitem__(self, item):
return self._subprograms[item]
def __str__(self):
s = "nb of subprograms: {:d}\n".format(len(self._subprograms))
return s
class Commons(BaseInfo):
def __init__(self, commons_list):
self._commons = commons_list
for cmn in self._commons:
setattr(self, cmn.name, cmn)
def __getitem__(self, item):
return self._commons[item]
def __str__(self):
s = "nb of commons: {:d}\n".format(len(self._commons))
return s
class Variables(BaseInfo):
"""
class VariableInfo2(BaseInfo):
def __init__(self, **kwargs):
self.name = kwargs.get('name', None)
#self.type = kwargs.get('type', None)
self.dimension = kwargs.get('dimension', None)
self.i = []
self.j = []
self.subprogram = kwargs.get('subprogram', None)
#self._find_type()
#self._find_dimension()
def __str__(self):
s = "Variable name: {}\n".format(self.name)
s += " type: {}\n".format(self.type)
s += " dimension: {}\n".format(self.dimension)
return s
def _find_implicit(self):
content = self.subprogram.content
pat = re.compile('^\s*IMPLICIT\s+', re.IGNORECASE)
def _find_type(self):
content = self.subprogram.content
pat = re.compile('^\s+((?:INTEGER|REAL|DOUBLE PRECISION|COMPLEX|LOGICAL|CHARACTER)\S*).*{}[\(,]?.*$'.format(self.name), re.IGNORECASE)
for line in content:
m = pat.match(line)
print(line)
if m:
return m.group(1).strip()
return None
def _find_dimension(self):
content = self.subprogram.content
dimension = None
#pat = re.compile('^\s+DIMENSION.*{}\(([^\(])\).*$'.format(self.name),re.IGNORECASE)
pat = re.compile('^\s+DIMENSION.*{}\((.*?)\).*$'.format(self.name),re.IGNORECASE)
for line in content:
m = pat.match(line)
if m:
print(line)
#dimension = m.group(1).strip()
dimension = m.group(1)
print(dimension)
if dimension is not None:
print('Variable: {}, dimension: {}'.format(self.name, dimension))
@property
def type(self):
t = self._find_type()
return t
###############################################################################
# UTILITY FUNCTIONS
###############################################################################
def splitline_(line, width=72):
result = []
i = 0
j = len(line)
ll = line[i:j]
if len(ll) > width:
s = ''
for dec in range(8):
s += '{:d} '.format(dec)
print(s)
print('0123456789'*7+'012')
#print(line)
while len(ll) > width:
breaks = [_.end() for _ in re.finditer('[ ,]', ll)]
print(ll)
print(breaks)
for ij, j in enumerate(breaks):
tmp = ll[i:j]
#print(breaks,i,j,ij, tmp, len(tmp))
if len(tmp) <= width and ij < len(breaks)-1:
continue
else:
_ = ll[i:breaks[ij-1]]
result.append(_)
i = len(_)
if i <= 6:
print(j, _)
raise NameError('Impossible to cut line at breaks')
ll = ' &' + ll[i:]
i = 0
break
result.append(ll)
print(ll)
return result
def splitline(line, width=72):
if len(line) == 0:
return []
if line[0].upper() == 'C':
return [line,]
head = line[:6]
L = line[6:] # the working line
# find the indentation
m = re.search('^\s*', L)
indent = L[m.start():m.end()]
# and define the true width to work with
W = width - 6 - len(indent)
def rule():
s = ''
for dec in range(20):
s += '{:d} '.format(dec)
print(s)
print('0123456789'*20)
# find all places to break the line
breaks = [_.end() for _ in re.finditer('[ ,()+-/*=:]', L)]
# split at breaks
indices = [0,] + breaks + [len(L),]
indices = zip(indices[:-1], indices[1:])
splitted_line = [L[a:b] for a,b in indices]
# iterate over each element and add it to the previous one if length is < max
chain = [splitted_line[0],]
for element in splitted_line[1:]:
l1 = len(chain[-1])
l2 = len(element)
if l1+l2 < W:
chain[-1] = chain[-1] + element
else:
chain.append(element)
# restore the head of the line
chain[0] = head + chain[0]
# add the & symbol
for i in range(1,len(chain)):
chain[i] = " &" + indent + chain[i]
# final check
for element in chain:
if len(element) > width:
rule()
print(f"{line}")
print(f"breaks at = {breaks}")
print(chain)
rule()
print(element)
raise NameError(f"Unable to split line!")
return chain
def content2str(content):
new_content = []
for index, line in enumerate(content):
#print(f'{index:>5d}#{line}')
multilines = splitline(line.rstrip(), width=72)
#print(multilines)
new_content += multilines
return '\n'.join(new_content)
def split_at_comma(string):
"""
"""
# remove all spaces from the string
line0 = string.replace(' ', '')
line = line0
# define some patterns
pat0 = re.compile('\(([^\(\)]*)\)', re.I)
# remove nested blocks in ()'s and replace them with
# hash signs (#) to make the treatment easier
while True:
M = list(pat0.finditer(line))
if len(M) == 0: break
for m in M:
i,j = m.start(), m.end()
line = line[:i] + '#'*(j-i) + line[j:]
# now get indices of ','
indices = [_.start() for _ in re.finditer(',', line)]
indices = zip([-1,] + indices, indices + [len(line),])
# create the list of
elements = [line0[i+1:j] for i,j in indices]
return elements
def find_dimension(string):
"""
Finds the components of a dimension declaration.
:param string: The argument of a dimension declaration
:type string: str
:return: A DimensionInfo object.
:rtype: DimensionInfo
:Example:
>>> dim = find_dimension('I,J,-3:2')
>>> print(dim)
>>> (3, ())
"""
# define some patterns
pat0 = re.compile('([^:]+):?([^:]+)?', re.I)
# create the list of axes
axl = split_at_comma(string)
# get the extents
extents = []
for ax in axl:
m = pat0.match(ax)
extents.append(m.groups())
return DimensionInfo(extents=extents)
def find_variables(string):
"""
Finds the name and dimension of variables in a comma separated
list of variables.
:param string: The comma separated variables declaration
:type string: str
:return: A Variables object.
:rtype: Variables
:Example:
>>> variables = find_variables('ONE, TWO(3,3)')
>>> print(variables)
>>> nb of Variables: 2
>>> === VariableInfo:
>>> name: 'ONE'
>>> type: None
>>> dimension: None
>>> subprogram: None
>>> === VariableInfo:
>>> name: 'TWO'
>>> type: None
>>> dimension: <DimensionInfo>
>>> subprogram: None
"""
# create the list of variables
var_list = []
variables = split_at_comma(string)
pat0 = re.compile('({})(?:\((.*)\))?'.format(Patterns.nam), re.I)
for var in variables:
# extract the variable's name and dimension if any
m = pat0.match(var)
name = m.group(1)
if m.group(2) is not None:
dimension = find_dimension(m.group(2))
else:
dimension = None
variable = VariableInfo(name=name, dimension=dimension)
if isinstance(dimension, DimensionInfo):
dimension.variable = variable
var_list.append(variable)
return Variables(var_list)
def find_subprograms(string):
lines = string.split('\n')
subprograms = []
for iline, line in enumerate(lines):
patterns = [('SUBROUTINE', re.compile("\s*SUBROUTINE\s+(\w+)\(?.*")),
('FUNCTION', re.compile("\s*.*FUNCTION\s+(\w+)\(?.*")),
('PROGRAM', re.compile("\s*PROGRAM\s+(\w+).*"))]
for t, pat in patterns:
m = pat.match(line)
if m is not None:
subprog = SubProgramInfo(type=t,
name=m.group(1),
l0=iline)
subprograms.append(subprog)
for i, subprog in enumerate(subprograms):
if i < len(subprograms) - 1:
subprog._l1 = subprograms[i+1].l0
else:
subprog._l1 = -1
return Subprograms(subprograms)
def find_commons(string):
pat = re.compile("^\s+COMMON\s*/([a-zA-Z0-9_]+)/(.*)$")
commons = []
for line in string.split('\n'):
# extract the name of the common block
m = pat.match(line)
if m is not None:
# name
name = m.group(1)
c = CommonBlockInfo(name=name, content=[line,])
commons.append(c)
return Commons(commons)
def find_names(string):
"""
Find the names in expression ie remove (,),+,-,*,/,**,=
"""
m = re.findall('[A-Z][A-Z0-9_]*', string, re.I)
return set(m)
def find_type(string):
"""
return a Variables object if string is a type declaration
"""
# get out if string is a comment
if string.upper().startswith('C'):
return None
pat = "^\s+"
pat += "(BYTE|"
pat += "CHARACTER(?:\*[0-9]+)?|CHARACTER\*\(\*\)|"
pat += "COMPLEX(?:\*(?:8|16|32))?|"
pat += "DOUBLE COMPLEX|"
pat += "DOUBLE PRECISION|"
pat += "INTEGER(?:\*(?:2|4|8))?|"
pat += "LOGICAL(?:\*(?:1|2|4|8))?|"
pat += "REAL(?:\*(?:4|8|16))?|"
pat += "AUTOMATIC|"
pat += "STATIC)"
pat += "\s+(.*)$"
m = re.match(pat, string, re.I)
if m is not None:
if re.search("IMPLICIT", string):
return None
else:
var_list = find_variables(m.groups()[1])
for var in var_list:
var.type = m.groups()[0]
return var_list
def find_dim(string):
"""
return a Variables object if string is a dimension declaration
"""
pat = "^\s+DIMENSION\s+(.*)$"
m = re.match(pat, string, re.I)
if m is not None:
var_list = find_variables(m.groups()[0])
return var_list
def write_modules(infile):
fi = FileInfo(filename=infile)
# Get all the common blocks defined in the source file
all_commons = []
for sp in fi.subprograms:
for c in sp.commons:
if c.name not in [_.name for _ in all_commons]:
all_commons.append(c)
all_commons = Commons(all_commons)
# a function to create a module fortran code from a CommonBlockInfo object
def common2module(cbi):
variables = cbi.variables
alloc_args = set()
module_name = cbi.name.upper() + "_MOD"
for variable in variables:
if variable.dimension is not None:
dim_vars = find_names(str(variable.dimension))
alloc_args.update(dim_vars)
s = f"MODULE {module_name}\n"
s += " IMPLICIT NONE\n"
# for each variable whose type is defined explicitely
for variable in variables:
s += f" {variable.type}"
dimension = variable.dimension
if dimension is not None:
if dimension.rank > 0:
s += f", ALLOCATABLE, DIMENSION(:" + ",:" * (variable.dimension.rank-1) + ")"
s += f" :: {variable.name}\n"
s += "CONTAINS\n"
#s += f" SUBROUTINE ALLOC_{cbi.name.upper()}({','.join(alloc_args)})\n"
#s += " IMPLICIT INTEGER (A-Z)\n"
s += f" SUBROUTINE ALLOC_{cbi.name.upper()}()\n"
s += f" USE DIM_MOD\n"
# for each variable with a defined dimension
for variable in variables:
if variable.dimension is not None:
s += f" IF (ALLOCATED({variable.name})) THEN\n"
s += f" DEALLOCATE({variable.name})\n"
s += f" ENDIF\n"
s += f" ALLOCATE({variable})\n"
s += f" END SUBROUTINE ALLOC_{cbi.name.upper()}\n"
s += f"END MODULE {module_name}\n"
# indentation
s = textwrap.indent(s, prefix=" ")
# split in too long
content = s.split('\n')
s = content2str(content)
return s
# write the modules.f file
with open("modules.f", "w") as fd:
for c in all_commons:
fd.write("C" + "="*71 + "\n")
s = common2module(c)
fd.write(s)
fd.write("\n"*2)
if __name__ == "__main__":
#infile = 'inv_mat_ms2_la.f'
infile = sys.argv[1]
# write the modules.f file
write_modules(infile)
#exit()
fi = FileInfo(filename=infile)
# Get all the common blocks defined in the source file
all_commons = []
for sp in fi.subprograms:
for c in sp.commons:
if c.name not in [_.name for _ in all_commons]:
all_commons.append(c)
all_commons = Commons(all_commons)
content = fi.content
# write the allocation.f file
dim_vars = [
"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"]
s = f"SUBROUTINE ALLOCATION({', '.join([v+'_' for v in dim_vars])})\n"
s += f" USE DIM_MOD\n"
s += f" IMPLICIT INTEGER (A-Z)\n"
for v in dim_vars:
s += f" {v} = {v+'_'}\n"
s += f" CALL INIT_DIM()\n"
s += f"END SUBROUTINE ALLOCATION\n"
# indentation
s = textwrap.indent(s, prefix=" ")
# split in too long
s = content2str(s.split('\n'))
with open("allocation.f", "w") as fd:
fd.write(s)
#exit()
# remove type definitions for variables that are in commons
for sp in fi.subprograms:
# get the list all all variables in all commons in this subprogram
vlist = []
for c in sp.commons:
for v in c.variables:
vlist.append(v.name)
for iline, line in enumerate(sp.content):
print(f"{sp.l0+iline:05d}: {line}")
newline = ''
# comment INCLUDE statement
if re.search('INCLUDE.*spec.inc', line, re.I):
newline = "C" + line
# replace the commons by USE statements
m = re.match("^.*COMMON\s+/(.*)/.*$", line, re.I)
if m is not None:
cmn_name = m.groups()[0]
# Here we test if the common variables are the same than the module
cmn_variables = sp.commons[cmn_name].variables
s = f" USE {cmn_name.upper()}_MOD "
modifications = []
for i, v in enumerate(cmn_variables):
original = all_commons[cmn_name].variables[i].name
if v.name != original:
modifications.append(f"{v.name} => {original}")
s += ", ".join(modifications)
newline = s
# Remove type declaration for variables that are now in modules
allv = find_type(line)
newallv = []
line_ = line
if allv is not None:
# Here the line is a declaration statement
# remove every variables that are also in vlist
for v in allv:
if v.name not in vlist:
# keep this variable in the list
newallv.append(str(v))
# if there is no change
if len(allv) == len(newallv):
line_ = ""
# if no more variables are defined, remove the line
elif len(newallv) == 0:
line_ = "C"
else:
line_ = " " + v.type + " " + ",".join(newallv)
newline = line_
# Remove dimension declaration for variables that are now in modules
allv = find_dim(line)
newallv = []
line_ = line
if allv is not None:
# Here the line is a dimension statement
# remove every variables that are also in vlist
for v in allv:
if v.name not in vlist:
# keep this variable in the list
#if v.dimension is not None:
newallv.append(str(v))
# if there is no change
if len(allv) == len(newallv):
line_ = ""
# if no more variables are defined, remove the line
elif len(newallv) == 0:
line_ = "C"
else:
line_ = " DIMENSION " + ",".join(newallv)
newline = line_
if newline != '':
print(sp.l0, iline, sp.l0+iline)
content[sp.l0+iline] = newline
print(f">>> {newline}")
# rewrite the file
with open(infile + ".new", "w") as fd:
fd.write(content2str(content))

785
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/treat_led.f
View File

@ -1,785 +0,0 @@
C
C=======================================================================
C
SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
C
C This routine sums up the calculations corresponding to different
C absorbers or different planes when this has to be done
C (parameter ISOM in the input data file).
C
C Last modified : 24 Jan 2013
C
C INCLUDE 'spec.inc'
USE DIM_MOD
USE OUTUNITS_MOD
USE TYPEXP_MOD, DUMMY => SPECTRO
USE VALIN_MOD
USE VALFIN_MOD
C
PARAMETER(N_HEAD=5000,N_FILES=1000)
C
CHARACTER*3 SPECTRO
C
CHARACTER*13 OUTDATA
CHARACTER*72 HEAD(N_HEAD,N_FILES)
C
REAL TAB(NDIM_M,4)
REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M)
C
C
DATA JVOL,JTOT/0,-1/
C
REWIND IUO2
C
C Reading and storing the headers:
C
NHEAD=0
DO JLINE=1,N_HEAD
READ(IUO2,888) HEAD(JLINE,JFICH)
NHEAD=NHEAD+1
IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333
ENDDO
C
333 CONTINUE
C
READ(IUO2,15) SPECTRO,OUTDATA
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,
&IPH_1,I_EXT
C
IF(I_EXT.EQ.2) THEN
IPH_1=0
ENDIF
C
IF(ISOM.EQ.0) THEN
C
C........ ISOM = 0 : case of independent input files .................
C
READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE
C
IF(IPH_1.EQ.1) THEN
N_FIXED=NPHI
FIX0=PHI0
FIX1=PHI1
N_SCAN=NTHETA
ELSE
N_FIXED=NTHETA
FIX0=THETA0
FIX1=THETA1
IF(STEREO.EQ.'YES') THEN
NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+
& 0.0001)+1
IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
ENDIF
N_SCAN=NPHI
ENDIF
C
IF(I_EXT.EQ.-1) THEN
N_SCAN=2*N_SCAN
ENDIF
C
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
NDP=NEMET*NTHETA*NPHI*NE
ELSEIF(I_EXT.EQ.-1) THEN
NDP=NEMET*NTHETA*NPHI*NE*2
ELSEIF(I_EXT.EQ.2) THEN
NDP=NEMET*NTHETA*NE
N_FIXED=NTHETA
N_SCAN=NPHI
IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
ENDIF
C
NTT=NPLAN*NDP
IF(NTT.GT.NDIM_M) GOTO 5
C
DO JPLAN=1,NPLAN
DO JEMET=1,NEMET
DO JE=1,NE
C
DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(
& N_FIXED-1)
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
IF(IPH_1.EQ.1) THEN
JPHI=J_FIXED
ELSE
THETA=THETA0+XINCRF
JTHETA=J_FIXED
IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11
ENDIF
IF(STEREO.EQ.' NO') THEN
N_SCAN_R=N_SCAN
ELSE
RTHETA=THETA*0.017453
FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.
& 0001)+1
ENDIF
C
DO J_SCAN=1,N_SCAN_R
IF(IPH_1.EQ.1) THEN
JTHETA=J_SCAN
ELSE
JPHI=J_SCAN
ENDIF
C
JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN +
& (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI
C
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
C
READ(IUO2,2) JPL
IF(JPLAN.EQ.JPL) THEN
BACKSPACE IUO2
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),TAB(JLIN,1),TAB(JLIN,2)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
ENDIF
ELSE
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),
& TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
& DPHI(JPHI2),ECIN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(
& JLIN2,3),TAB(JLIN2,4)
ENDIF
ENDIF
ELSE
BACKSPACE IUO2
DO JL=JLIN,JPLAN*NDP
TAB(JL,1)=0.0
TAB(JL,2)=0.0
TAB(JL,3)=0.0
TAB(JL,4)=0.0
ENDDO
GOTO 10
ENDIF
ENDDO
ENDDO
11 CONTINUE
ENDDO
ENDDO
10 CONTINUE
ENDDO
C
REWIND IUO2
C
C Skipping the NHEAD lines of headers before rewriting:
C
DO JLINE=1,NHEAD
READ(IUO2,888) HEAD(JLINE,JFICH)
ENDDO
C
WRITE(IUO2,15) SPECTRO,OUTDATA
WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
C
DO JE=1,NE
DO JTHETA=1,NTHETA
IF(STEREO.EQ.' NO') THEN
NPHI_R=NPHI
ELSE
RTHETA=DTHETA(JTHETA)*0.017453
FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
ENDIF
DO JPHI=1,NPHI_R
TOTDIF_1=0.
TOTDIR_1=0.
VOLDIF_1=0.
VOLDIR_1=0.
TOTDIF_2=0.
TOTDIR_2=0.
VOLDIF_2=0.
VOLDIR_2=0.
IF(I_EXT.EQ.-1) THEN
TOTDIF2_1=0.
TOTDIR2_1=0.
VOLDIF2_1=0.
VOLDIR2_1=0.
TOTDIF2_2=0.
TOTDIR2_2=0.
VOLDIF2_2=0.
VOLDIR2_2=0.
ENDIF
C
DO JPLAN=1,NPLAN
C
SF_1=0.
SR_1=0.
SF_2=0.
SR_2=0.
IF(I_EXT.EQ.-1) THEN
SF2_1=0.
SR2_1=0.
SF2_2=0.
SR2_2=0.
ENDIF
C
DO JEMET=1,NEMET
JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (
& JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JPHI
SF_1=SF_1+TAB(JLIN,2)
SR_1=SR_1+TAB(JLIN,1)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_1=SF2_1+TAB(JLIN2,2)
SR2_1=SR2_1+TAB(JLIN2,1)
ENDIF
IF(IDICHR.GE.1) THEN
SF_2=SF_2+TAB(JLIN,4)
SR_2=SR_2+TAB(JLIN,3)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_2=SF2_2+TAB(JLIN2,4)
SR2_2=SR2_2+TAB(JLIN2,3)
ENDIF
ENDIF
ENDDO
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),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
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),VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(
& JE),TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),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
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),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
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
C
ELSE
C
C........ ISOM not= 0 : multiple input files to be summed up ..........
C
READ(IUO2,7) NTHETA,NPHI,NE
C
IF(IPH_1.EQ.1) THEN
N_FIXED=NPHI
FIX0=PHI0
FIX1=PHI1
N_SCAN=NTHETA
ELSE
N_FIXED=NTHETA
FIX0=THETA0
FIX1=THETA1
IF(STEREO.EQ.'YES') THEN
NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+
& 0.0001)+1
IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
ENDIF
N_SCAN=NPHI
ENDIF
C
IF(I_EXT.EQ.-1) THEN
N_SCAN=2*N_SCAN
ENDIF
C
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
NDP=NTHETA*NPHI*NE
ELSEIF(I_EXT.EQ.-1) THEN
NDP=NTHETA*NPHI*NE*2
ELSEIF(I_EXT.EQ.2) THEN
NDP=NTHETA*NE
N_FIXED=NTHETA
N_SCAN=NPHI
IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
ENDIF
C
NTT=NFICHLEC*NDP
IF(NTT.GT.NDIM_M) GOTO 5
C
IF(ISOM.EQ.1) THEN
NPLAN=NP
NF=NP
ELSEIF(ISOM.EQ.2) THEN
NEMET=NFICHLEC
NF=NFICHLEC
NPLAN=1
ENDIF
C
DO JF=1,NF
C
C Reading the headers for each file:
C
IF(JF.GT.1) THEN
DO JLINE=1,NHEAD
READ(IUO2,888) HEAD(JLINE,JF)
ENDDO
ENDIF
C
DO JE=1,NE
C
DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(
& N_FIXED-1)
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
IF(IPH_1.EQ.1) THEN
JPHI=J_FIXED
ELSE
THETA=THETA0+XINCRF
JTHETA=J_FIXED
IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12
ENDIF
IF(STEREO.EQ.' NO') THEN
N_SCAN_R=N_SCAN
ELSE
RTHETA=THETA*0.017453
FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.
& 0001)+1
ENDIF
C
DO J_SCAN=1,N_SCAN_R
IF(IPH_1.EQ.1) THEN
JTHETA=J_SCAN
ELSE
JPHI=J_SCAN
ENDIF
C
JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)
& *NPHI + JPHI
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
C
IF(ISOM.EQ.1) THEN
READ(IUO2,2) JPL
IF(JF.EQ.JPL) THEN
BACKSPACE IUO2
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),
& DPHI(JPHI2),ECIN(JE),TAB(JLIN,1),TAB(JLIN,2)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,25) TAB(JLIN2,1),TAB(
& JLIN2,2)
ENDIF
ELSE
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
& DPHI(JPHI2),ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(
& JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(
& JTHETA),DPHI(JPHI2),ECIN(JE),TAB(JLIN2,1),TAB(
& JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
ENDIF
ENDIF
ELSE
BACKSPACE IUO2
DO JLINE=1,NHEAD
BACKSPACE IUO2
ENDDO
DO JL=JLIN,JF*NDP
TAB(JL,1)=0.0
TAB(JL,2)=0.0
TAB(JL,3)=0.0
TAB(JL,4)=0.0
ENDDO
GOTO 13
ENDIF
ELSEIF(ISOM.EQ.2) THEN
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),TAB(JLIN,1),TAB(JLIN,2)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
ENDIF
ELSE
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),
& TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
& DPHI(JPHI2),ECIN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(
& JLIN2,3),TAB(JLIN2,4)
ENDIF
ENDIF
ENDIF
ENDDO
12 CONTINUE
ENDDO
ENDDO
13 CONTINUE
ENDDO
C
REWIND IUO2
C
C Writing the headers:
C
DO JLINE=1,2
WRITE(IUO2,888) HEAD(JLINE,1)
ENDDO
DO JF=1,NFICHLEC
DO JLINE=3,6
WRITE(IUO2,888) HEAD(JLINE,JF)
ENDDO
WRITE(IUO2,888) HEAD(2,JF)
ENDDO
DO JLINE=7,NHEAD
WRITE(IUO2,888) HEAD(JLINE,1)
ENDDO
C
WRITE(IUO2,15) SPECTRO,OUTDATA
WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
C
IF(ISOM.EQ.1) THEN
C
DO JE=1,NE
C
DO JTHETA=1,NTHETA
IF(STEREO.EQ.' NO') THEN
NPHI_R=NPHI
ELSE
RTHETA=DTHETA(JTHETA)*0.017453
FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.
& 0001)+1
NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
ENDIF
DO JPHI=1,NPHI_R
C
TOTDIF_1=0.
TOTDIR_1=0.
VOLDIF_1=0.
VOLDIR_1=0.
TOTDIF_2=0.
TOTDIR_2=0.
VOLDIF_2=0.
VOLDIR_2=0.
IF(I_EXT.EQ.-1) THEN
TOTDIF2_1=0.
TOTDIR2_1=0.
VOLDIF2_1=0.
VOLDIR2_1=0.
TOTDIF2_2=0.
TOTDIR2_2=0.
VOLDIF2_2=0.
VOLDIR2_2=0.
ENDIF
C
DO JPLAN=1,NPLAN
JF=JPLAN
C
JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*
& NPHI + 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),ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
SR_2=TAB(JLIN,3)
SF_2=TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_2=TAB(JLIN2,4)
SR2_2=TAB(JLIN2,3)
ENDIF
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(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),VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),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
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
& ECIN(JE),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
ENDIF
ENDIF
C
ENDDO
ENDDO
ENDDO
ELSEIF(ISOM.EQ.2) THEN
DO JE=1,NE
C
DO JTHETA=1,NTHETA
IF(STEREO.EQ.' NO') THEN
NPHI_R=NPHI
ELSE
RTHETA=DTHETA(JTHETA)*0.017453
FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.
& 0001)+1
NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
ENDIF
DO JPHI=1,NPHI_R
C
SF_1=0.
SR_1=0.
SF_2=0.
SR_2=0.
IF(I_EXT.EQ.-1) THEN
SF2_1=0.
SR2_1=0.
SF2_2=0.
SR2_2=0.
ENDIF
C
DO JEMET=1,NEMET
JF=JEMET
C
JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-
& 1)*NPHI + 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),
& ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(
& JPHI2),ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2)
& ,ECIN(JE),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
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
C
GOTO 6
C
5 WRITE(IUO1,4)
STOP
35 WRITE(IUO1,36) N_FIXED
STOP
37 WRITE(IUO1,38) NTHETA*NPHI
STOP
C
1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ',
&'IN THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>')
7 FORMAT(I4,2X,I4,2X,I4)
8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
9 FORMAT(9(2X,I1),2X,I2)
15 FORMAT(2X,A3,11X,A13)
22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,
&E12.6,2X,E12.6)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,
&2X,E12.6)
25 FORMAT(37X,E12.6,2X,E12.6)
36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL
&','IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<<
& SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE
&INCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE
&AT LEAST ',I6,' >>>>>>>>>>')
888 FORMAT(A72)
C
6 RETURN
C
END

335
src/msspec/spec/fortran/led_mi_noso_nosp_nosym/weight_sum.f
View File

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

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

85
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/dwsph.f
View File

@ -1,85 +0,0 @@
C
C=======================================================================
C
SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
C
C This routine recomputes the T-matrix elements taking into account the
C mean square displacements.
C
C When the argument X is tiny, no vibrations are taken into account
C
C Last modified : 25 Apr 2013
C
USE DIM_MOD
C
USE TRANS_MOD
C
DIMENSION GNT(0:N_GAUNT)
C
COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC
C
COMPLEX*16 FFL(0:2*NL_M)
C
DATA PI4,EPS /12.566371,1.0E-10/
C
ZEROC=(0.,0.)
C
IF(X.GT.EPS) THEN
C
C Standard case: vibrations
C
IF(ISPEED.LT.0) THEN
NSUM_LB=ABS(ISPEED)
ENDIF
C
COEF=PI4*EXP(-X)
NL2=2*LMAX(JTYP,JE)+2
IBESP=5
MG1=0
MG2=0
C
CALL BESPHE(NL2,IBESP,X,FFL)
C
DO L=0,LMAX(JTYP,JE)
XL=FLOAT(L+L+1)
SL1=ZEROC
C
DO L1=0,LMAX(JTYP,JE)
XL1=FLOAT(L1+L1+1)
CALL GAUNT(L,MG1,L1,MG2,GNT)
L2MIN=ABS(L1-L)
IF(ISPEED.GE.0) THEN
L2MAX=L1+L
ELSEIF(ISPEED.LT.0) THEN
L2MAX=L2MIN+2*(NSUM_LB-1)
ENDIF
SL2=0.
C
DO L2=L2MIN,L2MAX,2
XL2=FLOAT(L2+L2+1)
C=SQRT(XL1*XL2/(PI4*XL))
SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2)))
ENDDO
C
SL1=SL1+SL2*TL(L1,1,JTYP,JE)
ENDDO
C
TLT(L,1,JTYP,JE)=COEF*SL1
C
ENDDO
C
ELSE
C
C Argument X tiny: no vibrations
C
DO L=0,LMAX(JTYP,JE)
C
TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE)
C
ENDDO
C
ENDIF
C
RETURN
C
END

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

113
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/facdif1.f
View File

@ -1,113 +0,0 @@
C
C=======================================================================
C
SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J
&E,*)
C
C This routine computes a spherical wave scattering factor
C
C Last modified : 03/04/2006
C
USE DIM_MOD
USE APPROX_MOD
USE EXPFAC_MOD
USE TRANS_MOD
USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I
&6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
C
DIMENSION PLMM(0:100,0:100)
DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
COMPLEX RHOJK
C
C
DATA PI/3.141593/
C
A=1.
INTER=0
IF(ITL.EQ.1) VKE=VK(JE)
RHOJ=VKE*RJ
RHOJK=VKE*RJK
HLM1=(1.,0.)
HLM2=(1.,0.)
HLM3=(1.,0.)
HLM4=(1.,0.)
IEM=1
CSTH=COS(BETA)
IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN
INTER=1
BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI))
ENDIF
CALL PLM(CSTH,PLMM,LMAX(JAT,JE))
IF(ISPHER.EQ.0) NO1=0
IF(ISPHER.EQ.1) THEN
IF(NO.EQ.8) THEN
NO1=LMAX(JAT,JE)+1
ELSE
NO1=NO
ENDIF
CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM)
IF(IEM.EQ.0) THEN
HLM4=HLM(0,L)
ENDIF
IF(RJK.GT.0.0001) THEN
NDUM=0
CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN)
ENDIF
CALL DJMN(THRJ,D,L)
A1=ABS(D(0,M,L))
IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1
&
ENDIF
MUMAX=MIN0(L,NO1)
SMU=(0.,0.)
DO 10 MU=0,MUMAX
IF(MOD(MU,2).EQ.0) THEN
B=1.
ELSE
B=-1.
IF(SIN(BETA).LT.0.) THEN
A=-1.
ENDIF
ENDIF
IF(ISPHER.LE.1) THEN
ALMU=(1.,0.)
C=1.
ENDIF
IF(ISPHER.EQ.0) GOTO 40
IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L))
IF(MU.GT.0) THEN
C=B*FLOAT(L+L+1)/EXPF(MU,L)
ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B*
* CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU
ELSE
C=1.
ALMU=CMPLX(D(M,0,L))/BLMU
ENDIF
40 SNU=(0.,0.)
NU1=INT(0.5*(NO1-MU)+0.0001)
NUMAX=MIN0(NU1,L-MU)
DO 20 NU=0,NUMAX
SLP=(0.,0.)
LPMIN=MAX0(MU,NU)
DO 30 LP=LPMIN,LMAX(JAT,JE)
IF(ISPHER.EQ.1) THEN
HLM1=HLM(NU,LP)
IF(RJK.GT.0.0001) HLM3=HLN(0,LP)
ENDIF
SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3
30 CONTINUE
IF(ISPHER.EQ.1) THEN
HLM2=HLM(MU+NU,L)
ENDIF
SNU=SNU+SLP*HLM2
20 CONTINUE
SMU=SMU+SNU*C*ALMU*A*B
10 CONTINUE
FSPH=SMU/(VKE*HLM4)
C
RETURN
C
END

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

5123
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/lapack_axb.f
View File

File diff suppressed because it is too large Load Diff

21
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main.f
View File

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

1700
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/main_phd_ns_ce.f
View File

File diff suppressed because it is too large Load Diff

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

106
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/plotfd.f
View File

@ -1,106 +0,0 @@
C
C=======================================================================
C
SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
C
C This routine prepares the output for a plot of the scattering factor
C
USE DIM_MOD
C
USE APPROX_MOD
USE FDIF_MOD
USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 =>
& LF2, I10 => ISTEP_LF
USE INIT_J_MOD
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP
&, I13 => I_EXT, I14 => I_TEST
USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO
&L
USE VALFIN_MOD
C
C
C
DIMENSION LMX(NATM,NE_M)
C
COMPLEX FSPH,VKE
C
C
C
DATA PI,CONV/3.141593,0.512314/
C
OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
IF(ISPHER.EQ.0) THEN
L=0
LMAX=0
ELSE
LMAX=L
ENDIF
PHITOT=360.
THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
NPHI=(NFTHET+1)*IPHI+(1-IPHI)
NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
* (1-ITHETA)
NE=NFTHET*IE + (1-IE)
WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
DO 10 JT=1,NTHT
DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
RTHETA=DTHETA*PI/180.
TEST=SIN(RTHETA)
IF(TEST.GE.0.) THEN
POZ=PI
EPS=1.
ELSE
POZ=0.
EPS=-1.
ENDIF
BETA=RTHETA*EPS
IF(ABS(TEST).LT.0.0001) THEN
NPHIM=1
ELSE
NPHIM=NPHI
ENDIF
DO 20 JP=1,NPHIM
DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
RPHI=DPHI*PI/180.
GAMMA=POZ-RPHI
DO 30 JE=1,NE
IF(NE.EQ.1) THEN
ECIN=E0
ELSE
ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
ENDIF
IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
DO 40 JAT=1,NAT
IF(L.GT.LMX(JAT,JE)) GOTO 90
DO 50 M=-LMAX,LMAX
CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J
&AT,JE,*60)
GOTO 70
60 WRITE(IUO1,80)
STOP
70 REFTH=REAL(FSPH)
XIMFTH=AIMAG(FSPH)
WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN
50 CONTINUE
GOTO 40
90 WRITE(IUO1,100) JAT
STOP
40 CONTINUE
30 CONTINUE
20 CONTINUE
10 CONTINUE
CLOSE(IUO3)
1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X,
&F8.2)
80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z
&ERO >>>>>')
100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : '
&,I2,' >>>>>')
C
RETURN
C
END

769
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/treat_phd.f
View File

@ -1,769 +0,0 @@
C
C=======================================================================
C
SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
C
C This routine sums up the calculations corresponding to different
C absorbers or different planes when this has to be done
C (parameter ISOM in the input data file).
C
C Last modified : 24 Jan 2013
C
USE DIM_MOD
USE OUTUNITS_MOD
USE TYPEXP_MOD , DUMMY => SPECTRO
USE VALIN_MOD
USE VALFIN_MOD
C
PARAMETER(N_HEAD=5000,N_FILES=1000)
C
CHARACTER*3 SPECTRO
C
CHARACTER*13 OUTDATA
CHARACTER*72 HEAD(N_HEAD,N_FILES)
C
REAL TAB(NDIM_M,4)
REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M)
C
C
DATA JVOL,JTOT/0,-1/
C
REWIND IUO2
C
C Reading and storing the headers:
C
NHEAD=0
DO JLINE=1,N_HEAD
READ(IUO2,888) HEAD(JLINE,JFICH)
NHEAD=NHEAD+1
IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333
ENDDO
C
333 CONTINUE
C
READ(IUO2,15) SPECTRO,OUTDATA
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IPH_1
&,I_EXT
C
IF(I_EXT.EQ.2) THEN
IPH_1=0
ENDIF
C
IF(ISOM.EQ.0) THEN
C
C........ ISOM = 0 : case of independent input files .................
C
READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE
C
IF(IPH_1.EQ.1) THEN
N_FIXED=NPHI
FIX0=PHI0
FIX1=PHI1
N_SCAN=NTHETA
ELSE
N_FIXED=NTHETA
FIX0=THETA0
FIX1=THETA1
IF(STEREO.EQ.'YES') THEN
NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
&+1
IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
ENDIF
N_SCAN=NPHI
ENDIF
C
IF(I_EXT.EQ.-1) THEN
N_SCAN=2*N_SCAN
ENDIF
C
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
NDP=NEMET*NTHETA*NPHI*NE
ELSEIF(I_EXT.EQ.-1) THEN
NDP=NEMET*NTHETA*NPHI*NE*2
ELSEIF(I_EXT.EQ.2) THEN
NDP=NEMET*NTHETA*NE
N_FIXED=NTHETA
N_SCAN=NPHI
IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
ENDIF
C
NTT=NPLAN*NDP
IF(NTT.GT.NDIM_M) GOTO 5
C
DO JPLAN=1,NPLAN
DO JEMET=1,NEMET
DO JE=1,NE
C
DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
IF(IPH_1.EQ.1) THEN
JPHI=J_FIXED
ELSE
THETA=THETA0+XINCRF
JTHETA=J_FIXED
IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11
ENDIF
IF(STEREO.EQ.' NO') THEN
N_SCAN_R=N_SCAN
ELSE
RTHETA=THETA*0.017453
FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
ENDIF
C
DO J_SCAN=1,N_SCAN_R
IF(IPH_1.EQ.1) THEN
JTHETA=J_SCAN
ELSE
JPHI=J_SCAN
ENDIF
C
JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN + (JE-1)*N
&_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI
C
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
C
READ(IUO2,2) JPL
IF(JPLAN.EQ.JPL) THEN
BACKSPACE IUO2
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
&),TAB(JLIN,1),TAB(JLIN,2)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
ENDIF
ELSE
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
&E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
&(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
ENDIF
ENDIF
ELSE
BACKSPACE IUO2
DO JL=JLIN,JPLAN*NDP
TAB(JL,1)=0.0
TAB(JL,2)=0.0
TAB(JL,3)=0.0
TAB(JL,4)=0.0
ENDDO
GOTO 10
ENDIF
ENDDO
ENDDO
11 CONTINUE
ENDDO
ENDDO
10 CONTINUE
ENDDO
C
REWIND IUO2
C
C Skipping the NHEAD lines of headers before rewriting:
C
DO JLINE=1,NHEAD
READ(IUO2,888) HEAD(JLINE,JFICH)
ENDDO
C
WRITE(IUO2,15) SPECTRO,OUTDATA
WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
C
DO JE=1,NE
DO JTHETA=1,NTHETA
IF(STEREO.EQ.' NO') THEN
NPHI_R=NPHI
ELSE
RTHETA=DTHETA(JTHETA)*0.017453
FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
ENDIF
DO JPHI=1,NPHI_R
TOTDIF_1=0.
TOTDIR_1=0.
VOLDIF_1=0.
VOLDIR_1=0.
TOTDIF_2=0.
TOTDIR_2=0.
VOLDIF_2=0.
VOLDIR_2=0.
IF(I_EXT.EQ.-1) THEN
TOTDIF2_1=0.
TOTDIR2_1=0.
VOLDIF2_1=0.
VOLDIR2_1=0.
TOTDIF2_2=0.
TOTDIR2_2=0.
VOLDIF2_2=0.
VOLDIR2_2=0.
ENDIF
C
DO JPLAN=1,NPLAN
C
SF_1=0.
SR_1=0.
SF_2=0.
SR_2=0.
IF(I_EXT.EQ.-1) THEN
SF2_1=0.
SR2_1=0.
SF2_2=0.
SR2_2=0.
ENDIF
C
DO JEMET=1,NEMET
JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (JE-1)*NTHE
&TA*NPHI +(JTHETA-1)*NPHI + JPHI
SF_1=SF_1+TAB(JLIN,2)
SR_1=SR_1+TAB(JLIN,1)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_1=SF2_1+TAB(JLIN2,2)
SR2_1=SR2_1+TAB(JLIN2,1)
ENDIF
IF(IDICHR.GE.1) THEN
SF_2=SF_2+TAB(JLIN,4)
SR_2=SR_2+TAB(JLIN,3)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_2=SF2_2+TAB(JLIN2,4)
SR2_2=SR2_2+TAB(JLIN2,3)
ENDIF
ENDIF
ENDDO
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
&_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
&SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S
&R_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
&,SR2_1,SF2_1,SR2_2,SF2_2
ENDIF
ENDIF
IF(JPLAN.GT.NONVOL(JFICH)) THEN
VOLDIF_1=VOLDIF_1+SF_1
VOLDIR_1=VOLDIR_1+SR_1
IF(I_EXT.EQ.-1) THEN
VOLDIF2_1=VOLDIF2_1+SF2_1
VOLDIR2_1=VOLDIR2_1+SR2_1
ENDIF
IF(IDICHR.GE.1) THEN
VOLDIF_2=VOLDIF_2+SF_2
VOLDIR_2=VOLDIR_1+SR_2
IF(I_EXT.EQ.-1) THEN
VOLDIF2_2=VOLDIF2_2+SF2_2
VOLDIR2_2=VOLDIR2_1+SR2_2
ENDIF
ENDIF
ENDIF
TOTDIF_1=TOTDIF_1+SF_1
TOTDIR_1=TOTDIR_1+SR_1
IF(I_EXT.EQ.-1) THEN
TOTDIF2_1=TOTDIF2_1+SF2_1
TOTDIR2_1=TOTDIR2_1+SR2_1
ENDIF
IF(IDICHR.GE.1) THEN
TOTDIF_2=TOTDIF_2+SF_2
TOTDIR_2=TOTDIR_2+SR_2
IF(I_EXT.EQ.-1) THEN
TOTDIF2_2=TOTDIF2_2+SF2_2
TOTDIR2_2=TOTDIR2_2+SR2_2
ENDIF
ENDIF
ENDDO
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOLD
&IR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO
&LDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOTD
&IR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO
&TDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOL
&DIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V
&OLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOT
&DIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T
&OTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
C
ELSE
C
C........ ISOM not= 0 : multiple input files to be summed up ..........
C
READ(IUO2,7) NTHETA,NPHI,NE
C
IF(IPH_1.EQ.1) THEN
N_FIXED=NPHI
FIX0=PHI0
FIX1=PHI1
N_SCAN=NTHETA
ELSE
N_FIXED=NTHETA
FIX0=THETA0
FIX1=THETA1
IF(STEREO.EQ.'YES') THEN
NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
&+1
IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
ENDIF
N_SCAN=NPHI
ENDIF
C
IF(I_EXT.EQ.-1) THEN
N_SCAN=2*N_SCAN
ENDIF
C
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
NDP=NTHETA*NPHI*NE
ELSEIF(I_EXT.EQ.-1) THEN
NDP=NTHETA*NPHI*NE*2
ELSEIF(I_EXT.EQ.2) THEN
NDP=NTHETA*NE
N_FIXED=NTHETA
N_SCAN=NPHI
IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
ENDIF
C
NTT=NFICHLEC*NDP
IF(NTT.GT.NDIM_M) GOTO 5
C
IF(ISOM.EQ.1) THEN
NPLAN=NP
NF=NP
ELSEIF(ISOM.EQ.2) THEN
NEMET=NFICHLEC
NF=NFICHLEC
NPLAN=1
ENDIF
C
DO JF=1,NF
C
C Reading the headers for each file:
C
IF(JF.GT.1) THEN
DO JLINE=1,NHEAD
READ(IUO2,888) HEAD(JLINE,JF)
ENDDO
ENDIF
C
DO JE=1,NE
C
DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
IF(IPH_1.EQ.1) THEN
JPHI=J_FIXED
ELSE
THETA=THETA0+XINCRF
JTHETA=J_FIXED
IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12
ENDIF
IF(STEREO.EQ.' NO') THEN
N_SCAN_R=N_SCAN
ELSE
RTHETA=THETA*0.017453
FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
ENDIF
C
DO J_SCAN=1,N_SCAN_R
IF(IPH_1.EQ.1) THEN
JTHETA=J_SCAN
ELSE
JPHI=J_SCAN
ENDIF
C
JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI +
&JPHI
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
C
IF(ISOM.EQ.1) THEN
READ(IUO2,2) JPL
IF(JF.EQ.JPL) THEN
BACKSPACE IUO2
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(
&JE),TAB(JLIN,1),TAB(JLIN,2)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
ENDIF
ELSE
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
&(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),EC
&IN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
ENDIF
ENDIF
ELSE
BACKSPACE IUO2
DO JLINE=1,NHEAD
BACKSPACE IUO2
ENDDO
DO JL=JLIN,JF*NDP
TAB(JL,1)=0.0
TAB(JL,2)=0.0
TAB(JL,3)=0.0
TAB(JL,4)=0.0
ENDDO
GOTO 13
ENDIF
ELSEIF(ISOM.EQ.2) THEN
IF(IDICHR.EQ.0) THEN
READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
&),TAB(JLIN,1),TAB(JLIN,2)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
ENDIF
ELSE
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
&E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
&(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
ENDIF
ENDIF
ENDIF
ENDDO
12 CONTINUE
ENDDO
ENDDO
13 CONTINUE
ENDDO
C
REWIND IUO2
C
C Writing the headers:
C
DO JLINE=1,2
WRITE(IUO2,888) HEAD(JLINE,1)
ENDDO
DO JF=1,NFICHLEC
DO JLINE=3,6
WRITE(IUO2,888) HEAD(JLINE,JF)
ENDDO
WRITE(IUO2,888) HEAD(2,JF)
ENDDO
DO JLINE=7,NHEAD
WRITE(IUO2,888) HEAD(JLINE,1)
ENDDO
C
WRITE(IUO2,15) SPECTRO,OUTDATA
WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
C
IF(ISOM.EQ.1) THEN
C
DO JE=1,NE
C
DO JTHETA=1,NTHETA
IF(STEREO.EQ.' NO') THEN
NPHI_R=NPHI
ELSE
RTHETA=DTHETA(JTHETA)*0.017453
FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
ENDIF
DO JPHI=1,NPHI_R
C
TOTDIF_1=0.
TOTDIR_1=0.
VOLDIF_1=0.
VOLDIR_1=0.
TOTDIF_2=0.
TOTDIR_2=0.
VOLDIF_2=0.
VOLDIR_2=0.
IF(I_EXT.EQ.-1) THEN
TOTDIF2_1=0.
TOTDIR2_1=0.
VOLDIF2_1=0.
VOLDIR2_1=0.
TOTDIF2_2=0.
TOTDIR2_2=0.
VOLDIF2_2=0.
VOLDIR2_2=0.
ENDIF
C
DO JPLAN=1,NPLAN
JF=JPLAN
C
JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JP
&HI
C
SR_1=TAB(JLIN,1)
SF_1=TAB(JLIN,2)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_1=TAB(JLIN2,2)
SR2_1=TAB(JLIN2,1)
ENDIF
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
&SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
&),SR2_1,SF2_1
ENDIF
ELSE
SR_2=TAB(JLIN,3)
SF_2=TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_2=TAB(JLIN2,4)
SR2_2=TAB(JLIN2,3)
ENDIF
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
&,SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
&E),SR2_1,SF2_1,SR2_2,SF2_2
ENDIF
ENDIF
IF(NONVOL(JPLAN).EQ.0) THEN
VOLDIF_1=VOLDIF_1+SF_1
VOLDIR_1=VOLDIR_1+SR_1
IF(I_EXT.EQ.-1) THEN
VOLDIF2_1=VOLDIF2_1+SF2_1
VOLDIR2_1=VOLDIR2_1+SR2_1
ENDIF
IF(IDICHR.GE.1) THEN
VOLDIF_2=VOLDIF_2+SF_2
VOLDIR_2=VOLDIR_2+SR_2
IF(I_EXT.EQ.-1) THEN
VOLDIF2_2=VOLDIF2_2+SF2_2
VOLDIR2_2=VOLDIR2_1+SR2_2
ENDIF
ENDIF
ENDIF
TOTDIF_1=TOTDIF_1+SF_1
TOTDIR_1=TOTDIR_1+SR_1
IF(I_EXT.EQ.-1) THEN
TOTDIF2_1=TOTDIF2_1+SF2_1
TOTDIR2_1=TOTDIR2_1+SR2_1
ENDIF
IF(IDICHR.GE.1) THEN
TOTDIF_2=TOTDIF_2+SF_2
TOTDIR_2=TOTDIR_2+SR_2
IF(I_EXT.EQ.-1) THEN
TOTDIF2_2=TOTDIF2_2+SF2_2
TOTDIR2_2=TOTDIR2_2+SR2_2
ENDIF
ENDIF
ENDDO
C
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO
&LDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
&VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO
&TDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
&TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V
&OLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
&,VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T
&OTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
&,TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
ENDIF
ENDIF
C
ENDDO
ENDDO
ENDDO
ELSEIF(ISOM.EQ.2) THEN
DO JE=1,NE
C
DO JTHETA=1,NTHETA
IF(STEREO.EQ.' NO') THEN
NPHI_R=NPHI
ELSE
RTHETA=DTHETA(JTHETA)*0.017453
FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
ENDIF
DO JPHI=1,NPHI_R
C
SF_1=0.
SR_1=0.
SF_2=0.
SR_2=0.
IF(I_EXT.EQ.-1) THEN
SF2_1=0.
SR2_1=0.
SF2_2=0.
SR2_2=0.
ENDIF
C
DO JEMET=1,NEMET
JF=JEMET
C
JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + J
&PHI
C
SF_1=SF_1+TAB(JLIN,2)
SR_1=SR_1+TAB(JLIN,1)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_1=SF2_1+TAB(JLIN2,2)
SR2_1=SR2_1+TAB(JLIN2,1)
ENDIF
IF(IDICHR.GE.1) THEN
SF_2=SF_2+TAB(JLIN,4)
SR_2=SR_2+TAB(JLIN,3)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
SF2_2=SF2_2+TAB(JLIN2,4)
SR2_2=SR2_2+TAB(JLIN2,3)
ENDIF
ENDIF
ENDDO
IF(I_EXT.LE.0) THEN
IF(STEREO.EQ.' NO') THEN
JPHI2=JPHI
ELSE
JPHI2=(JTHETA-1)*NPHI+JPHI
ENDIF
ELSE
JPHI2=JTHETA
ENDIF
IF(IDICHR.EQ.0) THEN
WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
&_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
&),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S
&R_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
&E),SR2_1,SF2_1,SR2_2,SF2_2
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
C
GOTO 6
C
5 WRITE(IUO1,4)
STOP
35 WRITE(IUO1,36) N_FIXED
STOP
37 WRITE(IUO1,38) NTHETA*NPHI
STOP
C
1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
&THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>')
7 FORMAT(I4,2X,I4,2X,I4)
8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
9 FORMAT(9(2X,I1),2X,I2)
15 FORMAT(2X,A3,11X,A13)
22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1
&2.6,2X,E12.6)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
25 FORMAT(37X,E12.6,2X,E12.6)
36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL ',
&'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<<
&SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE I
&NCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE AT
&LEAST ',I6,' >>>>>>>>>>')
888 FORMAT(A72)
C
6 RETURN
C
END

335
src/msspec/spec/fortran/phd_ce_noso_nosp_nosym/weight_sum.f
View File

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

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

5
src/msspec/tests.py
View File

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

66
src/msspec/utils.py
View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -19,8 +18,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/utils.py
# Last modified: Thu, 06 Oct 2022 18:27:24 +0200
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr> 1665073644 +0200
# Last modified: Thu, 06 Oct 2022 18:19:16 +0200
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr> 1665073156 +0200
"""
@ -71,7 +70,7 @@ class ForeignPotential(object):
self.phagen_data = {'types': []}
def write(self, filename, prototypical_atoms):
LOGGER.debug("Writing Phagen input potential file: {}".format(filename))
LOGGER.debug(f"Writing Phagen input potential file: {filename}")
def DEPRECATEDappend_atom_potential(atom):
Z = atom.number
@ -82,8 +81,8 @@ class ForeignPotential(object):
itypes.append(i)
# Check now that we have only one type in the list
# otherwise we do not know yet how to deal with this.
assert len(itypes) > 0, "Cannot find the data for atom with Z={}".format(Z)
assert len(itypes) == 1, "Too many datasets for atom with Z={}".format(Z)
assert len(itypes) > 0, f"Cannot find the data for atom with Z={Z}"
assert len(itypes) == 1, f"Too many datasets for atom with Z={Z}"
# So far so good, let's write the block
t = self.phagen_data['types'][itypes[0]]
s = "{:<7d}{:<10d}{:1.4f}\n".format(
@ -96,7 +95,7 @@ class ForeignPotential(object):
def append_atom_potential(atom):
line_fmt = "{:+1.8e} " * 4 + "\n"
atom_type = atom.get('atom_type')
assert atom_type != None, "Unable get the atom type!"
assert atom_type != None, f"Unable get the atom type!"
for t in self.phagen_data['types']:
if t['atom_type'] == atom_type:
s = "{:<7d}{:<10d}{:1.4f}\n".format(
@ -139,7 +138,7 @@ class SPRKKRPotential(ForeignPotential):
self.potfile = potfile
self.load_sprkkr_atom_types()
for f in exported_files:
LOGGER.info("Loading file {}...".format(f))
LOGGER.info(f"Loading file {f}...")
# get the IT from the filename
m=re.match('SPRKKR-IT_(?P<IT>\d+)-PHAGEN.*', os.path.basename(f))
it = int(m.group('IT'))
@ -193,7 +192,7 @@ class SPRKKRPotential(ForeignPotential):
return data
# load info in *.pot file
LOGGER.info("Loading SPRKKR *.pot file {}...".format(self.potfile))
LOGGER.info(f"Loading SPRKKR *.pot file {self.potfile}...")
with open(self.potfile, 'r') as fd:
content = fd.read()
@ -234,7 +233,7 @@ class SPRKKRPotential(ForeignPotential):
IT = occupation['ITOQ']
atom = self.atoms[i]
atom.set('atom_type', IT)
LOGGER.debug("Site #{} is type #{}, atom {}".format(IQ, IT, atom))
LOGGER.debug(f"Site #{IQ} is type #{IT}, atom {atom}")
@ -315,13 +314,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 +429,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]

38
src/msspec/version.py
View File

@ -1,5 +1,4 @@
#!/usr/bin/env python
# coding: utf-8
#
# Copyright © 2016-2020 - Rennes Physics Institute
#
@ -17,8 +16,8 @@
# along with this msspec. If not, see <http://www.gnu.org/licenses/>.
#
# Source file : src/msspec/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: Thu, 06 Oct 2022 18:19:16 +0200
# Committed by : Sylvain Tricot <sylvain.tricot@univ-rennes1.fr> 1665073156 +0200
import os
@ -27,29 +26,28 @@ from importlib.metadata import version
import subprocess
# find the version number
# 1- Try to read it from the git info
# 2- If it fails, try to read it from the VERSION file
# 3- If it fails, try to read it from the distribution file
# 1- If it fails, try to read it from the distribution file
# 2- Try to read it from the git info
# 3- If it fails, try to read it from the VERSION file
PKGNAME = 'msspec'
thisfile_path = os.path.abspath(__file__)
thisfile_dir = os.path.dirname(thisfile_path)
try:
cmd = ["git describe|sed 's/-\([0-9]\+\)-.*/.dev\\1/g'"]
result = subprocess.run(cmd, stdout=subprocess.PIPE, stderr=subprocess.DEVNULL,
shell=True, cwd=thisfile_dir)
__version__ = result.stdout.decode('utf-8').strip()
if __version__ == "":
raise
__version__ = version(PKGNAME)
except Exception as err:
try:
versionfile = os.path.join(thisfile_dir, "./VERSION")
with open(versionfile, "r") as fd:
__version__ = fd.readline().strip()
p = subprocess.run(["git", "describe"], capture_output=True, text=True)
if p.stdout not in ("", None):
__version__ = p.stdout.strip()
else:
raise NameError("git describe failed!")
except Exception as err:
try:
__version__ = version(PKGNAME)
thisfile_path = os.path.abspath(__file__)
thisfile_dir = os.path.dirname(thisfile_path)
versionfile = os.path.join(thisfile_dir, "../VERSION")
with open(versionfile, "r") as fd:
__version__ = fd.readline().strip()
except Exception as err:
__version__ = "0.0.0"
print("Unable to get the version number!")
__version__ = "9.9.9"

6
src/options.mk
View File

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

2
src/pip.freeze
View File

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

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

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

Binary file not shown.