diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b5578b2 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +__pycache__ +*.py[cod] +*.so +*.bak diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..7e9337a --- /dev/null +++ b/Makefile @@ -0,0 +1,20 @@ +MAKESELF:=makeself +LICENSE:=$(shell cat ./license.txt) +VERSION:=$(shell cd src && python -c "import msspec; print(msspec.__version__)") +SETUPFILE:=pymsspec-$(VERSION).setup + +.PHONY: clean + +clean: + @rm -rf *.setup + +purge: clean + @echo "Purging all..." + @find ./src -type f -name '*.pyc' -exec rm {} + + @find ./src -type d -name '__pycache__' -exec rm -r {} + + +$(MAKE) -C src/ clean + +selfex: purge + @echo "Creating the self-extractible setup program... " + $(MAKESELF) --license "$(LICENSE)" ./src $(SETUPFILE) "Python MsSpec" ./install.sh + diff --git a/README.md b/README.md new file mode 100644 index 0000000..ed28f41 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +To install +========== + + +```Bash +make selfex +./pymsspec-###.setup +``` diff --git a/license.txt b/license.txt new file mode 100644 index 0000000..3d50ac0 --- /dev/null +++ b/license.txt @@ -0,0 +1 @@ +Realeased under the GNU General Public License . diff --git a/src/MANIFEST.in b/src/MANIFEST.in new file mode 100644 index 0000000..e63bcb2 --- /dev/null +++ b/src/MANIFEST.in @@ -0,0 +1,2 @@ +include msspec/spec/*.so +include msspec/phagen/*.so diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..b85875b --- /dev/null +++ b/src/Makefile @@ -0,0 +1,18 @@ +VERSION:=$(shell python -c "import msspec; print(msspec.__version__)") + +install: sdist + @pip install dist/msspec-$(VERSION).tar.gz + +sdist: pybinding + @python setup.py sdist + +pybinding: + +$(MAKE) -C msspec/spec/fortran pybinding + +$(MAKE) -C msspec/phagen/fortran pybinding + +clean: + +$(MAKE) -C msspec/spec/fortran clean + +$(MAKE) -C msspec/phagen/fortran clean + @rm -rf dist + @rm -rf *.egg* + diff --git a/src/install.sh b/src/install.sh new file mode 100644 index 0000000..b22f3aa --- /dev/null +++ b/src/install.sh @@ -0,0 +1,3 @@ +#!/bin/bash + +make install diff --git a/src/msspec/__init__.py b/src/msspec/__init__.py new file mode 100644 index 0000000..0e544ba --- /dev/null +++ b/src/msspec/__init__.py @@ -0,0 +1 @@ +__version__ = '1.2rc3.post152' diff --git a/src/msspec/calcio.py b/src/msspec/calcio.py new file mode 100644 index 0000000..b56e88a --- /dev/null +++ b/src/msspec/calcio.py @@ -0,0 +1,957 @@ +# coding: utf-8 + +""" +Module calcio +============= + +""" + +import numpy as np +from datetime import datetime +import ase +import re + +from msspec.misc import UREG, LOGGER + +class PhagenIO(object): + def __init__(self, phagen_parameters, malloc_parameters): + self.parameters = phagen_parameters + self.malloc_parameters = malloc_parameters + + self.tl = None + self.nat = None + self.nateqm = None + self.ne = None + self.ipot = None + self.lmax_mode = None + self.nlmax = None + self.energies = None + + def write_input_file(self, filename='input.ms'): + # in input folder + atoms = self.parameters.atoms + if not atoms.has('mt_radii'): + for a in atoms: + a.set('mt_radius', 0.) + + if not atoms.has('mt_radii_scale'): + for a in atoms: + a.set('mt_radius_scale', 1.) + + radii = atoms.get_array('mt_radii') + radii_scale = atoms.get_array('mt_radii_scale') + + if np.all(radii == 0) and np.all(radii_scale == 1): + self.parameters.norman = 'stdcrm' + elif np.all(radii == 0) and np.any(radii_scale != 1): + self.parameters.norman = 'scaled' + radii = radii_scale + else: + self.parameters.norman = 'extrad' + radii *= radii_scale + + parameters = [] + for parameter in self.parameters: + name = parameter.name + if name in ('ionicity', 'atoms'): + # skip ionicity and atoms parameters as they are treated in + # other sections + continue + value = parameter.value + if isinstance(value, str) and not re.match('\..*\.', value): + s = ' {}=\'{:s}\''.format(name, str(parameter)) + else: + s = ' {}={:s}'.format(name, str(parameter)) + parameters.append(s) + + header = " &job\n" + header += ',\n'.join(parameters) + "\n &end\n" + header += (' c Auto-generated file on {}\n Computes the T-matrix and ' + 'radial matrix elements\n\n').format( + datetime.ctime(datetime.now())) + + # cluster section + try: + absorber = atoms.absorber + except AttributeError as err: + print(err) + absorber = 0 + + cluster_section = '' + absorber_line = '' + line_format = '{:>10s}{:4d}{:11.6f}{:14.6f}{:14.6f}{:13.4f}\n' + for iat, atom in enumerate(atoms): + symbol = atom.symbol + if symbol == 'X': + symbol = 'ES' + number = atom.number + x, y, z = atom.position + r = radii[iat] + cluster_line = line_format.format(symbol, number, x, y, z, r) + # store absober line + if atom.index == absorber: + absorber_line = cluster_line + else: + cluster_section += cluster_line + + cluster_section = absorber_line + cluster_section + cluster_section += '{:10d}{:4d}{:10.0f}{:9.0f}{:9.0f}{:8.0f}\n'.format( + -1, -1, 0, 0, 0, 0) + + # Ionicity section + ionicity = self.parameters.ionicity + ionicity_section = '' + ionicity_format = '{:8d}{:9.2f}\n' + symbols = set(atoms.get_chemical_symbols()) + for symbol in symbols: + try: + charge = ionicity[symbol] + except KeyError: + charge = 0. + ionicity_section += ionicity_format.format( + ase.data.atomic_numbers[symbol], + charge) + ionicity_section += '{:8d}\n'.format(-1) + + content = header + cluster_section + ionicity_section + + # Write the content to filename + try: + with open(filename, 'r') as fd: + old_content = fd.read() + except IOError: + old_content = '' + + pat = re.compile(r' c .*\n') + + modified = False + if pat.sub('', content) != pat.sub('', old_content): + with open(filename, 'w') as fd: + fd.write(content) + modified = True + + return modified + + def write_include_file(self, filename='msxas3.inc'): + # read the whole include file content + with open(filename, 'r') as fd: + content = fd.read() + + # backup the content in memory + old_content = content + + # replace the content + for p in self.malloc_parameters: + content = re.sub(r'({:s}\s*=\s*)\d+'.format(p.name), + r'\g<1>{:d}'.format(p.value), content) + + # actually write to the file only if different from the previous file + modified = False + if content != old_content: + with open(filename, 'w') as fd: + fd.write(content) + modified = True + return modified + + def load_tl_file(self, filename='tmatrix.tl'): + atom_data = [] + + # load all the file in the string 'content' + with open(filename, 'r') as fd: + content = fd.read() + + # convert the file to a (nat x ne) array + # + # first, split the content in a list for each atom + pattern = re.compile(r'-+\s*ATOM.*-+') + lines = pattern.split(content) + + # get the number of atoms (nat) and the number of energy points (ne) + nat, ne, _, ipot, lmax_mode = list(map(int, content.split('\n')[0].split())) + self.nat = nat + self.ne = ne + self.ipot = ipot + self.lmax_mode = lmax_mode + + # extract atom data + for line in lines: + numbers_str = ''.join(line.strip().split('\n')).split() + numbers = [] + for n in numbers_str: + if not re.match(r'^\d+$', n): + numbers.append(float(n)) + if len(numbers) > 0: + array = np.array(numbers).reshape((-1, 4)) # pylint: disable=no-member + atom_data.append(array) + + # construct the data array + data = [] + for i in range(nat): + data.append([]) + for j in range(ne): + data[i].append(atom_data[j * nat + i]) + + self.tl = data + return data + + def write_tl_file(self, filename='tmatrix.tl'): + + def get_lmaxs(ie): + lmaxs = np.zeros(int(4 * np.ceil(self.nat / 4.)), dtype=int) + for a in range(self.nat): + lmaxs[a] = len(self.tl[a][ie]) - 1 + lmaxs = lmaxs.reshape((-1, 4)) + return lmaxs + + def get_energies(unit='eV'): + emin = self.parameters.emin + emax = self.parameters.emax + delta = self.parameters.delta + energies = np.arange(emin, emax, delta) + if len(energies) == 0: + energies = np.array([emin]) + if energies[-1] + delta / 2 < emax: + energies = np.append(energies, energies[-1] + delta) + + # conversion in eV + if unit == 'eV': + energies = (energies * UREG.Ry).to('eV') + + return energies + + def custom_strfloat(f): + mantissa, exponent = '{:.10E}'.format(f).split('E') + m = format(float(mantissa) / 10, '.6f').replace('-0', '-') + e = format(int(exponent) + 1, '+03d') + return ' {}E{}'.format(m, e) + + with open(filename, 'w') as fd: + fd.write('{:>9}{:>9}{:>9}{:>9}{:>9}\n'.format(self.nat, self.ne, 1, + self.ipot, + self.lmax_mode)) + + nlmax = 0 + for ie in range(self.ne): + # write all lmaxs for each energy set + lmaxs = get_lmaxs(ie) + nlmax = int(max(nlmax, np.max(lmaxs))) + fmt1 = '{:>9}' * 4 + '\n' + fmt2 = '{:12.4f}{:10.4f}' + for _ in lmaxs: + fd.write(fmt1.format(*_)) + + for ia in range(self.nat): + # write the atom header line + fd.write('{}ATOM{:>4}{}\n'.format('-' * 26 + ' ', ia + 1, + ' ' + '-' * 23)) + for _a, _b, _c, _d in self.tl[ia][ie]: + fd.write(fmt2.format(_a, _b)) + fd.write(custom_strfloat(_c)) + fd.write(custom_strfloat(_d)) + fd.write('\n') + self.nlmax = nlmax + self.energies = get_energies() + + def load_cluster_file(self, filename='cluster.clu'): + data = np.loadtxt(filename, skiprows=1, usecols=(0, 2, 3, 4, 5, 6)) + atoms = self.parameters.atoms + + absorber_position = atoms[atoms.absorber].position + positions = data[:, 2:5] + absorber_position + + proto_indices = [] + for atom in atoms: + i = np.argmin(np.linalg.norm(positions - atom.position, axis=1)) + proto_index = int(data[i, -1]) + proto_indices.append(proto_index) + atoms.set_array('proto_indices', np.array(proto_indices)) + self.nateqm = int(np.max([len(np.where(data[:,-1]==i)[0]) for i in range( + 1, self.nat + 1)])) + + def load_potential_file(self, filename='plot_vc.dat'): + a_index = 0 + pot_data = [] + with open(filename, 'r') as fd: + data = fd.readlines() + + for d in data: + if d[1] == 'a': + a_index += 1 + d = d.split() + a = {'Symbol': d[1], 'distance': float(d[4]), + 'coord': np.array([float(d[7]), float(d[8]), float(d[9])]), + 'index': int(a_index), 'values': []} + pot_data.append(a) + else: + pot_data[a_index - 1]['values'].append(tuple(float(_) for _ in d.split())) + + # convert the values list to a numpy array + for _pot_data in pot_data: + v = _pot_data['values'] + _pot_data['values'] = np.asarray(v) + + return pot_data + +class SpecIO(object): + def __init__(self, parameters, malloc_parameters, phagenio): + self.parameters = parameters + self.malloc_parameters = malloc_parameters + self.phagenio = phagenio + + def write_input_file(self, filename='spec.dat'): + def title(t, shift=4, width=79, center=True): + if center: + s = ('{}*{:^%ds}*\n' % (width - shift - 2)).format(' ' * shift, t) + else: + s = ('{}*{:%ds}*\n' % (width - shift - 2)).format(' ' * shift, t) + return s + + def rule(tabs=(5, 10, 10, 10, 10), symbol='=', shift=4, width=79): + s = ' ' * shift + '*' + symbol * (width - shift - 2) + '*\n' + t = np.cumsum(tabs) + shift + l = list(s) + for i in t: + l[i] = '+' + return ''.join(l) + + def fillstr(a, b, index, justify='left'): + alist = list(a) + + if justify == 'left': + offset = -len(b) + 1 + elif justify == 'center': + offset = (-len(b) + 1) / 2 + elif justify == 'decimal': + try: + offset = -(b.index('.') - 1) + except ValueError: + offset = 0 + else: + offset = 0 + + for i, _ in enumerate(b): + alist[int(index + offset + i)] = _ + return ''.join(alist) + + def create_line(legend='', index=49, dots=False): + s = ' ' * 79 + '\n' + if dots: + s = fillstr(s, "..", 6, justify='right') + s = fillstr(s, "*", 4) + s = fillstr(s, "*", 78) + s = fillstr(s, legend, index, justify='right') + return s + + p = self.parameters + + content = rule(tabs=(), symbol='*') + content += title('spec input file') + content += rule(tabs=(), symbol='*') + content += rule(tabs=(), symbol='=') + + content += title('CRYSTAL STRUCTURE :') + content += rule() + line = create_line("CRIST,CENTR,IBAS,NAT") + line = fillstr(line, "CUB", 9, 'left') + line = fillstr(line, "P", 19, 'left') + line = fillstr(line, format(0, 'd'), 29, 'left') + line = fillstr(line, str(p.get_parameter('extra_nat')), 39, 'left') + content += line + line = create_line("A,BSURA,CSURA,UNIT") + line = fillstr(line, format(1., '.4f'), 9, 'decimal') + line = fillstr(line, format(1., '.3f'), 19, 'decimal') + line = fillstr(line, format(1., '.3f'), 29, 'decimal') + line = fillstr(line, "ATU", 39, 'left') + content += line + line = create_line("ALPHAD,BETAD,GAMMAD") + line = fillstr(line, format(90., '.2f'), 9, 'decimal') + line = fillstr(line, format(90., '.2f'), 19, 'decimal') + line = fillstr(line, format(90., '.2f'), 29, 'decimal') + content += line + line = create_line("H,K,I,L") + line = fillstr(line, format(0, 'd'), 9, 'left') + line = fillstr(line, format(0, 'd'), 19, 'left') + line = fillstr(line, format(0, 'd'), 29, 'left') + line = fillstr(line, format(1, 'd'), 39, 'left') + content += line + line = create_line("NIV,COUPUR,ITEST,IESURF") + line = fillstr(line, format(8, 'd'), 9, 'left') + line = fillstr(line, format(1.4, '.2f'), 19, 'decimal') + line = fillstr(line, format(0, 'd'), 29, 'left') + line = fillstr(line, format(1, 'd'), 39, 'left') + content += line + line = create_line("ATBAS,CHEM(NAT),NZAT(NAT)") + line = fillstr(line, format(0., '.6f'), 9, 'decimal') + line = fillstr(line, format(0., '.6f'), 19, 'decimal') + line = fillstr(line, format(0., '.6f'), 29, 'decimal') + line = fillstr(line, format("Mg", '>2s'), 39, 'right') + line = fillstr(line, format(12, '>2d'), 43, 'right') + content += line + line = create_line("ATBAS,CHEM(NAT),NZAT(NAT)") + line = fillstr(line, format(0., '.6f'), 9, 'decimal') + line = fillstr(line, format(0.5, '.6f'), 19, 'decimal') + line = fillstr(line, format(0., '.6f'), 29, 'decimal') + line = fillstr(line, format("O", '>2s'), 39, 'right') + line = fillstr(line, format(8, '>2d'), 43, 'right') + content += line + line = create_line("VECBAS") + line = fillstr(line, format(1., '.6f'), 9, 'decimal') + line = fillstr(line, format(0., '.6f'), 19, 'decimal') + line = fillstr(line, format(0., '.6f'), 29, 'decimal') + content += line + line = create_line("VECBAS") + line = fillstr(line, format(0., '.6f'), 9, 'decimal') + line = fillstr(line, format(1., '.6f'), 19, 'decimal') + line = fillstr(line, format(0., '.6f'), 29, 'decimal') + content += line + line = create_line("VECBAS") + line = fillstr(line, format(0., '.6f'), 9, 'decimal') + line = fillstr(line, format(0., '.6f'), 19, 'decimal') + line = fillstr(line, format(1., '.6f'), 29, 'decimal') + content += line + line = create_line("IREL,NREL,PCREL(NREL)") + line = fillstr(line, format(0, 'd'), 9, 'left') + line = fillstr(line, format(0, 'd'), 19, 'left') + line = fillstr(line, format(0., '.1f'), 29, 'decimal') + line = fillstr(line, format(0., '.1f'), 39, 'decimal') + content += line + line = create_line("OMEGA1,OMEGA2,IADS") + line = fillstr(line, format(28., '.2f'), 9, 'decimal') + line = fillstr(line, format(0., '.2f'), 19, 'decimal') + line = fillstr(line, format(1, 'd'), 29, 'left') + content += line + content += rule() + + content += title('TYPE OF CALCULATION :') + content += rule() + line = create_line("SPECTRO,ISPIN,IDICHR,IPOL") + line = fillstr(line, str(p.calctype_spectro), 9, 'left') + line = fillstr(line, str(p.get_parameter('calctype_ispin')), 19, 'left') + line = fillstr(line, str(p.calctype_idichr), 29, 'left') + line = fillstr(line, str(p.calctype_ipol), 39, 'left') + content += line + line = create_line("I_AMP") + line = fillstr(line, str(p.calctype_iamp), 9, 'left') + content += line + content += rule() + + content += title('PhD EXPERIMENTAL PARAMETERS :') + content += rule() + line = create_line("LI,S-O,INITL,I_SO") + line = fillstr(line, str(p.ped_li), 9, 'left') + line = fillstr(line, str(p.ped_so), 19, 'center') + line = fillstr(line, str(p.ped_initl), 29, 'left') + line = fillstr(line, str(p.ped_iso), 39, 'left') + content += line + line = create_line("IPHI,ITHETA,IE,IFTHET") + line = fillstr(line, str(p.ped_iphi), 9, 'left') + line = fillstr(line, str(p.ped_itheta), 19, 'left') + line = fillstr(line, str(p.ped_ie), 29, 'left') + line = fillstr(line, str(p.ped_ifthet), 39, 'left') + content += line + line = create_line("NPHI,NTHETA,NE,NFTHET") + line = fillstr(line, str(p.ped_nphi), 9, 'left') + line = fillstr(line, str(p.ped_ntheta), 19, 'left') + line = fillstr(line, str(p.ped_ne), 29, 'left') + line = fillstr(line, str(p.ped_nfthet), 39, 'left') + content += line + line = create_line("PHI0,THETA0,E0,R0") + line = fillstr(line, str(p.get_parameter('ped_phi0')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_theta0')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_e0')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_r0')), 39, 'decimal') + content += line + line = create_line("PHI1,THETA1,E1,R1") + line = fillstr(line, str(p.get_parameter('ped_phi1')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_theta1')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_e1')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_r1')), 39, 'decimal') + content += line + line = create_line("THLUM,PHILUM,ELUM") + line = fillstr(line, str(p.get_parameter('ped_thlum')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_philum')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_elum')), 29, 'decimal') + content += line + line = create_line("IMOD,IMOY,ACCEPT,ICHKDIR") + line = fillstr(line, str(p.get_parameter('ped_imod')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_imoy')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_accept')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('ped_ichkdir')), 39, 'decimal') + content += line + content += rule() + + content += title(' ' * 22 + 'LEED EXPERIMENTAL PARAMETERS :', center=False) + content += rule() + line = create_line("IPHI,ITHETA,IE,IFTHET") + line = fillstr(line, str(p.get_parameter('leed_iphi')), 9, 'left') + line = fillstr(line, str(p.get_parameter('leed_itheta')), 19, 'left') + line = fillstr(line, str(p.get_parameter('leed_ie')), 29, 'left') + line = fillstr(line, str(p.get_parameter('leed_ifthet')), 39, 'left') + content += line + line = create_line("NPHI,NTHETA,NE,NFTHET") + line = fillstr(line, str(p.get_parameter('leed_nphi')), 9, 'left') + line = fillstr(line, str(p.get_parameter('leed_ntheta')), 19, 'left') + line = fillstr(line, str(p.get_parameter('leed_ne')), 29, 'left') + line = fillstr(line, str(p.get_parameter('leed_nfthet')), 39, 'left') + content += line + line = create_line("PHI0,THETA0,E0,R0") + line = fillstr(line, str(p.get_parameter('leed_phi0')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_theta0')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_e0')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_r0')), 39, 'decimal') + content += line + line = create_line("PHI1,THETA1,E1,R1") + line = fillstr(line, str(p.get_parameter('leed_phi1')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_theta1')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_e1')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_r1')), 39, 'decimal') + content += line + line = create_line("TH_INI,PHI_INI") + line = fillstr(line, str(p.get_parameter('leed_thini')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_phiini')), 19, 'decimal') + content += line + line = create_line("IMOD,IMOY,ACCEPT,ICHKDIR") + line = fillstr(line, str(p.get_parameter('leed_imod')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_imoy')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_accept')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('leed_ichkdir')), 39, + 'decimal') + content += line + content += rule() + + content += title(' ' * 21 + 'EXAFS EXPERIMENTAL PARAMETERS :', center=False) + content += rule() + line = create_line("EDGE,INITL,THLUM,PHILUM") + line = fillstr(line, str(p.get_parameter('exafs_edge')), 9, 'left') + line = fillstr(line, str(p.get_parameter('exafs_initl')), 19, 'left') + line = fillstr(line, str(p.get_parameter('exafs_thlum')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('exafs_philum')), 39, + 'decimal') + content += line + line = create_line("NE,EK_INI,EK_FIN,EPH_INI") + line = fillstr(line, str(p.get_parameter('exafs_ne')), 9, 'left') + line = fillstr(line, str(p.get_parameter('exafs_ekini')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('exafs_ekfin')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('exafs_ephini')), 39, + 'decimal') + content += line + content += rule() + + content += title(' ' * 22 + 'AED EXPERIMENTAL PARAMETERS :', center=False) + content += rule() + line = create_line("EDGE_C,EDGE_I,EDGE_A") + line = fillstr(line, str(p.get_parameter('aed_edgec')), 9, 'left') + line = fillstr(line, str(p.get_parameter('aed_edgei')), 19, 'left') + line = fillstr(line, str(p.get_parameter('aed_edgea')), 29, 'left') + content += line + line = create_line("I_MULT,MULT") + line = fillstr(line, str(p.get_parameter('aed_imult')), 9, 'left') + line = fillstr(line, str(p.get_parameter('aed_mult')), 19, 'center') + content += line + line = create_line("IPHI,ITHETA,IFTHET,I_INT") + line = fillstr(line, str(p.get_parameter('aed_iphi')), 9, 'left') + line = fillstr(line, str(p.get_parameter('aed_itheta')), 19, 'left') + line = fillstr(line, str(p.get_parameter('aed_ifthet')), 29, 'left') + line = fillstr(line, str(p.get_parameter('aed_iint')), 39, 'left') + content += line + line = create_line("NPHI,NTHETA,NFTHET") + line = fillstr(line, str(p.get_parameter('aed_nphi')), 9, 'left') + line = fillstr(line, str(p.get_parameter('aed_ntheta')), 19, 'left') + line = fillstr(line, str(p.get_parameter('aed_nfthet')), 29, 'left') + content += line + line = create_line("PHI0,THETA0,R0") + line = fillstr(line, str(p.get_parameter('aed_phi0')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('aed_theta0')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('aed_r0')), 29, 'decimal') + content += line + line = create_line("PHI1,THETA1,R1") + line = fillstr(line, str(p.get_parameter('aed_phi1')), 9, 'decimal') + line = fillstr(line, str(p.get_parameter('aed_theta1')), 19, 'decimal') + line = fillstr(line, str(p.get_parameter('aed_r1')), 29, 'decimal') + content += line + line = create_line("IMOD,IMOY,ACCEPT,ICHKDIR") + line = fillstr(line, str(p.get_parameter('aed_imod')), 9, 'left') + line = fillstr(line, str(p.get_parameter('aed_imoy')), 19, 'left') + line = fillstr(line, str(p.get_parameter('aed_accept')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('aed_ichkdir')), 39, 'left') + content += line + content += rule() + + content += title(' ' * 19 + 'EIGENVALUE CALCULATION PARAMETERS :', + center=False) + content += rule() + line = create_line("NE,EK_INI,EK_FIN,I_DAMP") + line = fillstr(line, str(p.get_parameter('eigval_ne')), 9, 'left') + line = fillstr(line, str(p.get_parameter('eigval_ekini')), 19, + 'decimal') + line = fillstr(line, str(p.get_parameter('eigval_ekfin')), 29, + 'decimal') + line = fillstr(line, str(p.get_parameter('eigval_idamp')), 39, 'left') + content += line + + if p.get_parameter('calctype_spectro') == "EIG": + nlines = int(np.ceil(p.eigval_ne / 4.)) + else: + nlines = 1 + table = np.chararray((nlines, 4), unicode=True) + table[:] = str(p.get_parameter('eigval_ispectrum_ne').default) + for i in range(nlines): + line = create_line("I_SPECTRUM(NE)") + for j, o in enumerate((9, 19, 29, 39)): + line = fillstr(line, table[i, j], o, 'left') + content += line + + line = create_line("I_PWM,METHOD,ACC,EXPO") + line = fillstr(line, str(p.get_parameter('eigval_ipwm')), 9, 'left') + line = fillstr(line, str(p.get_parameter('eigval_method')), 19, 'left') + line = fillstr(line, str(p.get_parameter('eigval_acc')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('eigval_expo')), 39, 'decimal') + content += line + line = create_line("N_MAX,N_ITER,N_TABLE,SHIFT") + line = fillstr(line, str(p.get_parameter('eigval_nmax')), 9, 'left') + line = fillstr(line, str(p.get_parameter('eigval_niter')), 19, 'left') + line = fillstr(line, str(p.get_parameter('eigval_ntable')), 29, 'left') + line = fillstr(line, str(p.get_parameter('eigval_shift')), 39, + 'decimal') + content += line + line = create_line("I_XN,I_VA,I_GN,I_WN") + line = fillstr(line, str(p.get_parameter('eigval_ixn')), 9, 'left') + line = fillstr(line, str(p.get_parameter('eigval_iva')), 19, 'left') + line = fillstr(line, str(p.get_parameter('eigval_ign')), 29, 'left') + line = fillstr(line, str(p.get_parameter('eigval_iwn')), 39, 'left') + content += line + line = create_line("L,ALPHA,BETA") + line = fillstr(line, str(p.get_parameter('eigval_l')), 9, 'left') + line = fillstr(line, str(p.get_parameter('eigval_alpha')), 19, + 'decimal') + line = fillstr(line, str(p.get_parameter('eigval_beta')), 29, + 'decimal') + content += line + content += rule() + + content += title(' ' * 24 + 'CALCULATION PARAMETERS :', center=False) + content += rule() + line = create_line("NO,NDIF,ISPHER,I_GR") + line = fillstr(line, str(p.get_parameter('calc_no')), 9, 'left') + line = fillstr(line, str(p.get_parameter('calc_ndif')), 19, 'left') + line = fillstr(line, str(p.get_parameter('calc_ispher')), 29, 'left') + line = fillstr(line, str(p.get_parameter('calc_igr')), 39, 'left') + content += line + line = create_line("ISFLIP,IR_DIA,ITRTL,I_TEST") + line = fillstr(line, str(p.get_parameter('calc_isflip')), 9, 'left') + line = fillstr(line, str(p.get_parameter('calc_irdia')), 19, 'left') + line = fillstr(line, str(p.get_parameter('calc_itrtl')), 29, 'left') + line = fillstr(line, str(p.get_parameter('calc_itest')), 39, 'left') + content += line + line = create_line("NEMET,IEMET(NEMET)") + line = fillstr(line, format(1, 'd'), 9, 'left') + line = fillstr(line, format(1, 'd'), 19, 'left') + line = fillstr(line, format(0, 'd'), 29, 'left') + line = fillstr(line, format(0, 'd'), 39, 'left') + content += line + line = create_line("ISOM,NONVOL,NPATH,VINT") + line = fillstr(line, str(p.get_parameter('calc_isom')), 9, 'left') + line = fillstr(line, str(p.get_parameter('calc_nonvol')), 19, 'left') + line = fillstr(line, str(p.get_parameter('calc_npath')), 29, 'left') + line = fillstr(line, str(p.get_parameter('calc_vint')), 39, 'decimal') + content += line + line = create_line("IFWD,NTHOUT,I_NO,I_RA") + line = fillstr(line, str(p.get_parameter('calc_ifwd')), 9, 'left') + line = fillstr(line, str(p.get_parameter('calc_nthout')), 19, 'left') + line = fillstr(line, str(p.get_parameter('calc_ino')), 29, 'left') + line = fillstr(line, str(p.get_parameter('calc_ira')), 39, 'left') + content += line + + nat = p.extra_nat + nra_arr = np.ones((nat), dtype=np.int) + thfwd_arr = np.ones((nat)) + path_filtering = p.extra_parameters['calculation'].get_parameter( + 'path_filtering').value + if path_filtering != None and 'backward_scattering' in path_filtering: + ibwd_arr = np.ones((nat), dtype=np.int) + else: + ibwd_arr = np.zeros((nat), dtype=np.int) + thbwd_arr = np.ones((nat)) + for at in p.extra_atoms: + i = at.get('proto_index') - 1 + thfwd_arr[i] = at.get('forward_angle') + thbwd_arr[i] = at.get('backward_angle') + nra_arr[i] = at.get('RA_cut_off') + for i in range(p.extra_nat): + line = create_line("N_RA,THFWD,IBWD,THBWD(NAT)", dots=True) + line = fillstr(line, format(nra_arr[i], 'd'), 9, 'left') + line = fillstr(line, format(thfwd_arr[i], '.2f'), 19, 'decimal') + line = fillstr(line, format(ibwd_arr[i], 'd'), 29, 'left') + line = fillstr(line, format(thbwd_arr[i], '.2f'), 39, 'decimal') + content += line + + line = create_line("IPW,NCUT,PCTINT,IPP") + line = fillstr(line, str(p.get_parameter('calc_ipw')), 9, 'left') + line = fillstr(line, str(p.get_parameter('calc_ncut')), 19, 'left') + line = fillstr(line, str(p.get_parameter('calc_pctint')), 29, 'decimal') + line = fillstr(line, str(p.get_parameter('calc_ipp')), 39, 'left') + content += line + line = create_line("ILENGTH,RLENGTH,UNLENGTH") + line = fillstr(line, str(p.get_parameter('calc_ilength')), 9, 'left') + line = fillstr(line, str(p.get_parameter('calc_rlength')), 19, + 'decimal') + line = fillstr(line, str(p.get_parameter('calc_unlength')), 29, 'left') + content += line + line = create_line("IDWSPH,ISPEED,IATT,IPRINT") + # Here, if 'vibrational_damping' is None, use the 'debye_waller' + # approach and the debye model for the mean square displacements + # and set the temeprature to 0K and the Debye temeparture to 500K. + calc_param = p.extra_parameters['calculation'] + if calc_param.vibrational_damping is None: + idwsph = format(0, 'd') + idcm = format(2, 'd') + temp = format(0., '.2f') + td = format(500., '.2f') + LOGGER.warning('Vibrational damping is disabled for this calculation.') + else: + idwsph = str(p.get_parameter('calc_idwsph')) + idcm = str(p.get_parameter('calc_idcm')) + temp = str(p.get_parameter('calc_t')) + td = str(p.get_parameter('calc_td')) + ispeed = str(p.get_parameter('calc_ispeed')) + line = fillstr(line, idwsph, 9, 'left') + line = fillstr(line, ispeed, 19, 'left') + line = fillstr(line, str(p.get_parameter('calc_iatt')), 29, 'left') + line = fillstr(line, str(p.get_parameter('calc_iprint')), 39, 'left') + content += line + line = create_line("IDCM,TD,T,RSJ") + line = fillstr(line, idcm, 9, 'left') + line = fillstr(line, td, 19, 'decimal') + line = fillstr(line, temp, 29, 'decimal') + line = fillstr(line, str(p.get_parameter('calc_rsj')), 39, 'decimal') + content += line + line = create_line("ILPM,XLPM0") + line = fillstr(line, str(p.get_parameter('calc_ilpm')), 9, 'left') + line = fillstr(line, str(p.get_parameter('calc_xlpm0')), 19, 'decimal') + content += line + + nat = p.extra_nat + nlines = int(np.ceil(nat / 4.)) + uj2_array = np.zeros((4 * nlines)) + # Now, for each atom in the cluster, get the mean_square_vibration and + # store it in the index corresponding to the prototypical index + for at in p.extra_atoms: + i = at.get('proto_index') - 1 + msq_vib = at.get('mean_square_vibration') + uj2_array[i] = msq_vib + uj2_array = uj2_array.reshape((nlines, 4)) + for i in range(nlines): + line = create_line("UJ2(NAT)", dots=True) + for j, o in enumerate((9, 19, 29, 39)): + line = fillstr(line, format(uj2_array[i, j], '.5f'), o, + 'decimal') + content += line + content += rule() + + content += title(' ' * 17 + 'INPUT FILES (PHD, EXAFS, LEED, AED, ' + 'APECS) :', center=False) + content += rule(tabs=(), symbol='-') + content += title(' ' * 8 + 'NAME' + ' ' * 20 + 'UNIT' + ' ' * 16 + 'TYPE', + center=False) + content += rule(tabs=(5, 23, 7, 10)) + line = create_line("DATA FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input_data')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input_unit00')), 39, 'left') + content += line + line = create_line("PHASE SHIFTS/TL FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input_tl')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input_unit01')), 39, 'left') + content += line + line = create_line("RADIAL MATRIX ELTS FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input_rad')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input_unit02')), 39, 'left') + content += line + line = create_line("CLUSTER FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input_cluster')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input_unit03')), 39, 'left') + content += line + line = create_line("ADSORBATE FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input_adsorbate')), 9, + 'right') + line = fillstr(line, str(p.get_parameter('input_unit04')), 39, 'left') + content += line + line = create_line("K DIRECTIONS FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input_kdirs')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input_unit05')), 39, 'left') + content += line + content += rule(tabs=(5, 23, 7, 10)) + + content += title(' ' * 21 + 'ADDITIONAL INPUT FILES (APECS) :', + center=False) + content += title(' ' * 28 + '(AUGER ELECTRON)', center=False) + content += rule(tabs=(), symbol='-') + content += title(' ' * 8 + 'NAME' + ' ' * 20 + 'UNIT' + ' ' * 16 + 'TYPE', + center=False) + content += rule(tabs=(5, 23, 7, 10)) + line = create_line("PHASE SHIFTS/TL FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input2_tl')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input2_unit06')), 39, 'left') + content += line + line = create_line("RADIAL MATRIX ELTS FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input2_rad')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input2_unit07')), 39, 'left') + content += line + line = create_line("K DIRECTIONS FILE,UNIT") + line = fillstr(line, str(p.get_parameter('input2_kdirs')), 9, 'right') + line = fillstr(line, str(p.get_parameter('input2_unit08')), 39, 'left') + content += line + content += rule(tabs=(5, 23, 7, 10)) + + content += title(' ' * 29 + 'OUTPUT FILES :', center=False) + content += rule(tabs=(), symbol='-') + content += title(' ' * 8 + 'NAME' + ' ' * 20 + 'UNIT' + ' ' * 16 + 'TYPE', + center=False) + content += rule(tabs=(5, 23, 7, 10)) + line = create_line("CONTROL FILE,UNIT") + line = fillstr(line, str(p.get_parameter('output_log')), 9, 'right') + line = fillstr(line, str(p.get_parameter('output_unit09')), 39, 'left') + content += line + line = create_line("RESULT FILE,UNIT") + line = fillstr(line, str(p.get_parameter('output_res')), 9, 'right') + line = fillstr(line, str(p.get_parameter('output_unit10')), 39, 'left') + content += line + line = create_line("SCATTERING FACTOR FILE,UNIT") + line = fillstr(line, str(p.get_parameter('output_sf')), 9, 'right') + line = fillstr(line, str(p.get_parameter('output_unit11')), 39, 'left') + content += line + line = create_line("AUGMENTED CLUSTER FILE,UNIT") + line = fillstr(line, str(p.get_parameter('output_augclus')), 9, 'right') + line = fillstr(line, str(p.get_parameter('output_unit12')), 39, 'left') + content += line + content += rule(tabs=(5, 23, 7, 10)) + + content += title(' ' * 26 + 'END OF THE DATA FILE', center=False) + content += rule(tabs=()) + content += rule(tabs=(), symbol='*') + + try: + with open(filename, 'r') as fd: + old_content = fd.read() + except IOError: + old_content = '' + + modified = False + if content != old_content: + with open(filename, 'w') as fd: + fd.write(content) + modified = True + + return modified + + def write_include_file(self, filename='spec.inc'): + def get_li(level): + orbitals = 'spdfghi' + m = re.match(r'\d(?P[%s])(\d/2)?' % orbitals, level) + return orbitals.index(m.group('l')) + + requirements = { + 'NATP_M': self.phagenio.nat, + 'NATCLU_M': len(self.parameters.extra_atoms), + 'NAT_EQ_M': self.phagenio.nateqm, + 'N_CL_L_M': 0, + 'NE_M': self.phagenio.ne, + 'NL_M': self.phagenio.nlmax + 1, + 'LI_M': get_li(self.parameters.extra_level), + 'NEMET_M': 1, + 'NO_ST_M': self.parameters.calc_no, + } + + # read the include file + with open(filename, 'r') as fd: + content = fd.read() + + # backup the content in memory + old_content = content + + """ + for key in ('NATP_M', 'NATCLU_M', 'NE_M', 'NEMET_M', 'LI_M', 'NL_M', + 'NO_ST_M'): + required = requirements[key] + limit = self.malloc_parameters.get_parameter(key).value + value = required if required > limit else limit + content = re.sub(r'({:s}\s*=\s*)\d+'.format(key), + r'\g<1>{:d}'.format(value), content) + """ + + for key in ('NAT_EQ_M', 'N_CL_N_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'): + value = self.malloc_parameters.get_parameter(key).value + content = re.sub(r'({:s}\s*=\s*)\d+'.format(key), + r'\g<1>{:d}'.format(value), content) + + for key, value in list(requirements.items()): + content = re.sub(r'({:s}\s*=\s*)\d+'.format(key), + r'\g<1>{:d}'.format(value), content) + + + modified = False + if content != old_content: + with open(filename, 'w') as fd: + fd.write(content) + modified = True + return modified + + def write_kdirs_file(self, filename='kdirs.dat'): + fwhm = 1. + all_theta = self.parameters.extra_parameters['scan'].theta + all_phi = self.parameters.extra_parameters['scan'].phi + f = '{:7}{:4}{:6}\n' + + old_content = None + try: + with open(filename, 'r') as fd: + old_content = fd.read() + except IOError: + pass + + content = '' + content += f.format(2, 1, len(all_theta) * len(all_phi)) + content += f.format(1, len(all_phi), len(all_theta)) + for iphi, phi in enumerate(all_phi): + for itheta, theta in enumerate(all_theta): + s = '{:5}{:5}{:13.3f}{:11.3f}{:15e}\n' + s = s.format(iphi + 1, itheta + 1, theta, phi, fwhm) + content += s + + modified = False + if content != old_content: + with open(filename, 'w') as fd: + fd.write(content) + modified = True + return modified + + def load_results(self, filename='results.dat'): + rows2skip = { + 'PED': 27, + 'AED': 27, + 'EXAFS': 27, + 'LEED': 26, + 'EIG': 0 + } + spectro = self.parameters.extra_parameters['global'].spectroscopy + skip = rows2skip[spectro] + + data = np.loadtxt(filename, skiprows=skip, unpack=True) + if len(data.shape) <= 1: + data = data.reshape((1, data.shape[0])) + return data + + def load_facdif(self, filename='facdif1.dat'): + data = np.loadtxt(filename, skiprows=1) + return data + + def load_log(self, filename='spec.log'): + pat = re.compile(r'ORDER\s+(\d+)\s+TOTAL NUMBER OF PATHS\s+:\s+(\d+)') + with open(filename, 'r') as fd: + content = fd.read() + #return pat.findall(content.replace('\n', '__cr__')) + return pat.findall(content) + + + diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py new file mode 100644 index 0000000..f8b653d --- /dev/null +++ b/src/msspec/calculator.py @@ -0,0 +1,905 @@ +# coding: utf-8 +# vim: set et sw=4 ts=4 sts=4 nu ai cc=+0 fdm=indent mouse=a: +""" +Module calculator +================= + +This module contains different classes used to define a new calculator for +specific spectroscopies understood by MsSpec. + +These spectroscopies are listed :ref:`here `. + +There is one *calculator* class for each spectroscopy. The class name is based +on the spectroscopy name. For instance, the class for PhotoElectron Diffraction +is called :py:class:`_PED`. + +The helper function :py:func:`calculator.MSSPEC` is used to create objects from +these classes by passing the kind of spectroscopy as a keyword argument. + +For more information on MsSpec, follow this +`link `__ + +""" + + + +import os +import sys +import re +import inspect + +from subprocess import Popen, PIPE +from shutil import copyfile, rmtree +from datetime import datetime +import time +from io import StringIO +from collections import OrderedDict + +from ase.calculators.calculator import Calculator +import ase.data +import ase.atom +import ase.atoms + +import numpy as np + + +from msspec import iodata +from msspec.data import electron_be +from msspec.config import Config +from msspec.misc import (UREG, LOGGER, get_call_info, get_level_from_electron_configuration, + XRaySource, set_log_output, log_process_output) +from msspec.utils import get_atom_index + +from msspec.parameters import (PhagenParameters, PhagenMallocParameters, + SpecParameters, SpecMallocParameters, + GlobalParameters, MuffintinParameters, + TMatrixParameters, SourceParameters, + DetectorParameters, ScanParameters, + CalculationParameters, + PEDParameters, EIGParameters) +from msspec.calcio import PhagenIO, SpecIO + +from msspec.phagen.libphagen import main as do_phagen +from msspec.spec.libspec import run as do_spec + + +from terminaltables.ascii_table import AsciiTable + + + + +try: + MSSPEC_ROOT = os.environ['MSSPEC_ROOT'] +except KeyError: + cfg = Config() + MSSPEC_ROOT = cfg.get('path') + +if MSSPEC_ROOT == str(None): + raise NameError('No path to the MsSpec distribution found !!') + + + + +def init_msspec(): + LOGGER.debug('Initialization of the msspec module') + ase.atom.names['mt_radius'] = ('mt_radii', 0.) + ase.atom.names['mt_radius_scale'] = ('mt_radii_scale', 1.) + ase.atom.names['proto_index'] = ('proto_indices', 1) + ase.atom.names['mean_square_vibration'] = ('mean_square_vibrations', 0.) + ase.atom.names['forward_angle'] = ('forward_angles', 20.) + ase.atom.names['backward_angle'] = ('backward_angles', 20.) + ase.atom.names['RA_cut_off'] = ('RA_cuts_off', 1) + ase.atoms.Atoms.absorber = None +init_msspec() + + + + +class _MSCALCULATOR(Calculator): + """ + This class defines an ASE calculator for doing Multiple scattering + calculations. + """ + implemented_properties = ['', ] + __data = {} + + def __init__(self, spectroscopy='PED', algorithm='expansion', + polarization=None, dichroism=None, spinpol=False, + folder='./calc', txt='-', **kwargs): + stdout = sys.stdout + if isinstance(txt, str) and txt != '-': + stdout = open(txt, 'w') + #elif isinstance(txt, buffer): + # stdout = txt + elif txt == None: + stdout = open('/dev/null', 'a') + #set_log_output(stdout) + ######################################################################## + LOGGER.debug('Initialization of %s', self.__class__.__name__) + LOGGER.debug(get_call_info(inspect.currentframe())) + ######################################################################## + # Init the upper class + Calculator.__init__(self, **kwargs) + + ######################################################################## + LOGGER.debug(' create low level parameters') + ######################################################################## + self.phagen_parameters = PhagenParameters() + self.phagen_malloc_parameters = PhagenMallocParameters() + self.spec_parameters = SpecParameters() + self.spec_malloc_parameters = SpecMallocParameters() + + ######################################################################## + LOGGER.debug(' create higher level parameters') + ######################################################################## + self.tmatrix_parameters = TMatrixParameters(self.phagen_parameters) + self.muffintin_parameters = MuffintinParameters(self.phagen_parameters, + self.spec_parameters) + + + self.global_parameters = GlobalParameters(self.phagen_parameters, + self.spec_parameters) + + if spectroscopy == 'PED': + self.spectroscopy_parameters = PEDParameters(self.phagen_parameters, + self.spec_parameters) + elif spectroscopy == 'EIG': + self.spectroscopy_parameters = EIGParameters(self.phagen_parameters, + self.spec_parameters) + #pass + else: + raise NameError('No such spectrosopy') + + self.source_parameters = SourceParameters(self.global_parameters, + self.phagen_parameters, + self.spec_parameters) + + self.detector_parameters = DetectorParameters(self.global_parameters, + self.phagen_parameters, + self.spec_parameters) + + self.scan_parameters = ScanParameters(self.global_parameters, + self.phagen_parameters, + self.spec_parameters) + + self.calculation_parameters = CalculationParameters( + self.global_parameters, self.phagen_parameters, self.spec_parameters) + + # updated global parameters with provided keywords + self.global_parameters.spectroscopy = spectroscopy + self.global_parameters.algorithm = algorithm + self.global_parameters.polarization = polarization + self.global_parameters.dichroism = dichroism + self.global_parameters.spinpol = spinpol + self.global_parameters.folder = folder + + + + self.phagenio = PhagenIO(self.phagen_parameters, + self.phagen_malloc_parameters) + self.specio = SpecIO(self.spec_parameters, + self.spec_malloc_parameters, + self.phagenio) + + ######################################################################## + LOGGER.debug(' create a space dedicated to the calculation') + ######################################################################## + self.init_folder = os.getcwd() + self.msspec_folder = os.path.join(MSSPEC_ROOT) + self.tmp_folder = os.path.abspath(folder) + LOGGER.debug(' folder: \'%s\'', self.tmp_folder) + if not os.path.exists(self.tmp_folder): + os.makedirs(self.tmp_folder) + os.makedirs(os.path.join(self.tmp_folder, 'input')) + os.makedirs(os.path.join(self.tmp_folder, 'output')) + #copyfile(os.path.join(self.msspec_folder, 'ase', 'Makefile'), + # os.path.join(self.tmp_folder, 'Makefile')) + + os.chdir(self.tmp_folder) + + inv = cor = 'NO' + if algorithm == 'expansion': + pass + elif algorithm == 'inversion': + inv = 'YES' + elif algorithm == 'correlation': + cor = 'YES' + + # spin orbit resolved (not yet) + sorb = 'NO' + + # spin resolved + dichro_spinpol = False + if dichroism in ('sum_over_spin', 'spin_resolved'): + dichro_spinpol = True + + spin = 'NO' + if spinpol or dichro_spinpol: + spin = 'YES' + + if spin == 'YES': + LOGGER.error('Option not implemented!') + raise NotImplementedError( + 'Spin polarization is not implemeted yet!') + + + calctype_spectro = self.spec_parameters.get_parameter('calctype_spectro') + calctype_spectro = calctype_spectro.value + self._make_opts = (MSSPEC_ROOT, calctype_spectro, inv, cor, + spin, sorb, self.tmp_folder) + + # Initialize the working environment + #self._make('init') + + self.modified = False + + self.resources = {} + ######################################################################## + LOGGER.debug(' initialization done.\n') + ######################################################################## + + def _make(self, target): + LOGGER.debug(get_call_info(inspect.currentframe())) + os.chdir(self.tmp_folder) + cmd = ("make__SPACE__ROOT_FOLDER=\"{}\"__SPACE__SPEC=\"{}\"__SPACE__INV=\"{}\"__SPACE__COR=\"{" + "}\"__SPACE__" + "SPIN=\"{}\"__SPACE__SO=\"{}\"__SPACE__CALC_FOLDER=\"{}\"__SPACE__{}").format(*(self._make_opts + ( + target,))).split('__SPACE__') + #cmd = cmd.replace(' ', '\ ') + #cmd = cmd.split('__SPACE__') + + LOGGER.debug(' the full command is: %s', cmd) + + child = Popen(cmd,stdout=PIPE, stderr=PIPE) + logger_name = LOGGER.name + if target == 'tmatrix': + logger_name = 'Phagen' + elif target == 'compute': + logger_name = 'Spec' + + log_process_output(child, logger=logger_name) + os.chdir(self.init_folder) + + if child.returncode != 0: + LOGGER.error("Unable to successfully run the target: {}".format(target)) + sys.exit(1) + + + def _guess_ke(self, level): + """ Try to guess the kinetic energy based on the level and + the source energy. If the kinetic energy cannot be infered + because the level is not reported in the database, the returned + value is None. + """ + try: + state = get_level_from_electron_configuration(level) + absorber_atomic_number = self.atoms[self.atoms.absorber].number + lines = electron_be[absorber_atomic_number] + binding_energy = lines[state] + except KeyError: + # unable to find a binding energy in the database + return None + + # let's assume work function energy (in eV) + wf = 4.5 + source_energy = self.source_parameters.get_parameter('energy').value + ke = source_energy - binding_energy - wf + #return np.array(ke, dtype=np.float).flatten() + return ke + + + def run_phagen(self): + #include_fname = os.path.join(self.tmp_folder, 'src/msxas3.inc') + input_fname = os.path.join(self.tmp_folder, 'input/input.ms') + + #mod0 = self.phagenio.write_include_file(filename=include_fname) + mod1 = self.phagenio.write_input_file(filename=input_fname) + + self.modified = self.modified or mod1 #or mod0 or mod1 + + if self.modified: + # run phagen + #self._make('tmatrix') + os.chdir(os.path.join(self.tmp_folder, 'output')) + do_phagen() + # rename some output files to be more explicit + os.rename('fort.10', 'cluster.clu') + os.rename('fort.35', 'tmatrix.tl') + os.rename('fort.55', 'tmatrix.rad') + + + def run_spec(self): + def get_li(level): + orbitals = 'spdfghi' + m = re.match(r'\d(?P[%s])(\d/2)?' % orbitals, level) + return orbitals.index(m.group('l')) + + #include_fname = os.path.join(self.tmp_folder, 'src/spec.inc') + input_fname = os.path.join(self.tmp_folder, 'input/spec.dat') + kdirs_fname = os.path.join(self.tmp_folder, 'input/kdirs.dat') + + mod0 = self.specio.write_input_file(filename=input_fname) + #mod1 = self.specio.write_include_file(filename=include_fname) + mod2 = self.specio.write_kdirs_file(filename=kdirs_fname) + + #self.modified = self.modified or mod0 or mod1 or mod2 + self.modified = self.modified or mod0 or mod2 + + #self._make('tmatrix') + #self._make('bin/spec') + #t0 = time.time() + #self._make('compute') + #t1 = time.time() + #self.resources['spec_time'] = t1 - t0 + if self.modified: + #self.get_tmatrix() + t0 = time.time() + os.chdir(os.path.join(self.tmp_folder, 'output')) + # set/get the dimension values + requirements = OrderedDict({ + 'NATP_M' : self.phagenio.nat, + 'NATCLU_M' : len(self.atoms), + 'NAT_EQ_M' : self.phagenio.nateqm, + 'N_CL_L_M' : 1, + 'NE_M' : self.phagenio.ne, + 'NL_M' : self.phagenio.nlmax + 1, + 'LI_M' : get_li(self.spec_parameters.extra_level), + 'NEMET_M' : 1, + 'NO_ST_M' : self.spec_parameters.calc_no, + 'NDIF_M' : 10, + 'NSO_M' : 2, + 'NTEMP_M' : 1, + 'NODES_EX_M' : 3, + 'NSPIN_M' : 1, # to change for spin dependent + 'NTH_M' : 2000, + 'NPH_M' : 2000, + 'NDIM_M' : 100000, + 'N_TILT_M' : 11, # to change see extdir.f + 'N_ORD_M' : 200, + 'NPATH_M' : 500, + 'NGR_M' : 10,}) + + for key, value in requirements.items(): + setattr(self.spec_malloc_parameters, key, value) + + do_spec(*requirements.values()) + + t1 = time.time() + self.resources['spec_time'] = t1 - t0 + + def get_tmatrix(self): + LOGGER.info("Getting the TMatrix...") + LOGGER.debug(get_call_info(inspect.currentframe())) + + 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) + + + tl_threshold = self.tmatrix_parameters.get_parameter('tl_threshold') + if tl_threshold.value != None: + LOGGER.debug(" applying tl_threshold to %s...", + tl_threshold.value) + go_on = True + while go_on: + go_on = False + for ia in range(self.phagenio.nat): + for ie in range(self.phagenio.ne): + last_tl = tl[ia][ie][-1, -2:] + # convert to complex + last_tl = last_tl[0] + last_tl[1] * 1j + if np.abs(last_tl) < tl_threshold.value: + # remove last line of tl + tl[ia][ie] = tl[ia][ie][:-1, :] + go_on = True + + max_tl = self.tmatrix_parameters.get_parameter('max_tl').value + cluster = self.phagen_parameters.get_parameter('atoms').value + proto_indices = cluster.get_array('proto_indices') + + if max_tl != None: + LOGGER.debug(" applying max_tl: %s", max_tl) + for ia in range(self.phagenio.nat): + for ie in range(self.phagenio.ne): + try: + # for each set of tl: + # 1. get the symbol of the prototipical atom + j = np.where(proto_indices == ia+1) + symbol = cluster[j][0].symbol + # 2. get the number of max tl allowed + ntl = max_tl[symbol] + # 3. reshape the tl set accordingly + tl[ia][ie] = tl[ia][ie][:ntl, :] + except KeyError: + pass + + self.phagenio.write_tl_file( + os.path.join(self.tmp_folder, 'output/tmatrix.tl')) + + # update spec extra parameters here + self.spec_parameters.set_parameter('extra_nat', self.phagenio.nat) + self.spec_parameters.set_parameter('extra_nlmax', self.phagenio.nlmax) + + + + def set_atoms(self, atoms): + """Defines the cluster on which the calculator will work. + + :param atoms: The cluster to attach the calculator to. + :type atoms: :py:class:`ase.Atoms` + """ + if atoms.absorber == None: + LOGGER.error("You must define the absorber before setting the atoms to the" + "calculator.") + self.atoms = atoms + self.phagen_parameters.set_parameter('atoms', atoms) + self.spec_parameters.set_parameter('extra_atoms', atoms) + + + def get_parameters(self): + """Get all the defined parameters in the calculator. + + :return: A list of all parameters objects. + :rtype: List of :py:class:`parameters.Parameter` + + """ + _ = [] + for section in ('global', 'muffintin', 'tmatrix', 'spectroscopy', + 'source', 'detector', 'scan', 'calculation'): + parameters = getattr(self, section + '_parameters') + for p in parameters: + _.append(p) + return _ + + def shutdown(self): + """Removes the temporary folder and all its content. + + The user may whish to keep the calculation folder (see :ref:`globalparameters-folder`) so it is not removed + at the end of the calculation. The calculation folder contains raw results from *Phagen* and *Spec* programs as + well as their input files and configuration. It allows the program to save some time by not repeating some + tasks (such as the Fortran code generation, building the binaries, computing things that did not changed + between runs...). + Calling this function at the end of the calculation will erase this calculation folder. + + .. warning:: + + Calling this function will erase the produced data without prompting you for confirmation, + so take care of explicitly saving your results in your script, by using the + :py:func:`iodata.Data.save` method for example. + + """ + LOGGER.info('Deleting temporary files...') + rmtree(self.tmp_folder) + +class _PED(_MSCALCULATOR): + """This class creates a calculator object for PhotoElectron 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='expansion', polarization=None, dichroism=None, + spinpol=False, folder='./calc', txt='-'): + _MSCALCULATOR.__init__(self, spectroscopy='PED', algorithm=algorithm, + polarization=polarization, dichroism=dichroism, + spinpol=spinpol, folder=folder, txt=txt) + + self.iodata = iodata.Data('PED Simulation') + + def _get_scan(self, scan_type='theta', phi=0, + theta=np.linspace(-70, 70, 141), level=None, + kinetic_energy=None, data=None): + LOGGER.info("Computting the %s scan...", scan_type) + if data: + self.iodata = data + + if kinetic_energy is None: + # try to guess the kinetic energy + kinetic_energy = self._guess_ke(level) + + # if still None... + if kinetic_energy is None: + LOGGER.error('Unable to guess the kinetic energy!') + 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) + + self.get_tmatrix() + self.run_spec() + + # 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': + absorber_symbol = self.atoms[self.atoms.absorber].symbol + title = 'Polar scan of {}({}) at {:.2f} eV'.format( + absorber_symbol, level, 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) + 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': + absorber_symbol = self.atoms[self.atoms.absorber].symbol + title = 'Azimuthal scan of {}({}) at {:.2f} eV'.format( + absorber_symbol, level, 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 of {}({}) at {:.2f} eV' + '').format(absorber_symbol, level, 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) + + view = dset.add_view("Proto. atom #{:d}".format(proto_index), + title=title, projection='polar') + 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'$\Im(f(\theta))$') + view.select('theta', 'sf_imag', where=where, + legend=r'$\Re(f(\theta))$') + # 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") + + 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) + + filename = os.path.join(self.tmp_folder, 'bin/plot/plot_vc.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): + """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) + return data + + def get_theta_scan(self, phi=0, theta=np.linspace(-70, 70, 141), + level=None, kinetic_energy=None, data=None): + """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', level=level, theta=theta, + phi=phi, kinetic_energy=kinetic_energy, data=data) + return data + + def get_phi_scan(self, phi=np.linspace(0, 359, 359), theta=0, + level=None, kinetic_energy=None, data=None): + """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', level=level, theta=theta, + phi=phi, kinetic_energy=kinetic_energy, data=data) + return data + + def get_theta_phi_scan(self, phi=np.linspace(0, 360), + theta=np.linspace(0, 90, 45), level=None, + kinetic_energy=None, data=None): + """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. + + """ + self.spec_malloc_parameters.NPH_M = 8000 + data = self._get_scan(scan_type='theta_phi', level=level, theta=theta, + phi=phi, kinetic_energy=kinetic_energy, data=data) + return data + + +class _EIG(_MSCALCULATOR): + """ + .. 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='EIG', algorithm=algorithm, + polarization=polarization, dichroism=dichroism, + spinpol=spinpol, folder=folder, txt=txt) + if algorithm not in ('inversion', 'power'): + LOGGER.error("Only the 'inversion' or the 'power' algorithms " + "are supported in EIG spectroscopy mode") + exit(1) + self.iodata = iodata.Data('EIG Simulation') + + + def get_eigen_values(self, level=None, kinetic_energy=None, data=None): + LOGGER.info("Computting the eigen values...") + if data: + self.iodata = data + + if kinetic_energy is None: + # try to guess the kinetic energy + kinetic_energy = self._guess_ke(level) + + # if still None... + if kinetic_energy is None: + LOGGER.error('Unable to guess the kinetic energy!') + 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 < 0): + LOGGER.error('Source energy is not high enough or level too deep!') + raise ValueError('Kinetic energy is < 0! ({})'.format( + kinetic_energy)) + + self.spectroscopy_parameters.set_parameter('level', level) + + self.get_tmatrix() + self.run_spec() + + # Now load the data + ndset = len(self.iodata) + dset = self.iodata.add_dset('Eigen values calculation [{:d}]'.format(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) + + results_fname = os.path.join(self.tmp_folder, 'output/results.dat') + data = self.specio.load_results(results_fname) + + dset.add_columns(energy=data[:,0], eigen_value=data[:,1]) + + + return self.iodata + + +def MSSPEC(spectroscopy='PED', **kwargs): + """ The MsSpec calculator constructor. + + Instanciates a calculator for the given spectroscopy. + + :param spectroscopy: See :ref:`globalparameters-spectroscopy`. + :param kwargs: Other keywords are passed to the spectroscopy-specific + constructor. + :returns: A :py:class:`calculator._MSCALCULATOR` object. + """ + module = sys.modules[__name__] + cls = getattr(module, '_' + spectroscopy) + return cls(**kwargs) + + + +if __name__ == "__main__": + pass diff --git a/src/msspec/config.py b/src/msspec/config.py new file mode 100644 index 0000000..eaa3047 --- /dev/null +++ b/src/msspec/config.py @@ -0,0 +1,118 @@ +# coding: utf-8 +""" +Module config +============= + +""" + +from configparser import NoSectionError +from configparser import SafeConfigParser as ConfigParser +import os +import sys +import fnmatch +from msspec.misc import LOGGER + + +class NoConfigFile(Exception): pass + + +class Config(object): + def __init__(self, **kwargs): + self.fname = os.path.join(os.environ['HOME'], '.config/msspec/pymsspec.cfg') + self.version = sys.modules['msspec'].__version__ + self.config = ConfigParser() + self.defaults = {'path': 'None'} + self.defaults.update(kwargs) + + # try to load the config file, create one with defaults if none is found + try: + self.options = self.read() + self.options.update(kwargs) + self.set(**self.options) + self.write() + except NoConfigFile: + # write a file with default options + self.write(defaults=True) + except NoSectionError: + # the file exists but has no options for this version of pymsspec + self.config.add_section(self.version) + self.set(**self.defaults) + self.write() + + def read(self): + fp = self.config.read(self.fname) + if len(fp) == 0: + raise NoConfigFile + self.version = self.config.get('general', 'version') + return dict(self.config.items(self.version)) + + def set(self, **kwargs): + if not(self.config.has_section(self.version)): + self.config.add_section(self.version) + for k, v in list(kwargs.items()): + self.config.set(self.version, k, v) + + def get(self, key): + return self.config.get(self.version, key) + + def choose_msspec_folder(self, *folders): + print("Several folders containing the appropriate version of MsSpec were found.") + print("Please choose one tu use:") + s = "" + for i, f in enumerate(folders): + s += '{:d}) {:s}\n'.format(i, f) + print(s) + return(folders[int(input('Your choice: '))]) + + def find_msspec_folders(self): + version = sys.modules['msspec'].__version__ + folders = [] + i = 0 + prompt = 'Please wait while scanning the filesystem (%3d found) ' + sys.stdout.write(prompt % len(folders)) + sys.stdout.write('\033[s') + + for root, dirnames, filenames in os.walk('/home/stricot'): + sys.stdout.write('\033[u\033[k') + sys.stdout.write('%d folders scanned' % i) + i += 1 + for fn in fnmatch.filter(filenames, 'VERSION'): + with open(os.path.join(root, fn), 'r') as fd: + try: + line = fd.readline() + if line.strip() == version: + folders.append(root) + sys.stdout.write('\033[2000D\033[k') + sys.stdout.write(prompt % len(folders)) + except: + pass + sys.stdout.write('\033[u\033[k\n') + print('Done.') + return(folders) + + + def write(self, defaults=False): + if defaults: + self.set(**self.defaults) + + with open(self.fname, 'w') as fd: + self.config.write(fd) + LOGGER.info("{} file written".format(self.fname)) + + def set_mode(self, mode="pymsspec"): + if not(self.config.has_section("general")): + self.config.add_section("general") + self.config.set("general", "mode", str(mode)) + + def get_mode(self): + return self.config.get("general", "mode") + + def set_version(self, version=""): + if not(self.config.has_section("general")): + self.config.add_section("general") + self.config.set("general", "version", version) + + def remove_version(self, version): + pass + + diff --git a/src/msspec/data/__init__.py b/src/msspec/data/__init__.py new file mode 100644 index 0000000..b96b7ca --- /dev/null +++ b/src/msspec/data/__init__.py @@ -0,0 +1,5 @@ +# -*- 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 diff --git a/src/msspec/data/electron_be.py b/src/msspec/data/electron_be.py new file mode 100644 index 0000000..9709090 --- /dev/null +++ b/src/msspec/data/electron_be.py @@ -0,0 +1,1299 @@ +# coding: utf-8 + +""" +Module electron_be +================== + +This module contains a list of binding energy in eV for electronic levels +of atoms. These data are experimental values taken from the X-Ray data +booklet. + +This module is used by msspec to infer kinetic energy values when +they are not specified. For example, to get the Au 4f7/2 binding energy +(remembering that gold atomic number is 79 and that the 4f7/2 level is +n7 in spectroscopic notation...) + +.. code-block:: python + + from msspec.data import electron_be + print(electron_be[79]['n7']) + 84.0 + + +.. seealso:: + X-Ray data booklet + `Electron binding energies `_ are + taken from here. + +""" + + +# a database for elements +electron_be = [None for i in range(104)] + +electron_be[1] = { + 'k' : 13.6} +electron_be[2] = { + 'k' : 24.6} +electron_be[3] = { + 'k' : 54.7} +electron_be[4] = { + 'k' : 111.5} +electron_be[5] = { + 'k' : 188.} +electron_be[6] = { + 'k' : 284.2} +electron_be[7] = { + 'k' : 409.9, + 'l1':37.3} +electron_be[8] = { + 'k' : 543.1, + 'l1': 41.6} +electron_be[9] = { + 'k' : 696.7} +electron_be[10] = { + 'k' : 870.2, + 'l1': 48.5, + 'l2': 21.7, + 'l3': 21.6} +electron_be[11] = { + 'k' : 1070.8, + 'l1': 63.5, + 'l2': 30.65, + 'l3': 30.81} +electron_be[12] = { + 'k' : 1303., + 'l1': 88.7, + 'l2': 49.78, + 'l3': 49.50} +electron_be[13] = { + 'k' : 1559.6, + 'l1': 117.8, + 'l2': 72.95, + 'l3': 72.55} +electron_be[14] = { + 'k' : 1839., + 'l1': 149.7, + 'l2': 99.82, + 'l3': 99.42} +electron_be[15] = { + 'k' : 2145.5, + 'l1': 189., + 'l2': 136., + 'l3': 135.} +electron_be[16] = { + 'k' : 2472., + 'l1': 230.9, + 'l2': 163.6, + 'l3': 162.5} +electron_be[17] = { + 'k' : 2822.4, + 'l1': 270., + 'l2': 202., + 'l3': 200.} +electron_be[18] = { + 'k' : 3205.9, + 'l1': 326.3, + 'l2': 250.6, + 'l3': 248.4, + 'm1': 29.3, + 'm2': 15.9, + 'm3': 15.7} +electron_be[19] = { + 'k' : 3608.4, + 'l1': 378.6, + 'l2': 297.3, + 'l3': 294.6, + 'm1': 34.8, + 'm2': 18.3, + 'm3': 18.3} +electron_be[20] = { + 'k' : 4038.5, + 'l1': 438.4, + 'l2': 349.7, + 'l3': 346.2, + 'm1': 44.3, + 'm2': 25.4, + 'm3': 25.4} +electron_be[21] = { + 'k' : 4492., + 'l1': 498., + 'l2': 403.6, + 'l3': 398.7, + 'm1': 51.1, + 'm2': 28.3, + 'm3': 28.3} +electron_be[22] = { + 'k' : 4966., + 'l1': 560.9, + 'l2': 460.2, + 'l3': 453.8, + 'm1': 58.7, + 'm2': 32.6, + 'm3': 32.6} +electron_be[23] = { + 'k' : 5465., + 'l1': 626.7, + 'l2': 519.8, + 'l3': 512.1, + 'm1': 66.3, + 'm2': 37.2, + 'm3': 37.2} +electron_be[24] = { + 'k' : 5989., + 'l1': 696., + 'l2': 583.8, + 'l3': 574.1, + 'm1': 74.1, + 'm2': 42.2, + 'm3': 42.2} +electron_be[25] = { + 'k' : 6539., + 'l1': 796.1, + 'l2': 649.9, + 'l3': 638.7, + 'm1': 82.3, + 'm2': 47.2, + 'm3': 47.2} +electron_be[26] = { + 'k' : 7112., + 'l1': 844.6, + 'l2': 719.9, + 'l3': 706.8, + 'm1': 91.3, + 'm2': 52.7, + 'm3': 52.7} +electron_be[27] = { + 'k' : 7709., + 'l1': 925.1, + 'l2': 793.2, + 'l3': 778.1, + 'm1': 101., + 'm2': 58.9, + 'm3': 59.9} +electron_be[28] = { + 'k' : 8333., + 'l1': 1008.6, + 'l2': 870., + 'l3': 852.7, + 'm1': 110.8, + 'm2': 68.0, + 'm3': 66.2} +electron_be[29] = { + 'k' : 8979., + 'l1': 1096.7, + 'l2': 952.3, + 'l3': 932.7, + 'm1': 122.5, + 'm2': 77.3, + 'm3': 75.1} +electron_be[30] = { + 'k' : 9659., + 'l1': 1196.2, + 'l2': 1044.9, + 'l3': 1021.8, + 'm1': 139.8, + 'm2': 91.4, + 'm3': 88.6, + 'm4': 10.2, + 'm5': 10.1} +electron_be[31] = { + 'k' : 10367., + 'l1': 1299., + 'l2': 1143.2, + 'l3': 1116.4, + 'm1': 159.5, + 'm2': 103.5, + 'm3': 100., + 'm4': 18.7, + 'm5': 18.7} +electron_be[32] = { + 'k' : 11103., + 'l1': 1414.6, + 'l2': 1248.1, + 'l3': 1217., + 'm1': 180.1, + 'm2': 124.9, + 'm3': 120.8, + 'm4': 29.8, + 'm5': 29.2} +electron_be[33] = { + 'k' : 11867., + 'l1': 1527., + 'l2': 1359.1, + 'l3': 1323.6, + 'm1': 204.7, + 'm2': 146.2, + 'm3': 141.2, + 'm4': 41.7, + 'm5': 41.7} +electron_be[34] = { + 'k' : 12658., + 'l1': 1652., + 'l2': 1474.3, + 'l3': 1433.9, + 'm1': 229.6, + 'm2': 166.5, + 'm3': 160.7, + 'm4': 55.5, + 'm5': 54.6} +electron_be[35] = { + 'k' : 13474., + 'l1': 1782., + 'l2': 1596., + 'l3': 1550., + 'm1': 257., + 'm2': 189., + 'm3': 182., + 'm4': 70., + 'm5': 69.} +electron_be[36] = { + 'k' : 14326., + 'l1': 1921., + 'l2': 1703.9, + 'l3': 1678.4, + 'm1': 292.8, + 'm2': 222.2, + 'm3': 214.4, + 'm4': 95., + 'm5': 93.8, + 'n1': 27.5, + 'n2': 14.1, + 'n3': 14.1} +electron_be[37] = { + 'k' : 15200., + 'l1': 2065., + 'l2': 1864., + 'l3': 1804., + 'm1': 326.7, + 'm2': 248.7, + 'm3': 239.1, + 'm4': 113., + 'm5': 112., + 'n1': 30.5, + 'n2': 16.3, + 'n3': 15.3} +electron_be[38] = { + 'k' : 16105., + 'l1': 2216., + 'l2': 2007., + 'l3': 1940., + 'm1': 358.7, + 'm2': 280.3, + 'm3': 270., + 'm4': 136., + 'm5': 134.2, + 'n1': 38.9, + 'n2': 21.3, + 'n3': 20.1} +electron_be[39] = { + 'k' : 17038., + 'l1': 2373., + 'l2': 2156., + 'l3': 2080., + 'm1': 392., + 'm2': 310.6, + 'm3': 298.8, + 'm4': 157.7, + 'm5': 155.8, + 'n1': 43.8, + 'n2': 24.4, + 'n3': 23.1} + +electron_be[40] = { + 'k' : 17998., + 'l1': 2532., + 'l2': 2307., + 'l3': 2223., + 'm1': 430.3, + 'm2': 343.5, + 'm3': 329.8, + 'm4': 181.1, + 'm5': 178.8, + 'n1': 50.6, + 'n2': 28.5, + 'n3': 27.1} +electron_be[41] = { + 'k' : 18986., + 'l1': 2698., + 'l2': 2465., + 'l3': 2371., + 'm1': 466.6, + 'm2': 376.1, + 'm3': 360.6, + 'm4': 205.0, + 'm5': 202.3, + 'n1': 56.4, + 'n2': 32.6, + 'n3': 30.8} +electron_be[42] = { + 'k' : 20000., + 'l1': 2866., + 'l2': 2625., + 'l3': 2520., + 'm1': 506.3, + 'm2': 411.6, + 'm3': 394., + 'm4': 231.1, + 'm5': 227.9, + 'n1': 63.2, + 'n2': 37.6, + 'n3': 35.5} +electron_be[43] = { + 'k' : 21044., + 'l1': 3043., + 'l2': 2793., + 'l3': 2677., + 'm1': 544., + 'm2': 447.6, + 'm3': 417.7, + 'm4': 257.6, + 'm5': 253.9, + 'n1': 69.5, + 'n2': 42.3, + 'n3': 39.9} +electron_be[44] = { + 'k' : 22117., + 'l1': 3224., + 'l2': 2967., + 'l3': 2838., + 'm1': 586.1, + 'm2': 483.5, + 'm3': 461.4, + 'm4': 284.2, + 'm5': 280.0, + 'n1': 75.0, + 'n2': 46.3, + 'n3': 43.2} +electron_be[45] = { + 'k' : 23220., + 'l1': 3412., + 'l2': 3146., + 'l3': 3004., + 'm1': 628.1, + 'm2': 521.3, + 'm3': 496.5, + 'm4': 311.9, + 'm5': 307.2, + 'n1': 81.4, + 'n2': 50.5, + 'n3': 47.3} +electron_be[46] = { + 'k' : 24350., + 'l1': 3604., + 'l2': 3330., + 'l3': 3173., + 'm1': 671.6, + 'm2': 559.9, + 'm3': 532.3, + 'm4': 340.5, + 'm5': 335.2, + 'n1': 87.1, + 'n2': 55.7, + 'n3': 50.9} +electron_be[47] = { + 'k' : 25514., + 'l1': 3806., + 'l2': 3524., + 'l3': 3351., + 'm1': 719., + 'm2': 603.8, + 'm3': 573.0, + 'm4': 374., + 'm5': 368.3, + 'n1': 97., + 'n2': 63.7, + 'n3': 58.3} + +electron_be[48] = { + 'k' : 26711., + 'l1': 4018., + 'l2': 3727., + 'l3': 3538., + 'm1': 772., + 'm2': 652.6, + 'm3': 618.4, + 'm4': 411.9, + 'm5': 405.2, + 'n1': 109.8, + 'n2': 63.9, + 'n3': 63.9, + 'n4': 11.7, + 'n5': 10.7} +electron_be[49] = { + 'k' : 27940., + 'l1': 4238., + 'l2': 3938., + 'l3': 3730., + 'm1': 827.2, + 'm2': 703.2, + 'm3': 665.3, + 'm4': 451.4, + 'm5': 443.9, + 'n1': 122.9, + 'n2': 73.5, + 'n3': 73.5, + 'n4': 17.7, + 'n5': 16.9} +electron_be[50] = { + 'k' : 29200., + 'l1': 4465., + 'l2': 4156., + 'l3': 3929., + 'm1': 884.7, + 'm2': 756.5, + 'm3': 714.6, + 'm4': 493.2, + 'm5': 484.9, + 'n1': 137.1, + 'n2': 83.6, + 'n3': 83.6, + 'n4': 24.9, + 'n5': 23.9} +electron_be[51] = { + 'k' : 30491., + 'l1': 4698., + 'l2': 4380., + 'l3': 4132., + 'm1': 946., + 'm2': 812.7, + 'm3': 766.4, + 'm4': 537.5, + 'm5': 528.2, + 'n1': 153.2, + 'n2': 95.6, + 'n3': 95.6, + 'n4': 33.3, + 'n5': 32.1} +electron_be[52] = { + 'k' : 31814., + 'l1': 4939., + 'l2': 4612., + 'l3': 4341., + 'm1': 1006., + 'm2': 870.8, + 'm3': 820.0, + 'm4': 583.4, + 'm5': 573., + 'n1': 169.4, + 'n2': 103.3, + 'n3': 103.3, + 'n4': 41.9, + 'n5': 40.4} +electron_be[53] = { + 'k' : 33169., + 'l1': 5188., + 'l2': 4852., + 'l3': 4557., + 'm1': 1072., + 'm2': 931., + 'm3': 875.0, + 'm4': 630.8, + 'm5': 619.3, + 'n1': 186., + 'n2': 123., + 'n3': 123., + 'n4': 50.6, + 'n5': 48.9} +electron_be[54] = { + 'k' : 34561., + 'l1': 5453., + 'l2': 5107., + 'l3': 4786., + 'm1': 1148.7, + 'm2': 1002.1, + 'm3': 940.6, + 'm4': 689., + 'm5': 676.4, + 'n1': 213.2, + 'n2': 146.7, + 'n3': 145.5, + 'n4': 69.5, + 'n5': 67.5, + 'o1': 23.3, + 'o2': 13.4, + 'o3': 12.1} +electron_be[55] = { + 'k' : 35985., + 'l1': 5714., + 'l2': 5359., + 'l3': 5012., + 'm1': 1211., + 'm2': 1071., + 'm3': 1003., + 'm4': 740.5, + 'm5': 726.6, + 'n1': 231.3, + 'n2': 172.4, + 'n3': 161.3, + 'n4': 79.8, + 'n5': 77.5, + 'o1':22.7, + 'o2':14.2, + 'o3':12.1} +electron_be[56] = { + 'k' : 37441., + 'l1': 5989., + 'l2': 5624., + 'l3': 5247., + 'm1': 1293., + 'm2': 1137., + 'm3': 1063., + 'm4': 795.7, + 'm5': 780.5, + 'n1': 253.5, + 'n2': 192., + 'n3': 178.6, + 'n4': 92.6, + 'n5': 89.9, + 'o1':30.3, + 'o2':17., + 'o3':14.8} +electron_be[57] = { + 'k' : 38925., + 'l1': 6266., + 'l2': 5891., + 'l3': 5483., + 'm1': 1362., + 'm2': 1209., + 'm3': 1128., + 'm4': 853., + 'm5': 836., + 'n1': 274.7, + 'n2': 205.8, + 'n3': 196., + 'n4': 105.3, + 'n5': 102.5, + 'o1':34.3, + 'o2':19.3, + 'o3':16.8} +electron_be[58] = { + 'k' : 40443., + 'l1': 6549., + 'l2': 6164., + 'l3': 5723., + 'm1': 1436., + 'm2': 1274., + 'm3': 1187., + 'm4': 902.4, + 'm5': 883.8, + 'n1': 291., + 'n2': 223.2, + 'n3': 206.5, + 'n4': 109., + 'n6':0.1, + 'n7':0.1, + 'o1':37.8, + 'o2':19.8, + 'o3':17.} +electron_be[59] = { + 'k' : 41991., + 'l1': 6835., + 'l2': 6440., + 'l3': 5964., + 'm1': 1511., + 'm2': 1337., + 'm3': 1242., + 'm4': 948.3, + 'm5': 928.8, + 'n1': 304.5, + 'n2': 236.3, + 'n3': 217.6, + 'n4': 115.1, + 'n5': 115.1, + 'n6':2., + 'n7':2., + 'o1':37.4, + 'o2':22.3, + 'o3':22.3} +electron_be[60] = { + 'k' : 43569., + 'l1': 7126., + 'l2': 6722., + 'l3': 6208., + 'm1': 1575., + 'm2': 1403., + 'm3': 1297., + 'm4': 1003.3, + 'm5': 980.4, + 'n1': 319.2, + 'n2': 243.3, + 'n3': 224.6, + 'n4': 120.5, + 'n5': 120.5, + 'n6':1.5, + 'n7':1.5, + 'o1':37.5, + 'o2':21.1, + 'o3':21.1} +electron_be[61] = { + 'k' : 45184., + 'l1': 7428., + 'l2': 7013., + 'l3': 6459., + 'm2': 1471., + 'm3': 1357., + 'm4': 1052., + 'm5': 1027., + 'n2': 242., + 'n3': 242., + 'n4': 120., + 'n5': 120.} +electron_be[62] = { + 'k' : 46834., + 'l1': 7737., + 'l2': 7312., + 'l3': 6716., + 'm1': 1723., + 'm2': 1541., + 'm3': 1420., + 'm4': 1110.9, + 'm5': 1083.4, + 'n1': 347.2, + 'n2': 265.6, + 'n3': 247.4, + 'n4': 129., + 'n5': 129., + 'n6': 5.2, + 'n7': 5.2, + 'o1': 37.4, + 'o2': 21.3, + 'o3': 21.3} +electron_be[63] = { + 'k' : 48519., + 'l1': 8052., + 'l2': 7617., + 'l3': 6977., + 'm1': 1800., + 'm2': 1614., + 'm3': 1481., + 'm4': 1158.6, + 'm5': 1127.5, + 'n1': 360., + 'n2': 284., + 'n3': 257., + 'n4': 133., + 'n5': 127.7, + 'n6': 0., + 'n7': 0., + 'o1': 32., + 'o2': 22., + 'o3': 22.} +electron_be[64] = { + 'k' : 50239., + 'l1': 8376., + 'l2': 7930., + 'l3': 7243., + 'm1': 1881., + 'm2': 1688., + 'm3': 1544., + 'm4': 1221.9, + 'm5': 1189.6, + 'n1': 378.6, + 'n2': 286., + 'n3': 271., + 'n5': 142.6, + 'n6': 8.6, + 'n7': 8.6, + 'o1': 36., + 'o2': 28., + 'o3': 21.} +electron_be[65] = { + 'k' : 51996., + 'l1': 8708., + 'l2': 8252., + 'l3': 7514., + 'm1': 1968., + 'm2': 1768., + 'm3': 1611., + 'm4': 1276.9, + 'm5': 1241.1, + 'n1': 396., + 'n2': 322.4, + 'n3': 284.1, + 'n4': 150.5, + 'n5': 150.5, + 'n6': 7.7, + 'n7': 2.4, + 'o1': 45.6, + 'o2': 28.7, + 'o3': 22.6} + +electron_be[66] = { + 'k' : 53789., + 'l1': 9046., + 'l2': 8581., + 'l3': 7790., + 'm1': 2047., + 'm2': 1842., + 'm3': 1676., + 'm4': 1333., + 'm5': 1292.6, + 'n1': 414.2, + 'n2': 333.5, + 'n3': 293.2, + 'n4': 153.6, + 'n5': 153.6, + 'n6': 8., + 'n7': 4.3, + 'o1': 49.9, + 'o2': 26.3, + 'o3': 26.3} +electron_be[67] = { + 'k' : 55618., + 'l1': 9394., + 'l2': 8918., + 'l3': 8071., + 'm1': 2128., + 'm2': 1923., + 'm3': 1741., + 'm4': 1392., + 'm5': 1351., + 'n1': 432.4, + 'n2': 343.5, + 'n3': 308.2, + 'n4': 160., + 'n5': 160., + 'n6': 8.6, + 'n7': 5.2, + 'o1': 49.3, + 'o2': 30.8, + 'o3': 24.1} +electron_be[68] = { + 'k' : 57486., + 'l1': 9751., + 'l2': 9264., + 'l3': 8358., + 'm1': 2207., + 'm2': 2006., + 'm3': 1812., + 'm4': 1453., + 'm5': 1409., + 'n1': 449.8, + 'n2': 366.2, + 'n3': 320.2, + 'n4': 167.6, + 'n5': 167.6, + 'n7': 4.7, + 'o1': 50.6, + 'o2': 31.4, + 'o3': 24.7} +electron_be[69] = { + 'k' : 59390., + 'l1': 10116., + 'l2': 9617., + 'l3': 8648., + 'm1': 2307., + 'm2': 2090., + 'm3': 1885., + 'm4': 1515., + 'm5': 1468., + 'n1': 470.9, + 'n2': 385.9, + 'n3': 332.6, + 'n4': 175.5, + 'n5': 175.5, + 'n7': 4.6, + 'o1': 54.7, + 'o2': 31.8, + 'o3': 25.} +electron_be[70] = { + 'k' : 61332., + 'l1': 10486., + 'l2': 9978., + 'l3': 8944., + 'm1': 2398., + 'm2': 2173., + 'm3': 1950., + 'm4': 1576., + 'm5': 1528., + 'n1': 480.5, + 'n2': 388.7, + 'n3': 339.7, + 'n4': 191.2, + 'n5': 182.4, + 'n6': 2.5, + 'n7': 1.3, + 'o1': 52., + 'o2': 30.3, + 'o3': 24.1} +electron_be[71] = { + 'k' : 63314., + 'l1': 10870., + 'l2': 10349., + 'l3': 9244., + 'm1': 2491., + 'm2': 2264., + 'm3': 2024., + 'm4': 1639., + 'm5': 1589., + 'n1': 506.8, + 'n2': 412.4, + 'n3': 359.2, + 'n4': 206.1, + 'n5': 196.3, + 'n6': 8.9, + 'n7': 7.5, + 'o1': 57.3, + 'o2': 33.6, + 'o3': 26.7} +electron_be[72] = { + 'k' : 65351., + 'l1': 11271., + 'l2': 10739., + 'l3': 9561., + 'm1': 2601., + 'm2': 2365., + 'm3': 2108., + 'm4': 1716., + 'm5': 1662., + 'n1': 538., + 'n2': 438.2, + 'n3': 380.7, + 'n4': 220., + 'n5': 211.5, + 'n6': 15.9, + 'n7': 14.2, + 'o1': 64.2, + 'o2': 38., + 'o3': 29.9} +electron_be[73] = { + 'k' : 67416., + 'l1': 11682., + 'l2': 11136., + 'l3': 9881., + 'm1': 2708., + 'm2': 2469., + 'm3': 2194., + 'm4': 1793., + 'm5': 1735., + 'n1': 563.4, + 'n2': 463.4, + 'n3': 400.9, + 'n4': 237.9, + 'n5': 226.4, + 'n6': 23.5, + 'n7': 21.6, + 'o1': 69.7, + 'o2': 42.2, + 'o3': 32.7} +electron_be[74] = { + 'k' : 69525., + 'l1': 12100., + 'l2': 11544., + 'l3': 10207., + 'm1': 2820., + 'm2': 2575., + 'm3': 2281., + 'm4': 1872., + 'm5': 1809., + 'n1': 594.1, + 'n2': 490.4, + 'n3': 423.6, + 'n4': 255.9, + 'n5': 243.5, + 'n6': 33.6, + 'n7': 31.4, + 'o1': 75.6, + 'o2': 45.3, + 'o3': 36.8} +electron_be[75] = { + 'k' : 71676., + 'l1': 12527., + 'l2': 11959., + 'l3': 10535., + 'm1': 2932., + 'm2': 2682., + 'm3': 2367., + 'm4': 1949., + 'm5': 1883., + 'n1': 625.4, + 'n2': 518.7, + 'n3': 446.8, + 'n4': 273.9, + 'n5': 260.5, + 'n6': 42.9, + 'n7': 40.5, + 'o1': 83., + 'o2': 45.6, + 'o3': 34.6} +electron_be[76] = { + 'k' : 73871., + 'l1': 12968., + 'l2': 12385., + 'l3': 10871., + 'm1': 3049., + 'm2': 2792., + 'm3': 2457., + 'm4': 2031., + 'm5': 1960., + 'n1': 658.2, + 'n2': 549.1, + 'n3': 470.7, + 'n4': 293.1, + 'n5': 278.5, + 'n6': 53.4, + 'n7': 50.7, + 'o1': 84., + 'o2': 58., + 'o3': 44.5} +electron_be[77] = { + 'k' : 76111., + 'l1': 13419., + 'l2': 12824., + 'l3': 11215., + 'm1': 3174., + 'm2': 2909., + 'm3': 2551., + 'm4': 2116., + 'm5': 2040., + 'n1': 691.1, + 'n2': 577.8, + 'n3': 495.8, + 'n4': 311.9, + 'n5': 296.3, + 'n6': 63.8, + 'n7': 60.8, + 'o1': 95.2, + 'o2': 63., + 'o3': 48.} +electron_be[78] = { + 'k' : 78395., + 'l1': 13880., + 'l2': 13273., + 'l3': 11564., + 'm1': 3296., + 'm2': 3027., + 'm3': 2645., + 'm4': 2202., + 'm5': 2122., + 'n1': 725.4, + 'n2': 609.1, + 'n3': 519.4, + 'n4': 331.6, + 'n5': 314.6, + 'n6': 74.5, + 'n7': 71.2, + 'o1': 101.7, + 'o2': 65.3, + 'o3': 51.7} +electron_be[79] = { + 'k' : 80725., + 'l1': 14353., + 'l2': 13273., + 'l3': 11919., + 'm1': 3425., + 'm2': 3148., + 'm3': 2743., + 'm4': 2291., + 'm5': 2206., + 'n1': 762.1, + 'n2': 642.7, + 'n3': 546.3, + 'n4': 353.2, + 'n5': 335.1, + 'n6': 87.6, + 'n7': 84., + 'o1': 107.2, + 'o2': 74.2, + 'o3': 57.2} +electron_be[80] = { + 'k' : 83102., + 'l1': 14839., + 'l2': 14209., + 'l3': 12284., + 'm1': 3562., + 'm2': 3279., + 'm3': 2847., + 'm4': 2385., + 'm5': 2295., + 'n1': 802.2, + 'n2': 680.2, + 'n3': 576.6, + 'n4': 378.2, + 'n5': 358.8, + 'n6': 104., + 'n7': 99.9, + 'o1': 127., + 'o2': 83.1, + 'o3': 64.5, + 'o4': 9.6, + 'o5': 7.8} +electron_be[81] = { + 'k' : 85530., + 'l1': 15347., + 'l2': 14698., + 'l3': 12658., + 'm1': 3704., + 'm2': 3416., + 'm3': 2957., + 'm4': 2485., + 'm5': 2389., + 'n1': 846.2, + 'n2': 720.5, + 'n3': 609.5, + 'n4': 405.7, + 'n5': 385., + 'n6': 122.2, + 'n7': 117.8, + 'o1': 136., + 'o2': 94.6, + 'o3': 73.5, + 'o4': 14.7, + 'o5': 12.5} +electron_be[82] = { + 'k' : 88005., + 'l1': 15861., + 'l2': 15200., + 'l3': 13035., + 'm1': 3851., + 'm2': 3554., + 'm3': 3066., + 'm4': 2586., + 'm5': 2484., + 'n1': 891.8, + 'n2': 761.9, + 'n3': 643.5, + 'n4': 434.3, + 'n5': 412.2, + 'n6': 141.7, + 'n7': 136.9, + 'o1': 147., + 'o2': 106.4, + 'o3': 83.3, + 'o4': 20.7, + 'o5': 18.1} +electron_be[83] = { + 'k' : 90524., + 'l1': 16388., + 'l2': 15711., + 'l3': 13419., + 'm1': 3999., + 'm2': 3696., + 'm3': 3177., + 'm4': 2688., + 'm5': 2580., + 'n1': 939., + 'n2': 805.2, + 'n3': 678.8, + 'n4': 464., + 'n5': 440.1, + 'n6': 162.3, + 'n7': 157., + 'o1': 159.3, + 'o2': 119., + 'o3': 92.6, + 'o4': 26.9, + 'o5': 23.8} + +electron_be[84] = { + 'k' : 93105., + 'l1': 16939., + 'l2': 16244., + 'l3': 13814., + 'm1': 4149., + 'm2': 3854., + 'm3': 3302., + 'm4': 2798., + 'm5': 2683., + 'n1': 995., + 'n2': 851., + 'n3': 705., + 'n4': 500., + 'n5': 473., + 'n6': 184., + 'n7': 184., + 'o1': 177., + 'o2': 132., + 'o3': 104., + 'o4': 31., + 'o5': 31.} +electron_be[85] = { + 'k' : 95730., + 'l1': 17493., + 'l2': 16785., + 'l3': 14214., + 'm1': 4317., + 'm2': 4008., + 'm3': 3426., + 'm4': 2909., + 'm5': 2787., + 'n1': 1042., + 'n2': 886., + 'n3': 740., + 'n4': 533., + 'n5': 507., + 'n6': 210., + 'n7': 210., + 'o1': 195., + 'o2': 148., + 'o3': 115., + 'o4': 40., + 'o5': 40.} +electron_be[86] = { + 'k' : 98404., + 'l1': 18049., + 'l2': 17337., + 'l3': 14619., + 'm1': 4482., + 'm2': 4159., + 'm3': 3538., + 'm4': 3022., + 'm5': 2892., + 'n1': 1097., + 'n2': 929., + 'n3': 768., + 'n4': 567., + 'n5': 541., + 'n6': 238., + 'n7': 238., + 'o1': 214., + 'o2': 164., + 'o3': 127., + 'o4': 48., + 'o5': 48., + 'p1': 26.} +electron_be[87] = { + 'k' : 101137., + 'l1': 18639., + 'l2': 17907., + 'l3': 15031., + 'm1': 4652., + 'm2': 4327., + 'm3': 3663., + 'm4': 3136., + 'm5': 3000., + 'n1': 1153., + 'n2': 980., + 'n3': 810., + 'n4': 603., + 'n5': 577., + 'n6': 268., + 'n7': 268., + 'o1': 234., + 'o2': 182., + 'o3': 140., + 'o4': 58., + 'o5': 58., + 'p1': 34., + 'p2': 15., + 'p3': 15.} +electron_be[88] = { + 'k' : 103922., + 'l1': 19237., + 'l2': 18484., + 'l3': 15444., + 'm1': 4822., + 'm2': 4490., + 'm3': 3792., + 'm4': 3248., + 'm5': 3105., + 'n1': 1208., + 'n2': 1058., + 'n3': 879., + 'n4': 636., + 'n5': 603., + 'n6': 299., + 'n7': 299., + 'o1': 254., + 'o2': 200., + 'o3': 153., + 'o4': 68., + 'o5': 68., + 'p1': 44., + 'p2': 19., + 'p3': 19.} +electron_be[89] = { + 'k' : 106755., + 'l1': 19840., + 'l2': 19083., + 'l3': 15871., + 'm1': 5002., + 'm2': 4656., + 'm3': 3909., + 'm4': 3370., + 'm5': 3219., + 'n1': 1269., + 'n2': 1080., + 'n3': 890., + 'n4': 675., + 'n5': 639., + 'n6': 319., + 'n7': 319., + 'o1': 272., + 'o2': 215., + 'o3': 167., + 'o4': 80., + 'o5': 80.} +electron_be[90] = { + 'k' : 109651., + 'l1': 20472., + 'l2': 19693., + 'l3': 16300., + 'm1': 5182., + 'm2': 4830., + 'm3': 4046., + 'm4': 3491., + 'm5': 3332., + 'n1': 1330., + 'n2': 1168., + 'n3': 966.4, + 'n4': 712.1, + 'n5': 675.2, + 'n6': 342.4, + 'n7': 333.1, + 'o1': 290., + 'o2': 229., + 'o3': 182., + 'o4': 92.5, + 'o5': 85.4, + 'p1': 41.4, + 'p2': 24.5, + 'p3': 16.6} +electron_be[91] = { + 'k' : 112601., + 'l1': 21105., + 'l2': 20314., + 'l3': 16733., + 'm1': 5367., + 'm2': 5001., + 'm3': 4174., + 'm4': 3611., + 'm5': 3442., + 'n1': 1387., + 'n2': 1224., + 'n3': 1007., + 'n4': 743., + 'n5': 708., + 'n6': 371., + 'n7': 360., + 'o1': 310., + 'o2': 232., + 'o3': 232., + 'o4': 94., + 'o5': 94.} +electron_be[92] = { + 'k' : 115606., + 'l1': 21757., + 'l2': 20948., + 'l3': 17166., + 'm1': 5548., + 'm2': 5182., + 'm3': 4303., + 'm4': 3728., + 'm5': 3552., + 'n1': 1439., + 'n2': 1271., + 'n3': 1043., + 'n4': 778.3, + 'n5': 736.2, + 'n6': 388.2, + 'n7': 377.4, + 'o1': 321., + 'o2': 257., + 'o3': 192., + 'o4': 102.8, + 'o5': 94.2, + 'p1': 43.9, + 'p2': 26.8, + 'p3': 16.8} diff --git a/src/msspec/es/Modules/es_domain.py b/src/msspec/es/Modules/es_domain.py new file mode 100644 index 0000000..5c61520 --- /dev/null +++ b/src/msspec/es/Modules/es_domain.py @@ -0,0 +1,23 @@ +# coding: utf-8 + +import unittest +import numpy +import delaunay.core as delc +from ase import Atoms + +def Define_Domain(set,ncover,ratio) : + #defines the sphere englobing the molecule, such as we will have at least ncover empty spheres around the molecule, + #and this empty sphere have a size around ratio x {global size of muffin tin atom size} + + +def Distance(A,B) + #calculate distance between A and B + try : + assert len(A) == len(B) + d=0 + for l in range(0,len(A)) + d+=(B[l]-A[l])**2 + d=sqrt(d) + except AssertionError : + print("Error : distance calculated from two points in different spaces") + diff --git a/src/msspec/es/Modules/modultest.py b/src/msspec/es/Modules/modultest.py new file mode 100644 index 0000000..167e570 --- /dev/null +++ b/src/msspec/es/Modules/modultest.py @@ -0,0 +1,9 @@ +# coding: utf-8 + +import unittest +import numpy +import delaunay.core as delc +from ase import Atoms + + +#============================================= \ No newline at end of file diff --git a/src/msspec/es/Modules/tetramesh.py b/src/msspec/es/Modules/tetramesh.py new file mode 100644 index 0000000..b7a472a --- /dev/null +++ b/src/msspec/es/Modules/tetramesh.py @@ -0,0 +1,2 @@ +# coding: utf-8 + diff --git a/src/msspec/es/README b/src/msspec/es/README new file mode 100644 index 0000000..5bcbdf6 --- /dev/null +++ b/src/msspec/es/README @@ -0,0 +1,469 @@ +# coding: utf-8 + + ============================================================ +| Empty_Spheres Modules | + ============================================================ + +Made by : Ulysse DUPONT +Collaboration with : Didier SEBILLEAU, Sylvain TRICOT +Helped by : Floris Bruynooghe (Delny) and the team from scipy.spatial (qhull/Voronoi) + +Path : msspec/src/python/pymsspec/msspec/es +Language : Python +Important Global Variable : ES_AllRadius + + ============================================================ + | About ES_AllRadius | + ============================================================ + +For now : Empty spheres can be created from a cluster of Atoms. +The missing part is the definition of the Empty-Sphere Python Class : they are considered as "X" Atoms. +It means that the radius of empty spheres are not directly linked to them : +The routine empty-spheres.Atom_Radius(Structure,n,list) will recognize empty spheres because their atom number is 0. +So we created ES_AllRadius global variable, wich is updated after each EmptySphere generation with function +"ES_AllRadius_Updater(NewES,Structure)". The new radius are calculated brutally by taking the max, without touching +Structure molecules + +To use this global variable, it will be necessary to delete no empty spheres (or be sure to delete the +correspondant radius in ES_AllRadius). + +An example of ES_AllRadius use is given afterward : in the example "Covering GeCl4 using ES_AllRadius" + +In the future, the informations about each empty-spheres radius can be taken directly in construction routines, and linked +to the empty-sphere python object. + + + ============================================================ + | Objectives | + ============================================================ + +The empty_spheres modules are routines made to add empty spheres in clusters for diffusion computations. +The routines used are based on tetrahedralisation, convex-hull research and triangularisation to create adapted mesh, +and uses tangent-spheres resolutions to compute adapted coordinates and radius of empty-spheres + + + ============================================================ + | How to use ? | + ============================================================ + +Before adding empty-spheres, you need a cluster, or list of positions. +The argument name "Structure" designs the Atoms type in pymsspec. The coordinates of the set of points is given +by the command : numpy.ndarray.tolist(Structure.positions) + +For the moment, empty-sphere type isn't defined, only coordinates are computed. + +To see how the routines work : We will show few examples : You just need to adjust the folder where the xyz files will be + + +__________________Internal/External ConvexHull Cover in C60_____________________________________________________________ + +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph + +Structure = read('cluster_examples/C60.xyz') +ExtCover = esph.Convex_Hull_Cover(Structure,radius_es=1,tol=1) +1 +Result = Atoms(positions = ExtCover) +view(Structure + Result) +IntCover1 = esph.Internal_Hull_Cover(Structure,radius_es=0.84,tol=0.6) +l=len(IntCover1) +wcolor = "B"+str(l) +Result1 = Atoms(wcolor,positions = IntCover1) +view(Structure + Result1) +IntCover2 = esph.Internal_Hull_Cover(Structure + Result1) + +Result2 = Atoms(positions = IntCover2) +view(Result1 + Result2) +view(Structure + Result1 + Result2) +=================================Comments : + +The view will allow you to see the added spheres. For the moment, no empty spheres objects have been created, +so we defin special radii, from covalent radii table. + +You can change IntCover1, for example taking radius_es = 0.71 and wcolor with "N" letter, +or es_radius = 0.76 and C letter,etc... The letter allow view function to set correct radii. +The tol parameter influences Fusion_Overlap. Spheres are fusionned if the distance beetween centers is less than +the sum of the two spheres raddi, multiplied by tol parameter. So tol=1 is used to completely avoid spheres to touch +themselves. Default value of tol has been subjectively settled at 0.6 + +ICover2 will ask for radius_es : it is not given in the function call. +If you put radius = 1.3, for example, you will obtain the centroid of the hull after fusionning the spheres. +Try very big or smaller radius to understand how fusion works. +____________________________________________________ + + + +__________________Delaunay TetraHedral with a cube face-centered________________________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph + + +struct = struct = [[0,-1,0],[0,1,0],[0,0,1],[0,0,-1],[1,0,0],[-1,0,0],[-1,-1,-1],[1,-1,-1],[-1,1,-1],[1,1,-1],[-1,-1,1],[1,-1,1],[-1,1,1],[1,1,1]] +Structure = Atoms("C14",positions=struct) +set1 = esph.Delaunay_Tetrahedral_ES(Structure) +Set1 = Atoms (positions = set1) +view(Set1) +view(Structure + Set1) + +set2 = esph.Delaunay_Tetrahedral_ES(Structure+Set1) +Set2 = Atoms (positions = set2) +view(Set2) +view(Structure + Set1 + Set2) +=================================Comments : +First iteration as you can see is given with np minsize and maxsize : This parameters are otionnaly set both at 0 and 999. +The second iteration will show you an actual problem : +The size of empty spheres must be saved to be used once more. +If free space is to small, the routine will obtain some unsolvable problems. This issue is showed in your board with +singular matrix +____________________________________________________ + + + + +__________________Delaunay TetraHedral with a copper sample_____________________________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph + +Structure = read('cluster_examples/copper.xyz') +set1 = esph.Delaunay_Tetrahedral_ES(Structure) +Set1 = Atoms (positions = set1) +view(Set1) +view(Structure + Set1) + +=================================Comments : +First iteration as you can see is given with np minsize and maxsize : This parameters are otionnaly set both at 0 and 999. +If you want to delete the empty-spheres added out of convexhull, you can add the parameter maxsize=2 +No second iteration is done : see the centered cube example for explanations. +____________________________________________________ + + + + +__________________Experiment problem of missing spheres in cover________________________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph + +struct = struct = [[0,-1,0],[0,1,0],[0,0,1],[0,0,-1],[1,0,0],[-1,0,0],[-1,-1,-1],[1,-1,-1],[-1,1,-1],[1,1,-1],[-1,-1,1],[1,-1,1],[-1,1,1],[1,1,1]] +Structure = Atoms("C14",positions=struct) + +ExtCover = esph.Convex_Hull_Cover(Structure,radius_es=1,missing=True) +1 +Result = Atoms(positions = ExtCover) +view(Structure + Result) +ExtCover = esph.Convex_Hull_Cover(Structure,radius_es=1) +1 +Result = Atoms(positions = ExtCover) +view(Structure + Result) +=================================Comments : +As you will see : The Second Result show only 6 empty spheres, and this spheres could maybe overlap the centers of facets. +Classic ConveHull routine returns only boundary points of facets : if points are included in this facets, they miss... +To solve this problem : put the optionnal parameter "missing" at "True". Do it when your cluster as some huge facets with +some atoms included in (exactly like this cube facets, wich are centered). +The first result shows the "good way" : it solves the problem of atoms forgotten by ConvexHull routine. +____________________________________________________ + + + +__________________Covering Nanotube_____________________________________________________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph + + +Structure = read('cluster_examples/tubes.xyz') +#set = np.ndarray.tolist(Structure.positions) +#hull=ConvexHull(set) +Cover = esph.Convex_Hull_Cover(Structure,radius_es=1,missing=True) + +Result = Atoms(positions = Cover) +view(Structure + Result) + +=================================Comments : +Computing time here is bigger, as you will see (Operation is done twice, if you need to go faster, you can do internal and +external cover in one same routine, by not using Select_Int_Ext function. +You can test routine with no missing parameter (missing=False by default) : You will feel good the problem of ConvexHull. + +____________________________________________________ + + +__________________Covering little NH3___________________________________________________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph + +Structure = read('cluster_examples/NH3.xyz') + + +FCover = esph.Flat_Covering(Structure) +1 +3 +Result = Atoms(positions = FCover) +view(Structure + Result) + +Cover = esph.Convex_Hull_Cover(Structure) +1 +1 +Result = Atoms(positions = Cover) +view(Structure + Result) + +TCover = esph.Delaunay_Tetrahedral_ES(Structure) +Result = Atoms(positions = TCover) +view(Structure + Result) +=================================Comments : +Using Flat Covening in caseof little molecule can let some problems : the "biggest plane" selected isn't H3, but an NH2 +face. The results you would prefer are obtained in Convex_Hull_Cover : with a small radius (1 for example), overlap will +happen and routine computes only the empty sphere on the other side of H3 face. With bigger radius (try 2), you will +obtain 3 empty spheres. +TCover uses Tetrahedral resolution. But this problem set a radius solution of polygon with delta < 0, ie no solution is +computed + + + +__________________Covering GeCl4 using ES_AllRadius global variable_____________________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph + +Structure = read('cluster_examples/GeCl4.xyz') +Cover = esph.Convex_Hull_Cover(Structure,radius_es=2) +1 +Result = Atoms(positions = Cover) +view(Structure+Result) + +ESAR1=esph.ES_AllRadius_Updater(Result,Structure,list=1) +print("Actual ES radius list (ESAR1) :\n{}".format(ESAR1)) +Structure=Structure+Result + +Cover = esph.Convex_Hull_Cover(Structure,radius_es=3.5,tol=0) +1 +Result = Atoms(positions = Cover) +view(Structure+Result) + +ESAR2=esph.ES_AllRadius_Updater(Result,Structure,list=1) +print("Actual ES radius list (ESAR2) :\n{}".format(ESAR2)) +comp1=ESAR2[-1] +Cover = esph.Convex_Hull_Cover(Structure,radius_es=3.5) +1 +Result = Atoms(positions = Cover) +view(Structure+Result) + +ESAR2bis=esph.ES_AllRadius_Updater(Result,Structure,list=1) +comp2=ESAR2bis[-1] +print("\n\nWithout fusioning 2nd Cover, empty spheres are sized {} , after fusion there radius is {}".format(comp1,comp2)) + + +=================================Comments : +ESAR1 and ESAR2 are just copy in time of the global variable "ES_AllRadius". Indeed : this global variable is used in +empty_spheres.py, not in main. So ES_AllRadius_Updater returns the global variable in the time it is called. + +We also use this example to show tol use : in the second covering, we need a big radius to touch the 3 bounds of triangle +vertices, so afterward the empty spheres are overlapping. So without tol parameter (tol=0.6 by default), the empty-spheres +fusion, and the second cover is aligned with Cl atoms. +With tol = 0 , no fusion is done, so we have more empty spheres in cover. +Comparing the size of spheres with and without fusionning, you can see that fusion isn't always a good solution. + + + +__________________Covering molecule Phtalocyanine_______________________________________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph +from scipy.spatial import ConvexHull + +Structure = read('cluster_examples/phtalocyanine.xyz') +view(Structure) +FCover = esph.Flat_Covering(Structure,R=2) + +Result = Atoms(positions = FCover) +view(Structure + Result) +FCover = esph.Flat_Covering(Structure,Curved=True) + +Result = Atoms(positions = FCover) +view(Structure + Result) +=================================Comments : +The first FCover is using classic "FlatCovering" : the routine search for every plane, then triangulate and add ES. +The problem here is that phtalocyanine is curved : so the polygons we see are not in same plane ! +As command : Enter 1 to tell there are a lot of different planes. +To see the planes constructed, remove the R=2 parameter. Don't be afraid about time taken in this routine (5min possible) + +To solve the problem : we add the "Curved=True" : as the cluster is close to z=0 plane (but curved), we project him as +2D plane with z=0. So we can triangulate correctly. Be careful with this method : all spheres are taken in the mesh ! +As radius, you should select 1.5, and do again with 2 : The results are pretty different because of the overlap : it can +be interesting to compare the results. + + + +__________________Computin Voronoi Vertices of a Structure (face-centered cube)_________________________________________ +=================================Commands : +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from es_mod import empty_spheres as esph +Structure = read('cluster_examples/centeredcube.xyz') +Vor=esph.Voronoi_Vertex(Structure) +Result=Atoms(positions=Vor) +view(Structure+Result) +Structure = read('cluster_examples/GeCl4.xyz') +Vor=esph.Voronoi_Vertex(Structure) +Result=Atoms(positions=Vor) +view(Structure+Result) +Structure = read('cluster_examples/tubes.xyz') +Vor=esph.Voronoi_Vertex(Structure) +Result=Atoms(positions=Vor) +view(Structure) +view(Structure+Result) +=================================Commands for complete Voronoi informations (ridges, regions/polyhedrons) : +from ase import Atoms +from ase.io import write,read +import numpy as np +from scipy.spatial import Voronoi + +Structure = read('cluster_examples/centeredcube.xyz') +Str=np.ndarray.tolist(Structure.positions) +Vor = Voronoi(Str) + +Vor. [Then click on Tab] +=================================Comments : +The Voronoi_Vertex routine uses scipy.spatial.Voronoi : +https://docs.scipy.org/doc/scipy-0.19.1/reference/generated/scipy.spatial.Voronoi.html + +You can use commands for complete Voronoi information to get voronoi ridges, regions, etc (see details after clicking Tab) + +As you can see, the Voronoi research is very similar to the research of empty spheres. But the common errors solved +before will happen here to (see the 2 last figures : example with nanotube) + +Other Voronoi Tesselations can be found under C++ opensource Voro++ : http://math.lbl.gov/voro++/about.html + +======================================================================================================================== +======================================================================================================================== + + + ============================================================ + | Routines | + ============================================================ + +The Empty_Spheres routines are agenced in different folders : + +=====================empty_spheres.py========================= + + ES_AllRadius_Updater(NewES,Structure,[list]) : Update ES_AllRadius global variable with new radius of empty spheres + given as NewES + + Voronoi_Vertex(Structure) : Computes Voronoi Vertices of Structure + + Delaunay_Tetrahedral_ES(Structure,[minsize],[maxsize],[tol]) : Creates a tetrehedral mesh from the structure, + then returns for each center the perfect sphere going in. + + Convex_Hull_Cover(Structure,[es_radius],[tol],[missing],[Int_Ext]) : Finds the exterior Hull from the set, create triangular + mesh then returns cover coordinates. tol=0 => no fusion + + Select_Int_Ext(Centroid,E1,E2,IE) : Clean the Cover, taking only internal or external + + Internal_Hull_Cover(Structure,[es_radius],[tol],[missing]) : Finds the interior Hull from the set, create triangular + mesh then returns cover coordinates + + Internal_Hull_Centers(set) : Finds the interior Hull from the set, create triangular mesh then returns centers coordinates + + ES_Fusion(set, structure, size) : Change the set by clustering spheres near from size to each other. No size given => take shortest + Maintain distances with structure, compared with the ancient set. + + Fusion_Overlap(Spheres_Data,tol) : Find Spheres touching each other, and fusions them. Don't return radius : only final coordinates + + Flat_Covering(Structure,[R],[tol],[Curved]) : For flat (or almost) set : Searchs major plane, triangulates, + and cover the 2 sides. + + Plane_Triangulation(Plane3D,Plane_eq): Return triangulation of a 3D Plane (convert into 2D, uses Delny) + + Atom_Radius(Structure,n,list) : Returns radius of n°th atom in Structure (Angstrom). Regroup different radius lists. + + Convex_Hull_InterCover(set) : Return list of internal cover using ConvexHull : Different from Delaunay_Intersphere : + made for empty clusters + +============================================================== +=====================es_clustering.py========================= +Tangent_Fourth_Sphere(Spheres_data, r, inout=1) : From 3 tangent spheres, returns the fourth, tangent to others, with radius r. + inout determines the side of the coordinate. +Spheres_Data_Structure_Extractor (Structure,list) : From Structure, returns data as [[S1][S2]...] where Si = [[xi,yi,zi],ri] + used in Tangent_Fourth routine. List determines the radius we will use. + +Spheres_Data_XYZ_Extractor (name,list) : From name, given as "_____.xyz", returns data as [[S1][S2]...] where Si = [[xi,yi,zi],ri] + used in Tangent_Fourth routine. List determines the radius we will use. + +Tetrahedron_ES (Spheres_data) : From 4 spheres forming a tetrahedron,returns the sphere tangent to others, with radius r. + +Triangle_ES (Spheres_data,R) : Returns the 2 solutions of tangent of 3 spheres with radius R. +============================================================== +========================es_tools.py=========================== +=================Vector tools================== +vector_def(A,B) : returns simply the vector translating A to B +vector_norm(V) : return euclidian norm of a vector +throw_away (P,O,d) : returns P' so as O,P and P' are aligned, and OP'=d. So it translate P from O with distance d to direction OP +angle_vector(u,v) : returns the value of the convex angle defined by vectors u and v, in radians. +ColinearTest(u,v) : returns 1 if u and v colinear, and 0 if not. + +===========Distance and Proximity tools======== +distance(a,b) : calculate distance between 2 points +search_nearest(point,set,d) : search the point in set wich is the nearest from point. We must know that the min distance is d +point_set_proximity(point, set) : returns the min distance between the point and the set of points +set_set_proximity(S1,S2) : returns minimal distance between each points of each sets. +longest_dist(set) : returns the longest distance between the points in the set +shortest_dist(set) : returns the shortest distance between the points in the set +dist_point_plan(Pt,Plan) : From Pt=[x,y,z] and Plan=[a,b,c,d], return distance beetween Pt and Plan + +===============Construction tools=============== +Isobarycenter(set) : Calculate isobarycenter of a set of points. Returns his coordinates +Invert_Coord(set,O,r) : Apply circular inversion to every point in the set, excepted for origin, remaining origin. +Midpoint(P1,P2) : Computes the middle point of P1 and P2 +rot3D(P,A,u) : Returns P' image of P by rotation from angle A around unity vector u +===================Data tools=================== +commonlist(L1,L2) : Returns a list of elements common to L1 and L2, ie output is L1 intercection with L2 +cleanlist(list) : Returns a list without repeated elements (each element in cleaned list appears only once) +=====================es_sym_analys.py========================= +sym_analyse(Cluster) : Convert set into xyz folder, then finds all symetries using. Uses compare_sym and read_sym_file + +major_plane(set) : Search the major plane with max nb of points in set and returns all of his points, and his equation + +Cluster_flatness_informations(set) : Returns set's hull's total volume and area + +Cluster_search_hollow(set,tol) : Returns the hollow datas : hollow=[[list,center,volume]...] where list is hollow' vertice's + +Cluster_emptyness_informations(structure) : Returns the % of volume of hull occupied by his spheres index,[center,volume] his hollow's center and volume. tol defines hollow's diagonale + +Vertice_Sphere_Proportion(O,hull) : Returns the proportion of the sphere centered in Oth pt in the hull (proportion in ]O,1]) + +hull_search_neighbors(O,Simplices) : Returns list including O and neighbors (list contains only index, no coordinates) + +convex_base(Neil,Simplices) : Returns all Neil[0] neighbors so as ConvBase is the base of pyramid from top Neil[0] + +Neighbors_List(numAtom,Structure) : Returns index list in Structure of neighbors of Atom indexed numAtom. numatom not included + +Hull_Tetracut(O,Structure,hull) : Returns index list in Structure of centers of spheres defining the terahedron cuting the vertice O + +facet_cap(O,Structure,hull) : Return the proportion of sphere centered in O out from the hull(ie return the cap proportion of the sphere defined by cuting sphere with hull facets) +============================================================== + + + + + + diff --git a/src/msspec/es/Sym_Analys/clus_geom b/src/msspec/es/Sym_Analys/clus_geom new file mode 100644 index 0000000..f2dc1d7 Binary files /dev/null and b/src/msspec/es/Sym_Analys/clus_geom differ diff --git a/src/msspec/es/Sym_Analys/cluster_geometry.inc b/src/msspec/es/Sym_Analys/cluster_geometry.inc new file mode 100644 index 0000000..241f0d2 --- /dev/null +++ b/src/msspec/es/Sym_Analys/cluster_geometry.inc @@ -0,0 +1,11 @@ + PARAMETER(NATCLU_M=700,NLINE_M=10000,NP_M=50) + PARAMETER(NATP_M=700,NAT_EQ_M=64) +C +C NATCLU_M : MAXIMUM NUMBER OF ATOMS IN THE CLUSTER FILE +C NLINE_M : MAXIMUM NUMBER OF LINES IN THE CLUSTER FILE +C NP_M : MAXIMUM NUMBER OF PREAMBLE LINES IN THE +C phagen_scf. f INPUT FILE (BEFORE THE CLUSTER +C SECTION) +C NATP_M : MAXIMUM NUMBER OF PROTOTYPICAL ATOMS +C NAT_EQ_M : MAXIMUM NUMBER OF EQUIVALENT ATOMS +C diff --git a/src/msspec/es/Sym_Analys/proc_geom b/src/msspec/es/Sym_Analys/proc_geom new file mode 100644 index 0000000..5fa2658 --- /dev/null +++ b/src/msspec/es/Sym_Analys/proc_geom @@ -0,0 +1,73 @@ +#! /bin/bash -f +clear +echo " " +echo " " +echo "****************************************************" +echo "* *" +echo "* CLUSTER GEOMETRY ANALYSIS CODE *" +echo "* *" +echo "****************************************************" +echo " " +echo " " +# +time -p ./clus_geom <& error.dat +Test.xyz # Input cluster file +1 # Tetrahedra detection +1 # Octahedra detection +1 # Cube detection +1 # Hollow molecules detection +1 # Nanotube detection +1 # Regular polygons detection +1 # Iregular polygons detection +1 # Symmetries detection +Fin +# +# Checking for errors in the execution +# +cat error.dat | sed -e '1,35d' \ + -e '/real/,/ /d' > error.txt +# +# Checking for a blend of dialog +# +DIAL=`which dialog | cut -d: -f2 | grep -c 'dialog'` +XDIA=`which Xdialog | cut -d: -f2 | grep -c 'Xdialog'` +KDIA=`which kdialog | cut -d: -f2 | grep -c 'kdialog'` +ZENI=`which zenity | cut -d: -f2 | grep -c 'zenity'` +# +if [ "$ZENI" -ne "0" ]; then + DIALOG=zenity +else + if [ "$XDIA" -ne "0" ]; then + DIALOG=Xdialog + else + if [ "$KDIA" -ne "0" ]; then + DIALOG=kdialog + else + if [ "$DIAL" -ne "0" ]; then + DIALOG=dialog + else + DIALOG=none + fi + fi + fi +fi +# +FILE=`ls -at | grep .lis | awk '{print $1}'` +tail --lines=10 $FILE | grep '<<<<' | sed 's/<>/ /g' >> run.txt +cat run.txt >> error.txt +ERR=`cat error.txt` +NLINE=`cat error.txt | wc -l` +# +if [ $NLINE != 0 ]; then + if [ "$DIALOG" = "zenity" ]; then + zenity --width 400 --height 180 \ + --title "MsSpec-1.1 runtime error" \ + --info --text "The code has stopped with the message : \n \n \n $ERR" \ + --timeout 5 + fi +fi +# +rm -f error.dat error.txt run.txt +# +exit + diff --git a/src/msspec/es/__init__.py b/src/msspec/es/__init__.py new file mode 100644 index 0000000..e69de29 diff --git a/src/msspec/es/cluster_examples/C60.xyz b/src/msspec/es/cluster_examples/C60.xyz new file mode 100644 index 0000000..de2ae05 --- /dev/null +++ b/src/msspec/es/cluster_examples/C60.xyz @@ -0,0 +1,62 @@ +60 + +C -0.70401 0.00110 3.57345 +C 0.70083 0.00133 3.57327 +C 3.57574 -0.70246 0.00129 +C 3.57685 0.70239 0.00110 +C 0.00074 3.57570 0.70219 +C 0.00060 3.57460 -0.70265 +C 0.70410 -0.00010 -3.57531 +C -0.70080 -0.00043 -3.57472 +C -3.57649 0.70168 -0.00040 +C -3.57650 -0.70328 -0.00080 +C -0.00022 -3.57603 -0.70253 +C -0.00065 -3.57534 0.70260 +C 1.45527 1.22059 3.10904 +C 1.22007 3.11053 1.45642 +C 3.11158 1.45695 1.22069 +C -1.45773 1.22048 3.10909 +C -3.11002 1.45543 1.21878 +C -1.21916 3.10985 1.45535 +C -1.45798 -1.21865 3.10901 +C -3.11094 -1.45629 1.21895 +C -1.22020 -3.10925 1.45579 +C 1.45456 -1.21797 3.10872 +C 1.21832 -3.10945 1.45706 +C 3.10958 -1.45572 1.22084 +C -1.45534 -1.22011 -3.11047 +C -1.21944 -3.11066 -1.45668 +C -3.10954 -1.45689 -1.22018 +C 1.45725 -1.21982 -3.10992 +C 3.10891 -1.45572 -1.21802 +C 1.21907 -3.10943 -1.45581 +C 1.45804 1.21938 -3.10976 +C 3.11051 1.45522 -1.21855 +C 1.22021 3.10873 -1.45574 +C -1.45417 1.21854 -3.10850 +C -1.21859 3.10885 -1.45655 +C -3.10979 1.45514 -1.21977 +C 0.75317 2.35757 2.67585 +C 2.67579 0.75479 2.35684 +C 2.35709 2.67579 0.75442 +C -2.67816 0.75415 2.35674 +C -0.75451 2.35720 2.67539 +C -2.35486 2.67378 0.75265 +C -2.67807 -0.75360 2.35625 +C -0.75519 -2.35526 2.67525 +C -2.35673 -2.67557 0.75321 +C 0.75208 -2.35504 2.67576 +C 2.35468 -2.67447 0.75491 +C 2.67533 -0.75265 2.35696 +C -0.75325 -2.35679 -2.67619 +C -2.67475 -0.75438 -2.35653 +C -2.35590 -2.67596 -0.75411 +C 2.67648 -0.75411 -2.35574 +C 0.75400 -2.35630 -2.67588 +C 2.35436 -2.67411 -0.75219 +C 2.67749 0.75328 -2.35614 +C 0.75540 2.35626 -2.67613 +C 2.35610 2.67388 -0.75278 +C -0.75218 2.35599 -2.67618 +C -2.35517 2.67402 -0.75419 +C -2.67390 0.75268 -2.35549 diff --git a/src/msspec/es/cluster_examples/GeCl4.xyz b/src/msspec/es/cluster_examples/GeCl4.xyz new file mode 100644 index 0000000..aed12c6 --- /dev/null +++ b/src/msspec/es/cluster_examples/GeCl4.xyz @@ -0,0 +1,7 @@ +5 +Properties=species:S:1:pos:R:3:Z:I:1 pbc="F F F" +Ge 0.0000 0.0000 0.0000 32 +Cl 1.2100 1.2100 1.2100 17 +Cl 1.2100 -1.2100 -1.2100 17 +Cl -1.2100 1.2100 -1.2100 17 +Cl -1.2100 -1.2100 1.2100 17 diff --git a/src/msspec/es/cluster_examples/H2O.xyz b/src/msspec/es/cluster_examples/H2O.xyz new file mode 100644 index 0000000..2adb0ef --- /dev/null +++ b/src/msspec/es/cluster_examples/H2O.xyz @@ -0,0 +1,5 @@ +3 +Properties=species:S:1:pos:R:3:Z:I:1 pbc="F F F" +O 0.00000000 0.00000000 0.11926200 8 +H 0.00000000 0.76323900 -0.47704700 1 +H 0.00000000 -0.76323900 -0.47704700 1 diff --git a/src/msspec/es/cluster_examples/NH3.xyz b/src/msspec/es/cluster_examples/NH3.xyz new file mode 100644 index 0000000..4700851 --- /dev/null +++ b/src/msspec/es/cluster_examples/NH3.xyz @@ -0,0 +1,6 @@ +4 +Ammonia +N 0.257 -0.363 0.000 +H 0.257 0.727 0.000 +H 0.771 -0.727 0.890 +H 0.771 -0.727 -0.890 diff --git a/src/msspec/es/cluster_examples/centeredcube.xyz b/src/msspec/es/cluster_examples/centeredcube.xyz new file mode 100644 index 0000000..2d2d2ee --- /dev/null +++ b/src/msspec/es/cluster_examples/centeredcube.xyz @@ -0,0 +1,16 @@ +14 +Properties=species:S:1:pos:R:3:Z:I:1 pbc="F F F" +C 0.00000000 -1.00000000 0.00000000 6 +C 0.00000000 1.00000000 0.00000000 6 +C 0.00000000 0.00000000 1.00000000 6 +C 0.00000000 0.00000000 -1.00000000 6 +C 1.00000000 0.00000000 0.00000000 6 +C -1.00000000 0.00000000 0.00000000 6 +C -1.00000000 -1.00000000 -1.00000000 6 +C 1.00000000 -1.00000000 -1.00000000 6 +C -1.00000000 1.00000000 -1.00000000 6 +C 1.00000000 1.00000000 -1.00000000 6 +C -1.00000000 -1.00000000 1.00000000 6 +C 1.00000000 -1.00000000 1.00000000 6 +C -1.00000000 1.00000000 1.00000000 6 +C 1.00000000 1.00000000 1.00000000 6 diff --git a/src/msspec/es/cluster_examples/copper.xyz b/src/msspec/es/cluster_examples/copper.xyz new file mode 100644 index 0000000..0858355 --- /dev/null +++ b/src/msspec/es/cluster_examples/copper.xyz @@ -0,0 +1,85 @@ +83 +Lattice="36.0 0.0 0.0 0.0 36.0 0.0 0.0 0.0 36.0" Properties=species:S:1:pos:R:3:Z:I:1 pbc="T T T" +Cu -5.40000000 -3.60000000 -1.80000000 29 +Cu -5.40000000 -1.80000000 -3.60000000 29 +Cu -5.40000000 -1.80000000 0.00000000 29 +Cu -5.40000000 0.00000000 -1.80000000 29 +Cu -5.40000000 1.80000000 -3.60000000 29 +Cu -7.20000000 0.00000000 0.00000000 29 +Cu -5.40000000 1.80000000 0.00000000 29 +Cu -5.40000000 3.60000000 -1.80000000 29 +Cu -3.60000000 -5.40000000 -1.80000000 29 +Cu -1.80000000 -5.40000000 -3.60000000 29 +Cu -1.80000000 -5.40000000 0.00000000 29 +Cu -3.60000000 -1.80000000 -5.40000000 29 +Cu -1.80000000 -3.60000000 -5.40000000 29 +Cu -3.60000000 -3.60000000 -3.60000000 29 +Cu -3.60000000 -1.80000000 -1.80000000 29 +Cu -1.80000000 -3.60000000 -1.80000000 29 +Cu -1.80000000 -1.80000000 -3.60000000 29 +Cu -3.60000000 -3.60000000 0.00000000 29 +Cu -1.80000000 -1.80000000 0.00000000 29 +Cu -3.60000000 1.80000000 -5.40000000 29 +Cu -1.80000000 0.00000000 -5.40000000 29 +Cu -3.60000000 0.00000000 -3.60000000 29 +Cu -3.60000000 1.80000000 -1.80000000 29 +Cu -1.80000000 0.00000000 -1.80000000 29 +Cu -1.80000000 1.80000000 -3.60000000 29 +Cu -3.60000000 0.00000000 0.00000000 29 +Cu -1.80000000 1.80000000 0.00000000 29 +Cu -1.80000000 3.60000000 -5.40000000 29 +Cu -3.60000000 3.60000000 -3.60000000 29 +Cu -3.60000000 5.40000000 -1.80000000 29 +Cu -1.80000000 3.60000000 -1.80000000 29 +Cu -1.80000000 5.40000000 -3.60000000 29 +Cu -3.60000000 3.60000000 0.00000000 29 +Cu -1.80000000 5.40000000 0.00000000 29 +Cu 0.00000000 -5.40000000 -1.80000000 29 +Cu 1.80000000 -5.40000000 -3.60000000 29 +Cu 0.00000000 -7.20000000 0.00000000 29 +Cu 1.80000000 -5.40000000 0.00000000 29 +Cu 0.00000000 -1.80000000 -5.40000000 29 +Cu 1.80000000 -3.60000000 -5.40000000 29 +Cu 0.00000000 -3.60000000 -3.60000000 29 +Cu 0.00000000 -1.80000000 -1.80000000 29 +Cu 1.80000000 -3.60000000 -1.80000000 29 +Cu 1.80000000 -1.80000000 -3.60000000 29 +Cu 0.00000000 -3.60000000 0.00000000 29 +Cu 1.80000000 -1.80000000 0.00000000 29 +Cu 0.00000000 0.00000000 -7.20000000 29 +Cu 0.00000000 1.80000000 -5.40000000 29 +Cu 1.80000000 0.00000000 -5.40000000 29 +Cu 0.00000000 0.00000000 -3.60000000 29 +Cu 0.00000000 1.80000000 -1.80000000 29 +Cu 1.80000000 0.00000000 -1.80000000 29 +Cu 1.80000000 1.80000000 -3.60000000 29 +Cu 0.00000000 0.00000000 0.00000000 29 +Cu 1.80000000 1.80000000 0.00000000 29 +Cu 1.80000000 3.60000000 -5.40000000 29 +Cu 0.00000000 3.60000000 -3.60000000 29 +Cu 0.00000000 5.40000000 -1.80000000 29 +Cu 1.80000000 3.60000000 -1.80000000 29 +Cu 1.80000000 5.40000000 -3.60000000 29 +Cu 0.00000000 3.60000000 0.00000000 29 +Cu 1.80000000 5.40000000 0.00000000 29 +Cu 0.00000000 7.20000000 0.00000000 29 +Cu 3.60000000 -5.40000000 -1.80000000 29 +Cu 3.60000000 -1.80000000 -5.40000000 29 +Cu 3.60000000 -3.60000000 -3.60000000 29 +Cu 3.60000000 -1.80000000 -1.80000000 29 +Cu 5.40000000 -3.60000000 -1.80000000 29 +Cu 5.40000000 -1.80000000 -3.60000000 29 +Cu 3.60000000 -3.60000000 0.00000000 29 +Cu 5.40000000 -1.80000000 0.00000000 29 +Cu 3.60000000 1.80000000 -5.40000000 29 +Cu 3.60000000 0.00000000 -3.60000000 29 +Cu 3.60000000 1.80000000 -1.80000000 29 +Cu 5.40000000 0.00000000 -1.80000000 29 +Cu 5.40000000 1.80000000 -3.60000000 29 +Cu 3.60000000 0.00000000 0.00000000 29 +Cu 5.40000000 1.80000000 0.00000000 29 +Cu 3.60000000 3.60000000 -3.60000000 29 +Cu 3.60000000 5.40000000 -1.80000000 29 +Cu 5.40000000 3.60000000 -1.80000000 29 +Cu 3.60000000 3.60000000 0.00000000 29 +Cu 7.20000000 0.00000000 0.00000000 29 diff --git a/src/msspec/es/cluster_examples/iron.xyz b/src/msspec/es/cluster_examples/iron.xyz new file mode 100644 index 0000000..04526b7 --- /dev/null +++ b/src/msspec/es/cluster_examples/iron.xyz @@ -0,0 +1,146 @@ +144 +Lattice="28.700000000000003 0.0 0.0 0.0 28.700000000000003 0.0 0.0 0.0 28.700000000000003" Properties=species:S:1:pos:R:3:Z:I:1 pbc="T T T" +Fe -7.17500000 -4.30500000 -1.43500000 26 +Fe -7.17500000 -1.43500000 -4.30500000 26 +Fe -7.17500000 -1.43500000 -1.43500000 26 +Fe -7.17500000 1.43500000 -4.30500000 26 +Fe -7.17500000 1.43500000 -1.43500000 26 +Fe -8.61000000 0.00000000 0.00000000 26 +Fe -7.17500000 4.30500000 -1.43500000 26 +Fe -4.30500000 -7.17500000 -1.43500000 26 +Fe -4.30500000 -4.30500000 -4.30500000 26 +Fe -5.74000000 -5.74000000 -2.87000000 26 +Fe -4.30500000 -4.30500000 -1.43500000 26 +Fe -5.74000000 -5.74000000 0.00000000 26 +Fe -4.30500000 -1.43500000 -7.17500000 26 +Fe -5.74000000 -2.87000000 -5.74000000 26 +Fe -4.30500000 -1.43500000 -4.30500000 26 +Fe -5.74000000 -2.87000000 -2.87000000 26 +Fe -4.30500000 -1.43500000 -1.43500000 26 +Fe -5.74000000 -2.87000000 0.00000000 26 +Fe -4.30500000 1.43500000 -7.17500000 26 +Fe -5.74000000 0.00000000 -5.74000000 26 +Fe -4.30500000 1.43500000 -4.30500000 26 +Fe -5.74000000 0.00000000 -2.87000000 26 +Fe -4.30500000 1.43500000 -1.43500000 26 +Fe -5.74000000 0.00000000 0.00000000 26 +Fe -5.74000000 2.87000000 -5.74000000 26 +Fe -4.30500000 4.30500000 -4.30500000 26 +Fe -5.74000000 2.87000000 -2.87000000 26 +Fe -4.30500000 4.30500000 -1.43500000 26 +Fe -5.74000000 2.87000000 0.00000000 26 +Fe -5.74000000 5.74000000 -2.87000000 26 +Fe -4.30500000 7.17500000 -1.43500000 26 +Fe -5.74000000 5.74000000 0.00000000 26 +Fe -1.43500000 -7.17500000 -4.30500000 26 +Fe -1.43500000 -7.17500000 -1.43500000 26 +Fe -1.43500000 -4.30500000 -7.17500000 26 +Fe -2.87000000 -5.74000000 -5.74000000 26 +Fe -1.43500000 -4.30500000 -4.30500000 26 +Fe -2.87000000 -5.74000000 -2.87000000 26 +Fe -1.43500000 -4.30500000 -1.43500000 26 +Fe -2.87000000 -5.74000000 0.00000000 26 +Fe -1.43500000 -1.43500000 -7.17500000 26 +Fe -2.87000000 -2.87000000 -5.74000000 26 +Fe -1.43500000 -1.43500000 -4.30500000 26 +Fe -2.87000000 -2.87000000 -2.87000000 26 +Fe -1.43500000 -1.43500000 -1.43500000 26 +Fe -2.87000000 -2.87000000 0.00000000 26 +Fe -1.43500000 1.43500000 -7.17500000 26 +Fe -2.87000000 0.00000000 -5.74000000 26 +Fe -1.43500000 1.43500000 -4.30500000 26 +Fe -2.87000000 0.00000000 -2.87000000 26 +Fe -1.43500000 1.43500000 -1.43500000 26 +Fe -2.87000000 0.00000000 0.00000000 26 +Fe -1.43500000 4.30500000 -7.17500000 26 +Fe -2.87000000 2.87000000 -5.74000000 26 +Fe -1.43500000 4.30500000 -4.30500000 26 +Fe -2.87000000 2.87000000 -2.87000000 26 +Fe -1.43500000 4.30500000 -1.43500000 26 +Fe -2.87000000 2.87000000 0.00000000 26 +Fe -2.87000000 5.74000000 -5.74000000 26 +Fe -1.43500000 7.17500000 -4.30500000 26 +Fe -2.87000000 5.74000000 -2.87000000 26 +Fe -1.43500000 7.17500000 -1.43500000 26 +Fe -2.87000000 5.74000000 0.00000000 26 +Fe 1.43500000 -7.17500000 -4.30500000 26 +Fe 1.43500000 -7.17500000 -1.43500000 26 +Fe 0.00000000 -8.61000000 0.00000000 26 +Fe 1.43500000 -4.30500000 -7.17500000 26 +Fe 0.00000000 -5.74000000 -5.74000000 26 +Fe 1.43500000 -4.30500000 -4.30500000 26 +Fe 0.00000000 -5.74000000 -2.87000000 26 +Fe 1.43500000 -4.30500000 -1.43500000 26 +Fe 0.00000000 -5.74000000 0.00000000 26 +Fe 1.43500000 -1.43500000 -7.17500000 26 +Fe 0.00000000 -2.87000000 -5.74000000 26 +Fe 1.43500000 -1.43500000 -4.30500000 26 +Fe 0.00000000 -2.87000000 -2.87000000 26 +Fe 1.43500000 -1.43500000 -1.43500000 26 +Fe 0.00000000 -2.87000000 0.00000000 26 +Fe 0.00000000 0.00000000 -8.61000000 26 +Fe 1.43500000 1.43500000 -7.17500000 26 +Fe 0.00000000 0.00000000 -5.74000000 26 +Fe 1.43500000 1.43500000 -4.30500000 26 +Fe 0.00000000 0.00000000 -2.87000000 26 +Fe 1.43500000 1.43500000 -1.43500000 26 +Fe 0.00000000 0.00000000 0.00000000 26 +Fe 1.43500000 4.30500000 -7.17500000 26 +Fe 0.00000000 2.87000000 -5.74000000 26 +Fe 1.43500000 4.30500000 -4.30500000 26 +Fe 0.00000000 2.87000000 -2.87000000 26 +Fe 1.43500000 4.30500000 -1.43500000 26 +Fe 0.00000000 2.87000000 0.00000000 26 +Fe 0.00000000 5.74000000 -5.74000000 26 +Fe 1.43500000 7.17500000 -4.30500000 26 +Fe 0.00000000 5.74000000 -2.87000000 26 +Fe 1.43500000 7.17500000 -1.43500000 26 +Fe 0.00000000 5.74000000 0.00000000 26 +Fe 0.00000000 8.61000000 0.00000000 26 +Fe 4.30500000 -7.17500000 -1.43500000 26 +Fe 2.87000000 -5.74000000 -5.74000000 26 +Fe 4.30500000 -4.30500000 -4.30500000 26 +Fe 2.87000000 -5.74000000 -2.87000000 26 +Fe 4.30500000 -4.30500000 -1.43500000 26 +Fe 2.87000000 -5.74000000 0.00000000 26 +Fe 4.30500000 -1.43500000 -7.17500000 26 +Fe 2.87000000 -2.87000000 -5.74000000 26 +Fe 4.30500000 -1.43500000 -4.30500000 26 +Fe 2.87000000 -2.87000000 -2.87000000 26 +Fe 4.30500000 -1.43500000 -1.43500000 26 +Fe 2.87000000 -2.87000000 0.00000000 26 +Fe 4.30500000 1.43500000 -7.17500000 26 +Fe 2.87000000 0.00000000 -5.74000000 26 +Fe 4.30500000 1.43500000 -4.30500000 26 +Fe 2.87000000 0.00000000 -2.87000000 26 +Fe 4.30500000 1.43500000 -1.43500000 26 +Fe 2.87000000 0.00000000 0.00000000 26 +Fe 2.87000000 2.87000000 -5.74000000 26 +Fe 4.30500000 4.30500000 -4.30500000 26 +Fe 2.87000000 2.87000000 -2.87000000 26 +Fe 4.30500000 4.30500000 -1.43500000 26 +Fe 2.87000000 2.87000000 0.00000000 26 +Fe 2.87000000 5.74000000 -5.74000000 26 +Fe 2.87000000 5.74000000 -2.87000000 26 +Fe 4.30500000 7.17500000 -1.43500000 26 +Fe 2.87000000 5.74000000 0.00000000 26 +Fe 5.74000000 -5.74000000 -2.87000000 26 +Fe 7.17500000 -4.30500000 -1.43500000 26 +Fe 5.74000000 -5.74000000 0.00000000 26 +Fe 5.74000000 -2.87000000 -5.74000000 26 +Fe 7.17500000 -1.43500000 -4.30500000 26 +Fe 5.74000000 -2.87000000 -2.87000000 26 +Fe 7.17500000 -1.43500000 -1.43500000 26 +Fe 5.74000000 -2.87000000 0.00000000 26 +Fe 5.74000000 0.00000000 -5.74000000 26 +Fe 7.17500000 1.43500000 -4.30500000 26 +Fe 5.74000000 0.00000000 -2.87000000 26 +Fe 7.17500000 1.43500000 -1.43500000 26 +Fe 5.74000000 0.00000000 0.00000000 26 +Fe 5.74000000 2.87000000 -5.74000000 26 +Fe 5.74000000 2.87000000 -2.87000000 26 +Fe 7.17500000 4.30500000 -1.43500000 26 +Fe 5.74000000 2.87000000 0.00000000 26 +Fe 5.74000000 5.74000000 -2.87000000 26 +Fe 5.74000000 5.74000000 0.00000000 26 +Fe 8.61000000 0.00000000 0.00000000 26 diff --git a/src/msspec/es/cluster_examples/mgo.xyz b/src/msspec/es/cluster_examples/mgo.xyz new file mode 100644 index 0000000..e86dbe8 --- /dev/null +++ b/src/msspec/es/cluster_examples/mgo.xyz @@ -0,0 +1,786 @@ +784 +Lattice="4.21 0.0 0.0 0.0 4.21 0.0 0.0 0.0 4.21" Properties=species:S:1:pos:R:3:Z:I:1:tags:I:1 pbc="T T T" +O -12.63000000 -4.21000000 -4.21000000 8 0 +Mg -12.63000000 -6.31500000 -4.21000000 12 1 +Mg -12.63000000 -4.21000000 -6.31500000 12 1 +O -12.63000000 -6.31500000 -2.10500000 8 0 +O -12.63000000 -4.21000000 0.00000000 8 0 +Mg -12.63000000 -6.31500000 0.00000000 12 1 +Mg -12.63000000 -4.21000000 -2.10500000 12 1 +O -12.63000000 -2.10500000 -6.31500000 8 0 +O -12.63000000 0.00000000 -4.21000000 8 0 +Mg -12.63000000 -2.10500000 -4.21000000 12 1 +Mg -12.63000000 0.00000000 -6.31500000 12 1 +O -12.63000000 -2.10500000 -2.10500000 8 0 +Mg -14.73500000 0.00000000 0.00000000 12 1 +O -12.63000000 0.00000000 0.00000000 8 0 +Mg -12.63000000 -2.10500000 0.00000000 12 1 +Mg -12.63000000 0.00000000 -2.10500000 12 1 +O -12.63000000 2.10500000 -6.31500000 8 0 +O -12.63000000 4.21000000 -4.21000000 8 0 +Mg -12.63000000 2.10500000 -4.21000000 12 1 +Mg -12.63000000 4.21000000 -6.31500000 12 1 +O -12.63000000 2.10500000 -2.10500000 8 0 +O -12.63000000 4.21000000 0.00000000 8 0 +Mg -12.63000000 2.10500000 0.00000000 12 1 +Mg -12.63000000 4.21000000 -2.10500000 12 1 +Mg -12.63000000 6.31500000 -4.21000000 12 1 +O -12.63000000 6.31500000 -2.10500000 8 0 +Mg -12.63000000 6.31500000 0.00000000 12 1 +O -8.42000000 -8.42000000 -8.42000000 8 0 +Mg -10.52500000 -8.42000000 -4.21000000 12 1 +O -8.42000000 -8.42000000 -4.21000000 8 0 +Mg -8.42000000 -10.52500000 -4.21000000 12 1 +Mg -8.42000000 -8.42000000 -6.31500000 12 1 +O -8.42000000 -10.52500000 -2.10500000 8 0 +Mg -10.52500000 -8.42000000 0.00000000 12 1 +O -8.42000000 -8.42000000 0.00000000 8 0 +Mg -8.42000000 -10.52500000 0.00000000 12 1 +Mg -8.42000000 -8.42000000 -2.10500000 12 1 +O -10.52500000 -8.42000000 -2.10500000 8 0 +Mg -10.52500000 -4.21000000 -8.42000000 12 1 +O -8.42000000 -4.21000000 -8.42000000 8 0 +Mg -8.42000000 -6.31500000 -8.42000000 12 1 +Mg -8.42000000 -4.21000000 -10.52500000 12 1 +Mg -10.52500000 -6.31500000 -6.31500000 12 1 +O -8.42000000 -6.31500000 -6.31500000 8 0 +Mg -10.52500000 -4.21000000 -4.21000000 12 1 +O -8.42000000 -4.21000000 -4.21000000 8 0 +Mg -8.42000000 -6.31500000 -4.21000000 12 1 +O -10.52500000 -6.31500000 -4.21000000 8 0 +Mg -8.42000000 -4.21000000 -6.31500000 12 1 +O -10.52500000 -4.21000000 -6.31500000 8 0 +Mg -10.52500000 -6.31500000 -2.10500000 12 1 +O -8.42000000 -6.31500000 -2.10500000 8 0 +Mg -10.52500000 -4.21000000 0.00000000 12 1 +O -8.42000000 -4.21000000 0.00000000 8 0 +Mg -8.42000000 -6.31500000 0.00000000 12 1 +O -10.52500000 -6.31500000 0.00000000 8 0 +Mg -8.42000000 -4.21000000 -2.10500000 12 1 +O -10.52500000 -4.21000000 -2.10500000 8 0 +O -8.42000000 -2.10500000 -10.52500000 8 0 +Mg -10.52500000 0.00000000 -8.42000000 12 1 +O -8.42000000 0.00000000 -8.42000000 8 0 +Mg -8.42000000 -2.10500000 -8.42000000 12 1 +O -10.52500000 -2.10500000 -8.42000000 8 0 +Mg -8.42000000 0.00000000 -10.52500000 12 1 +Mg -10.52500000 -2.10500000 -6.31500000 12 1 +O -8.42000000 -2.10500000 -6.31500000 8 0 +Mg -10.52500000 0.00000000 -4.21000000 12 1 +O -8.42000000 0.00000000 -4.21000000 8 0 +Mg -8.42000000 -2.10500000 -4.21000000 12 1 +O -10.52500000 -2.10500000 -4.21000000 8 0 +Mg -8.42000000 0.00000000 -6.31500000 12 1 +O -10.52500000 0.00000000 -6.31500000 8 0 +Mg -10.52500000 -2.10500000 -2.10500000 12 1 +O -8.42000000 -2.10500000 -2.10500000 8 0 +Mg -10.52500000 0.00000000 0.00000000 12 1 +O -8.42000000 0.00000000 0.00000000 8 0 +Mg -8.42000000 -2.10500000 0.00000000 12 1 +O -10.52500000 -2.10500000 0.00000000 8 0 +Mg -8.42000000 0.00000000 -2.10500000 12 1 +O -10.52500000 0.00000000 -2.10500000 8 0 +O -8.42000000 2.10500000 -10.52500000 8 0 +Mg -10.52500000 4.21000000 -8.42000000 12 1 +O -8.42000000 4.21000000 -8.42000000 8 0 +Mg -8.42000000 2.10500000 -8.42000000 12 1 +O -10.52500000 2.10500000 -8.42000000 8 0 +Mg -8.42000000 4.21000000 -10.52500000 12 1 +Mg -10.52500000 2.10500000 -6.31500000 12 1 +O -8.42000000 2.10500000 -6.31500000 8 0 +Mg -10.52500000 4.21000000 -4.21000000 12 1 +O -8.42000000 4.21000000 -4.21000000 8 0 +Mg -8.42000000 2.10500000 -4.21000000 12 1 +O -10.52500000 2.10500000 -4.21000000 8 0 +Mg -8.42000000 4.21000000 -6.31500000 12 1 +O -10.52500000 4.21000000 -6.31500000 8 0 +Mg -10.52500000 2.10500000 -2.10500000 12 1 +O -8.42000000 2.10500000 -2.10500000 8 0 +Mg -10.52500000 4.21000000 0.00000000 12 1 +O -8.42000000 4.21000000 0.00000000 8 0 +Mg -8.42000000 2.10500000 0.00000000 12 1 +O -10.52500000 2.10500000 0.00000000 8 0 +Mg -8.42000000 4.21000000 -2.10500000 12 1 +O -10.52500000 4.21000000 -2.10500000 8 0 +O -8.42000000 8.42000000 -8.42000000 8 0 +Mg -8.42000000 6.31500000 -8.42000000 12 1 +Mg -10.52500000 6.31500000 -6.31500000 12 1 +O -8.42000000 6.31500000 -6.31500000 8 0 +Mg -10.52500000 8.42000000 -4.21000000 12 1 +O -8.42000000 8.42000000 -4.21000000 8 0 +Mg -8.42000000 6.31500000 -4.21000000 12 1 +O -10.52500000 6.31500000 -4.21000000 8 0 +Mg -8.42000000 8.42000000 -6.31500000 12 1 +Mg -10.52500000 6.31500000 -2.10500000 12 1 +O -8.42000000 6.31500000 -2.10500000 8 0 +Mg -10.52500000 8.42000000 0.00000000 12 1 +O -8.42000000 8.42000000 0.00000000 8 0 +Mg -8.42000000 6.31500000 0.00000000 12 1 +O -10.52500000 6.31500000 0.00000000 8 0 +Mg -8.42000000 8.42000000 -2.10500000 12 1 +O -10.52500000 8.42000000 -2.10500000 8 0 +Mg -8.42000000 10.52500000 -4.21000000 12 1 +O -8.42000000 10.52500000 -2.10500000 8 0 +Mg -8.42000000 10.52500000 0.00000000 12 1 +Mg -6.31500000 -12.63000000 -4.21000000 12 1 +O -4.21000000 -12.63000000 -4.21000000 8 0 +Mg -4.21000000 -12.63000000 -6.31500000 12 1 +Mg -6.31500000 -12.63000000 0.00000000 12 1 +O -4.21000000 -12.63000000 0.00000000 8 0 +Mg -4.21000000 -12.63000000 -2.10500000 12 1 +O -6.31500000 -12.63000000 -2.10500000 8 0 +Mg -6.31500000 -8.42000000 -8.42000000 12 1 +O -4.21000000 -8.42000000 -8.42000000 8 0 +Mg -4.21000000 -10.52500000 -8.42000000 12 1 +Mg -4.21000000 -8.42000000 -10.52500000 12 1 +Mg -6.31500000 -10.52500000 -6.31500000 12 1 +O -4.21000000 -10.52500000 -6.31500000 8 0 +Mg -6.31500000 -8.42000000 -4.21000000 12 1 +O -4.21000000 -8.42000000 -4.21000000 8 0 +Mg -4.21000000 -10.52500000 -4.21000000 12 1 +O -6.31500000 -10.52500000 -4.21000000 8 0 +Mg -4.21000000 -8.42000000 -6.31500000 12 1 +O -6.31500000 -8.42000000 -6.31500000 8 0 +Mg -6.31500000 -10.52500000 -2.10500000 12 1 +O -4.21000000 -10.52500000 -2.10500000 8 0 +Mg -6.31500000 -8.42000000 0.00000000 12 1 +O -4.21000000 -8.42000000 0.00000000 8 0 +Mg -4.21000000 -10.52500000 0.00000000 12 1 +O -6.31500000 -10.52500000 0.00000000 8 0 +Mg -4.21000000 -8.42000000 -2.10500000 12 1 +O -6.31500000 -8.42000000 -2.10500000 8 0 +Mg -6.31500000 -4.21000000 -12.63000000 12 1 +O -4.21000000 -4.21000000 -12.63000000 8 0 +Mg -4.21000000 -6.31500000 -12.63000000 12 1 +Mg -6.31500000 -6.31500000 -10.52500000 12 1 +O -4.21000000 -6.31500000 -10.52500000 8 0 +Mg -6.31500000 -4.21000000 -8.42000000 12 1 +O -4.21000000 -4.21000000 -8.42000000 8 0 +Mg -4.21000000 -6.31500000 -8.42000000 12 1 +O -6.31500000 -6.31500000 -8.42000000 8 0 +Mg -4.21000000 -4.21000000 -10.52500000 12 1 +O -6.31500000 -4.21000000 -10.52500000 8 0 +Mg -6.31500000 -6.31500000 -6.31500000 12 1 +O -4.21000000 -6.31500000 -6.31500000 8 0 +Mg -6.31500000 -4.21000000 -4.21000000 12 1 +O -4.21000000 -4.21000000 -4.21000000 8 0 +Mg -4.21000000 -6.31500000 -4.21000000 12 1 +O -6.31500000 -6.31500000 -4.21000000 8 0 +Mg -4.21000000 -4.21000000 -6.31500000 12 1 +O -6.31500000 -4.21000000 -6.31500000 8 0 +Mg -6.31500000 -6.31500000 -2.10500000 12 1 +O -4.21000000 -6.31500000 -2.10500000 8 0 +Mg -6.31500000 -4.21000000 0.00000000 12 1 +O -4.21000000 -4.21000000 0.00000000 8 0 +Mg -4.21000000 -6.31500000 0.00000000 12 1 +O -6.31500000 -6.31500000 0.00000000 8 0 +Mg -4.21000000 -4.21000000 -2.10500000 12 1 +O -6.31500000 -4.21000000 -2.10500000 8 0 +Mg -6.31500000 0.00000000 -12.63000000 12 1 +O -4.21000000 0.00000000 -12.63000000 8 0 +Mg -4.21000000 -2.10500000 -12.63000000 12 1 +O -6.31500000 -2.10500000 -12.63000000 8 0 +Mg -6.31500000 -2.10500000 -10.52500000 12 1 +O -4.21000000 -2.10500000 -10.52500000 8 0 +Mg -6.31500000 0.00000000 -8.42000000 12 1 +O -4.21000000 0.00000000 -8.42000000 8 0 +Mg -4.21000000 -2.10500000 -8.42000000 12 1 +O -6.31500000 -2.10500000 -8.42000000 8 0 +Mg -4.21000000 0.00000000 -10.52500000 12 1 +O -6.31500000 0.00000000 -10.52500000 8 0 +Mg -6.31500000 -2.10500000 -6.31500000 12 1 +O -4.21000000 -2.10500000 -6.31500000 8 0 +Mg -6.31500000 0.00000000 -4.21000000 12 1 +O -4.21000000 0.00000000 -4.21000000 8 0 +Mg -4.21000000 -2.10500000 -4.21000000 12 1 +O -6.31500000 -2.10500000 -4.21000000 8 0 +Mg -4.21000000 0.00000000 -6.31500000 12 1 +O -6.31500000 0.00000000 -6.31500000 8 0 +Mg -6.31500000 -2.10500000 -2.10500000 12 1 +O -4.21000000 -2.10500000 -2.10500000 8 0 +Mg -6.31500000 0.00000000 0.00000000 12 1 +O -4.21000000 0.00000000 0.00000000 8 0 +Mg -4.21000000 -2.10500000 0.00000000 12 1 +O -6.31500000 -2.10500000 0.00000000 8 0 +Mg -4.21000000 0.00000000 -2.10500000 12 1 +O -6.31500000 0.00000000 -2.10500000 8 0 +Mg -6.31500000 4.21000000 -12.63000000 12 1 +O -4.21000000 4.21000000 -12.63000000 8 0 +Mg -4.21000000 2.10500000 -12.63000000 12 1 +O -6.31500000 2.10500000 -12.63000000 8 0 +Mg -6.31500000 2.10500000 -10.52500000 12 1 +O -4.21000000 2.10500000 -10.52500000 8 0 +Mg -6.31500000 4.21000000 -8.42000000 12 1 +O -4.21000000 4.21000000 -8.42000000 8 0 +Mg -4.21000000 2.10500000 -8.42000000 12 1 +O -6.31500000 2.10500000 -8.42000000 8 0 +Mg -4.21000000 4.21000000 -10.52500000 12 1 +O -6.31500000 4.21000000 -10.52500000 8 0 +Mg -6.31500000 2.10500000 -6.31500000 12 1 +O -4.21000000 2.10500000 -6.31500000 8 0 +Mg -6.31500000 4.21000000 -4.21000000 12 1 +O -4.21000000 4.21000000 -4.21000000 8 0 +Mg -4.21000000 2.10500000 -4.21000000 12 1 +O -6.31500000 2.10500000 -4.21000000 8 0 +Mg -4.21000000 4.21000000 -6.31500000 12 1 +O -6.31500000 4.21000000 -6.31500000 8 0 +Mg -6.31500000 2.10500000 -2.10500000 12 1 +O -4.21000000 2.10500000 -2.10500000 8 0 +Mg -6.31500000 4.21000000 0.00000000 12 1 +O -4.21000000 4.21000000 0.00000000 8 0 +Mg -4.21000000 2.10500000 0.00000000 12 1 +O -6.31500000 2.10500000 0.00000000 8 0 +Mg -4.21000000 4.21000000 -2.10500000 12 1 +O -6.31500000 4.21000000 -2.10500000 8 0 +Mg -4.21000000 6.31500000 -12.63000000 12 1 +Mg -6.31500000 6.31500000 -10.52500000 12 1 +O -4.21000000 6.31500000 -10.52500000 8 0 +Mg -6.31500000 8.42000000 -8.42000000 12 1 +O -4.21000000 8.42000000 -8.42000000 8 0 +Mg -4.21000000 6.31500000 -8.42000000 12 1 +O -6.31500000 6.31500000 -8.42000000 8 0 +Mg -4.21000000 8.42000000 -10.52500000 12 1 +Mg -6.31500000 6.31500000 -6.31500000 12 1 +O -4.21000000 6.31500000 -6.31500000 8 0 +Mg -6.31500000 8.42000000 -4.21000000 12 1 +O -4.21000000 8.42000000 -4.21000000 8 0 +Mg -4.21000000 6.31500000 -4.21000000 12 1 +O -6.31500000 6.31500000 -4.21000000 8 0 +Mg -4.21000000 8.42000000 -6.31500000 12 1 +O -6.31500000 8.42000000 -6.31500000 8 0 +Mg -6.31500000 6.31500000 -2.10500000 12 1 +O -4.21000000 6.31500000 -2.10500000 8 0 +Mg -6.31500000 8.42000000 0.00000000 12 1 +O -4.21000000 8.42000000 0.00000000 8 0 +Mg -4.21000000 6.31500000 0.00000000 12 1 +O -6.31500000 6.31500000 0.00000000 8 0 +Mg -4.21000000 8.42000000 -2.10500000 12 1 +O -6.31500000 8.42000000 -2.10500000 8 0 +Mg -4.21000000 10.52500000 -8.42000000 12 1 +Mg -6.31500000 10.52500000 -6.31500000 12 1 +O -4.21000000 10.52500000 -6.31500000 8 0 +Mg -6.31500000 12.63000000 -4.21000000 12 1 +O -4.21000000 12.63000000 -4.21000000 8 0 +Mg -4.21000000 10.52500000 -4.21000000 12 1 +O -6.31500000 10.52500000 -4.21000000 8 0 +Mg -4.21000000 12.63000000 -6.31500000 12 1 +Mg -6.31500000 10.52500000 -2.10500000 12 1 +O -4.21000000 10.52500000 -2.10500000 8 0 +Mg -6.31500000 12.63000000 0.00000000 12 1 +O -4.21000000 12.63000000 0.00000000 8 0 +Mg -4.21000000 10.52500000 0.00000000 12 1 +O -6.31500000 10.52500000 0.00000000 8 0 +Mg -4.21000000 12.63000000 -2.10500000 12 1 +O -6.31500000 12.63000000 -2.10500000 8 0 +Mg -2.10500000 -12.63000000 -4.21000000 12 1 +O 0.00000000 -12.63000000 -4.21000000 8 0 +Mg 0.00000000 -12.63000000 -6.31500000 12 1 +O -2.10500000 -12.63000000 -6.31500000 8 0 +Mg -2.10500000 -12.63000000 0.00000000 12 1 +O 0.00000000 -12.63000000 0.00000000 8 0 +Mg 0.00000000 -14.73500000 0.00000000 12 1 +Mg 0.00000000 -12.63000000 -2.10500000 12 1 +O -2.10500000 -12.63000000 -2.10500000 8 0 +Mg -2.10500000 -8.42000000 -8.42000000 12 1 +O 0.00000000 -8.42000000 -8.42000000 8 0 +Mg 0.00000000 -10.52500000 -8.42000000 12 1 +O -2.10500000 -10.52500000 -8.42000000 8 0 +Mg 0.00000000 -8.42000000 -10.52500000 12 1 +O -2.10500000 -8.42000000 -10.52500000 8 0 +Mg -2.10500000 -10.52500000 -6.31500000 12 1 +O 0.00000000 -10.52500000 -6.31500000 8 0 +Mg -2.10500000 -8.42000000 -4.21000000 12 1 +O 0.00000000 -8.42000000 -4.21000000 8 0 +Mg 0.00000000 -10.52500000 -4.21000000 12 1 +O -2.10500000 -10.52500000 -4.21000000 8 0 +Mg 0.00000000 -8.42000000 -6.31500000 12 1 +O -2.10500000 -8.42000000 -6.31500000 8 0 +Mg -2.10500000 -10.52500000 -2.10500000 12 1 +O 0.00000000 -10.52500000 -2.10500000 8 0 +Mg -2.10500000 -8.42000000 0.00000000 12 1 +O 0.00000000 -8.42000000 0.00000000 8 0 +Mg 0.00000000 -10.52500000 0.00000000 12 1 +O -2.10500000 -10.52500000 0.00000000 8 0 +Mg 0.00000000 -8.42000000 -2.10500000 12 1 +O -2.10500000 -8.42000000 -2.10500000 8 0 +Mg -2.10500000 -4.21000000 -12.63000000 12 1 +O 0.00000000 -4.21000000 -12.63000000 8 0 +Mg 0.00000000 -6.31500000 -12.63000000 12 1 +O -2.10500000 -6.31500000 -12.63000000 8 0 +Mg -2.10500000 -6.31500000 -10.52500000 12 1 +O 0.00000000 -6.31500000 -10.52500000 8 0 +Mg -2.10500000 -4.21000000 -8.42000000 12 1 +O 0.00000000 -4.21000000 -8.42000000 8 0 +Mg 0.00000000 -6.31500000 -8.42000000 12 1 +O -2.10500000 -6.31500000 -8.42000000 8 0 +Mg 0.00000000 -4.21000000 -10.52500000 12 1 +O -2.10500000 -4.21000000 -10.52500000 8 0 +Mg -2.10500000 -6.31500000 -6.31500000 12 1 +O 0.00000000 -6.31500000 -6.31500000 8 0 +Mg -2.10500000 -4.21000000 -4.21000000 12 1 +O 0.00000000 -4.21000000 -4.21000000 8 0 +Mg 0.00000000 -6.31500000 -4.21000000 12 1 +O -2.10500000 -6.31500000 -4.21000000 8 0 +Mg 0.00000000 -4.21000000 -6.31500000 12 1 +O -2.10500000 -4.21000000 -6.31500000 8 0 +Mg -2.10500000 -6.31500000 -2.10500000 12 1 +O 0.00000000 -6.31500000 -2.10500000 8 0 +Mg -2.10500000 -4.21000000 0.00000000 12 1 +O 0.00000000 -4.21000000 0.00000000 8 0 +Mg 0.00000000 -6.31500000 0.00000000 12 1 +O -2.10500000 -6.31500000 0.00000000 8 0 +Mg 0.00000000 -4.21000000 -2.10500000 12 1 +O -2.10500000 -4.21000000 -2.10500000 8 0 +Mg -2.10500000 0.00000000 -12.63000000 12 1 +O 0.00000000 0.00000000 -12.63000000 8 0 +Mg 0.00000000 -2.10500000 -12.63000000 12 1 +O -2.10500000 -2.10500000 -12.63000000 8 0 +Mg 0.00000000 0.00000000 -14.73500000 12 1 +Mg -2.10500000 -2.10500000 -10.52500000 12 1 +O 0.00000000 -2.10500000 -10.52500000 8 0 +Mg -2.10500000 0.00000000 -8.42000000 12 1 +O 0.00000000 0.00000000 -8.42000000 8 0 +Mg 0.00000000 -2.10500000 -8.42000000 12 1 +O -2.10500000 -2.10500000 -8.42000000 8 0 +Mg 0.00000000 0.00000000 -10.52500000 12 1 +O -2.10500000 0.00000000 -10.52500000 8 0 +Mg -2.10500000 -2.10500000 -6.31500000 12 1 +O 0.00000000 -2.10500000 -6.31500000 8 0 +Mg -2.10500000 0.00000000 -4.21000000 12 1 +O 0.00000000 0.00000000 -4.21000000 8 0 +Mg 0.00000000 -2.10500000 -4.21000000 12 1 +O -2.10500000 -2.10500000 -4.21000000 8 0 +Mg 0.00000000 0.00000000 -6.31500000 12 1 +O -2.10500000 0.00000000 -6.31500000 8 0 +Mg -2.10500000 -2.10500000 -2.10500000 12 1 +O 0.00000000 -2.10500000 -2.10500000 8 0 +Mg -2.10500000 0.00000000 0.00000000 12 1 +O 0.00000000 0.00000000 0.00000000 8 0 +Mg 0.00000000 -2.10500000 0.00000000 12 1 +O -2.10500000 -2.10500000 0.00000000 8 0 +Mg 0.00000000 0.00000000 -2.10500000 12 1 +O -2.10500000 0.00000000 -2.10500000 8 0 +Mg -2.10500000 4.21000000 -12.63000000 12 1 +O 0.00000000 4.21000000 -12.63000000 8 0 +Mg 0.00000000 2.10500000 -12.63000000 12 1 +O -2.10500000 2.10500000 -12.63000000 8 0 +Mg -2.10500000 2.10500000 -10.52500000 12 1 +O 0.00000000 2.10500000 -10.52500000 8 0 +Mg -2.10500000 4.21000000 -8.42000000 12 1 +O 0.00000000 4.21000000 -8.42000000 8 0 +Mg 0.00000000 2.10500000 -8.42000000 12 1 +O -2.10500000 2.10500000 -8.42000000 8 0 +Mg 0.00000000 4.21000000 -10.52500000 12 1 +O -2.10500000 4.21000000 -10.52500000 8 0 +Mg -2.10500000 2.10500000 -6.31500000 12 1 +O 0.00000000 2.10500000 -6.31500000 8 0 +Mg -2.10500000 4.21000000 -4.21000000 12 1 +O 0.00000000 4.21000000 -4.21000000 8 0 +Mg 0.00000000 2.10500000 -4.21000000 12 1 +O -2.10500000 2.10500000 -4.21000000 8 0 +Mg 0.00000000 4.21000000 -6.31500000 12 1 +O -2.10500000 4.21000000 -6.31500000 8 0 +Mg -2.10500000 2.10500000 -2.10500000 12 1 +O 0.00000000 2.10500000 -2.10500000 8 0 +Mg -2.10500000 4.21000000 0.00000000 12 1 +O 0.00000000 4.21000000 0.00000000 8 0 +Mg 0.00000000 2.10500000 0.00000000 12 1 +O -2.10500000 2.10500000 0.00000000 8 0 +Mg 0.00000000 4.21000000 -2.10500000 12 1 +O -2.10500000 4.21000000 -2.10500000 8 0 +Mg 0.00000000 6.31500000 -12.63000000 12 1 +O -2.10500000 6.31500000 -12.63000000 8 0 +Mg -2.10500000 6.31500000 -10.52500000 12 1 +O 0.00000000 6.31500000 -10.52500000 8 0 +Mg -2.10500000 8.42000000 -8.42000000 12 1 +O 0.00000000 8.42000000 -8.42000000 8 0 +Mg 0.00000000 6.31500000 -8.42000000 12 1 +O -2.10500000 6.31500000 -8.42000000 8 0 +Mg 0.00000000 8.42000000 -10.52500000 12 1 +O -2.10500000 8.42000000 -10.52500000 8 0 +Mg -2.10500000 6.31500000 -6.31500000 12 1 +O 0.00000000 6.31500000 -6.31500000 8 0 +Mg -2.10500000 8.42000000 -4.21000000 12 1 +O 0.00000000 8.42000000 -4.21000000 8 0 +Mg 0.00000000 6.31500000 -4.21000000 12 1 +O -2.10500000 6.31500000 -4.21000000 8 0 +Mg 0.00000000 8.42000000 -6.31500000 12 1 +O -2.10500000 8.42000000 -6.31500000 8 0 +Mg -2.10500000 6.31500000 -2.10500000 12 1 +O 0.00000000 6.31500000 -2.10500000 8 0 +Mg -2.10500000 8.42000000 0.00000000 12 1 +O 0.00000000 8.42000000 0.00000000 8 0 +Mg 0.00000000 6.31500000 0.00000000 12 1 +O -2.10500000 6.31500000 0.00000000 8 0 +Mg 0.00000000 8.42000000 -2.10500000 12 1 +O -2.10500000 8.42000000 -2.10500000 8 0 +Mg 0.00000000 10.52500000 -8.42000000 12 1 +O -2.10500000 10.52500000 -8.42000000 8 0 +Mg -2.10500000 10.52500000 -6.31500000 12 1 +O 0.00000000 10.52500000 -6.31500000 8 0 +Mg -2.10500000 12.63000000 -4.21000000 12 1 +O 0.00000000 12.63000000 -4.21000000 8 0 +Mg 0.00000000 10.52500000 -4.21000000 12 1 +O -2.10500000 10.52500000 -4.21000000 8 0 +Mg 0.00000000 12.63000000 -6.31500000 12 1 +O -2.10500000 12.63000000 -6.31500000 8 0 +Mg -2.10500000 10.52500000 -2.10500000 12 1 +O 0.00000000 10.52500000 -2.10500000 8 0 +Mg -2.10500000 12.63000000 0.00000000 12 1 +O 0.00000000 12.63000000 0.00000000 8 0 +Mg 0.00000000 10.52500000 0.00000000 12 1 +O -2.10500000 10.52500000 0.00000000 8 0 +Mg 0.00000000 12.63000000 -2.10500000 12 1 +O -2.10500000 12.63000000 -2.10500000 8 0 +Mg 0.00000000 14.73500000 0.00000000 12 1 +Mg 2.10500000 -12.63000000 -4.21000000 12 1 +O 4.21000000 -12.63000000 -4.21000000 8 0 +Mg 4.21000000 -12.63000000 -6.31500000 12 1 +O 2.10500000 -12.63000000 -6.31500000 8 0 +Mg 2.10500000 -12.63000000 0.00000000 12 1 +O 4.21000000 -12.63000000 0.00000000 8 0 +Mg 4.21000000 -12.63000000 -2.10500000 12 1 +O 2.10500000 -12.63000000 -2.10500000 8 0 +Mg 2.10500000 -8.42000000 -8.42000000 12 1 +O 4.21000000 -8.42000000 -8.42000000 8 0 +Mg 4.21000000 -10.52500000 -8.42000000 12 1 +O 2.10500000 -10.52500000 -8.42000000 8 0 +Mg 4.21000000 -8.42000000 -10.52500000 12 1 +O 2.10500000 -8.42000000 -10.52500000 8 0 +Mg 2.10500000 -10.52500000 -6.31500000 12 1 +O 4.21000000 -10.52500000 -6.31500000 8 0 +Mg 2.10500000 -8.42000000 -4.21000000 12 1 +O 4.21000000 -8.42000000 -4.21000000 8 0 +Mg 4.21000000 -10.52500000 -4.21000000 12 1 +O 2.10500000 -10.52500000 -4.21000000 8 0 +Mg 4.21000000 -8.42000000 -6.31500000 12 1 +O 2.10500000 -8.42000000 -6.31500000 8 0 +Mg 2.10500000 -10.52500000 -2.10500000 12 1 +O 4.21000000 -10.52500000 -2.10500000 8 0 +Mg 2.10500000 -8.42000000 0.00000000 12 1 +O 4.21000000 -8.42000000 0.00000000 8 0 +Mg 4.21000000 -10.52500000 0.00000000 12 1 +O 2.10500000 -10.52500000 0.00000000 8 0 +Mg 4.21000000 -8.42000000 -2.10500000 12 1 +O 2.10500000 -8.42000000 -2.10500000 8 0 +Mg 2.10500000 -4.21000000 -12.63000000 12 1 +O 4.21000000 -4.21000000 -12.63000000 8 0 +Mg 4.21000000 -6.31500000 -12.63000000 12 1 +O 2.10500000 -6.31500000 -12.63000000 8 0 +Mg 2.10500000 -6.31500000 -10.52500000 12 1 +O 4.21000000 -6.31500000 -10.52500000 8 0 +Mg 2.10500000 -4.21000000 -8.42000000 12 1 +O 4.21000000 -4.21000000 -8.42000000 8 0 +Mg 4.21000000 -6.31500000 -8.42000000 12 1 +O 2.10500000 -6.31500000 -8.42000000 8 0 +Mg 4.21000000 -4.21000000 -10.52500000 12 1 +O 2.10500000 -4.21000000 -10.52500000 8 0 +Mg 2.10500000 -6.31500000 -6.31500000 12 1 +O 4.21000000 -6.31500000 -6.31500000 8 0 +Mg 2.10500000 -4.21000000 -4.21000000 12 1 +O 4.21000000 -4.21000000 -4.21000000 8 0 +Mg 4.21000000 -6.31500000 -4.21000000 12 1 +O 2.10500000 -6.31500000 -4.21000000 8 0 +Mg 4.21000000 -4.21000000 -6.31500000 12 1 +O 2.10500000 -4.21000000 -6.31500000 8 0 +Mg 2.10500000 -6.31500000 -2.10500000 12 1 +O 4.21000000 -6.31500000 -2.10500000 8 0 +Mg 2.10500000 -4.21000000 0.00000000 12 1 +O 4.21000000 -4.21000000 0.00000000 8 0 +Mg 4.21000000 -6.31500000 0.00000000 12 1 +O 2.10500000 -6.31500000 0.00000000 8 0 +Mg 4.21000000 -4.21000000 -2.10500000 12 1 +O 2.10500000 -4.21000000 -2.10500000 8 0 +Mg 2.10500000 0.00000000 -12.63000000 12 1 +O 4.21000000 0.00000000 -12.63000000 8 0 +Mg 4.21000000 -2.10500000 -12.63000000 12 1 +O 2.10500000 -2.10500000 -12.63000000 8 0 +Mg 2.10500000 -2.10500000 -10.52500000 12 1 +O 4.21000000 -2.10500000 -10.52500000 8 0 +Mg 2.10500000 0.00000000 -8.42000000 12 1 +O 4.21000000 0.00000000 -8.42000000 8 0 +Mg 4.21000000 -2.10500000 -8.42000000 12 1 +O 2.10500000 -2.10500000 -8.42000000 8 0 +Mg 4.21000000 0.00000000 -10.52500000 12 1 +O 2.10500000 0.00000000 -10.52500000 8 0 +Mg 2.10500000 -2.10500000 -6.31500000 12 1 +O 4.21000000 -2.10500000 -6.31500000 8 0 +Mg 2.10500000 0.00000000 -4.21000000 12 1 +O 4.21000000 0.00000000 -4.21000000 8 0 +Mg 4.21000000 -2.10500000 -4.21000000 12 1 +O 2.10500000 -2.10500000 -4.21000000 8 0 +Mg 4.21000000 0.00000000 -6.31500000 12 1 +O 2.10500000 0.00000000 -6.31500000 8 0 +Mg 2.10500000 -2.10500000 -2.10500000 12 1 +O 4.21000000 -2.10500000 -2.10500000 8 0 +Mg 2.10500000 0.00000000 0.00000000 12 1 +O 4.21000000 0.00000000 0.00000000 8 0 +Mg 4.21000000 -2.10500000 0.00000000 12 1 +O 2.10500000 -2.10500000 0.00000000 8 0 +Mg 4.21000000 0.00000000 -2.10500000 12 1 +O 2.10500000 0.00000000 -2.10500000 8 0 +Mg 2.10500000 4.21000000 -12.63000000 12 1 +O 4.21000000 4.21000000 -12.63000000 8 0 +Mg 4.21000000 2.10500000 -12.63000000 12 1 +O 2.10500000 2.10500000 -12.63000000 8 0 +Mg 2.10500000 2.10500000 -10.52500000 12 1 +O 4.21000000 2.10500000 -10.52500000 8 0 +Mg 2.10500000 4.21000000 -8.42000000 12 1 +O 4.21000000 4.21000000 -8.42000000 8 0 +Mg 4.21000000 2.10500000 -8.42000000 12 1 +O 2.10500000 2.10500000 -8.42000000 8 0 +Mg 4.21000000 4.21000000 -10.52500000 12 1 +O 2.10500000 4.21000000 -10.52500000 8 0 +Mg 2.10500000 2.10500000 -6.31500000 12 1 +O 4.21000000 2.10500000 -6.31500000 8 0 +Mg 2.10500000 4.21000000 -4.21000000 12 1 +O 4.21000000 4.21000000 -4.21000000 8 0 +Mg 4.21000000 2.10500000 -4.21000000 12 1 +O 2.10500000 2.10500000 -4.21000000 8 0 +Mg 4.21000000 4.21000000 -6.31500000 12 1 +O 2.10500000 4.21000000 -6.31500000 8 0 +Mg 2.10500000 2.10500000 -2.10500000 12 1 +O 4.21000000 2.10500000 -2.10500000 8 0 +Mg 2.10500000 4.21000000 0.00000000 12 1 +O 4.21000000 4.21000000 0.00000000 8 0 +Mg 4.21000000 2.10500000 0.00000000 12 1 +O 2.10500000 2.10500000 0.00000000 8 0 +Mg 4.21000000 4.21000000 -2.10500000 12 1 +O 2.10500000 4.21000000 -2.10500000 8 0 +Mg 4.21000000 6.31500000 -12.63000000 12 1 +O 2.10500000 6.31500000 -12.63000000 8 0 +Mg 2.10500000 6.31500000 -10.52500000 12 1 +O 4.21000000 6.31500000 -10.52500000 8 0 +Mg 2.10500000 8.42000000 -8.42000000 12 1 +O 4.21000000 8.42000000 -8.42000000 8 0 +Mg 4.21000000 6.31500000 -8.42000000 12 1 +O 2.10500000 6.31500000 -8.42000000 8 0 +Mg 4.21000000 8.42000000 -10.52500000 12 1 +O 2.10500000 8.42000000 -10.52500000 8 0 +Mg 2.10500000 6.31500000 -6.31500000 12 1 +O 4.21000000 6.31500000 -6.31500000 8 0 +Mg 2.10500000 8.42000000 -4.21000000 12 1 +O 4.21000000 8.42000000 -4.21000000 8 0 +Mg 4.21000000 6.31500000 -4.21000000 12 1 +O 2.10500000 6.31500000 -4.21000000 8 0 +Mg 4.21000000 8.42000000 -6.31500000 12 1 +O 2.10500000 8.42000000 -6.31500000 8 0 +Mg 2.10500000 6.31500000 -2.10500000 12 1 +O 4.21000000 6.31500000 -2.10500000 8 0 +Mg 2.10500000 8.42000000 0.00000000 12 1 +O 4.21000000 8.42000000 0.00000000 8 0 +Mg 4.21000000 6.31500000 0.00000000 12 1 +O 2.10500000 6.31500000 0.00000000 8 0 +Mg 4.21000000 8.42000000 -2.10500000 12 1 +O 2.10500000 8.42000000 -2.10500000 8 0 +Mg 4.21000000 10.52500000 -8.42000000 12 1 +O 2.10500000 10.52500000 -8.42000000 8 0 +Mg 2.10500000 10.52500000 -6.31500000 12 1 +O 4.21000000 10.52500000 -6.31500000 8 0 +Mg 2.10500000 12.63000000 -4.21000000 12 1 +O 4.21000000 12.63000000 -4.21000000 8 0 +Mg 4.21000000 10.52500000 -4.21000000 12 1 +O 2.10500000 10.52500000 -4.21000000 8 0 +Mg 4.21000000 12.63000000 -6.31500000 12 1 +O 2.10500000 12.63000000 -6.31500000 8 0 +Mg 2.10500000 10.52500000 -2.10500000 12 1 +O 4.21000000 10.52500000 -2.10500000 8 0 +Mg 2.10500000 12.63000000 0.00000000 12 1 +O 4.21000000 12.63000000 0.00000000 8 0 +Mg 4.21000000 10.52500000 0.00000000 12 1 +O 2.10500000 10.52500000 0.00000000 8 0 +Mg 4.21000000 12.63000000 -2.10500000 12 1 +O 2.10500000 12.63000000 -2.10500000 8 0 +Mg 6.31500000 -12.63000000 -4.21000000 12 1 +Mg 6.31500000 -12.63000000 0.00000000 12 1 +O 6.31500000 -12.63000000 -2.10500000 8 0 +Mg 6.31500000 -8.42000000 -8.42000000 12 1 +O 8.42000000 -8.42000000 -8.42000000 8 0 +Mg 6.31500000 -10.52500000 -6.31500000 12 1 +Mg 6.31500000 -8.42000000 -4.21000000 12 1 +O 8.42000000 -8.42000000 -4.21000000 8 0 +Mg 8.42000000 -10.52500000 -4.21000000 12 1 +O 6.31500000 -10.52500000 -4.21000000 8 0 +Mg 8.42000000 -8.42000000 -6.31500000 12 1 +O 6.31500000 -8.42000000 -6.31500000 8 0 +Mg 6.31500000 -10.52500000 -2.10500000 12 1 +O 8.42000000 -10.52500000 -2.10500000 8 0 +Mg 6.31500000 -8.42000000 0.00000000 12 1 +O 8.42000000 -8.42000000 0.00000000 8 0 +Mg 8.42000000 -10.52500000 0.00000000 12 1 +O 6.31500000 -10.52500000 0.00000000 8 0 +Mg 8.42000000 -8.42000000 -2.10500000 12 1 +O 6.31500000 -8.42000000 -2.10500000 8 0 +Mg 6.31500000 -4.21000000 -12.63000000 12 1 +Mg 6.31500000 -6.31500000 -10.52500000 12 1 +Mg 6.31500000 -4.21000000 -8.42000000 12 1 +O 8.42000000 -4.21000000 -8.42000000 8 0 +Mg 8.42000000 -6.31500000 -8.42000000 12 1 +O 6.31500000 -6.31500000 -8.42000000 8 0 +Mg 8.42000000 -4.21000000 -10.52500000 12 1 +O 6.31500000 -4.21000000 -10.52500000 8 0 +Mg 6.31500000 -6.31500000 -6.31500000 12 1 +O 8.42000000 -6.31500000 -6.31500000 8 0 +Mg 6.31500000 -4.21000000 -4.21000000 12 1 +O 8.42000000 -4.21000000 -4.21000000 8 0 +Mg 8.42000000 -6.31500000 -4.21000000 12 1 +O 6.31500000 -6.31500000 -4.21000000 8 0 +Mg 8.42000000 -4.21000000 -6.31500000 12 1 +O 6.31500000 -4.21000000 -6.31500000 8 0 +Mg 6.31500000 -6.31500000 -2.10500000 12 1 +O 8.42000000 -6.31500000 -2.10500000 8 0 +Mg 6.31500000 -4.21000000 0.00000000 12 1 +O 8.42000000 -4.21000000 0.00000000 8 0 +Mg 8.42000000 -6.31500000 0.00000000 12 1 +O 6.31500000 -6.31500000 0.00000000 8 0 +Mg 8.42000000 -4.21000000 -2.10500000 12 1 +O 6.31500000 -4.21000000 -2.10500000 8 0 +Mg 6.31500000 0.00000000 -12.63000000 12 1 +O 6.31500000 -2.10500000 -12.63000000 8 0 +Mg 6.31500000 -2.10500000 -10.52500000 12 1 +O 8.42000000 -2.10500000 -10.52500000 8 0 +Mg 6.31500000 0.00000000 -8.42000000 12 1 +O 8.42000000 0.00000000 -8.42000000 8 0 +Mg 8.42000000 -2.10500000 -8.42000000 12 1 +O 6.31500000 -2.10500000 -8.42000000 8 0 +Mg 8.42000000 0.00000000 -10.52500000 12 1 +O 6.31500000 0.00000000 -10.52500000 8 0 +Mg 6.31500000 -2.10500000 -6.31500000 12 1 +O 8.42000000 -2.10500000 -6.31500000 8 0 +Mg 6.31500000 0.00000000 -4.21000000 12 1 +O 8.42000000 0.00000000 -4.21000000 8 0 +Mg 8.42000000 -2.10500000 -4.21000000 12 1 +O 6.31500000 -2.10500000 -4.21000000 8 0 +Mg 8.42000000 0.00000000 -6.31500000 12 1 +O 6.31500000 0.00000000 -6.31500000 8 0 +Mg 6.31500000 -2.10500000 -2.10500000 12 1 +O 8.42000000 -2.10500000 -2.10500000 8 0 +Mg 6.31500000 0.00000000 0.00000000 12 1 +O 8.42000000 0.00000000 0.00000000 8 0 +Mg 8.42000000 -2.10500000 0.00000000 12 1 +O 6.31500000 -2.10500000 0.00000000 8 0 +Mg 8.42000000 0.00000000 -2.10500000 12 1 +O 6.31500000 0.00000000 -2.10500000 8 0 +Mg 6.31500000 4.21000000 -12.63000000 12 1 +O 6.31500000 2.10500000 -12.63000000 8 0 +Mg 6.31500000 2.10500000 -10.52500000 12 1 +O 8.42000000 2.10500000 -10.52500000 8 0 +Mg 6.31500000 4.21000000 -8.42000000 12 1 +O 8.42000000 4.21000000 -8.42000000 8 0 +Mg 8.42000000 2.10500000 -8.42000000 12 1 +O 6.31500000 2.10500000 -8.42000000 8 0 +Mg 8.42000000 4.21000000 -10.52500000 12 1 +O 6.31500000 4.21000000 -10.52500000 8 0 +Mg 6.31500000 2.10500000 -6.31500000 12 1 +O 8.42000000 2.10500000 -6.31500000 8 0 +Mg 6.31500000 4.21000000 -4.21000000 12 1 +O 8.42000000 4.21000000 -4.21000000 8 0 +Mg 8.42000000 2.10500000 -4.21000000 12 1 +O 6.31500000 2.10500000 -4.21000000 8 0 +Mg 8.42000000 4.21000000 -6.31500000 12 1 +O 6.31500000 4.21000000 -6.31500000 8 0 +Mg 6.31500000 2.10500000 -2.10500000 12 1 +O 8.42000000 2.10500000 -2.10500000 8 0 +Mg 6.31500000 4.21000000 0.00000000 12 1 +O 8.42000000 4.21000000 0.00000000 8 0 +Mg 8.42000000 2.10500000 0.00000000 12 1 +O 6.31500000 2.10500000 0.00000000 8 0 +Mg 8.42000000 4.21000000 -2.10500000 12 1 +O 6.31500000 4.21000000 -2.10500000 8 0 +Mg 6.31500000 6.31500000 -10.52500000 12 1 +Mg 6.31500000 8.42000000 -8.42000000 12 1 +O 8.42000000 8.42000000 -8.42000000 8 0 +Mg 8.42000000 6.31500000 -8.42000000 12 1 +O 6.31500000 6.31500000 -8.42000000 8 0 +Mg 6.31500000 6.31500000 -6.31500000 12 1 +O 8.42000000 6.31500000 -6.31500000 8 0 +Mg 6.31500000 8.42000000 -4.21000000 12 1 +O 8.42000000 8.42000000 -4.21000000 8 0 +Mg 8.42000000 6.31500000 -4.21000000 12 1 +O 6.31500000 6.31500000 -4.21000000 8 0 +Mg 8.42000000 8.42000000 -6.31500000 12 1 +O 6.31500000 8.42000000 -6.31500000 8 0 +Mg 6.31500000 6.31500000 -2.10500000 12 1 +O 8.42000000 6.31500000 -2.10500000 8 0 +Mg 6.31500000 8.42000000 0.00000000 12 1 +O 8.42000000 8.42000000 0.00000000 8 0 +Mg 8.42000000 6.31500000 0.00000000 12 1 +O 6.31500000 6.31500000 0.00000000 8 0 +Mg 8.42000000 8.42000000 -2.10500000 12 1 +O 6.31500000 8.42000000 -2.10500000 8 0 +Mg 6.31500000 10.52500000 -6.31500000 12 1 +Mg 6.31500000 12.63000000 -4.21000000 12 1 +Mg 8.42000000 10.52500000 -4.21000000 12 1 +O 6.31500000 10.52500000 -4.21000000 8 0 +Mg 6.31500000 10.52500000 -2.10500000 12 1 +O 8.42000000 10.52500000 -2.10500000 8 0 +Mg 6.31500000 12.63000000 0.00000000 12 1 +Mg 8.42000000 10.52500000 0.00000000 12 1 +O 6.31500000 10.52500000 0.00000000 8 0 +O 6.31500000 12.63000000 -2.10500000 8 0 +Mg 10.52500000 -8.42000000 -4.21000000 12 1 +Mg 10.52500000 -8.42000000 0.00000000 12 1 +O 10.52500000 -8.42000000 -2.10500000 8 0 +Mg 10.52500000 -4.21000000 -8.42000000 12 1 +Mg 10.52500000 -6.31500000 -6.31500000 12 1 +Mg 10.52500000 -4.21000000 -4.21000000 12 1 +O 12.63000000 -4.21000000 -4.21000000 8 0 +Mg 12.63000000 -6.31500000 -4.21000000 12 1 +O 10.52500000 -6.31500000 -4.21000000 8 0 +Mg 12.63000000 -4.21000000 -6.31500000 12 1 +O 10.52500000 -4.21000000 -6.31500000 8 0 +Mg 10.52500000 -6.31500000 -2.10500000 12 1 +O 12.63000000 -6.31500000 -2.10500000 8 0 +Mg 10.52500000 -4.21000000 0.00000000 12 1 +O 12.63000000 -4.21000000 0.00000000 8 0 +Mg 12.63000000 -6.31500000 0.00000000 12 1 +O 10.52500000 -6.31500000 0.00000000 8 0 +Mg 12.63000000 -4.21000000 -2.10500000 12 1 +O 10.52500000 -4.21000000 -2.10500000 8 0 +Mg 10.52500000 0.00000000 -8.42000000 12 1 +O 10.52500000 -2.10500000 -8.42000000 8 0 +Mg 10.52500000 -2.10500000 -6.31500000 12 1 +O 12.63000000 -2.10500000 -6.31500000 8 0 +Mg 10.52500000 0.00000000 -4.21000000 12 1 +O 12.63000000 0.00000000 -4.21000000 8 0 +Mg 12.63000000 -2.10500000 -4.21000000 12 1 +O 10.52500000 -2.10500000 -4.21000000 8 0 +Mg 12.63000000 0.00000000 -6.31500000 12 1 +O 10.52500000 0.00000000 -6.31500000 8 0 +Mg 10.52500000 -2.10500000 -2.10500000 12 1 +O 12.63000000 -2.10500000 -2.10500000 8 0 +Mg 10.52500000 0.00000000 0.00000000 12 1 +O 12.63000000 0.00000000 0.00000000 8 0 +Mg 12.63000000 -2.10500000 0.00000000 12 1 +O 10.52500000 -2.10500000 0.00000000 8 0 +Mg 12.63000000 0.00000000 -2.10500000 12 1 +O 10.52500000 0.00000000 -2.10500000 8 0 +Mg 10.52500000 4.21000000 -8.42000000 12 1 +O 10.52500000 2.10500000 -8.42000000 8 0 +Mg 10.52500000 2.10500000 -6.31500000 12 1 +O 12.63000000 2.10500000 -6.31500000 8 0 +Mg 10.52500000 4.21000000 -4.21000000 12 1 +O 12.63000000 4.21000000 -4.21000000 8 0 +Mg 12.63000000 2.10500000 -4.21000000 12 1 +O 10.52500000 2.10500000 -4.21000000 8 0 +Mg 12.63000000 4.21000000 -6.31500000 12 1 +O 10.52500000 4.21000000 -6.31500000 8 0 +Mg 10.52500000 2.10500000 -2.10500000 12 1 +O 12.63000000 2.10500000 -2.10500000 8 0 +Mg 10.52500000 4.21000000 0.00000000 12 1 +O 12.63000000 4.21000000 0.00000000 8 0 +Mg 12.63000000 2.10500000 0.00000000 12 1 +O 10.52500000 2.10500000 0.00000000 8 0 +Mg 12.63000000 4.21000000 -2.10500000 12 1 +O 10.52500000 4.21000000 -2.10500000 8 0 +Mg 10.52500000 6.31500000 -6.31500000 12 1 +Mg 10.52500000 8.42000000 -4.21000000 12 1 +Mg 12.63000000 6.31500000 -4.21000000 12 1 +O 10.52500000 6.31500000 -4.21000000 8 0 +Mg 10.52500000 6.31500000 -2.10500000 12 1 +O 12.63000000 6.31500000 -2.10500000 8 0 +Mg 10.52500000 8.42000000 0.00000000 12 1 +Mg 12.63000000 6.31500000 0.00000000 12 1 +O 10.52500000 6.31500000 0.00000000 8 0 +O 10.52500000 8.42000000 -2.10500000 8 0 +Mg 14.73500000 0.00000000 0.00000000 12 1 diff --git a/src/msspec/es/cluster_examples/phtalocyanine.xyz b/src/msspec/es/cluster_examples/phtalocyanine.xyz new file mode 100644 index 0000000..649d493 --- /dev/null +++ b/src/msspec/es/cluster_examples/phtalocyanine.xyz @@ -0,0 +1,59 @@ +57 +Phtalocyanine +Ti 0.0000 0.0000 0.0000 +N 1.9944 0.0000 -0.6270 +N 0.0000 1.9944 -0.6270 +N -1.9944 0.0000 -0.6270 +N 0.0000 -1.9944 -0.6270 +N 2.3811 -2.3811 -0.7747 +N 2.3811 2.3811 -0.7747 +N -2.3811 2.3811 -0.7747 +N -2.3811 -2.3811 -0.7747 +C 2.7862 -1.1243 -0.7216 +C 1.1243 2.7862 -0.7216 +C -2.7862 1.1243 -0.7216 +C -1.1243 2.7862 -0.7216 +C -2.7862 -1.1243 -0.7216 +C 1.1243 -2.7862 -0.7216 +C 2.7862 1.1243 -0.7216 +C -1.1243 -2.7862 -0.7216 +C 4.1814 -0.7098 -0.8274 +C 0.7098 4.1814 -0.8274 +C -4.1814 0.7098 -0.8274 +C -0.7098 4.1814 -0.8274 +C -4.1814 -0.7098 -0.8274 +C 0.7098 -4.1814 -0.8274 +C 4.1814 0.7098 -0.8274 +C -0.7098 -4.1814 -0.8274 +C 5.3704 -1.4277 -0.9433 +C 1.4277 5.3704 -0.9433 +C -5.3704 1.4277 -0.9433 +C -1.4277 5.3704 -0.9433 +C -5.3704 -1.4277 -0.9433 +C 1.4277 -5.3704 -0.9433 +C 5.3704 1.4277 -0.9433 +C -1.4277 -5.3704 -0.9433 +C 6.5622 -0.7166 -1.0358 +C 0.7166 6.5622 -1.0358 +C -6.5622 0.7166 -1.0358 +C -0.7166 6.5622 -1.0358 +C -6.5622 -0.7166 -1.0358 +C 0.7166 -6.5622 -1.0358 +C 6.5622 0.7166 -1.0358 +C -0.7166 -6.5622 -1.0358 +H 5.4029 -2.4925 -0.9609 +H 2.4925 5.4029 -0.9609 +H -5.4029 2.4925 -0.9609 +H -2.4925 5.4029 -0.9609 +H -5.4029 -2.4925 -0.9609 +H 2.4925 -5.4029 -0.9609 +H 5.4029 2.4925 -0.9609 +H -2.4925 -5.4029 -0.9609 +H 7.5337 -1.1483 -1.1224 +H 1.1483 7.5337 -1.1224 +H -7.5337 1.1483 -1.1224 +H -1.1483 7.5337 -1.1224 +H -7.5337 -1.1483 -1.1224 +H 1.1483 -7.5337 -1.1224 +H 7.5337 1.1483 -1.1224 +H -1.1483 -7.5337 -1.1224 diff --git a/src/msspec/es/cluster_examples/tubes.xyz b/src/msspec/es/cluster_examples/tubes.xyz new file mode 100644 index 0000000..9fc1f92 --- /dev/null +++ b/src/msspec/es/cluster_examples/tubes.xyz @@ -0,0 +1,312 @@ +310 +#A (5,5) Tube material is: C , radius is: 3.43 bond legth used: 1.42 +C 3.427256 .000000 .000000 +C 3.351267 -.717699 1.222920 +C 1.059080 -3.259514 .000000 +C .353026 -3.409025 1.222920 +C -2.772708 -2.014490 .000000 +C -3.133085 -1.389195 1.222920 +C -2.772708 2.014491 .000000 +C -2.289379 2.550456 1.222920 +C 1.059081 3.259514 .000000 +C 1.718171 2.965462 1.222920 +C 2.772708 2.014490 1.222921 +C 3.133085 1.389195 2.445841 +C 2.772708 -2.014490 1.222921 +C 2.289379 -2.550456 2.445841 +C -1.059080 -3.259514 1.222921 +C -1.718170 -2.965463 2.445841 +C -3.427256 .000000 1.222921 +C -3.351267 .717699 2.445841 +C -1.059081 3.259514 1.222921 +C -.353026 3.409025 2.445841 +C 1.059080 3.259514 2.445841 +C 1.718170 2.965463 3.668761 +C 3.427256 .000000 2.445841 +C 3.351267 -.717699 3.668761 +C 1.059080 -3.259514 2.445841 +C .353026 -3.409025 3.668761 +C -2.772708 -2.014490 2.445841 +C -3.133085 -1.389195 3.668761 +C -2.772708 2.014491 2.445841 +C -2.289379 2.550456 3.668761 +C -1.059080 3.259514 3.668762 +C -.353027 3.409025 4.891682 +C 2.772708 2.014490 3.668762 +C 3.133085 1.389195 4.891682 +C 2.772708 -2.014490 3.668762 +C 2.289379 -2.550456 4.891682 +C -1.059080 -3.259514 3.668762 +C -1.718170 -2.965463 4.891682 +C -3.427256 .000000 3.668762 +C -3.351267 .717699 4.891682 +C -2.772708 2.014490 4.891682 +C -2.289379 2.550456 6.114603 +C 1.059080 3.259514 4.891682 +C 1.718170 2.965463 6.114603 +C 3.427256 .000000 4.891682 +C 3.351267 -.717699 6.114603 +C 1.059080 -3.259514 4.891682 +C .353026 -3.409025 6.114603 +C -2.772708 -2.014490 4.891682 +C -3.133085 -1.389195 6.114603 +C -3.427256 -.000000 6.114603 +C -3.351267 .717698 7.337523 +C -1.059080 3.259514 6.114603 +C -.353027 3.409025 7.337523 +C 2.772708 2.014490 6.114603 +C 3.133085 1.389195 7.337523 +C 2.772708 -2.014490 6.114603 +C 2.289379 -2.550456 7.337523 +C -1.059080 -3.259514 6.114603 +C -1.718170 -2.965463 7.337523 +C -2.772708 -2.014491 7.337523 +C -3.133084 -1.389195 8.560444 +C -2.772708 2.014490 7.337523 +C -2.289379 2.550456 8.560444 +C 1.059080 3.259514 7.337523 +C 1.718170 2.965463 8.560444 +C 3.427256 .000000 7.337523 +C 3.351267 -.717699 8.560444 +C 1.059080 -3.259514 7.337523 +C .353026 -3.409025 8.560444 +C -1.059081 -3.259514 8.560444 +C -1.718171 -2.965462 9.783364 +C -3.427256 .000001 8.560444 +C -3.351267 .717699 9.783364 +C -1.059080 3.259514 8.560444 +C -.353026 3.409025 9.783364 +C 2.772708 2.014490 8.560444 +C 3.133085 1.389194 9.783364 +C 2.772707 -2.014491 8.560444 +C 2.289378 -2.550456 9.783364 +C 1.059081 -3.259514 9.783364 +C .353026 -3.409025 11.006285 +C -2.772708 -2.014491 9.783364 +C -3.133084 -1.389195 11.006285 +C -2.772708 2.014490 9.783364 +C -2.289379 2.550456 11.006285 +C 1.059080 3.259514 9.783364 +C 1.718170 2.965463 11.006285 +C 3.427256 .000000 9.783364 +C 3.351267 -.717699 11.006285 +C 2.772709 -2.014489 11.006285 +C 2.289380 -2.550455 12.229205 +C -1.059079 -3.259514 11.006285 +C -1.718169 -2.965464 12.229205 +C -3.427256 -.000001 11.006285 +C -3.351267 .717698 12.229205 +C -1.059081 3.259513 11.006285 +C -.353027 3.409025 12.229205 +C 2.772707 2.014491 11.006285 +C 3.133084 1.389196 12.229205 +C 3.427256 .000001 12.229205 +C 3.351267 -.717697 13.452126 +C 1.059081 -3.259514 12.229205 +C .353026 -3.409025 13.452126 +C -2.772708 -2.014491 12.229205 +C -3.133084 -1.389195 13.452126 +C -2.772708 2.014490 12.229205 +C -2.289379 2.550456 13.452126 +C 1.059080 3.259514 12.229205 +C 1.718170 2.965463 13.452126 +C 2.772708 2.014490 13.452126 +C 3.133085 1.389194 14.675046 +C 2.772708 -2.014491 13.452126 +C 2.289380 -2.550455 14.675046 +C -1.059081 -3.259514 13.452126 +C -1.718171 -2.965462 14.675046 +C -3.427256 .000001 13.452126 +C -3.351267 .717699 14.675046 +C -1.059080 3.259514 13.452126 +C -.353026 3.409025 14.675046 +C 1.059080 3.259514 14.675047 +C 1.718170 2.965463 15.897967 +C 3.427256 .000001 14.675047 +C 3.351267 -.717697 15.897967 +C 1.059081 -3.259514 14.675047 +C .353026 -3.409025 15.897967 +C -2.772708 -2.014491 14.675047 +C -3.133084 -1.389195 15.897967 +C -2.772708 2.014490 14.675047 +C -2.289379 2.550456 15.897967 +C -1.059082 3.259513 15.897967 +C -.353027 3.409025 17.120888 +C 2.772707 2.014492 15.897967 +C 3.133084 1.389197 17.120888 +C 2.772709 -2.014489 15.897967 +C 2.289380 -2.550455 17.120888 +C -1.059079 -3.259514 15.897967 +C -1.718169 -2.965464 17.120888 +C -3.427256 -.000001 15.897967 +C -3.351267 .717698 17.120888 +C -2.772708 2.014491 17.120888 +C -2.289378 2.550457 18.343807 +C 1.059081 3.259513 17.120888 +C 1.718170 2.965463 18.343807 +C 3.427256 -.000001 17.120888 +C 3.351267 -.717700 18.343807 +C 1.059079 -3.259514 17.120888 +C .353026 -3.409025 18.343807 +C -2.772709 -2.014489 17.120888 +C -3.133085 -1.389194 18.343807 +C -3.427256 -.000000 18.343807 +C -3.351267 .717699 19.566727 +C -1.059079 3.259514 18.343807 +C -.353024 3.409025 19.566727 +C 2.772708 2.014490 18.343807 +C 3.133085 1.389194 19.566727 +C 2.772708 -2.014491 18.343807 +C 2.289380 -2.550455 19.566727 +C -1.059081 -3.259514 18.343807 +C -1.718171 -2.965462 19.566727 +C -2.772707 -2.014491 19.566729 +C -3.133085 -1.389195 20.789650 +C -2.772708 2.014491 19.566729 +C -2.289378 2.550457 20.789650 +C 1.059080 3.259514 19.566729 +C 1.718170 2.965463 20.789650 +C 3.427256 .000001 19.566729 +C 3.351267 -.717697 20.789650 +C 1.059081 -3.259514 19.566729 +C .353026 -3.409025 20.789650 +C -1.059079 -3.259514 20.789650 +C -1.718169 -2.965464 22.012569 +C -3.427256 -.000000 20.789650 +C -3.351267 .717699 22.012569 +C -1.059082 3.259513 20.789650 +C -.353027 3.409025 22.012569 +C 2.772707 2.014492 20.789650 +C 3.133084 1.389197 22.012569 +C 2.772709 -2.014489 20.789650 +C 2.289380 -2.550455 22.012569 +C 1.059083 -3.259513 22.012569 +C .353028 -3.409025 23.235489 +C -2.772707 -2.014491 22.012569 +C -3.133085 -1.389195 23.235489 +C -2.772710 2.014488 22.012569 +C -2.289381 2.550455 23.235489 +C 1.059078 3.259515 22.012569 +C 1.718168 2.965465 23.235489 +C 3.427256 .000002 22.012569 +C 3.351267 -.717697 23.235489 +C 2.772708 -2.014490 23.235491 +C 2.289379 -2.550456 24.458412 +C -1.059079 -3.259514 23.235491 +C -1.718169 -2.965464 24.458412 +C -3.427256 -.000000 23.235491 +C -3.351267 .717699 24.458412 +C -1.059079 3.259514 23.235491 +C -.353024 3.409025 24.458412 +C 2.772708 2.014490 23.235491 +C 3.133085 1.389194 24.458412 +C 3.427256 .000001 24.458410 +C 3.351267 -.717698 25.681332 +C 1.059083 -3.259513 24.458410 +C .353028 -3.409025 25.681332 +C -2.772707 -2.014491 24.458410 +C -3.133085 -1.389195 25.681332 +C -2.772708 2.014491 24.458410 +C -2.289378 2.550457 25.681332 +C 1.059080 3.259514 24.458410 +C 1.718170 2.965463 25.681332 +C 2.772707 2.014492 25.681332 +C 3.133084 1.389196 26.904251 +C 2.772710 -2.014488 25.681332 +C 2.289381 -2.550454 26.904251 +C -1.059079 -3.259514 25.681332 +C -1.718169 -2.965464 26.904251 +C -3.427256 -.000000 25.681332 +C -3.351267 .717699 26.904251 +C -1.059082 3.259513 25.681332 +C -.353027 3.409025 26.904251 +C 1.059081 3.259514 26.904251 +C 1.718171 2.965462 28.127171 +C 3.427256 -.000002 26.904251 +C 3.351266 -.717701 28.127171 +C 1.059080 -3.259514 26.904251 +C .353025 -3.409025 28.127171 +C -2.772707 -2.014491 26.904251 +C -3.133085 -1.389195 28.127171 +C -2.772708 2.014491 26.904251 +C -2.289378 2.550457 28.127171 +C -1.059081 3.259514 28.127172 +C -.353026 3.409025 29.350094 +C 2.772709 2.014489 28.127172 +C 3.133085 1.389193 29.350094 +C 2.772708 -2.014490 28.127172 +C 2.289379 -2.550456 29.350094 +C -1.059079 -3.259514 28.127172 +C -1.718169 -2.965464 29.350094 +C -3.427256 -.000000 28.127172 +C -3.351267 .717699 29.350094 +C -2.772709 2.014489 29.350094 +C -2.289380 2.550455 30.573013 +C 1.059081 3.259514 29.350094 +C 1.718171 2.965462 30.573013 +C 3.427256 .000001 29.350094 +C 3.351267 -.717698 30.573013 +C 1.059083 -3.259513 29.350094 +C .353028 -3.409025 30.573013 +C -2.772707 -2.014491 29.350094 +C -3.133085 -1.389195 30.573013 +C -3.427256 -.000002 30.573013 +C -3.351267 .717697 31.795933 +C -1.059081 3.259514 30.573013 +C -.353026 3.409025 31.795933 +C 2.772707 2.014492 30.573013 +C 3.133084 1.389196 31.795933 +C 2.772710 -2.014488 30.573013 +C 2.289381 -2.550454 31.795933 +C -1.059079 -3.259514 30.573013 +C -1.718169 -2.965464 31.795933 +C -2.772706 -2.014493 31.795935 +C -3.133082 -1.389200 33.018856 +C -2.772709 2.014489 31.795935 +C -2.289380 2.550455 33.018856 +C 1.059077 3.259515 31.795935 +C 1.718169 2.965464 33.018856 +C 3.427256 .000004 31.795935 +C 3.351268 -.717695 33.018856 +C 1.059083 -3.259513 31.795935 +C .353028 -3.409025 33.018856 +C -1.059076 -3.259515 33.018856 +C -1.718165 -2.965466 34.241776 +C -3.427256 -.000002 33.018856 +C -3.351267 .717697 34.241776 +C -1.059084 3.259513 33.018856 +C -.353030 3.409025 34.241776 +C 2.772705 2.014495 33.018856 +C 3.133083 1.389199 34.241776 +C 2.772710 -2.014488 33.018856 +C 2.289381 -2.550454 34.241776 +C 1.059079 -3.259514 34.241776 +C .353027 -3.409025 35.464695 +C -2.772710 -2.014488 34.241776 +C -3.133085 -1.389194 35.464695 +C -2.772707 2.014492 34.241776 +C -2.289377 2.550457 35.464695 +C 1.059081 3.259514 34.241776 +C 1.718171 2.965462 35.464695 +C 3.427256 -.000002 34.241776 +C 3.351266 -.717701 35.464695 +C 2.772708 -2.014491 35.464695 +C 2.289381 -2.550455 36.687614 +C -1.059083 -3.259513 35.464695 +C -1.718170 -2.965463 36.687614 +C -3.427256 .000001 35.464695 +C -3.351267 .717700 36.687614 +C -1.059081 3.259514 35.464695 +C -.353026 3.409025 36.687614 +C 2.772709 2.014489 35.464695 +C 3.133085 1.389193 36.687614 +C 3.427256 .000000 36.687614 +C 3.351267 -.717696 37.910534 +C 1.059079 -3.259514 36.687614 +C .353027 -3.409025 37.910534 +C -2.772710 -2.014488 36.687614 +C -3.133085 -1.389194 37.910534 +C -2.772709 2.014489 36.687614 +C -2.289380 2.550455 37.910534 +C 1.059081 3.259514 36.687614 +C 1.718171 2.965462 37.910534 diff --git a/src/msspec/es/es_mod/Sym_Analys/clus_sym b/src/msspec/es/es_mod/Sym_Analys/clus_sym new file mode 100644 index 0000000..f7354f4 Binary files /dev/null and b/src/msspec/es/es_mod/Sym_Analys/clus_sym differ diff --git a/src/msspec/es/es_mod/Sym_Analys/proc_geom b/src/msspec/es/es_mod/Sym_Analys/proc_geom new file mode 100644 index 0000000..c0c4c49 --- /dev/null +++ b/src/msspec/es/es_mod/Sym_Analys/proc_geom @@ -0,0 +1,72 @@ +#! /bin/bash -f +echo " " +echo " " +echo "****************************************************" +echo "* *" +echo "* CLUSTER GEOMETRY ANALYSIS CODE *" +echo "* *" +echo "****************************************************" +echo " " +echo " " +# +time -p ./es_mod/Sym_Analys/clus_sym <& error.dat +Cluster.xyz # Input cluster file +0 # Tetrahedra detection +0 # Octahedra detection +0 # Cube detection +0 # Hollow molecules detection +0 # Nanotube detection +0 # Regular polygons detection +0 # Iregular polygons detection +1 # Symmetries detection +Fin +# +# Checking for errors in the execution +# +cat error.dat | sed -e '1,35d' \ + -e '/real/,/ /d' > error.txt +# +# Checking for a blend of dialog +# +DIAL=`which dialog | cut -d: -f2 | grep -c 'dialog'` +XDIA=`which Xdialog | cut -d: -f2 | grep -c 'Xdialog'` +KDIA=`which kdialog | cut -d: -f2 | grep -c 'kdialog'` +ZENI=`which zenity | cut -d: -f2 | grep -c 'zenity'` +# +if [ "$ZENI" -ne "0" ]; then + DIALOG=zenity +else + if [ "$XDIA" -ne "0" ]; then + DIALOG=Xdialog + else + if [ "$KDIA" -ne "0" ]; then + DIALOG=kdialog + else + if [ "$DIAL" -ne "0" ]; then + DIALOG=dialog + else + DIALOG=none + fi + fi + fi +fi +# +FILE=`ls -at | grep .lis | awk '{print $1}'` +tail --lines=10 $FILE | grep '<<<<' | sed 's/<>/ /g' >> run.txt +cat run.txt >> error.txt +ERR=`cat error.txt` +NLINE=`cat error.txt | wc -l` +# +if [ $NLINE != 0 ]; then + if [ "$DIALOG" = "zenity" ]; then + zenity --width 400 --height 180 \ + --title "MsSpec-1.1 runtime error" \ + --info --text "The code has stopped with the message : \n \n \n $ERR" \ + --timeout 5 + fi +fi +# +rm -f error.dat error.txt run.txt +# +exit + diff --git a/src/msspec/es/es_mod/__init__.py b/src/msspec/es/es_mod/__init__.py new file mode 100644 index 0000000..36ae534 --- /dev/null +++ b/src/msspec/es/es_mod/__init__.py @@ -0,0 +1 @@ +__all__ = ["Delaunay_Intersphere","Convex_Hull_Cover"] \ No newline at end of file diff --git a/src/msspec/es/es_mod/empty_spheres.py b/src/msspec/es/es_mod/empty_spheres.py new file mode 100644 index 0000000..d30512d --- /dev/null +++ b/src/msspec/es/es_mod/empty_spheres.py @@ -0,0 +1,712 @@ +# coding: utf-8 + +import unittest +import math +import numpy as np +import delaunay.core as delc +import es_sym_analys as essyma +import es_tools as tool +import es_clustering as esclus +from scipy.spatial import ConvexHull, Voronoi + +# =========== +from ase import Atoms +from ase.visualize import view +from ase.data import covalent_radii + +# =================================================================== +# List of routines : +""" +================= + ES_AllRadius_Updater(NewES,Structure,[list]) : Update ES_AllRadius global variable with new radius of empty spheres + given as NewES + + Voronoi_Vertex(Structure) : Computes Voronoi Vertices of Structure + Delaunay_Tetrahedral_ES(Structure,[minsize],[maxsize],[tol]) : Creates a tetrehedral mesh from the structure, + then returns for each center the perfect sphere going in. + Convex_Hull_Cover(Structure,[es_radius],[tol],[missing]) : Finds the exterior Hull from the set, create triangular + mesh then returns cover coordinates. tol=0 => no fusion + Select_Int_Ext(Centroid,E1,E2,IE) : Clean the Cover, taking only internal or external + Internal_Hull_Cover(Structure,[es_radius],[tol],[missing]) : Finds the interior Hull from the set, create triangular + mesh then returns cover coordinates + Internal_Hull_Centers(set) : Finds the interior Hull from the set, create triangular mesh then returns centers coordinates + ES_Fusion(set, structure, size) : Change the set by clustering spheres near from size to each other. No size given => take shortest + Maintain distances with structure, compared with the ancient set. + Fusion_Overlap(Spheres_Data,tol) : Find Spheres touching each other, and fusions them. Don't return radius : only final coordinates + Flat_Covering(Structure,[R],[tol],[Curved]) : For flat (or almost) set : Searchs major plane, triangulates, + and cover the 2 sides. + Plane_Triangulation(Plane3D,Plane_eq): Return triangulation of a 3D Plane (convert into 2D, uses Delny) + Atom_Radius(Structure,n,list) : Returns radius of n°th atom in Structure (Angstrom). Regroup different radius lists. + Convex_Hull_InterCover(set) : Return list of internal cover using ConvexHull : Different from Delaunay_Intersphere : + made for empty clusters + +================= +""" + +ES_AllRadius = [] # Global Variable taking all empty spheres radius + + +# =================================================================== +def ES_AllRadius_Updater(NewES, Structure, list=1): + # Update ES_AllRadius global variable with new radius of empty spheres given as NewES + global ES_AllRadius + StrPos = np.ndarray.tolist(Structure.positions) + for ES in np.ndarray.tolist(NewES.positions): + # print("ES = {}".format(ES)) + Tempo = [] + for A in StrPos: + # print("A = {}".format(A)) + d = tool.distance(ES, A) + Tempo.append(d - Atom_Radius(Structure, StrPos.index(A), list)) + ES_AllRadius.append(min(Tempo)) + return ES_AllRadius + + +# =================================================================== +def Voronoi_Vertex(Structure): + # Uses Delaunay triangulation to create a tetrahedral mesh from the set of + # atoms-centers coordinates, then computes each tetrahedron's inerty center + # Returns list of tetrahedrons-centers coordinates + # Be careful on tetrahedralisation done : the cube for example will not be correctly tesselated (6tetrahedrons in) + """ + Triag=delc.Triangulation(set) + tetracenters=[] + for tetra in Triag.indices: + x = y = z = 0.0 + for vertex in tetra: + x += set[vertex][0] / 4.0 + y += set[vertex][1] / 4.0 + z += set[vertex][2] / 4.0 + tetracenters.append((x, y, z)) + """ + struct = np.ndarray.tolist(Structure.positions) + Vor = Voronoi(struct) + return np.ndarray.tolist(Vor.vertices) + + +# =================================================================== +def Delaunay_Tetrahedral_ES(Structure, minsize=0, maxsize=999, tol=0.6): + # Uses Delaunay triangulation to create a tetrahedral mesh from the Structure of + # atoms-centers coordinates, then adds empty sphere in each tetrahedron, equidistant to all Atoms + es_data = [] + allradius = [] + set = Structure.positions + All_Spheres_Data = esclus.Spheres_Data_Structure_Extractor(Structure, 1) + # print All_Spheres_Data + Triag = delc.Triangulation(set) + for tetra in Triag.indices: + Data = [] + for vertex in tetra: + Data.append(All_Spheres_Data[vertex]) + tetra_es = esclus.Tetrahedron_ES(Data) + if tetra_es == 999: + EV = [] + for vertex in tetra: + EV.append(vertex) + print( + "Error by computing tangent solution to tetrahedron {} : delta < 0 for radius determination ".format(EV)) + elif tetra_es != 999: # 999 is returned when the problem has no solution due to singular matrix + if tetra_es[1] <= maxsize: + if tetra_es[1] >= minsize: + es_data.append(tetra_es) + # output.append(tetra_es[0]) + + """Verify result : ________________ + print("E_S created at position {}, in center of tetrahedron {}".format(output[0],tetra)) + viewer = [output[-1]] + for vertex in tetra : + d=tool.distance(set[vertex],tetra_es[0]) + print("Distance with vertex {} : {}\nAtom radius = {}, ES radius = {}, so the sum is : {}".format(vertex,d,All_Spheres_Data[vertex][1],tetra_es[1],All_Spheres_Data[vertex][1]+tetra_es[1])) + #viewer.append(set[vertex]) + #View=Atoms("XC4",positions = viewer) + #view(View) + #raw_input("\nPress Enter to continue ...\n") + #""" # _______________________________ + + # print "allradius : \n",allradius + output = Fusion_Overlap(es_data, tol) + return output + + +# =================================================================== +def Convex_Hull_Cover(Structure, radius_es=0, tol=0.6, missing=False, Int_Ext=0): + # Uses ConvexHull to find the triangular Hull from the set, then generate a covering by adding + # an empty sphere on each hull triangle. + # Default tol value is used for Fusion Overlap + # Returns list of cover coordinates + if Int_Ext == 0: + print("Select wich covering you wish :\n0: Internal Cover\n1: External Cover\n2: Both Cover") + CovChoice = input() + + Cover_Data = [] + set = np.ndarray.tolist(Structure.positions) + if radius_es == 0: + radius_es = input("Please select the radius of empty spheres you desire : ") + hull = ConvexHull(set) + xc = yc = zc = 0 + lh = len(hull.vertices) + for hpt in hull.vertices: + xc += set[hpt][0] / lh + yc += set[hpt][1] / lh + zc += set[hpt][2] / lh + Centroid = [xc, yc, zc] + + if missing == False: # It means we don't care if some hull points are not implemented because they are in facet + # Computes the centroïd of the hull + + AllData = esclus.Spheres_Data_Structure_Extractor(Structure, 1) + for facet in hull.simplices: # hull.simplices contains index of simplices vertex, grouped by 3. + Data = [] + for vertex in facet: + Data.append(AllData[vertex]) + ES1, ES2 = esclus.Triangle_ES(Data, radius_es) + if ES1 == 666: + print("For radius {}, no solution of tangent to triangle {} ".format(radius_es, facet)) + if ES1 != 666: + ES = Select_Int_Ext(Centroid, ES1, ES2, 1) # Last parameter != 0 => external cover + if tool.distance(Centroid, ES) < 1000000000: + Cover_Data.append([ES, radius_es]) + + + + elif missing == True: + Data = esclus.Spheres_Data_Structure_Extractor(Structure, 1) + HullPlane = tool.cleanlist(np.ndarray.tolist(hull.equations)) + for HP in HullPlane: + a, b, c, d = HP + HPList = [] + HPIndex = [] + for pt in set: + x, y, z = pt + if abs(a * x + b * y + c * z + d) < 0.01: # Then pt is in Plane HP + HPList.append(pt) + HPIndex.append(set.index(pt)) + + Tria = Plane_Triangulation(HPList, HP) + for tria in Tria.indices: + Spheres_data = [Data[HPIndex[tria[0]]], Data[HPIndex[tria[1]]], Data[HPIndex[tria[2]]]] + ES1, ES2 = esclus.Triangle_ES(Spheres_data, radius_es) + if ES1 == 666: + print("For radius {}, no solution of tangent to triangle {} ".format(radius_es, [HPIndex[tria[0]], + HPIndex[tria[1]], + HPIndex[tria[2]]])) + if ES1 != 666: + # ES = Select_Int_Ext(Centroid, ES1, ES2, 1) # Last parameter != 1 => external cover + + # Cover_Data.append([ES, radius_es]) + if CovChoice > 1: + Cover_Data.append([ES1, radius_es]) + Cover_Data.append([ES2, radius_es]) + else: + ES = Select_Int_Ext(Centroid, ES1, ES2, CovChoice) # 1 : external; 0 : internal + Cover_Data.append([ES, radius_es]) + + """Verify result : ________________ + print("E_S created at position {}, defined on triangle {}".format(ES, facet)) + viewer = [ES,ES2] + for vertex in facet: + d = tool.distance(set[vertex], ES) + print("Distance with vertex {} : {}\nAtom radius = {}, ES radius = {}, so the sum is : {}".format(vertex, d,AllData[vertex][1],radius_es,AllData[vertex][1]+radius_es)) + viewer.append(set[vertex]) + View=Atoms("XH4",positions = viewer) + view(View) + # raw_input("\nPress Enter to continue ...\n") + # """ # _______________________________ + + # Fusion overlapping spheres + + Output = Fusion_Overlap(Cover_Data, tol) # tol at 1% : means fusion if d < (r1 + r2) * 0.01 + + return Output + + +# =================================================================== +def Select_Int_Ext(Centroid, E1, E2, IE): + # Returns only internal or external part of cover, using the fact hull is convex : so using his centroid + # IE = 0 : take internal part, IE != 0 : take external part + d1 = tool.distance(Centroid, E1) + d2 = tool.distance(Centroid, E2) + if IE == 0: # Internal part : the closest to centroid + if d1 < d2: + return E1 + else: # External part : the farest from centroïd + if d2 < d1: + return E1 + # Excepted this 2 double conditions : we have to take E2 + return E2 + + +# =================================================================== + + +def Internal_Hull_Cover(Structure, radius_es=0, tol=0.6, missing=False): + # Uses ConvexHull to find the triangular Hull from the set, then generate a covering by adding + # an empty sphere on each hull triangle. + # Default tol value is used for Fusion Overlap + # Returns list of cover coordinates + Cover_Data = [] + set = np.ndarray.tolist(Structure.positions) + + if radius_es == 0: + radius_es = input("Please select the radius of empty spheres you desire : ") + + hull = ConvexHull(set) + + xc = yc = zc = 0 + lh = len(hull.vertices) + for hpt in hull.vertices: + xc += set[hpt][0] / lh + yc += set[hpt][1] / lh + zc += set[hpt][2] / lh + Centroid = [xc, yc, zc] + + invset = tool.Invert_Coord(set, Centroid, 10) + hull = ConvexHull(invset) + + if missing == False: # It means we don't care if some hull points are not implemented because they are in facet + # Computes the centroïd of the hull + + AllData = esclus.Spheres_Data_Structure_Extractor(Structure, 1) + for facet in hull.simplices: # hull.simplices contains index of simplices vertex, grouped by 3. + Data = [] + for vertex in facet: + Data.append(AllData[vertex]) + ES1, ES2 = esclus.Triangle_ES(Data, radius_es) + if ES1 == 666: + print("For radius {}, no solution of tangent to triangle {} ".format(radius_es, facet)) + if ES1 != 666: + ES = Select_Int_Ext(Centroid, ES1, ES2, 0) # Last parameter = 0 => internal cover + + Cover_Data.append([ES, radius_es]) + + elif missing == True: + Data = esclus.Spheres_Data_Structure_Extractor(Structure, 1) + HullPlane = tool.cleanlist(np.ndarray.tolist(hull.equations)) + for HP in HullPlane: + a, b, c, d = HP + HPList = [] + HPIndex = [] + for pt in set: + x, y, z = pt + if abs(a * x + b * y + c * z + d) < 0.01: # Then pt is in Plane HP + HPList.append(pt) + HPIndex.append(set.index(pt)) + + Tria = Plane_Triangulation(HPList, HP) + for tria in Tria.indices: + Spheres_data = [Data[HPIndex[tria[0]]], Data[HPIndex[tria[1]]], Data[HPIndex[tria[2]]]] + ES1, ES2 = esclus.Triangle_ES(Spheres_data, radius_es) + if ES1 == 666: + print("For radius {}, no solution of tangent to triangle {} ".format(radius_es, [HPIndex[tria[0]], + HPIndex[tria[1]], + HPIndex[tria[2]]])) + if ES1 != 666: + ES = Select_Int_Ext(Centroid, ES1, ES2, 0) # Last parameter != 0 => internal cover + + Cover_Data.append([ES, radius_es]) + + """Verify result : ________________ + print("E_S created at position {}, defined on triangle {}".format(ES, facet)) + viewer = [ES,ES2] + for vertex in facet: + d = tool.distance(set[vertex], ES) + print("Distance with vertex {} : {}\nAtom radius = {}, ES radius = {}, so the sum is : {}".format(vertex, d,AllData[vertex][1],radius_es,AllData[vertex][1]+radius_es)) + viewer.append(set[vertex]) + View=Atoms("XH4",positions = viewer) + view(View) + # raw_input("\nPress Enter to continue ...\n") + # """ # _______________________________ + + # Fusion overlapping spheres + + Output = Fusion_Overlap(Cover_Data, tol) # tol at 1% : means fusion if d < (r1 + r2) * 0.01 + + return Output + + +# =================================================================== +def Internal_Hull_Centers(set): + # Uses ConvexHull to find the intern triangular Hull from the set, then computes all centers of simplices + # Returns list of centers coordinates + invset = tool.Invert_Coord(set, [0, 0, 0], 10) + hull = ConvexHull(invset) + output = [] + for facet in hull.simplices: + x = y = z = 0.0 + for vertex in facet: + x += set[vertex][0] / 3.0 + y += set[vertex][1] / 3.0 + z += set[vertex][2] / 3.0 + facet_center = [x, y, z] # Center of the triangular facet + output.append(facet_center) + output = np.array(output).tolist() + return output + + +# =================================================================== + +# =================================================================== + + +# =================================================================== +def ES_Fusion(set, structure, size=0): + # study the given set, and fusion some empty spheres to create a better set. Size is used for the partitionnal + # clustering, and structure assures the clustering will not reduce the distances. It it set basically to the min distance in the set. + if size == 0: + size = tool.shortest_dist(set) + # print("initial size :", size) + size = size * 11. / 10 # we add 10%, to include the very similar cases + # print("with error correction size :", size) + fusion_set = [] # output : defined like set + dmin = tool.set_set_proximity(set, structure) + hull = ConvexHull(structure) + # simplice_centers=Convex_Hull_Centers(structure+set) + while len(set) > 0: + # Define a new cluster, add as much empty spheres as possible, and regroup around the centroid + cluster = [set[0]] + centroid = cluster[0] # Initialisation of the next cluster (it may rest one element, to progress until set=void + set.pop(0) + reroll = 1 + while reroll == 1: + d0_error = 0 + reroll = 0 # We must scan the set everytime we change centroid, or we could miss some ES in set + for ES in set: + # Other possible condition : tool.point_set_proximity(ES, cluster)<=size + if tool.distance(ES, centroid) < size: # We can fusion to the cluster + reroll = 1 # Centroid will be updated, so reroll the scan of set + print("Fusionned a sphere to the cluster") + cluster.append(ES) + set.remove(ES) # It is in the cluster, so remove from set : we studied it + centroid = tool.Isobarycenter(cluster) + if tool.point_set_proximity(centroid, + structure) < dmin: # We have to put centroid farer to balance fusion + Nearest = tool.search_nearest(centroid, structure, + tool.point_set_proximity(centroid, structure)) + V = np.ndarray.tolist( + np.array(centroid) - np.array(Nearest)) # So we need nearest structure point + d = tool.distance(centroid, Nearest) + if d == 0: # it means the centroid came right on existing structure + print("Cluster centered exactly in the structure. Size must be revised : cluster cancelled") + d0_error = 1 + fusion_set += cluster + reroll = 0 + break + else: + V = np.multiply(V, 1. / d) # set V as norm 1 + V = np.multiply(V, dmin) + # + print("\n\n We put away form:\n{}\ndmin={}\n".format(tool.vector_norm(V), dmin)) + # + centroid = np.ndarray.tolist( + np.array(Nearest) + V) # get centroid away from Nearest to dmin + # + # + # + if d0_error == 0: + fusion_set.append(centroid) + # + # + return fusion_set + + +# =================================================================== +def Fusion_Overlap(Spheres_Data, tol): + # Find Spheres touching each other, and fusions them. Don't return radius : only final coordinates + Output = [] + ls = len(Spheres_Data) + Index = range(ls) + for iS in range(ls): + if iS in Index: # The we have to treat this case + FusionIndex = [iS] + for iOS in range(iS + 1, ls): + if iOS in Index: + S = Spheres_Data[iS][0] + OS = Spheres_Data[iOS][0] + rS = Spheres_Data[iS][1] + rOS = Spheres_Data[iOS][1] + # print("S : {}\nOS : {}".format(S,OS)) + if tool.distance(S, OS) < (rS + rOS) * tol: + # print("Overlap detected : d= {}, r1 ={}, r2 = {}".format(tool.distance(S, OS),rS,rOS)) + Index.remove(iOS) # S and OS are same coord or almost : we remove the last : OS + FusionIndex.append(iOS) + lf = len(FusionIndex) + x = y = z = 0 + for i in FusionIndex: + x += Spheres_Data[i][0][0] / lf + y += Spheres_Data[i][0][1] / lf + z += Spheres_Data[i][0][2] / lf + Output.append([x, y, z]) + # else : iS correspond to coord already fusionned + return Output + + +# =================================================================== + +# =================================================================== + +# =================================================================== + +# =================================================================== + +# =================================================================== +# =================================================================== +def Flat_Covering(Structure, R=0, tol=0.6, Curved=False): + # Designed for quite flat set : Searchs major plane, triangulates it, and cover both sides with empty spheres wich radius=size. + + if R != 0: + NoAsk = 1 + else: + NoAsk = 0 + + if Curved == False: + + flatness = input("Please describe cluster :\nOnly one major plane : Enter 0\nMore major planes : Enter 1\n") + + set = np.ndarray.tolist(Structure.positions) + struct = set + FlatCover = [] + # Search major plane(s) + if flatness != 0: + AllPlanes = essyma.major_plane(struct, multiple=True) + + else: + [Plane3D, Plane_eq] = essyma.major_plane(struct) + AllPlanes = [[Plane3D, Plane_eq]] + + """ + for P in AllPlanes : + PlaneView = Atoms(positions=P[0]) + #view(Structure+PlaneView) + view(PlaneView) + print("Plane n°{} : \nContains : {}\n PlaneEq = {}".format(AllPlanes.index(P)+1,P[0],P[1])) + + #""" + + # Build empty spheres for all major planes : + + for AP in AllPlanes: + Plane3D, Plane_eq = AP + + if NoAsk == 0: + Pview = Atoms(positions=Plane3D) + view(Pview) + print("Please select the radius of empty spheres you desire : ") + R = input("(See the view of current plane to get help)\n") + + Index = [] + for Ppt in Plane3D: + Index.append(struct.index(Ppt)) + + """ Show Details on Plane + #print("Plane : Equation is {}x+{}y+{}z+{}=0\n Plane norm is {}".format(Plane_eq[0],Plane_eq[1],Plane_eq[2],Plane_eq[3],Norm)) + Lset = len(set) + name = "C" + str(Lset) + Structure = Atoms(name, positions=struct) + Plane3DView = Atoms(positions=Plane3D) + view(Structure + Plane3DView) + #""" # ===== + + Triang = Plane_Triangulation(Plane3D, Plane_eq) + # print("Triangulation 2D : {}".format(Triang.indices)) + # Extract DataforTangent_Fourth_Sphere fromStructure + Data = esclus.Spheres_Data_Structure_Extractor(Structure, 1) + simplicenters = [] + for tria in Triang.indices: + Spheres_data = [Data[Index[tria[0]]], Data[Index[tria[1]]], Data[Index[tria[2]]]] + """ + h = (Spheres_data[0][1] + Spheres_data[1][1] + Spheres_data[2][1]) #h is set as 3 times the average covalent radii of atoms + xc = 1. / 3 * (Spheres_data[0][0][0] + Spheres_data[1][0][0] + Spheres_data[2][0][0]) + yc = 1. / 3 * (Spheres_data[0][0][1] + Spheres_data[1][0][1] + Spheres_data[2][0][1]) + zc = 1. / 3 * (Spheres_data[0][0][2] + Spheres_data[1][0][2] + Spheres_data[2][0][2]) + Addpoint = np.ndarray.tolist(np.array([xc,yc,zc])+np.multiply(Norm,h)) + Spheres_data.append([Addpoint,1]) # We add one sphere with radius=0, that must be tangent to solution + """ + + P1, P2 = esclus.Triangle_ES(Spheres_data, R) + if P1 == 666: + print("For radius {}, no solution of tangent to triangle {} ".format(R, [Index[tria[0]], + Index[tria[1]], + Index[tria[2]]])) + if P1 != 666: + FlatCover.append([P1, R]) + FlatCover.append([P2, R]) + """ + ViewPos=[Spheres_data[0][0],Spheres_data[1][0],Spheres_data[2][0],Addpoint,Cov1[0]] + print "preview :",ViewPos + Viewer=Atoms("H2OClX",positions=[Spheres_data[0][0],Spheres_data[1][0],Spheres_data[2][0],Addpoint,Cov1[0]]) + view(Viewer) + Spheres_data.remove([Addpoint, 1]) + Addpoint = np.ndarray.tolist(np.array([xc, yc, zc]) - np.multiply(Norm, h)) + Spheres_data.append([Addpoint, 1]) # Our + print Spheres_data + Cov2 = esclus.Tetrahedron_ES (Spheres_data) + ViewPos = [Spheres_data[0][0], Spheres_data[1][0], Spheres_data[2][0], Addpoint, Cov2] + print "preview :", ViewPos + Viewer = Atoms("H2OClX", positions=[Spheres_data[0][0], Spheres_data[1][0], Spheres_data[2][0], Addpoint, Cov2[0]]) + view(Viewer) + FlatCover.append(Cov1[0]) + FlatCover.append(Cov2[0]) + + """ + """ + for tria in Triang.indices: #compute classic simplice center : + x=y=z=0 + for vertex in tria: + x += set[vertex][0] / 3.0 + y += set[vertex][1] / 3.0 + z += set[vertex][2] / 3.0 + simcen=[x,y,z] + for simcen in simplicenters : + C1=np.ndarray.tolist(np.array(simcen) + np.array(Norm)) + C2=np.ndarray.tolist(np.array(simcen) - np.array(Norm)) + FlatCover.append(C1) + FlatCover.append(C2) + #""" # + + + + elif Curved == True: # With curve : Complicated to define planes... So we need to do as if it was pure 2D. + # In Case of Curved routine, ALL spheres will be included in Cover iteration. + FlatCover = [] + Plane3D = Structure.positions + Plane2D = [] + Projection_selected = 0 + while Projection_selected == 0: + PProj = input( + "To create mesh, we need to project on a plane : please select him.\n1 for x=0\n2 for y=0\n3 for z=0\n") + if PProj == 1: + for pt in Plane3D: + Plane2D.append(pt[1:]) + Projection_selected = 1 + elif PProj == 3: + for pt in Plane3D: + Plane2D.append(pt[:2]) + Projection_selected = 1 + elif PProj == 2: + for pt in Plane3D: + Plane2D.append([pt[0], pt[2]]) + Projection_selected = 1 + Triang = delc.Triangulation(Plane2D) + if R == 0: + R = input("Please select the radius of empty spheres you desire : ") + + Data = esclus.Spheres_Data_Structure_Extractor(Structure, 1) + simplicenters = [] + for tria in Triang.indices: + Spheres_data = [Data[tria[0]], Data[tria[1]], Data[tria[2]]] + P1, P2 = esclus.Triangle_ES(Spheres_data, R) + if P1 == 666: + print("For radius {}, no solution of tangent to triangle {} ".format(R, [tria[0], tria[1], + tria[2]])) + if P1 != 666: + FlatCover.append([P1, R]) + FlatCover.append([P2, R]) + + FlatCover = Fusion_Overlap(FlatCover, tol) + + return FlatCover + + +# ==================================================================== +def Plane_Triangulation(Plane3D, Plane_eq): + # Transform plane into same z + Norm = Plane_eq[:3] + a, b, c, d = Plane_eq + Plane2D = [] + NormZ0 = [0, 0, 1] + Alpha = tool.angle_vector(Norm, NormZ0) # Angle of rotation + + if Alpha % math.pi == 0: # Plane already at z=K : no rotation needed + for pt in Plane3D: + Plane2D.append(pt[:2]) + else: # We must see the axis of rotation, then rotate all points : + if a == 0: + u = [1, 0, 0] + M = [-d / b, 0, 0] + else: + u = [-b / a, 1, 0] + M = [-d / a, 0, 0] + # print("Norm of Plane = {}, so : \nAlpha = {}° \nu={} and M = {}".format(Norm,Alpha * 180 / math.pi, u,M)) + # Plane def by ax + by + cz + d = 0. Intercect z=0 at array ax + by + d = 0, so vector directing intercection is (-b,a,0) + nu = tool.vector_norm(u) + u = np.ndarray.tolist(np.multiply(u, 1. / nu)) + # print("Intercection is line defined by vector u={} and point p={}\nAngle of rotation will be {}°".format(u,M,Alpha*180/math.pi)) + # Now rotate all points with rotation angled Alpha round u. + Rview = [] + for pt in Plane3D: # Translate point until axis of rotation include origin : for easier rotation + x, y, z = pt + Mm = [-M[0], -M[1], -M[2]] + pt = tool.vector_trslt(pt, Mm) + rpt = tool.rot3D(pt, Alpha, u) + rpt = tool.vector_trslt(rpt, M) + + # print("pt = {}, rotate to rpt = {} (Verify same z !)".format(pt,rpt)) + Rview.append(rpt) + Plane2D.append(rpt[:2]) + + # Triangulate with Delny : indices will be the same as original Plane : no need to invert transformation + Triang = delc.Triangulation(Plane2D) + return Triang + + +# ==================================================================== + +# ==================================================================== +def Atom_Radius(Structure, n, list): + # Returns the radius of the n°th atom in Structure. 0 are placed to keep information. Unit = Angstrom + # List variable determines wich information we need + global ES_AllRadius + + if 0 in Structure.numbers: + FirstES = np.ndarray.tolist(Structure.numbers).index(0) # Number of the first Empty_Spheres + N = Structure.numbers[n] + if N == 0: # Atom is X : empty sphere + Atom_Radius = ES_AllRadius[n - FirstES] + + if list == 1: # Covalent Radii + Atom_Radius_List = covalent_radii + else: + print("No list found, verify list variable. Routine returns 0") + return 0 + if Atom_Radius_List[N] == 0: + print ("No information on this atom, or false n° given. Routine returns 0") + return Atom_Radius_List[N] + + +# =================================================================== + +def Convex_Hull_InterCover(set): + # Uses ConvexHull to find the triangular Hull from the set, then generate a covering by adding + # an empty sphere on each hull triangle. + # Returns list of cover coordinates + reverset = tool.Invert_Coord(set, [0, 0, 0], 2) + hull = ConvexHull(reverset) + cover_coord = [] + counter = 0 + for facet in hull.simplices: # hull.simplices contains index of simplices vertex, grouped by 3. + x = y = z = 0.0 + for vertex in facet: + x += reverset[vertex][0] / 3.0 + y += reverset[vertex][1] / 3.0 + z += reverset[vertex][2] / 3.0 + facet_center = [x, y, z] # Center of the triangular facet + normal_facet = hull.equations[counter][:3] # The exterior normal of the facet + addpoint = facet_center + normal_facet + cover_coord.append(addpoint) + counter += 1 + cover_coord = np.array(cover_coord).tolist() + cover_coord = tool.Invert_Coord(cover_coord, [0, 0, 0], 2) + return cover_coord + + +# =================================================================== +def lookhull(Structure, hull): + # view the structure and his hull + hullview = [] + for i in hull.vertices: + hullview.append(Structure.positions[i]) + L = len(hullview) + Lookhull = Atoms(positions=hullview) + view(Lookhull) + view(Structure + Lookhull) + return 0 \ No newline at end of file diff --git a/src/msspec/es/es_mod/es_apollonius.py b/src/msspec/es/es_mod/es_apollonius.py new file mode 100644 index 0000000..a16a83f --- /dev/null +++ b/src/msspec/es/es_mod/es_apollonius.py @@ -0,0 +1,61 @@ +# coding: utf-8 + +import unittest +from subprocess import call +import numpy as np +from ase import Atoms +from ase.io import read,write +import empty_spheres as esph +import es_tools as tool + +#=================================================================== + +def Apollonius_CCC(circles_data) : + # From the circle_data list defined like : [[list of centers coordinates 3D],[list of radius]] + # defines the Apollonius point, equidistant to the 3 circles + #___________________________________________________________ + # Regroup data, and define the case + O1=circles_data[0][0] + O2=circles_data[0][1] + O3=circles_data[0][2] + r1 = circles_data[1][0] + r2 = circles_data[1][1] + r3 = circles_data[1][2] + rmin=min(circles_data[1]) + nbmin=circles_data[1].count(rmin)#So it is the number of circles with the smallest radius + if nbmin==1 : #then we have 1 little circle, we go to Apollonius CCP + + elif nbmin==2: #then we have 2 little circles, we go to Apollonius CPP + if r1!=rmin : + data=[[O1,r1],O2,O3] + elif r2!=rmin : + data = [[O2, r2], O1, O3] + elif r3!=rmin : + data = [[O3, r3], O1, O2] + Apollo=Apollonius_CPP(data) + + elif nbmin==3 :#then the 3 circles have the same radius, so we search simply the centroid, form Apollonius PPP + data=[O1,O2,O3] + Apollo=tool.Isobarycenter(data) + + return Apollo + +# =================================================================== +def Apollonius_CPP(set) : + #From a set define like this : [[Coordinates of circle center,Circle radius],Coord P1, Coord P2] + # define the point equidistant to P1, P2 and the circle. We will use circular inversion method + Apollo=0 + return Apollo +# =================================================================== +def Circular_Inversion (P,O,R) : + #Computes P' the image of circular inversion of P by the circle (O,R). It means OP*OP'=R² + OP=tool.vector_def(O,P) + nOP=tool.vector_norm(OP) + OPprim = (OP * R ** 2) / (nOP ** 2) + Apollo = np.ndarray.tolist(np.array(OPprim)-np.array(O)) + return Apollo +# =================================================================== + + + + diff --git a/src/msspec/es/es_mod/es_clustering.py b/src/msspec/es/es_mod/es_clustering.py new file mode 100644 index 0000000..070dad4 --- /dev/null +++ b/src/msspec/es/es_mod/es_clustering.py @@ -0,0 +1,209 @@ +# coding: utf-8 +import unittest +from subprocess import call +import numpy as np +from numpy import sqrt, dot, cross +from numpy.linalg import norm +from ase import Atoms +from ase.io import read, write +from ase.visualize import view +import empty_spheres as esph +import es_tools as tool + +# =================================================================== +# List of routines : +""" +================= +Tangent_Fourth_Sphere(Spheres_data, r, inout=1) : From 3 tangent spheres, returns the fourth, tangent to others, with radius r. + inout determines the side of the coordinate. +Spheres_Data_Structure_Extractor (Structure,list) : From Structure, returns data as [[S1][S2]...] where Si = [[xi,yi,zi],ri] + used in Tangent_Fourth routine. List determines the radius we will use. + +Spheres_Data_XYZ_Extractor (name,list) : From name, given as "_____.xyz", returns data as [[S1][S2]...] where Si = [[xi,yi,zi],ri] + used in Tangent_Fourth routine. List determines the radius we will use. + +Tetrahedron_ES (Spheres_data) : From 4 spheres forming a tetrahedron,returns the sphere tangent to others, with radius r. + +Triangle_ES (Spheres_data,R) : Returns the 2 solutions of tangent of 3 spheres with radius R. +================= +""" + + +# =================================================================== + +def Tangent_Fourth_Sphere(Spheres_data, r, inout=1): + # From Spheres_data build like : [[S1],[S2],[S3]] containing spheres informations Si=[[xi,yi,zi],ri], the wanted radius r, + # and with the inout variable (equal to 1 or -1, depends on the facet, to build empty sphere in or out the hull) + # computes the center of the fourth sphere tangent to S1, S2 and S3, and with radius r + # WARNING : Require S1, S2 and S3 are tangent each to another ! + # ================ + # Read information + S1, S2, S3 = Spheres_data + + d1 = S1[1] + r + d2 = S2[1] + r + d3 = S3[1] + r + # Solve the problem in the right space : using u,v,t as base to solution + u = tool.vector_def(S2[0], S1[0]) + v = tool.vector_def(S3[0], S1[0]) + unorm = tool.vector_norm(u) + vnorm = tool.vector_norm(v) + u = np.multiply(u, 1. / unorm) + v = np.multiply(v, 1. / vnorm) + w = np.multiply(S1[0], -2) + # ===== + a = (d2 ** 2 - d1 ** 2 + S1[0][0] ** 2 - S2[0][0] ** 2 + S1[0][1] ** 2 - S2[0][1] ** 2 + S1[0][2] ** 2 - + S2[0][2] ** 2) / (2 * unorm) + b = (d3 ** 2 - d1 ** 2 + S1[0][0] ** 2 - S3[0][0] ** 2 + S1[0][1] ** 2 - S3[0][1] ** 2 + S1[0][2] ** 2 - + S3[0][2] ** 2) / (2 * vnorm) + c = d1 ** 2 - S1[0][0] ** 2 - S1[0][1] ** 2 - S1[0][2] ** 2 + # ===== + t = np.ndarray.tolist(np.cross(u, v)) + tnorm = tool.vector_norm(t) + t = np.multiply(t, 1 / tnorm) + # + alpha = (a - b * np.dot(u, v)) / (1 - np.dot(u, v) ** 2) + beta = (b - a * np.dot(u, v)) / (1 - np.dot(u, v) ** 2) + d = alpha ** 2 + beta ** 2 + 2 * alpha * beta * np.dot(u, v) + alpha * np.dot(u, w) + beta * np.dot(v, w) - c + theta = (-1 * np.dot(w, t) + inout * np.sqrt(np.dot(w, t) ** 2 - 4 * d)) / 2 + # + solution = np.ndarray.tolist(np.multiply(u, alpha) + np.multiply(v, beta) + np.multiply(t, theta)) + return solution + + +# =================================================================== +def Spheres_Data_Structure_Extractor(Structure, list): + # From Structure, returns data as [[S1][S2]...] where Si = [[xi,yi,zi],ri] + # used in Tangent_Fourth routine. List determines the radius we will use. + # list determines wich radius we take : 1 for covalent + + set_pos = np.ndarray.tolist(Structure.positions) + set_nb = np.ndarray.tolist(Structure.numbers) + data = [] + for i in range(0, len(set_nb)): + data.append([set_pos[i], esph.Atom_Radius(Structure, i, list)]) + return data + + +# =================================================================== +def Spheres_Data_XYZ_Extractor(name, list): + # From name, given as "_____.xyz", returns data as [[S1][S2]...] where Si = [[xi,yi,zi],ri] + # used in Tangent_Fourth routine. List determines the radius we will use. + # list determines wich radius we take : 1 for covalent + set = read(name) + set_pos = np.ndarray.tolist(set.positions) + set_nb = np.ndarray.tolist(set.numbers) + data = [] + for i in range(0, len(set_nb)): + data.append([set_pos[i], esph.Atom_Radius(set, i, list)]) + return data + + +# =================================================================== +def Tetrahedron_ES(Spheres_data): + # print "Spheres datas :",Spheres_data + S1, S2, S3, S4 = Spheres_data + x1, y1, z1 = S1[0] + r1 = S1[1] + x2, y2, z2 = S2[0] + r2 = S2[1] + x3, y3, z3 = S3[0] + r3 = S3[1] + x4, y4, z4 = S4[0] + r4 = S4[1] + + # Solve this problem equals to found V=[x,y,z] and r as : MV = S + r P with : + M = np.array([[x1 - x2, y1 - y2, z1 - z2], [x2 - x3, y2 - y3, z2 - z3], [x3 - x4, y3 - y4, z3 - z4]]) + P = np.array([r2 - r1, r3 - r2, r4 - r3]) + S = np.array([(r1 ** 2 - r2 ** 2) + (x2 ** 2 - x1 ** 2) + (y2 ** 2 - y1 ** 2) + (z2 ** 2 - z1 ** 2), + (r2 ** 2 - r3 ** 2) + (x3 ** 2 - x2 ** 2) + (y3 ** 2 - y2 ** 2) + (z3 ** 2 - z2 ** 2), + (r3 ** 2 - r4 ** 2) + (x4 ** 2 - x3 ** 2) + (y4 ** 2 - y3 ** 2) + (z4 ** 2 - z3 ** 2)]) + S = np.multiply(S, 0.5) + + """ + print("M= {}".format(M)) + print("P= {}".format(P)) + print("S= {}".format(S)) + #""" + + # MV = S + r P <=> V = Minv S + r MinvP, rewrite as V = Mbar + r Pbar + if np.linalg.det(M) == 0: + print("Singular matrix on the Tetrahedron Fourth SPhere Problem : So we cancel routine") + return 999 + + Minv = np.linalg.inv(M) + Sbar = np.matmul(Minv, S) + Pbar = np.matmul(Minv, P) + """ + print("Minv= {}\n So verify inversion : Minv * M = \n{}".format(Minv,np.matmul(M,Minv))) + print("Pbar= {}".format(Pbar)) + print("Sbar= {}".format(Sbar)) + #""" + # V = [x,y,z] depends on r : We need to solve r first : as a root of a 2 degree polygon + Vi = np.array(S1[0]) + ri = np.array(S1[1]) + D = Sbar - Vi + a = np.linalg.norm(Pbar) ** 2 - 1 + b = 2 * (np.dot(D, P) - ri) + c = np.linalg.norm(Sbar) ** 2 - 2 * np.dot(Vi, Sbar) - ri ** 2 + + delta = b ** 2 - 4 * a * c # Theorically delta >=0 + if delta < 0: + return 999 + rsol = (-b - np.sqrt(delta)) / (2 * a) # radius of sphere internally tangent + # print("rsol found : {}".format(r)) + # print("Verify solution : ar² + br + c = {}".format(a * rsol**2 + b * rsol + c)) + + # Now we can compute the solution V = x,y,z + V = -1 * (Sbar + np.multiply(Pbar, rsol)) + r = tool.distance(V, Vi) - ri + # print("r that should really be : {}".format(r)) + # print("Verify solution : ar² + br + c = {}".format(a * r ** 2 + b * r + c)) + return [np.ndarray.tolist(V), r] + + +# =================================================================== + +def Triangle_ES(Spheres_data, R): + # Routine posted by Andrew Wagner, Thanks to him. + # Implementaton based on Wikipedia Trilateration article, about intercection of 3 spheres + # This problem solves sphere tangent to 3 spheres : and returns the 2 solutions + P1 = np.array(Spheres_data[0][0]) + r1 = Spheres_data[0][1] + R + P2 = np.array(Spheres_data[1][0]) + r2 = Spheres_data[1][1] + R + P3 = np.array(Spheres_data[2][0]) + r3 = Spheres_data[2][1] + R + temp1 = P2 - P1 + if norm(temp1) == 0: + return 666, 666 + e_x = temp1 / norm(temp1) + temp2 = P3 - P1 + i = dot(e_x, temp2) + temp3 = temp2 - i * e_x + if norm(temp3) == 0: + return 666, 666 + e_y = temp3 / norm(temp3) + e_z = cross(e_x, e_y) + d = norm(P2 - P1) + j = dot(e_y, temp2) + x = (r1 * r1 - r2 * r2 + d * d) / (2 * d) + y = (r1 * r1 - r3 * r3 - 2 * i * x + i * i + j * j) / (2 * j) + temp4 = r1 * r1 - x * x - y * y + if temp4 < 0: + # print("The three spheres do not intersect!") + return 666, 666 + else: + z = sqrt(temp4) + p_12_a = P1 + x * e_x + y * e_y + z * e_z + p_12_b = P1 + x * e_x + y * e_y - z * e_z + + p_12_a = np.ndarray.tolist(p_12_a) + p_12_b = np.ndarray.tolist(p_12_b) + + return p_12_a, p_12_b + +# =================================================================== + + + diff --git a/src/msspec/es/es_mod/es_sym_analys.py b/src/msspec/es/es_mod/es_sym_analys.py new file mode 100644 index 0000000..ff6b87a --- /dev/null +++ b/src/msspec/es/es_mod/es_sym_analys.py @@ -0,0 +1,553 @@ +# coding: utf-8 + +import unittest +import delaunay.core as delc +from subprocess import call +import numpy as np +from scipy.spatial import ConvexHull +from ase import Atoms +from ase.io import read,write +from ase.visualize import view +import empty_spheres as esph +import es_tools as tool +import math +#=================================================================== +# List of routines : +""" +================= +sym_analyse(Cluster) : Convert set into xyz folder, then finds all symetries using. Uses compare_sym and read_sym_file +major_plane(set,[multiple]) : Search the major(s) plane with max nb of points in set and returns all of his points, and his equation + if multiple = True, returns all Plane equations of planes containing enough points +Cluster_flatness_informations(set) : Returns set's hull's total volume and area +Cluster_search_hollow(set,tol) : Returns the hollow datas : hollow=[[list,center,volume]...] where list is hollow' vertice's +Cluster_emptyness_informations(Structure) : Returns the % of volume of hull occupied by his spheres + index,[center,volume] his hollow's center and volume. tol defines hollow's diagonale +Vertice_Sphere_Proportion(O,hull) : Returns the proportion of the sphere centered in Oth pt in the hull (proportion in ]O,1]) +hull_search_neighbors(O,Simplices) : Returns list including O and neighbors (list contains only index, no coordinates) +convex_base(Neil,Simplices) : Returns all Neil[0] neighbors so as ConvBase is the base of pyramid from top Neil[0] +Neighbors_List(numAtom,Structure) : Returns index list in Structure of neighbors of Atom indexed numAtom. numatom not included +Hull_Tetracut(O,Structure,hull) : Returns index list in Structure of centers of spheres defining the terahedron cuting the vertice O +facet_cap(O,Structure,hull) : Return the proportion of sphere centered in O out from the hull + (ie return the cap proportion of the sphere defined by cuting sphere with hull facets) +================= +""" +#=================================================================== +def sym_analyse(Cluster) : + #This function convert the given set into a xyz folder, then uses modified clus_geom executable to find + # the set symmetries. Then, it computes and returns the list of symmetries the list into "sym" + #Sym begins with the integer number of symetries, then with all symmetry-names on strings + sym=[] + write('Cluster.xyz',Cluster) #Sym_Analys folder contains actually the cluster_geom executables + call(["./es_mod/Sym_Analys/proc_geom"]) + sym=read_sym_file('sym_analysis.lis') + #For the moment, the file isn't removed... + return sym +# =================================================================== +def compare_sym(Nsym,Osym): + # Compare the new list of symmetries Nsym to the old one (Osym). + # If the lists are not the same, it tells user to fusion more empty-spheres, to keep sym unchanged + # Situation will be defined with output : 1 if symmetry conserved, 0 if not. + # If there was no symmetry except identity : (-1). And if symmetries have been gained : 2. + N=Nsym[0] + O=Osym[0] + print("Old number of sym :",O) + print("New number of sym :", N) + if N>O : + output=2 + print "Symmetries gained. Symmetry-list updated" + elif O==1 : + output=-1 + print "No symmetry existing to help at decision" + elif N == O: + output=1 + print "Symmetry has been conserved." + elif N len(Plane): + Plane = P + elif len(P) == len(Plane): + if tool.longest_dist(P) < tool.longest_dist(Plane): + Plane = P + # Else, Plane remains the one with the most and the nearest points + # + index = Plane_list.index(Plane) + Plane_eq = Plane_eq[index] + return [Plane, Plane_eq] + + elif multiple == True : + #print("We have Planelist at {} element and Planeeq at {} elements".format(len(Plane_list),len(Plane_eq))) + CleanLen=tool.cleanlist(PlanesLen) + print("Planes include number of spheres in {}".format(sorted(CleanLen))) + planesize = input("Please select minimal size of plane we should take : ") + AllPlanes = [] + + for P in Plane_list : + if len(P) >= planesize : + index=Plane_list.index(P) + PEQ=Plane_eq[index] + + #AllPlanes.append(PEQ) + AllPlanes.append([P,PEQ]) + """ + print("In total we have {} planes".format(len(AllPlanes))) + for P in AllPlanes: + print("P n°{} : Equation : {}\nPoints : {}\n".format(AllPlanes.index(P) + 1, P[1],P[0])) + + #""" + + #Clean Double Planes : ax + by + cz + d = 0 <=> -ax -by -cz -d =0 + + AllPlanesIndex = range(len(AllPlanes)) + Output = [] + + for iP in range(len(AllPlanes)): + if iP in AllPlanesIndex: + for iOP in range(iP + 1, len(AllPlanes)): + Plist = AllPlanes[iP][0] + OPlist = AllPlanes[iOP][0] + if Plist == OPlist: + AllPlanesIndex.remove(iOP) # P and OP are same Planes as they include same points + for I in AllPlanesIndex: + Output.append(AllPlanes[I]) + + return Output + + +# =================================================================== + +def combinaison_3_noorder_norepeat(set) : + #returns every 3-uplet combinaison of the set, with no repetition, and no order variation (ie :{1,2,3}={1,3,2}) + l=len(set) + Combi = [] + for i in range(0, l - 2): + for j in range(i + 1, l - 1): + for k in range(j + 1, l): + Combi.append([set[i], set[j], set[k]]) + return Combi +# =================================================================== +def Cluster_flatness_informations(set) : + #returns the total volume and area of the set's hull, then + hull= ConvexHull(set) + set_area=hull.area + set_volume=hull.volume + return[set_volume,set_area] +# =================================================================== +def Cluster_search_hollow(set,tol) : + #Returns the hollow datas : hollow=[[[list],center,volume]...] where list is hollow vertices, and center and volume respectively + #his center and volume.'Tol' can be 2 (big) or sqrt(3) to consider cubes as hollow, or even sqrt(2) to consider terahedrons as hollow + #Notice that no hollows are detected fo a pentagone, due to his particular alignment of vertices... + #Compute Centroid of Cluster : + dmin = tool.shortest_dist(set) + #Search for hollows + hollow = [] + L=len(set) + for i in range(0,L-1): + for j in range(i+1,L) : + #Data print (debug) : + P1=set[i] + P2=set[j] + print("i,j : {},{}\nP1 :{}\nP2 :{}\ndistance(P1,P2):{}\n dmin={} so tol becomes {}\n".format(i+1,j+1,P1,P2,tool.distance(P1,P2),dmin,tol*0.99*dmin)) + if tool.distance(P1,P2) > 0.99*tol * dmin :#Then we may have find a hole center between P1 and P2 + hcenter=tool.Midpoint(P1,P2) + d = tool.distance(P1,P2)/2 + print("hcenter is distant form set to {}...\nMust be > {}".format(tool.point_set_proximity(hcenter, set),0.98*d)) + if tool.point_set_proximity(hcenter, set) > 0.98*d :#We have a hollow there : + hollow_list=[] + hollowinvset=tool.Invert_Coord(set,hcenter,10)#10 is just decent : the volumewill be multiplied by 1000 + hollowhull=ConvexHull(hollowinvset) + hollow_index =np.ndarray.tolist(hollowhull.vertices) + hollow_volume=hollowhull.volume/1000 + hollow.append([hollow_index,hcenter,hollow_volume]) + print("Hollow founded :{}\n".format(hcenter)) + # + #else : no hollow finally + # else : P1 and P2 pretty neighboors + # + # + return hollow +# =================================================================== +def Cluster_emptyness_informations(Structure) : + #returns the % of volume of hull occupied by his spheres + Allproportions=[] + set=Structure.positions + hull= ConvexHull(set) + #esph.lookhull(Structure,hull) + set_volume=hull.volume + spheres_volume=0 + for pt in range(0,len(set)) : #Study all set point from index. + print("Pt n°{}".format(pt)) + if pt in hull.vertices : + #pt is a boundary point. We need to know the proportion of the sphere in the hull. + proportion=Vertice_Sphere_Proportion(pt,hull,Structure) + else : #We must verify sphere is completely is the cluster or not : it can have a cap out : + NeibPt=Neighbors_List(pt,Structure) + NeibInHull=tool.commonlist(NeibPt,hull.vertices) + if len(NeibInHull) != 0 :#We must search the cap cutting the sphere. + cap=facet_cap(pt,Structure,hull) + proportion = 1 - cap + else : + proportion = 1 + + previous = spheres_volume + spheres_volume += proportion * (4 * math.pi / 3) * (esph.Atom_Radius(Structure,pt,1)**3) + print("So sphere n°{} is at proportion {} in hull : We add {} to total sphere volume, being at {} now".format(pt,proportion,spheres_volume-previous,spheres_volume)) + raw_input("\nPress Enter to continue ...\n") + + Allproportions.append(proportion) + print "AllProportions : ",Allproportions + + print("Hull volume = {}".format(set_volume)) + return spheres_volume / set_volume * 100 +# =================================================================== + +# =================================================================== +def Vertice_Sphere_Proportion(O,hull,Structure) : + #Returns the proportion of the sphere centered in O in the hull (proportion in ]O,1]). + #O is the index of the center in hull vertices list. + R = esph.Atom_Radius(Structure, O, 1) # Radius of O + Vertices_list = np.ndarray.tolist(hull.vertices) + Simplices_list = np.ndarray.tolist(hull.simplices) + Point_list = np.ndarray.tolist(hull.points) + Norm_list = np.ndarray.tolist(hull.equations) + #print("Vertices : {}\nSimplices :{}\nPoints : {}\nO :{}".format(Vertices_list,Simplices_list,Point_list,O)) + Proportion = 0 #initialisation + Neighbors=Hull_Neighbors_List(O,Structure,hull) + print("Neighbors :{}".format(Neighbors)) + #Neighbors=tool.commonlist(Neighbors,Vertices_list)#We delete all neighbors not included in the hull + Neighbors.insert(0,O) + #print("Neighbors in hull :{}".format(Neighbors)) + + if len(Neighbors) == 3 : #O is on a ridge + Pt=[] + for pt in Neighbors : + Pt.append(hull.points[pt]) + Ox = tool.vector_def(Pt[0],Pt[1]) + Oy = tool.vector_def(Pt[0], Pt[2]) + Alpha=tool.angle_vector(Ox,Oy) + Proportion=Alpha / (2 * math.pi) + + else : + + if len(Neighbors) < 3 : #There is an error here + print("Hull is strangely defined : you can check on view") + #Test if O is in a big facet : + norms=[] + for Sim in Simplices_list : + if O in Sim : + indx=Simplices_list.index(Sim) + norm=Norm_list[indx][:3] + if norm not in norms : + norms.append(norm) + if len(norms)==1 : #Only one norm for all facets containing O : O in center of a big facet + Proportion = 0.5 + else : #Here the work begins : O top of a pyramid + + Triag = delc.Triangulation(Structure.positions) + for tetra in Triag.indices : + if O in tetra: #A tetrahedron containing O : O will be counted as top + print("Tetraedron found with {} in : {}".format(O,tetra)) + tetra.remove(O) + P1 = Point_list[tetra[0]] + P2 = Point_list[tetra[1]] + P3 = Point_list[tetra[2]] + #View tetrahedron : + Tetraview=Atoms("XH3",positions=[Point_list[O],P1,P2,P3]) + view(Structure+Tetraview) + V1 = tool.vector_def(Point_list[O], P1) + V2 = tool.vector_def(Point_list[O], P2) + V3 = tool.vector_def(Point_list[O], P3) + print "Vectors from top of pyramid to base points" , [V1, V2, V3] + a = tool.angle_vector(V1, V2) + b = tool.angle_vector(V2, V3) + c = tool.angle_vector(V3, V1) + + # """____________________________________________________________ + # L'Huilier Theorem : + p = (a + b + c) / 2 + #print("p = {} , or {}° , Angles : {}, {}, and {}".format(p,p*180/math.pi,a*180/math.pi,b*180/math.pi,c*180/math.pi)) + S = 4 * np.arctan( + np.sqrt(np.tan(p / 2) * np.tan((p - a) / 2) * np.tan((p - b) / 2) * np.tan((p - c) / 2))) + #print("L'huilier pocess :\nS =4arctan( Sqrt( tan(p/2)*tan(p-a/2)* tan(p-b/2) * tan(p-c/2) ) )\n =4arctan(sqrt(tan({})*tan({})*tan({})*tan({})))\n =4arctan(sqrt({}*{}*{}*{}))\n =4arctan({})\n = {} \n\n Sphere Volume = {}, so proportion = {}".format(p/2,(p-a)/2,(p-b)/2,(p-c)/2,np.tan(p/2),np.tan((p-a)/2),np.tan((p-b)/2),np.tan((p-c)/2),np.tan(p/2)*np.tan((p-a)/2)*np.tan((p-b)/2)*np.tan((p-c)/2),S,(4 * math.pi),S / (4 * math.pi))) + print("S with Huilier = {}".format(S)) + # """____________________________________________________________ + + # """____________________________________________________________ + # Spherical area computing : Sinus formula + Girard's formula + cosT = (np.cos(c) - np.cos(a)*np.cos(b)) / (np.sin(a)*np.sin(b)) + Theta = np.arccos(cosT) + sinT = np.sin(Theta) + sinA = np.sin(a) * sinT / np.sin(c) + sinB = np.sin(b) * sinT / np.sin(c) + print("sinB detail : b = {}, sin(b) = {}, sinT = {},c = {} sin(c) = {}\So : sinB = {}".format(b,np.sin(b),sinT,c,np.sin(c),sinB)) + if sinA >=1 : + Alpha=math.pi/2 + else : + Alpha = np.arcsin(sinA) + if sinB >=1 : + Beta=math.pi/2 + else : + Beta = np.arcsin(sinB) + S = (Alpha + Beta + Theta - math.pi) + print("S with sinus and Girard's formulaes = {}".format(S)) + #"""____________________________________________________________ + + + + Proportion += S / (4 * math.pi) + print("We had {} to actual {} Proportion, being now at {}".format(S / (4*math.pi), Proportion - S / (4 * math.pi), Proportion)) + #else the tetraedron in disconnected to the center of sphere : no need to study him + + print("proportion : {}".format(Proportion, 1. / Proportion)) + + """Little thing to see exactly what happens + print("proportion : {} , or 1/{}".format(Proportion, 1./Proportion)) + Lset=len(Neighbors)-1 + set = [] + Lhul=len(np.ndarray.tolist(hull.points)) + namehull= "C" +str(Lhul) + HullView=Atoms(namehull,positions=np.ndarray.tolist(hull.points)) + for pt in Neighbors: + set.append(Point_list[pt]) + set.remove(Point_list[O]) + nameset= "H" + str(Lset) + ViewNeig=Atoms(nameset,positions=set) + Ostr=Atoms(positions=[Point_list[O]]) + view(HullView+ViewNeig+Ostr) + #""" + + return Proportion + +# =================================================================== + +def hull_search_neighbors(O,Simplices) : + #Returns the list including O in fist position and all of his neighbors (list contains only index, no coordinates) + Neil=[O] + print("O in the search neighbors routine :",O) + for facet in Simplices : + if O in facet : + for i in facet : + if i not in Neil : + Neil.append(i) + #else : i still in neighbors list + return Neil +# =================================================================== + +def convex_base(Neil,Simplices) : + #Order the neighbors list by listing them so as each consecutives elements in the list are themselves neighbors. + #So it returns all Neil[0] neighbors so as ConvBase is the base of pyramid from top Neil[0] + ConvBase=[] + ConvBase.append(Neil[1]) + Rest=Neil[2:] + print("Initial Neil : ",Neil) + while len(Rest)>0 : + for i in Rest : + print("Convbase :{}\nRest :{}\nactual i:{}".format(ConvBase, Rest,i)) + Last=ConvBase[-1] + print(Last) + Neighborsi=hull_search_neighbors(i,Simplices) + print ("The last elements :{}\nHis neighbors : {}".format(ConvBase[-1],Neighborsi)) + if ConvBase[-1] in Neighborsi : + ConvBase.append(i) + Rest.remove(i) + + return ConvBase + +# =================================================================== + +def Neighbors_List(numAtom,Structure) : + # Returns the list of all atom's indexes in Structure wich are neighbors of Atom indexed numAtom (numAtom must be int, 0 included) + set=np.ndarray.tolist(Structure.positions) + radAtom=esph.Atom_Radius(Structure,numAtom,1) + posAtom=set[numAtom] + Neilist=[] + for i in range(0,len(set)) : + int(i) + radi=esph.Atom_Radius(Structure,i,1) + D = tool.distance(set[i],posAtom) - radi - radAtom + if D < 0.1 : + Neilist.append(i) + Neilist.remove(numAtom) + return Neilist + +# =================================================================== +def Hull_Neighbors_List(O,Structure,hull) : + # Returns the list of all atom's indexes in hull wich are neighbors of Atom indexed numAtom (numAtom must be int, 0 included) + Allfacets = np.ndarray.tolist(hull.simplices) + Hull_Neilist = [] + print Allfacets + for facet in Allfacets : + if O in facet : + for index in facet : + if index not in Hull_Neilist : + Hull_Neilist.append(index) + Hull_Neilist.remove(O) + return Hull_Neilist +# =================================================================== + +def facet_cap(O,Structure,hull) : + #From the hull, the Structure and the index of the sphere center O (int), return the proportion of sphere cuted by hull facets + #(ie the caps out of the hull). cap is returned proportionnal to total sphere volume (ie cap in [0,1[) + cap = 0 + Center = Structure.positions[O] + Radius = esph.Atom_Radius(Structure,O,1) + AllFacets = np.ndarray.tolist(hull.equations) + hullplan=tool.cleanlist(AllFacets) + cutplan = [] # List of all cuting plan equations + cuthigh = [] # List of cuting high, corelated to cutplan + cutpoint = [] #List containing for each plan one point of the hull included in this plan (used for overlap routine) + for facet_plan in AllFacets: + d=tool.dist_point_plan(Center,facet_plan) + if d 1.99 * math.pi :#considering a little error here from 1% : because soon OrthoProjO is in a facet ridge + if facet_plan not in cutplan :#If OrthoProjO in a ridge, the plan can be counted twice or more... + h=Radius-d + cutplan.append(facet_plan) + cuthigh.append(h) + cutpoint.append(FacetPtsCoord[0]) # Just one point is enough : + + # Draw to see better :=================== + Draw = FacetPtsCoord + Draw.append(np.ndarray.tolist(hull.points[O])) + Draw.append(OrthoProjO) + DrawView = Atoms("X3CH", positions=Draw) + view(DrawView) + # ======================================= + + + + """________________________________________________________________ + # Little thing to see exactly what happens + hullview = [] + for i in hull.vertices: + hullview.append(Structure.positions[i]) + L = len(hullview) + Lookhull = Atoms(positions=hullview) + set = [] + for ffp in AllFacets : + if ffp == cutplan : + FacetPts = np.ndarray.tolist(hull.simplices[plan_index]) + for pt in FacetPts: + if pt not in set : + set.append(np.ndarray.tolist(hull.points[pt])) + nameset = "H" + str(len(set)) + ViewFacet = Atoms(nameset, positions=set) + Ostr = Atoms("C", positions=[np.ndarray.tolist(hull.points[O])]) + view(Lookhull + ViewFacet + Ostr) + # __________________________________________________________________""" + + if len(cutplan) <1 : + print("Finally no plan cutting our sphere...\n\n" ) + + if len(cutplan) == 1 :#Only one plan cuting sphere : One cap to be calculated : + h = cuthigh[0] + print("Sphere (radius {}) is cuted by one plan at cap from high {}\n Plan equation :{} ".format(Radius, h, + facet_plan)) + + Vtot = 4 * math.pi * (Radius ** 3) / 3 + Vcap = math.pi * (h ** 2) / 3 * (3 * Radius - h) + cap += Vcap / Vtot + + if len(cutplan) > 1: + print("We have {} plans cutting the sphere.... We have to calculate overlap... ".format(len(cutplan))) + + return cap diff --git a/src/msspec/es/es_mod/es_tools.py b/src/msspec/es/es_mod/es_tools.py new file mode 100644 index 0000000..7c826a4 --- /dev/null +++ b/src/msspec/es/es_mod/es_tools.py @@ -0,0 +1,278 @@ +# coding: utf-8 +from ase import Atoms +from ase.visualize import view +import numpy as np +import math + +# List of tools : +""" +=================Vector tools================== +vector_def(A,B) : returns simply the vector translating A to B +vector_norm(V) : return euclidian norm of a vector +vector_trslt(P,V) : return image of translation of P from vector V +throw_away (P,O,d) : returns P' so as O,P and P' are aligned, and OP'=d. So it translate P from O with distance d to direction OP +angle_vector(u,v) : returns the value of the convex angle defined by vectors u and v, in radians. +ColinearTest(u,v) : returns 1 if u and v colinear, and 0 if not. + +===========Distance and Proximity tools======== +distance(a,b) : calculate distance between 2 points +search_nearest(point,set,d) : search the point in set wich is the nearest from point. We must know that the min distance is d +point_set_proximity(point, set) : returns the min distance between the point and the set of points +set_set_proximity(S1,S2) : returns minimal distance between each points of each sets. +longest_dist(set) : returns the longest distance between the points in the set +shortest_dist(set) : returns the shortest distance between the points in the set +dist_point_plan(Pt,Plan) : From Pt=[x,y,z] and Plan=[a,b,c,d], return distance beetween Pt and Plan + +===============Construction tools=============== +Isobarycenter(set) : Calculate isobarycenter of a set of points. Returns his coordinates +Invert_Coord(set,O,r) : Apply circular inversion to every point in the set, excepted for origin, remaining origin. +Midpoint(P1,P2) : Computes the middle point of P1 and P2 +rot3D(P,A,u) : Returns P' image of P by rotation from angle A around unity vector u +===================Data tools=================== +commonlist(L1,L2) : Returns a list of elements common to L1 and L2, ie output is L1 intercection with L2 +cleanlist(list) : Returns a list without repeated elements (each element in cleaned list appears only once) +""" + + +# ========================Vector Tools============================= +def vector_def(A, B): + # returns simply the vector translating A to B + l = len(A) + if l != len(B): + print("Major Error : The 2 given points aren't same dimensioned :\nA = {}\nB={}".format(A, B)) + V = [] + for i in range(0, l): + V.append(B[i] - A[i]) + return V + + +# ========================================== +def vector_norm(V): + # return euclidian norm of a vector + l = (len(V)) + Origin = np.ndarray.tolist(np.zeros(l)) + return distance(V, Origin) + + +# ========================================== +def vector_trslt(P, V): + x, y, z = P + a, b, c = V + return [x + a, y + b, z + c] + + +# ========================================== +def throw_away(P, O, d): + # returns P' so as O,P and P' are aligned, and OP'=d. So it translate P from O with distance d to direction OP + OP = tool.vector_def(O, P) + OP = np.ndarray.tolist(np.multiply(OP, 1. / tool.vector_norm(OP))) + output = np.ndarray.tolist(np.multiply(OP, d)) + return output + + +# ========================================== +def angle_vector(u, v): + # returns the value in radian of the convex angle defined by vectors u and v. + U = vector_norm(u) + V = vector_norm(v) + UV = np.dot(u, v) + # print("U : {}\nV : {}\n u.v : {}".format(U,U,UV,)) + if UV == 0: + # print("u.v = 0, on a donc un angle de {}, soit {}°".format(math.pi/2,math.pi/2*180/math.pi)) + return math.pi / 2 + else: + # print("L'angle est donc donc arccos({}) = {} = {}°".format(UV / (U * V),np.arccos(UV/(U*V)),np.arccos(UV/(U*V))*180/math.pi)) + return np.arccos(UV / (U * V)) + + +# ========================================== +def ColinearTest(u, v): + # Tests if u and v colinear + L = len(u) + k = 999999999999 # initial value, to be sure first ktest will become k + if L != len(v): + print( + "Error : u and v ant same dimension : \nu={}\nv={}\nSo we return u and v not aligned... but verify consequences".format( + u, v)) + else: + for i in range(0, L): + if u[i] == 0 or v[i] == 0: + if u[i] != 0 or v[i] != 0: + return 1 + else: + ktest = u[i] / v[i] + if k == 999999999999: + k = ktest + elif np.abs(k - ktest) < 0.0000001: # We accept almost colinearité at 1/10^6 + return 1 + return 0 + + +# ========================================== + +# ========================================== +# ========================================== +# ==============Distance and Proximity Tools======================= +def distance(a, b): + # Calculate distance between 2 points + d = 0.0 + dim = len(a) + for i in range(0, dim): + d += (b[i] - a[i]) ** 2 + d = np.sqrt(d) + return d + + +# ========================================== +def search_nearest(point, set, d): + # search the point in set wich is the nearest from point. We must know that the min distance is d + for p in set: + if distance(point, p) == d: + return p + + +# ========================================== +# ========================================== +def point_set_proximity(point, set): + # returns the min distance between the point and the set of points + d = distance(point, set[0]) + for p in set[1:]: + d = min(d, distance(point, p)) + return d + + +# ========================================== +def set_set_proximity(S1, S2): + # returns minimal distance between each points of each sets. + d = point_set_proximity(S1[0], S2) + for s in S1[1:]: + d = min(d, point_set_proximity(s, S2)) + return d + + +# ========================================== +def longest_dist(set): + # returns the longest distance between the points in the set + L = len(set) + if L < 2: + print("Major ERROR : the set has become a 1-UPLET") + quit() + else: + d = distance(set[L - 2], set[L - 1]) # The last ones + for i in range(0, L - 2): + for j in range(i + 1, L - 2): + d = max(d, distance(set[i], set[j])) + return d + + +# ========================================== +def shortest_dist(set): + # returns the shortest distance between the points in the set + L = len(set) + if L < 2: + print("Major ERROR : the set has become a 1-UPLET") + quit() + else: + d = distance(set[L - 2], set[L - 1]) # The last ones + for i in range(0, L - 2): + for j in range(i + 1, L - 2): + d = min(d, distance(set[i], set[j])) + return d + + +# ========================================== +def dist_point_plan(Pt, Plan): + # From Pt=[x,y,z] and Plan=[a,b,c,d] corresponding to plan's equation ax + by + cz + d = 0, give the distance beetween Pt and the Plan + x, y, z = Pt + a, b, c, d = Plan + dist = np.abs(a * x + b * y + c * z + d) / np.sqrt(a ** 2 + b ** 2 + c ** 2) + return dist + + +# ======================Construction tools========================= +def Isobarycenter(set): + # Calculate isobarycenter of a set of points. Returns his coordinates + x = y = z = 0.0 + l = len(set) + for point in set: + x += point[0] / l + y += point[1] / l + z += point[2] / l + # print("New Centroid of cluter:",[x,y,z]) + return [x, y, z] + + +# ========================================== +def Invert_Coord(set, O, r): + # Apply circular inversion to every point in the set, excepted for origin, remaining origin. + output = [] + for point in set: + if point == O: + output.append(point) + else: + D = distance(O, point) + OP = vector_def(O, point) + OP = np.multiply(OP, 1. / D) # set OP to unity vector + add = np.ndarray.tolist(np.array(O) + np.multiply(OP, r ** 2 / D)) + output.append(add) + return output + + +# ========================================== +def Midpoint(P1, P2): + # From points coordinates P1 and P2 : construct the middle point of [P1,P2] + output = np.ndarray.tolist(np.multiply((np.array(P1) + np.array(P2)), 0.5)) + return output + + +# ========================================== +def rot3D(P, A, u): + # Verify first if u is unity vector : + if vector_norm(u) != 1: + u = np.ndarray.tolist(np.multiply(u, 1. / vector_norm(u))) + # From P in R3, A in R and u in R3, returns the image from P's rotation around u from angle A + x, y, z = P + ux, uy, uz = u + c = np.cos(A) + s = np.sin(A) + # We compute directly the result : see the 3D rotation matrix + X = x * (ux ** 2 * (1 - c) + c) + y * (ux * uy * (1 - c) - uz * s) + z * (ux * uz * (1 - c) + uy * s) + Y = x * (ux * uy * (1 - c) + uz * s) + y * (uy ** 2 * (1 - c) + c) + z * (uy * uz * (1 - c) - ux * s) + Z = x * (ux * uz * (1 - c) - uy * s) + y * (uy * uz * (1 - c) + ux * s) + z * (uz ** 2 * (1 - c) + c) + + return [X, Y, Z] + + +# =========================Data Tools============================== +def commonlist(L1, L2): + # Returns a list of elements common to L1 and L2, ie output is L1 intercection with L2 + output = [] + for i in L1: + if i in L2: + output.append(i) + return output + + +# ========================================== +def cleanlist(list): + # Returns a list without repeated elements (each element in cleaned list appears only once) + ls = len(list) + Index = range(ls) + Output = [] + + for iS in range(ls): + if iS in Index: + for iOS in range(iS + 1, ls): + S = list[iS] + OS = list[iOS] + if S == OS: + Index.remove(iOS) # S and OS are same coord or almost : we remove the last : OS + # else : iS correspond to coord needed to be deleted, so we don't add it + + for I in Index: + Output.append(list[I]) + + return Output + +# ========================================== + diff --git a/src/msspec/es/main.py b/src/msspec/es/main.py new file mode 100644 index 0000000..cfb0500 --- /dev/null +++ b/src/msspec/es/main.py @@ -0,0 +1,53 @@ +# coding: utf-8 + +from ase import Atoms +from ase.io import write,read +from ase.visualize import view +from scipy.spatial import ConvexHull +from es_mod import empty_spheres as esph + + +"""=============Generate empty spheres in copper cluster +Structure = read('cluster_examples/copper.xyz') +struct = np.ndarray.tolist(Structure.positions) +set = esph.Delaunay_Intersphere(struct) +Set=Atoms(positions=set) +view(Structure+Set) +view(Set) +#"""#==================================================== + +from msspec.calculator import MSSPEC +from msspec.utils import * + +#"""=============Use Python MsSpec +cluster = read('cluster_examples/GeCl4.xyz') + +# Set the absorber (the deepest atom centered in the xy-plane) +cluster.absorber = 0 +# Create a calculator for the PhotoElectron Diffration +calc = MSSPEC(spectroscopy='PED') +# Set the cluster to use for the calculation +calc.set_atoms(cluster) + +# Run the calculation +data = calc.get_theta_scan(level='2p3/2', kinetic_energy=[320,325,5]) + +# Show the results +data.view() +#"""#=============================== + +#"""===================MsSpec on ClusterC Test : +cluster = read('ClusterFinal.xyz') +# Set the absorber (the deepest atom centered in the xy-plane) +cluster.absorber = 0 +# Create a calculator for the PhotoElectron Diffration +calc = MSSPEC(spectroscopy='PED') +# Set the cluster to use for the calculation +calc.set_atoms(cluster) + +# Run the calculation +data = calc.get_theta_scan(level='2p3/2', kinetic_energy=[320,325,5]) + +# Show the results +data.view() +#"""#=============================== \ No newline at end of file diff --git a/src/msspec/iodata.py b/src/msspec/iodata.py new file mode 100644 index 0000000..f6ba048 --- /dev/null +++ b/src/msspec/iodata.py @@ -0,0 +1,1188 @@ +# coding: utf-8 +""" +Module iodata +============= + +This module contains all classes useful to manipulate, store and display +data results. + +The :py:class:`Data` and :py:class:`DataSet` are the two enduser classes +important to manipulate the data. +Here is an example of how to store values in a Data object: + +.. code-block:: python + + from msspec.iodata import Data + import numpy as np + + + # Let's create first some dumy data + X = np.arange(0, 20) + Y = X**2 + + # Create a Data object. You need to give a title as an argument + data = Data('all my data') + # and append a new DataSet with its title + dset = data.add_dset('Dataset 0') + + # To feed the DataSet with columns, use the add_columns method + # and provide as many keywords as you like. Each key being the + # column name and each value being an array holding the column + # data. + dset.add_columns(x=X, y=Y, z=X+2, w=Y**3) + # you can provide parameters with their values with keywords as well + dset.add_parameter(name='truc', group='main', value='3.14', unit='eV') + + # To plot these data, you need to add a 'view' with its title + view = dset.add_view('my view') + # You then need to select which columns you which to plot and + # and under wich conditions (with the 'which' keyword) + view.select('x', 'y', where="z<10", legend=r"z = 0") + view.select('x', 'y', where="z>10", legend=r"z = 1") + + # To pop up the graphical window + data.view() + +""" + + +import os +import numpy as np +import h5py +from lxml import etree +import msspec +from msspec.misc import LOGGER +import ase.io +from io import StringIO + +import wx +import wx.grid + +from matplotlib.backends.backend_wxagg import FigureCanvasWxAgg as FigureCanvas +from matplotlib.backends.backend_wxagg import NavigationToolbar2WxAgg +from matplotlib.figure import Figure + +from terminaltables import AsciiTable +from distutils.version import StrictVersion, LooseVersion + +import sys +#sys.path.append('../../MsSpecGui/msspecgui/msspec/gui') +from .msspecgui.msspec.gui.clusterviewer import ClusterViewer + +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 + newx = np.linspace(np.min(x), np.max(x), nx) + newy = np.linspace(np.min(y), np.max(y), ny) + ux = np.unique(np.append(x, newx)) + uy = np.unique(np.append(y, newy)) + + # create an empty matrix to hold the results + zz = np.empty((len(ux), len(uy))) + zz[:] = np.nan + + for p in zip(x, y, z): + i = np.argwhere(ux == p[0]) + j = np.argwhere(uy == p[1]) + zz[i, j] = p[2] + + for i in range(len(ux)): + #ok, = np.where(-np.isnan(zz[i,:])) + ok, = np.where(~np.isnan(zz[i, :])) + if len(ok) > 0: + xp = uy[ok] + fp = zz[i, ok] + zz[i,:] = np.interp(uy, xp, fp) + + for i in range(len(uy)): + #ok, = np.where(-np.isnan(zz[:,i])) + ok, = np.where(~np.isnan(zz[:, i])) + if len(ok) > 0: + xp = ux[ok] + fp = zz[ok, i] + zz[:,i] = np.interp(ux, xp, fp) + + return ux, uy, zz + + +class _DataPoint(dict): + def __init__(self, *args, **kwargs): + dict.__init__(self, *args, **kwargs) + + def __getattr__(self, name): + if name in list(self.keys()): + return self[name] + else: + raise AttributeError("'{}' object has no attribute '{}'".format( + self.__class__.__name__, name)) + +class DataSet(object): + """ + This class can create an object to hold column-oriented data. + + :param title: The text used to entitled the dataset + :type title: str + :param notes: Some comments to add to the data + :type notes: str + + """ + def __init__(self, title, notes=""): + self.title = title + self.notes = notes + self._views = [] + self._parameters = [] + self.attributes = {} + + + self._col_names = [] + self._col_arrays = [] + self._defaults = {'bool': False, 'str': '', 'int': 0, 'float': 0., + 'complex': complex(0)} + self._formats = {bool: '{:s}', str: '{:s}', int: '{:<20d}', + float: '{:<20.10e}', complex: 's'} + + def _empty_array(self, val): + if isinstance(val, str): + t = 'S256' + else: + t = np.dtype(type(val)) + + if isinstance(val, bool): + default = self._defaults['bool'] + elif isinstance(val, str): + default = self._defaults['str'] + elif isinstance(val, int): + default = self._defaults['int'] + elif isinstance(val, float): + default = self._defaults['float'] + elif isinstance(val, complex): + default = self._defaults['complex'] + else: + raise TypeError('Not a supported type') + + return np.array([default]*len(self), dtype=t) + + def add_row(self, **kwargs): + """Add a row of data into the dataset. + + :param kwargs: Each keyword is a column name. The number of keywords (columns) must be coherent with the + number of existing columns. If no column are defined yet, they will be created. + + """ + for k, v in list(kwargs.items()): + if k not in self._col_names: + self._col_names.append(k) + self._col_arrays.append(self._empty_array(v)) + for k, v in list(kwargs.items()): + i = self._col_names.index(k) + arr = self._col_arrays[i] + arr = np.append(arr, v) + self._col_arrays[i] = arr + + def add_columns(self, **kwargs): + """ + Add columns to the dataset. + + You can provide as many columns as you want to this function. This + function can be called several times on the same dataset but each time + with different column names. Column names are given as keywords. + + :Example: + + >>> from iodata import DataSet + >>> dset = DataSet('My Dataset', notes="Just an example") + >>> xdata = range(10) + >>> ydata = [i**2 for i in xdata] + >>> dset.add_columns(x=xdata, y=ydata) + >>> print dset + >>> +-------+ + >>> | x y | + >>> +-------+ + >>> | 0 0 | + >>> | 1 1 | + >>> | 2 4 | + >>> | 3 9 | + >>> | 4 16 | + >>> | 5 25 | + >>> | 6 36 | + >>> | 7 49 | + >>> | 8 64 | + >>> | 9 81 | + >>> +-------+ + + """ + for k, vv in list(kwargs.items()): + assert k not in self._col_names, ("'{}' column already exists" + "".format(k)) + #if len(self) > 0: + # assert len(vv) == len(self), ( + # 'Too many values in the column (max = {})'.format( + # len(self))) + for k, vv in list(kwargs.items()): + arr = np.array(vv) + self._col_names.append(k) + self._col_arrays.append(arr) + + def delete_rows(self, itemspec): + """ + Delete the rows specified with itemspec. + + """ + for i in range(len(self._col_names)): + self._col_arrays[i] = np.delete(self._col_arrays[i], itemspec) + + def delete_columns(self, *tags): + """ + Removes all columns name passed as arguments + + :param tags: column names. + :type tags: str + + """ + for tag in tags: + i = self._col_names.index(tag) + self._col_names.pop(i) + self._col_arrays.pop(i) + + def columns(self): + """ + Get all the column names. + + :return: List of column names. + :rtype: List of str + + """ + return self._col_names + + def add_view(self, name, **plotopts): + """ + Creates a new view named *name* with specied plot options. + + :param name: name of the view. + :type name: str + :param plotopts: list of keywords for configuring the plots. + :return: a view. + :rtype: :py:class:`iodata._DataSetView` + """ + if isinstance(name, str): + v = _DataSetView(self, name, **plotopts) + else: + v = name + v.dataset = self + self._views.append(v) + return v + + def views(self): + """Returns all the defined views in the dataset. + + :return: A list of view + :rtype: List of :py:class:`iodata._DataSetView` + """ + return self._views + + def add_parameter(self, **kwargs): + """Add a parameter to store with the dataset. + + :param kwargs: list of keywords with str values. + + These keywords are: + * name: the name of the parameter. + * group: the name of a group it belongs to. + * value: the value of the parameter. + * unit: the unit of the parameter. + + For example: + + .. code-block:: python + + from iodata import DataSet + + mydset = DataSet("Experiment") + mydset.add_parameter(name='Spectrometer', group='misc', value='Omicron', unit='') + + """ + self._parameters.append(kwargs) + + def parameters(self): + """ + Returns the list of defined parameters. + + :return: all parameters defined in the :py:class:`iodata.DataSet` object. + :rtype: List of dict + """ + return self._parameters + + def get_parameter(self, group=None, name=None): + """Retrieves all parameters for a given name and group. + + * If *name* is given and *group* is None, returns all parameters with such a *name* in all groups. + * If *group* is given and *name* is None, returns all parameters in such a *group* + * If both *name* and *group* are None. Returns all parameters (equivalent to + :py:func:`iodata.DataSet.parameters`). + + :param group: The group name or None. + :type group: str + :param name: The parameter's name or None. + :type name: str + :return: A list of parameters. + :rtype: List of dict + """ + p = [] + for _ in self._parameters: + if _['group'] == group or group == None: + if _['name'] == name or name == None: + p.append(_) + return p[0] if len(p) == 1 else p + + def get_cluster(self): + """Get all the atoms in the cluster. + + :return: The cluster + :rtype: :py:class:`ase.Atoms` + """ + s = StringIO() + s.write(self.get_parameter(group='Cluster', name='cluster')['value']) + return ase.io.read(s, format='xyz') + + + def select(self, *args, **kwargs): + condition = kwargs.get('where', 'True') + indices = [] + + + def export(self, filename="", mode="w"): + """Export the DataSet to the given *filename*. + + :param filename: The name of the file. + :type filename: str + + .. warning:: + + Not yet implemented + """ + colnames = self.columns() + with open(filename, mode) as fd: + fd.write("# " + ("{:<20s}" * len(colnames)).format(*colnames + ) + "\n") + for i in range(len(self)): + row = self[i] + for key in row.columns(): + value = row[key][0] + fmt = '{:s}' + #print value + for t, f in list(self._formats.items()): + if isinstance(value, t): + fmt = f + break + #fd.write(' ') + fd.write(fmt.format(value)) + #fd.write(str(value) + ', ') + fd.write('\n') + + def __getitem__(self, itemspec): + if isinstance(itemspec, str): + return getattr(self, itemspec) + title = 'untitled' + new = DataSet(title) + + new._col_names = self.columns() + for arr in self._col_arrays: + new._col_arrays.append(np.array(arr[itemspec]).flatten()) + + return new + + def __setstate__(self, state): + self.__dict__ = state + + def __getstate__(self): + return self.__dict__ + + def __getattr__(self, name): + if name in self._col_names: + i = self._col_names.index(name) + return self._col_arrays[i] + else: + raise AttributeError("'{}' object has no attribute '{}'".format( + self.__class__.__name__, name)) + + def __iter__(self): + for i in range(len(self)): + _ = {k: arr[i] for k, arr in zip(self._col_names, + self._col_arrays)} + point = _DataPoint(_) + yield point + + def __len__(self): + try: + length = len(self._col_arrays[0]) + except IndexError: + length = 0 + return length + + def __str__(self): + max_len = 10 + max_col = 10 + ncols = min(max_col, len(self._col_arrays)) + table_data = [self._col_names[:ncols]] + table_data[0].insert(0, "") + + all_indices = np.arange(0, len(self)) + indices = all_indices + if len(self) > max_len: + indices = list(range(max_len/2)) + list(range(-max_len/2, 0)) + + _i = 0 + for i in indices: + if i < _i: + row = ['...' for _ in range(ncols + 1)] + table_data.append(row) + row = [str(all_indices[i]),] + for j in range(ncols): + arr = self._col_arrays[j] + row.append(str(arr[i])) + if len(self._col_names) > max_col: + row.append('...') + table_data.append(row) + _i = i + + table = AsciiTable(table_data) + table.outer_border = True + table.title = self.title + table.inner_column_border = False + return table.table + + def __repr__(self): + s = "<{}('{}')>".format(self.__class__.__name__, self.title) + return s + +class Data(object): + """Creates a new Data object to store DataSets. + + :param title: The title of the Data object. + :type str: + + """ + def __init__(self, title=''): + self.title = title + self._datasets = [] + self._dirty = False + + def add_dset(self, title): + """Adds a new DataSet in the Data object. + + :param title: The name of the DataSet. + :type title: str + :return: The newly created DataSet. + :rtype: :py:class:`iodata.DataSet` + """ + titles = [d.title for d in self._datasets] + if not title in titles: + dset = DataSet(title) + self._datasets.append(dset) + self._dirty = True + return dset + else: + raise NameError('A Dataset with that name already exists!') + + def delete_dset(self, title): + """Removes a DataSet from the Data object. + + :param title: The DataSet name to be removed. + :type title: str + + """ + titles = [d.title for d in self._datasets] + i = titles.index(title) + self._datasets.pop(i) + self._dirty = True + + def get_last_dset(self): + """Get the last DataSet of the Data object. + + :return: The lastly created DataSet in the Data object + :rtype: :py:class:`iodata.DataSet` + """ + return self._datasets[-1] + + def is_dirty(self): + """Wether the Data object needs to be saved. + + :return: A boolean value to indicate if Data has changed since last dump to hard drive. + :rtype: bool + """ + return self._dirty + + + def save(self, filename, append=False): + """Saves the current Data to the hard drive. + + The Data, all its content along with parameters, defined views... are saved to the hard drive in the HDF5 + file format. Please see `hdfgroup `_ for more details about HDF5. + + :param filename: The name of the file to create or to append to. + :type filename: str + :param append: Wether to create a neww file or to append to an existing one. + :type append: bool + + """ + mode = 'a' if append else 'w' + titles = [d.title for d in self._datasets] + with h5py.File(filename, mode) as fd: + if append: + try: + data_grp = fd['DATA'] + meta_grp = fd['MsSpec viewer metainfo'] + except Exception as err: + fd.close() + self.save(filename, append=False) + return + else: + data_grp = fd.create_group('DATA') + meta_grp = fd.create_group('MsSpec viewer metainfo') + + data_grp.attrs['title'] = self.title + for dset in self._datasets: + if dset.title in data_grp: + LOGGER.warning('dataset \"{}\" already exists in file \"{}\", not overwritting'.format( + dset.title, os.path.abspath(filename))) + continue + grp = data_grp.create_group(dset.title) + grp.attrs['notes'] = dset.notes + for col_name in dset.columns(): + data = dset[col_name] + grp.create_dataset(col_name, data=data) + + meta_grp.attrs['version'] = msspec.__version__ + + root = etree.Element('metainfo') + # xmlize views + for dset in self._datasets: + views_node = etree.SubElement(root, 'views', dataset=dset.title) + for view in dset.views(): + view_el = etree.fromstring(view.to_xml()) + views_node.append(view_el) + + # xmlize parameters + for dset in self._datasets: + param_node = etree.SubElement(root, 'parameters', dataset=dset.title) + for p in dset.parameters(): + child = etree.SubElement(param_node, 'parameter') + for k, v in list(p.items()): + child.attrib[k] = v + xml_str = etree.tostring(root, pretty_print=False) + try: + del meta_grp['info'] + except: + meta_grp.create_dataset('info', data=np.array((xml_str,)).view('S1')) + self._dirty = False + LOGGER.info('Data saved in {}'.format(os.path.abspath(filename))) + + @staticmethod + def load(filename): + """Loads an HDF5 file from the disc. + + :param filename: The path to the file to laod. + :type filename: str + :return: A Data object. + :rtype: :py:class:`iodata.Data` + """ + output = Data() + with h5py.File(filename, 'r') as fd: + parameters = {} + views = {} + + output.title = fd['DATA'].attrs['title'] + for dset_name in fd['DATA'] : + parameters[dset_name] = [] + views[dset_name] = [] + dset = output.add_dset(dset_name) + dset.notes = fd['DATA'][dset_name].attrs['notes'] + for h5dset in fd['DATA'][dset_name]: + dset.add_columns(**{h5dset: fd['DATA'][dset_name][h5dset].value}) + + try: + vfile = LooseVersion(fd['MsSpec viewer metainfo'].attrs['version']) + if vfile > LooseVersion(msspec.__version__): + raise NameError('File was saved with a more recent format') + xml = fd['MsSpec viewer metainfo']['info'].value.tostring() + root = etree.fromstring(xml) + for elt0 in root.iter('parameters'): + dset_name = elt0.attrib['dataset'] + for elt1 in elt0.iter('parameter'): + parameters[dset_name].append(elt1.attrib) + + for elt0 in root.iter('views'): + dset_name = elt0.attrib['dataset'] + for elt1 in elt0.iter('view'): + view = _DataSetView(None, "") + view.from_xml(etree.tostring(elt1)) + views[dset_name].append(view) + + except Exception as err: + print(err) + + + for dset in output: + for v in views[dset.title]: + dset.add_view(v) + for p in parameters[dset.title]: + dset.add_parameter(**p) + + output._dirty = False + return output + + def __iter__(self): + for dset in self._datasets: + yield dset + + def __getitem__(self, key): + try: + titles = [d.title for d in self._datasets] + i = titles.index(key) + except ValueError: + i = key + return self._datasets[i] + + def __len__(self): + return len(self._datasets) + + def __str__(self): + s = str([dset.title for dset in self._datasets]) + return s + + def __repr__(self): + s = "".format(self.title) + return s + + def view(self): + """Pops up a grphical window to show all the defined views of the Data object. + + """ + app = wx.App(False) + app.SetAppName('MsSpec Data Viewer') + frame = _DataWindow(self) + frame.Show(True) + app.MainLoop() + + +class _DataSetView(object): + def __init__(self, dset, name, **plotopts): + self.dataset = dset + self.title = name + self._plotopts = dict( + title='No title', + xlabel='', ylabel='', grid=True, legend=[], colorbar=False, + projection='rectilinear', xlim=[None, None], ylim=[None, None], + scale='linear', + marker=None, autoscale=False) + self._plotopts.update(plotopts) + self._selection_tags = [] + self._selection_conditions = [] + + def set_plot_options(self, **kwargs): + self._plotopts.update(kwargs) + + def select(self, *args, **kwargs): + condition = kwargs.get('where', 'True') + legend = kwargs.get('legend', '') + self._selection_conditions.append(condition) + self._selection_tags.append(args) + self._plotopts['legend'].append(legend) + + def tags(self): + return self._selection_tags + + def get_data(self): + data = [] + for condition, tags in zip(self._selection_conditions, + self._selection_tags): + indices = [] + # replace all occurence of tags + for tag in self.dataset.columns(): + condition = condition.replace(tag, "p['{}']".format(tag)) + + for i, p in enumerate(self.dataset): + if eval(condition): + indices.append(i) + + values = [] + for tag in tags: + values.append(getattr(self.dataset[indices], tag)) + + data.append(values) + return data + + def serialize(self): + data = { + 'name': self.title, + 'selection_conditions': self._selection_conditions, + 'selection_tags': self._selection_tags, + 'plotopts': self._plotopts + } + root = etree.Element('root') + + return data + + def to_xml(self): + plotopts = self._plotopts.copy() + legends = plotopts.pop('legend') + + root = etree.Element('view', name=self.title) + for key, value in list(plotopts.items()): + root.attrib[key] = str(value) + #root.attrib['dataset_name'] = self.dataset.title + + for tags, cond, legend in zip(self._selection_tags, + self._selection_conditions, + legends): + curve = etree.SubElement(root, 'curve') + curve.attrib['legend'] = legend + curve.attrib['condition'] = cond + axes = etree.SubElement(curve, 'axes') + for tag in tags: + variable = etree.SubElement(axes, 'axis', name=tag) + + + return etree.tostring(root, pretty_print=False) + + def from_xml(self, xmlstr): + root = etree.fromstring(xmlstr) + self.title = root.attrib['name'] + #self._plotopts['title'] = root.attrib['title'] + #self._plotopts['xlabel'] = root.attrib['xlabel'] + # self._plotopts['ylabel'] = root.attrib['ylabel'] + # self._plotopts['grid'] = bool(root.attrib['grid']) + # self._plotopts['colorbar'] = bool(root.attrib['colorbar']) + # self._plotopts['projection'] = root.attrib['projection'] + # self._plotopts['marker'] = root.attrib['marker'] + for key in list(self._plotopts.keys()): + try: + self._plotopts[key] = eval(root.attrib.get(key)) + except: + self._plotopts[key] = root.attrib.get(key) + + + + legends = [] + conditions = [] + tags = [] + for curve in root.iter("curve"): + legends.append(curve.attrib['legend']) + conditions.append(curve.attrib['condition']) + variables = [] + for var in curve.iter('axis'): + variables.append(var.attrib['name']) + tags.append(tuple(variables)) + + self._selection_conditions = conditions + self._selection_tags = tags + self._plotopts['legend'] = legends + + def __repr__(self): + s = "<{}('{}')>".format(self.__class__.__name__, self.title) + return s + + def __str__(self): + try: + dset_title = self.dataset.title + except AttributeError: + dset_title = "unknown" + s = '{}:\n'.format(self.__class__.__name__) + s += '\tname : %s\n' % self.title + s += '\tdataset : %s\n' % dset_title + s += '\ttags : %s\n' % str(self._selection_tags) + s += '\tconditions : %s\n' % str(self._selection_conditions) + return s + +class _GridWindow(wx.Frame): + def __init__(self, dset, parent=None): + title = 'Data: ' + dset.title + wx.Frame.__init__(self, parent, title=title, size=(640, 480)) + self.create_grid(dset) + + def create_grid(self, dset): + grid = wx.grid.Grid(self, -1) + grid.CreateGrid(len(dset), len(dset.columns())) + for ic, c in enumerate(dset.columns()): + grid.SetColLabelValue(ic, c) + for iv, v in enumerate(dset[c]): + grid.SetCellValue(iv, ic, str(v)) + +class _ParametersWindow(wx.Frame): + def __init__(self, dset, parent=None): + title = 'Parameters: ' + dset.title + wx.Frame.__init__(self, parent, title=title, size=(400, 480)) + self.create_tree(dset) + + def create_tree(self, dset): + datatree = {} + for p in dset.parameters(): + is_hidden = p.get('hidden', "False") + if is_hidden == "True": + continue + group = datatree.get(p['group'], []) + #strval = str(p['value'] * p['unit'] if p['unit'] else p['value']) + #group.append("{:s} = {:s}".format(p['name'], strval)) + group.append("{} = {} {}".format(p['name'], p['value'], p['unit'])) + datatree[p['group']] = group + + tree = wx.TreeCtrl(self, -1) + root = tree.AddRoot('Parameters') + + for key in list(datatree.keys()): + item0 = tree.AppendItem(root, key) + for item in datatree[key]: + tree.AppendItem(item0, item) + tree.ExpandAll() + tree.SelectItem(root) + +class _DataWindow(wx.Frame): + def __init__(self, data): + assert isinstance(data, (Data, DataSet)) + + if isinstance(data, DataSet): + dset = data + data = Data() + data.first = dset + self.data = data + self._filename = None + self._current_dset = None + + wx.Frame.__init__(self, None, title="", size=(640, 480)) + + self.Bind(wx.EVT_CLOSE, self.on_close) + + # Populate the menu bar + self.create_menu() + + # Create the status bar + statusbar = wx.StatusBar(self, -1) + statusbar.SetFieldsCount(3) + statusbar.SetStatusWidths([-2, -1, -1]) + self.SetStatusBar(statusbar) + + # Add the notebook to hold all graphs + self.notebooks = {} + sizer = wx.BoxSizer(wx.VERTICAL) + #sizer.Add(self.notebook) + self.SetSizer(sizer) + + self.Bind(wx.EVT_NOTEBOOK_PAGE_CHANGED, self.on_page_changed) + + self.create_notebooks() + + self.update_title() + + def create_notebooks(self): + for key in list(self.notebooks.keys()): + nb = self.notebooks.pop(key) + nb.Destroy() + + for dset in self.data: + nb = wx.Notebook(self, -1) + self.notebooks[dset.title] = nb + self.GetSizer().Add(nb, 1, wx.ALL|wx.EXPAND) + for view in dset.views(): + self.create_page(nb, view) + + self.create_menu() + + self.show_dataset(self.data[0].title) + + + def create_menu(self): + menubar = wx.MenuBar() + menu1 = wx.Menu() + menu1.Append(110, "Open\tCtrl+O") + menu1.Append(120, "Save\tCtrl+S") + menu1.Append(130, "Save as...") + menu1.Append(140, "Export\tCtrl+E") + menu1.AppendSeparator() + menu1.Append(199, "Close\tCtrl+Q") + + menu2 = wx.Menu() + for i, dset in enumerate(self.data): + menu_id = 201 + i + menu2.AppendRadioItem(menu_id, dset.title) + self.Bind(wx.EVT_MENU, self.on_menu_dataset, id=menu_id) + + self.Bind(wx.EVT_MENU, self.on_open, id=110) + self.Bind(wx.EVT_MENU, self.on_save, id=120) + self.Bind(wx.EVT_MENU, self.on_saveas, id=130) + self.Bind(wx.EVT_MENU, self.on_close, id=199) + + + menu3 = wx.Menu() + menu3.Append(301, "Data") + menu3.Append(302, "Cluster") + menu3.Append(303, "Parameters") + + self.Bind(wx.EVT_MENU, self.on_viewdata, id=301) + self.Bind(wx.EVT_MENU, self.on_viewcluster, id=302) + self.Bind(wx.EVT_MENU, self.on_viewparameters, id=303) + + menubar.Append(menu1, "&File") + menubar.Append(menu2, "&Datasets") + menubar.Append(menu3, "&View") + self.SetMenuBar(menubar) + + def on_open(self, event): + if self.data.is_dirty(): + mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do ' + 'you wish to save before opening' + 'another file ?'), + 'Warning: Unsaved data', + wx.YES_NO | wx.ICON_WARNING) + if mbx.ShowModal() == wx.ID_YES: + self.on_saveas(wx.Event()) + mbx.Destroy() + + wildcard = "HDF5 files (*.hdf5)|*.hdf5" + dlg = wx.FileDialog( + self, message="Open a file...", defaultDir=os.getcwd(), + defaultFile="", wildcard=wildcard, style=wx.OPEN + ) + + if dlg.ShowModal() == wx.ID_OK: + path = dlg.GetPath() + self._filename = path + self.data = Data.load(path) + self.create_notebooks() + dlg.Destroy() + self.update_title() + + def on_save(self, event): + if self._filename: + if self.data.is_dirty(): + self.data.save(self._filename) + else: + self.on_saveas(event) + + def on_saveas(self, event): + overwrite = True + wildcard = "HDF5 files (*.hdf5)|*.hdf5|All files (*.*)|*.*" + dlg = wx.FileDialog( + self, message="Save file as ...", defaultDir=os.getcwd(), + defaultFile='{}.hdf5'.format(self.data.title.replace(' ','_')), + wildcard=wildcard, style=wx.SAVE) + dlg.SetFilterIndex(0) + + if dlg.ShowModal() == wx.ID_OK: + path = dlg.GetPath() + if os.path.exists(path): + mbx = wx.MessageDialog(self, ('This file already exists. ' + 'Do you wish to overwrite it ?'), + 'Warning: File exists', + wx.YES_NO | wx.ICON_WARNING) + if mbx.ShowModal() == wx.ID_NO: + overwrite = False + mbx.Destroy() + if overwrite: + self.data.save(path) + self._filename = path + dlg.Destroy() + self.update_title() + + def on_viewdata(self, event): + dset = self.data[self._current_dset] + frame = _GridWindow(dset, parent=self) + frame.Show() + + def on_viewcluster(self, event): + win = wx.Frame(None, size=wx.Size(480, 340)) + cluster_viewer = ClusterViewer(win, size=wx.Size(480, 340)) + + dset = self.data[self._current_dset] + s = StringIO() + s.write(dset.get_parameter(group='Cluster', name='cluster')['value']) + atoms = ase.io.read(s, format='xyz') + cluster_viewer.set_atoms(atoms, rescale=True, center=True) + cluster_viewer.rotate_atoms(45., 45.) + cluster_viewer.show_emitter(True) + win.Show() + + def on_viewparameters(self, event): + dset = self.data[self._current_dset] + frame = _ParametersWindow(dset, parent=self) + frame.Show() + + def on_close(self, event): + if self.data.is_dirty(): + mbx = wx.MessageDialog(self, ('Displayed data is unsaved. Do you ' + 'really want to quit ?'), + 'Warning: Unsaved data', + wx.YES_NO | wx.ICON_WARNING) + if mbx.ShowModal() == wx.ID_NO: + mbx.Destroy() + return + self.Destroy() + + + def on_menu_dataset(self, event): + menu_id = event.GetId() + dset_name = self.GetMenuBar().FindItemById(menu_id).GetText() + self.show_dataset(dset_name) + + + def show_dataset(self, name): + for nb in list(self.notebooks.values()): + nb.Hide() + self.notebooks[name].Show() + self.Layout() + self.update_statusbar() + self._current_dset = name + + def create_page(self, nb, view): + opts = view._plotopts + p = wx.Panel(nb, -1) + + figure = Figure() + + axes = None + proj = opts['projection'] + scale = opts['scale'] + if proj == 'rectilinear': + axes = figure.add_subplot(111, projection='rectilinear') + elif proj in ('polar', 'ortho', 'stereo'): + axes = figure.add_subplot(111, projection='polar') + + canvas = FigureCanvas(p, -1, figure) + sizer = wx.BoxSizer(wx.VERTICAL) + + toolbar = NavigationToolbar2WxAgg(canvas) + toolbar.Realize() + + sizer.Add(toolbar, 0, wx.ALL|wx.EXPAND) + toolbar.update() + + sizer.Add(canvas, 5, wx.ALL|wx.EXPAND) + + p.SetSizer(sizer) + p.Fit() + p.Show() + + + for values, label in zip(view.get_data(), opts['legend']): + if proj in ('ortho', 'stereo'): + theta, phi, Xsec = cols2matrix(*values) + theta_ticks = np.arange(0, 91, 15) + if proj == 'ortho': + R = np.sin(np.radians(theta)) + R_ticks = np.sin(np.radians(theta_ticks)) + elif proj == 'stereo': + R = 2 * np.tan(np.radians(theta/2.)) + R_ticks = 2 * np.tan(np.radians(theta_ticks/2.)) + #R = np.tan(np.radians(theta/2.)) + X, Y = np.meshgrid(np.radians(phi), R) + im = axes.pcolormesh(X, Y, Xsec) + axes.set_yticks(R_ticks) + axes.set_yticklabels(theta_ticks) + + figure.colorbar(im) + + elif proj == 'polar': + values[0] = np.radians(values[0]) + axes.plot(*values, label=label, picker=5, marker=opts['marker']) + else: + if scale == 'semilogx': + pltcmd = axes.semilogx + elif scale == 'semilogy': + pltcmd = axes.semilogy + elif scale == 'log': + pltcmd = axes.loglog + else: + pltcmd = axes.plot + pltcmd(*values, label=label, picker=5, marker=opts['marker']) + axes.grid(opts['grid']) + axes.set_title(opts['title']) + axes.set_xlabel(opts['xlabel']) + axes.set_ylabel(opts['ylabel']) + axes.set_xlim(*opts['xlim']) + axes.set_ylim(*opts['ylim']) + if label: + axes.legend() + axes.autoscale(enable=opts['autoscale']) + + + # MPL events + figure.canvas.mpl_connect('motion_notify_event', self.on_mpl_motion) + figure.canvas.mpl_connect('pick_event', self.on_mpl_pick) + + nb.AddPage(p, view.title) + + + def update_statusbar(self): + sb = self.GetStatusBar() + menu_id = self.GetMenuBar().FindMenu('Datasets') + menu = self.GetMenuBar().GetMenu(menu_id) + for item in menu.GetMenuItems(): + if item.IsChecked(): + sb.SetStatusText("%s" % item.GetText(), 1) + break + + def update_title(self): + title = "MsSpec Data Viewer" + if self.data.title: + title += ": " + self.data.title + if self._filename: + title += " [" + os.path.basename(self._filename) + "]" + self.SetTitle(title) + + def on_mpl_motion(self, event): + sb = self.GetStatusBar() + try: + txt = "[{:.3f}, {:.3f}]".format(event.xdata, event.ydata) + sb.SetStatusText(txt, 2) + except Exception: + pass + + def on_mpl_pick(self, event): + print(event.artist) + + def on_page_changed(self, event): + self.update_statusbar() + + + + + + + + + + + +if __name__ == "__main__": + if False: + data = Data('all my data') + dset = data.add_dset('Dataset 0') + X = np.arange(0, 20) + Y = X**2 + + dset.add_columns(x=X, y=Y, z=X+2, w=Y**3) + dset.add_parameter(name='truc', group='main', value='3.14', unit='eV') + dset.add_parameter(name='machin', group='main', value='abc', unit='') + + # Z = [0,1] + # + # for z in Z: + # for x, y in zip(X, Y): + # dset.add_row(x=x, y=y, z=z, random=np.random.rand()) + # + # + view = dset.add_view('my view', autoscale=True) + view.select('x', 'y', where="z<10", legend=r"z = 0") + view.select('x', 'y', where="z>10", legend=r"z = 1") + print(dset.get_parameter(group='main')) + constraint = lambda a, b: (a > 10 and a < 15) and b > 0 + indices = list(map(constraint, dset.x, dset.w)) + print(dset.y[indices]) + + #data.view() + import sys + data = Data.load(sys.argv[1]) + data.view() + + + + diff --git a/src/msspec/misc.py b/src/msspec/misc.py new file mode 100644 index 0000000..b828b47 --- /dev/null +++ b/src/msspec/misc.py @@ -0,0 +1,86 @@ +# coding: utf-8 +""" +Module misc +=========== + +""" +import logging +from pint import UnitRegistry +import numpy as np +import inspect +import re + +class XRaySource(object): + MG_KALPHA = 1253.6 + AL_KALPHA = 1486.6 + def __init__(self): + pass + +UREG = UnitRegistry() +UREG.define('rydberg = c * h * rydberg_constant = Ry') +UREG.define('bohr_radius = 4 * pi * epsilon_0 * hbar**2 / electron_mass / e**2 = a0') + +logging.basicConfig(level=logging.INFO) +LOGGER = logging.getLogger('msspec') + +np.set_printoptions(formatter={'float': lambda x:'%.2f' % x}, threshold=5) + +def set_log_level(level): + lvl = getattr(logging, level.upper()) + LOGGER.setLevel(lvl) + +def set_log_output(stream): + LOGGER.parent.handlers[0].stream = stream + +def get_call_info(frame): + args, varargs, varkw, loc = inspect.getargvalues(frame) + _, _, function, _, _ = inspect.getframeinfo(frame) + s = '%s called with:\n' % function + + for kws in (args, varargs, varkw): + if kws != None: + if isinstance(kws, (tuple, list)): + for kw in kws: + s += '\t\t%s = %r\n' % (kw, loc[kw]) + else: + s += '\t\t%s = %r\n' % (kws, loc[kws]) + return s.strip() + + +def log_process_output(process, logger=None, severity=logging.INFO): + if logger == None: + logger = logging + else: + logger = logging.getLogger(logger) + logger.setLevel(LOGGER.getEffectiveLevel()) + + for line in iter(process.stdout.readline, b''): + logger.log(severity, line.rstrip('\n')) + + process.stdout.close() + process.wait() + + +def get_level_from_electron_configuration(notation): + l_letters = 'spdfghiklmnoqrtuv' + n_letters = 'klmnopqrstuv' + pattern = re.compile(r'(?P\d+)(?P[%s%s])' + r'((?P\d)/2)?' % (l_letters, l_letters.upper())) + m = pattern.match(notation) + assert m, 'Not a valid notation' + n, l, _, j = m.groups() + n = int(n) + l = l_letters.index(l.lower()) + assert (l < n), 'Invalid l' + j1 = abs(l - 0.5) + j2 = abs(l + 0.5) + if j: + j = int(j) / 2. + else: + j = j1 + assert j in (j1, j2), 'Invalid j' + letter = n_letters[n - 1] + subscript = str(int((2 * (l + j) + 1) / 2)) + if letter == 'k': + subscript = '' + return '{}{}'.format(letter, subscript) diff --git a/src/msspec/msspecgui/.gitignore b/src/msspec/msspecgui/.gitignore new file mode 100644 index 0000000..3da397e --- /dev/null +++ b/src/msspec/msspecgui/.gitignore @@ -0,0 +1 @@ +/contribs/ diff --git a/src/msspec/msspecgui/__init__.py b/src/msspec/msspecgui/__init__.py new file mode 100644 index 0000000..0e544ba --- /dev/null +++ b/src/msspec/msspecgui/__init__.py @@ -0,0 +1 @@ +__version__ = '1.2rc3.post152' diff --git a/src/msspec/msspecgui/dataflow/__init__.py b/src/msspec/msspecgui/dataflow/__init__.py new file mode 100644 index 0000000..96fdfab --- /dev/null +++ b/src/msspec/msspecgui/dataflow/__init__.py @@ -0,0 +1,8 @@ +# from __future__ import absolute_import +from .operator import Operator +from .ioperatorcreator import IOperatorCreator +from .idataflowserializer import IDataflowSerializer +from msspecgui.dataflow.dataflow import DataFlow +from .idatatype import IDataType +from .plug import Plug +from .wire import Wire diff --git a/src/msspec/msspecgui/dataflow/attribute.py b/src/msspec/msspecgui/dataflow/attribute.py new file mode 100644 index 0000000..936efda --- /dev/null +++ b/src/msspec/msspecgui/dataflow/attribute.py @@ -0,0 +1,24 @@ + + +class Attribute(object): + def __init__(self, attr_name, attr_type_name, attr_desc, is_pluggable=True): + """ + :param attr_name: the name of this attribute, eg 'file_name' + :type attr_name: str + :param attr_type_name: the id of the type of this attribute (eg 'string'). Note that this type of attribute should have been registered in the dataflow first + :type attr_type_name: str + :param attr_desc: a string describing the role of this attribute + :type attr_desc: str + """ + self._attr_name = attr_name + self._attr_type_name = attr_type_name + self._attr_desc = attr_desc + self.is_pluggable = is_pluggable # indicates that this attribute can be plugged to another one using a wire. If not, then the value of this attribute is set using other means (eg graphical user interface) + + @property + def name(self): + return self._attr_name + + @property + def type_name(self): + return self._attr_type_name diff --git a/src/msspec/msspecgui/dataflow/dataflow.py b/src/msspec/msspecgui/dataflow/dataflow.py new file mode 100644 index 0000000..231f920 --- /dev/null +++ b/src/msspec/msspecgui/dataflow/dataflow.py @@ -0,0 +1,229 @@ +# from __future__ import absolute_import +# from .plug import Plug +from .wire import Wire + + +class DataFlow(object): + ''' a flow of operators, each of them having inputs and outputs that are connected together + ''' + + class IDataFlowEventsHandler(object): + """an abstract class that listens and responds to events affecting a flow of operators + + """ + def on_added_operator(self, operator): + """this method is invoked whenever an operator is added to the flow + + :param dataflow.Operator operator: the operator that has just been added to the flow + """ + pass + + def on_deleted_operator(self, operator): + """this method is invoked whenever an operator is deleted from the data flow + + :param dataflow.Operator operator: the operator that has just been deleted + """ + pass + + def on_modified_operator(self, operator): + """this method is invoked whenever an operator is modified in the flow + + :param operator: the operator that has just been modified + :type operator: dataflow.Operator + """ + pass + + def on_added_wire(self, wire): + """this method is invoked whenever a wire is added to the flow + + :param wire: the wire that has just been added to the flow + :type wire: dataflow.Wire + """ + pass + + def on_deleted_wire(self, wire): + """this method is invoked whenever a wire is deleted from the flow + + :param dataflow.Wire wire: the wire that has just been deleted + """ + pass + + def __init__(self): + self._last_created_operator_id = 0 # each operator (node) has a uniqueid in the flow + self._operators = {} #: :type self._operators: dict[int, msspec.dataflow.Operator] + self._registered_creators = {} # This factory lists and creates cluster creator instances + self._registered_data_types = {} #: :type self._registered_data_types: dict(str, msspecgui.dataflow.IDataType) ; the list of known data types (for links between nodes) in this dataflow + self._dataflow_events_handlers = [] + self._wires = [] + + @property + def last_created_operator_id(self): + return self._last_created_operator_id + + @last_created_operator_id.setter + def last_created_operator_id(self, operator_id): + """initializes the operator id generator + + useful for restoring the dataflow state, eg after loading + + :param int operator_id: + """ + self._last_created_operator_id = operator_id + + def add_dataflow_events_handler(self, dataflow_events_handler): + """adds a dataflow events handler to the list of dataflow events handler + + :type dataflow_events_handler: IDataFlowEventsHandler + """ + self._dataflow_events_handlers.append(dataflow_events_handler) + + def remove_dataflow_events_handler(self, dataflow_events_handler): + """removes a dataflow events handler to the list of dataflow events handler + + :type dataflow_events_handler: IDataFlowEventsHandler + """ + self._dataflow_events_handlers.remove(dataflow_events_handler) + + def add_operator(self, operator): + """ + :type operator: msspec.dataflow.Operator + """ + self._operators[operator.id] = operator + for dataflow_events_handler in self._dataflow_events_handlers: + dataflow_events_handler.on_added_operator(operator) + + def delete_operator(self, operator): + """ + :param msspec.dataflow.Operator operator: + """ + data_flow = operator.data_flow + + # delete incoming wires + for plug in operator.get_input_plugs(): + if plug.is_connected(): + wire = plug.incoming_wire + data_flow.delete_wire(wire) + + # delete outgoing wires + for plug in operator.get_output_plugs(): #: :type plug: Plug + if plug.is_connected(): + for wire in plug.outgoing_wires: + data_flow.delete_wire(wire) + + self._operators.pop(operator.id) + for dataflow_events_handler in self._dataflow_events_handlers: + dataflow_events_handler.on_deleted_operator(operator) + + def on_modified_operator(self, operator): + """tells the dataflow that the given operator has been modified (eg its paraeters have been changed) + + :type operator: Operator + """ + # print("on_modified_operator : operator %d" % operator.id) + operator.set_dirty() + for deh in self._dataflow_events_handlers: + deh.on_modified_operator(operator) + + def get_operator(self, operator_id): + """ + :param int operator_id: + :rtype: msspec.dataflow.Operator + """ + return self._operators[operator_id] + + def find_operator(self, operator_name): + """ + :param str operator_name: + :rtype: msspec.dataflow.Operator + """ + for op in self.operators: + if op.name == operator_name: + return op + return None + + @property + def operators(self): + """ + :rtype: list(Operator) + """ + return list(self._operators.itervalues()) + + def get_new_operator_id(self): + """ + :rtype: int + """ + self._last_created_operator_id += 1 + return self._last_created_operator_id + + def register_operator_creator(self, operator_creator): + ''' + + :param operator_creator: + :type operator_creator: derived from IOperatorCreator + ''' + self._registered_creators[operator_creator.get_operator_type_id()] = operator_creator + + def register_data_type(self, data_type): + ''' + + :param data_type: the type of this argument is expected to be derived from IDataType + :type data_type: derived from IDataType + ''' + self._registered_data_types[data_type.get_type_id()] = data_type + + def get_data_type(self, data_type_id): + """ + :return msspecggui.dataflow.IDataType: + """ + return self._registered_data_types[data_type_id] + + def get_operator_creators(self): + """ + :rtype: list(dataflow.ioperatorcreator.IOperatorCreator) + """ + return list(self._registered_creators.itervalues()) + + @property + def wires(self): + """ + :rtype: list(msspec.dataflow.Wire) + """ + return self._wires + + def create_operator(self, operator_type_id): + """ creates an operator of the given type and adds it to this flow + + :param operator_type_id: the type of operator to create. This type must be one of the allowed types for this flow (in other words, this type must have been registered to this flow) + """ + creator = self._registered_creators[operator_type_id] + return creator.create_operator(self) + + def create_wire(self, input_plug, output_plug): + """ + :param Plug input_plug: the input plug + :param Plug output_plug: + :return dataflow.Wire: + """ + wire = Wire(input_plug, output_plug) + input_plug.add_outgoing_wire(wire) + output_plug.incoming_wire = wire + self._wires.append(wire) + + for dataflow_events_handler in self._dataflow_events_handlers: + dataflow_events_handler.on_added_wire(wire) + + return wire + + def delete_wire(self, wire): + """ + :param Wire wire: the wire that needs to be destroyed + """ + wire.input_plug.detach_wire(wire) + wire.output_plug.detach_wire(wire) + + self._wires.remove(wire) + + for dataflow_events_handler in self._dataflow_events_handlers: + dataflow_events_handler.on_deleted_wire(wire) + + return wire diff --git a/src/msspec/msspecgui/dataflow/datatypes.py b/src/msspec/msspecgui/dataflow/datatypes.py new file mode 100644 index 0000000..fb545bc --- /dev/null +++ b/src/msspec/msspecgui/dataflow/datatypes.py @@ -0,0 +1,69 @@ +from .idatatype import IDataType + + +class StringDataType(IDataType): + def __init__(self): + IDataType.__init__(self) + + def get_type_id(self): + """ + Returns a string uniquely identifying this data type + """ + return 'string' + + def get_python_class(self): # pylint: disable=no-self-use + """ + see IDataType.get_python_class + """ + return str + + +class FloatDataType(IDataType): + def __init__(self): + IDataType.__init__(self) + + def get_type_id(self): + """ + Returns a string uniquely identifying this data type + """ + return 'float' + + def get_python_class(self): # pylint: disable=no-self-use + """ + see IDataType.get_python_class + """ + return float + + +class BoolDataType(IDataType): + def __init__(self): + IDataType.__init__(self) + + def get_type_id(self): + """ + Returns a string uniquely identifying this data type + """ + return 'bool' + + def get_python_class(self): # pylint: disable=no-self-use + """ + see IDataType.get_python_class + """ + return bool + + +class IntDataType(IDataType): + def __init__(self): + IDataType.__init__(self) + + def get_type_id(self): + """ + Returns a string uniquely identifying this data type + """ + return 'int' + + def get_python_class(self): # pylint: disable=no-self-use + """ + see IDataType.get_python_class + """ + return int diff --git a/src/msspec/msspecgui/dataflow/idataflowserializer.py b/src/msspec/msspecgui/dataflow/idataflowserializer.py new file mode 100644 index 0000000..aee280c --- /dev/null +++ b/src/msspec/msspecgui/dataflow/idataflowserializer.py @@ -0,0 +1,26 @@ +import abc + + +class IDataflowSerializer(object): + + @abc.abstractmethod + def save_dataflow(self, dataflow, filepath): + """ saves the given dataflow at the given file location + + :param dataflow: the dataflow to save + :type dataflow: msspecgui.dataflow.DataFlow + :param file_path: the path of the file that will store this dataflow in serialized form + :type file_path: str + """ + pass + + @abc.abstractmethod + def load_dataflow(self, file_path, dataflow): + """loads the dataflow from the given serialized dataflow file + + :param str file_path: the xml file describng the dataflow to load + :param msspecgui.dataflow.DataFlow dataflow: an empty dataflow that will be filled + + :rtype: DataFlow + """ + return None diff --git a/src/msspec/msspecgui/dataflow/idatatype.py b/src/msspec/msspecgui/dataflow/idatatype.py new file mode 100644 index 0000000..5c8eca5 --- /dev/null +++ b/src/msspec/msspecgui/dataflow/idatatype.py @@ -0,0 +1,59 @@ +import abc + + +class IDataType(object): + + class IAction(object): + """an abstract class that represents an action that can be performed on a data of the given data type + + for example, the export cluster is an action (with a gui that allows the user to select a file path) that can be performed on a data of type physics.atomscluster. This mechanism is used in the dataflow editor : when the user right-clicks on a wire, a list of actions related to the wire's datatype is offered to the user. + """ + def __init__(self, datatype): + """ + :param msspecgui.dataflow.IDataType datatype: the datatype on which this action is expected to perform + """ + self.datatype = datatype + + @abc.abstractmethod + def get_name(self): + """ returns a name that uniquely identifies the action amongst actions associated with a given IDataType + """ + assert False + + @abc.abstractmethod + def execute_on_data(self, data): + """executes this action on the given data + + :param data: the data on which this action is performed + """ + assert False + + def __init__(self): + self._actions = {} #: :type self._actions: dict(str, IDataType.IAction) + + def get_type_id(self): # pylint: disable=no-self-use + """ + Returns a string iuniquely identifying this data type + :rtype: str + """ + assert False # this method is expected to be defined in a derived class + + def get_python_class(self): # pylint: disable=no-self-use + """ + returns the python class associated with this data type + """ + assert False # this method is expected to be defined in a derived class + + def register_datatype_action(self, action): + """ + + :type action: IDataType.IAction + """ + assert action.datatype == self + self._actions[action.get_name()] = action + + def get_actions(self): + """ + :rtype: list(IDataType.IAction) + """ + return list(self._actions.itervalues()) diff --git a/src/msspec/msspecgui/dataflow/ioperatorcreator.py b/src/msspec/msspecgui/dataflow/ioperatorcreator.py new file mode 100644 index 0000000..8665e3c --- /dev/null +++ b/src/msspec/msspecgui/dataflow/ioperatorcreator.py @@ -0,0 +1,101 @@ + +from .attribute import Attribute +import abc + + +class IOperatorCreator(object): + '''abstract base class that allows registration of operator creators + ''' + + class IAction(object): + """an abstract class that represents an action that can be performed on an operator type + + for example, the ase.lattice.bulk operator's gui (property settings) is an action that can be performed on an operator of type ase.lattice.bulk + """ + def __init__(self): + pass + + @abc.abstractmethod + def get_name(self): + """ returns a name that uniquely identifies the action amongst actions associated with a given IOperatorCreator + """ + assert False + + @abc.abstractmethod + def execute_on_operator(self, operator): + """executes this action on the given operator + + :param operator: the operator on which this action is performed + :type operator: dataflow.Operator + """ + assert False + + def __init__(self): + self._input_attrs = {} + self._output_attrs = {} + self._actions = {} + + @abc.abstractmethod + def get_operator_type_id(self): # pylint: disable=no-self-use + '''returns the unique id of the type of the operator that this creator creates (eg ipr.msspec.simpleclustercreator) + ''' + assert False # this method should be implemented in a derived class + + @abc.abstractmethod + def create_operator(self, dflow): # pylint: disable=no-self-use + '''creates an application specific operator in the given Dataflow dflow + + :type dflow: DataFlow + ''' + assert False # this method should be implemented in a derived class + + def register_operator_action(self, action): + """ + + :type action: dataflow.ioperatorcreator.IOperatorCreator.IAction + """ + self._actions[action.get_name()] = action + + def get_actions(self): + """ + :rtype: list(dataflow.ioperatorcreator.IOperatorCreator.IAction) + """ + return list(self._actions.itervalues()) + + def add_input_attribute(self, attr_name, attr_type_name, attr_desc, is_pluggable=True): + """Declares a new input attribute for the related operator + + :param attr_name: the name of the attribute + :type attr_name: str + :param attr_type_name: the name of the type of the attribute (eg 'math.position3') + :type attr_type_name: str + :param attr_desc: the description of the attribute + :type attr_desc: str + + :rtype: Attribute + """ + attr = Attribute(attr_name, attr_type_name, attr_desc, is_pluggable=is_pluggable) + self._input_attrs[attr_name] = attr + return attr + + def add_output_attribute(self, attr_name, attr_type_name, attr_desc, is_pluggable=True): + """Declares a new output attribute for the related operator + + :param attr_name: the name of the attribute + :type attr_name: str + :param attr_type_name: the name of the type of the attribute (eg 'math.position3') + :type attr_type_name: str + :param attr_desc: the description of the attribute + :type attr_desc: str + + :rtype: Attribute + """ + attr = Attribute(attr_name, attr_type_name, attr_desc, is_pluggable=is_pluggable) + self._output_attrs[attr_name] = attr + return attr + + def get_input_attributes(self): + return self._input_attrs.itervalues() + + def get_output_attributes(self): + return self._output_attrs.itervalues() diff --git a/src/msspec/msspecgui/dataflow/operator.py b/src/msspec/msspecgui/dataflow/operator.py new file mode 100644 index 0000000..35b2a6d --- /dev/null +++ b/src/msspec/msspecgui/dataflow/operator.py @@ -0,0 +1,120 @@ +# import plug +# from .dflow import DataFlow +from .plug import Plug + + +class Operator(object): + ''' + an abstract operator that generates outputs from its inputs + ''' + + def __init__(self, data_flow, creator): + ''' + Constructor + + :param data_flow: the data_flow that will contain this operator + :type data_flow: DataFlow + :param creator: an instance of IOperatorCreator, the creator of this object (consider it as an object that stores informations that are common to all operators of this type). + :type creator: dataflow.ioperatorcreator.IOperatorCreator + ''' + self._data_flow = data_flow + self._creator = creator + self._id = data_flow.get_new_operator_id() + self._input_plugs = {} + self._output_plugs = {} + for attr in self._creator.get_input_attributes(): + data_type = self._data_flow.get_data_type(attr.type_name) + assert data_type is not None + p = Plug(attr, data_type, Plug.PlugSide.INPUT, self) + self._input_plugs[p.name] = p + for attr in self._creator.get_output_attributes(): + data_type = self._data_flow.get_data_type(attr.type_name) + assert data_type is not None + p = Plug(attr, data_type, Plug.PlugSide.OUTPUT, self) + self._output_plugs[p.name] = p + + @property + def name(self): + return '%s_%d' % (self._creator.get_operator_type_id(), self._id) + + def get_input_plugs(self): + """ + :rtype: list(msspecgui.dataflow.Plug) + """ + return list(self._input_plugs.itervalues()) + + def get_output_plugs(self): + """ + :rtype: list(msspecgui.dataflow.Plug) + """ + return list(self._output_plugs.itervalues()) + + def get_plug(self, plug_name): + """ + :type plug_name: str + :rtype: msspecgui.dataflow.Plug + """ + if plug_name in self._input_plugs: + return self._input_plugs[plug_name] + if plug_name in self._output_plugs: + return self._output_plugs[plug_name] + + @property + def wires(self): + """ + :return list(msspecgui.dataflow.Wire) + """ + wires = [] + for p in self._input_plugs.itervalues(): + if p.is_connected(): + wires.append(p.incoming_wire) + for p in self._output_plugs.itervalues(): + if p.is_connected(): + for wire in p.outgoing_wires: + wires.append(wire) + return wires + + def set_dirty(self): + """ + indicates that the output values of this operator are obsolete and need to be recomputed + """ + print("setting operator %d as dirty" % self.id) + for plug in self.get_output_plugs(): + plug.set_dirty() + + def update(self): + """ + compute this operator's output values from its input values + + this method is supposed to be overriden in derived classes + """ + assert False # should be implemented in derived classes + + def all_inputs_are_available(self): + for input_plug in self.get_input_plugs(): + if not input_plug.value_is_available(): + return False + return True + + @property + def id(self): + """ + :rtype: int + """ + return self._id + + @id.setter + def id(self, operator_id): + """changes the unique identifier of this operator (use at your own risk) + + :param int operator_id: the new unique identifier for this operator + """ + self._id = operator_id + + @property + def creator(self): + return self._creator + + @property + def data_flow(self): + return self._data_flow diff --git a/src/msspec/msspecgui/dataflow/plug.py b/src/msspec/msspecgui/dataflow/plug.py new file mode 100644 index 0000000..8332659 --- /dev/null +++ b/src/msspec/msspecgui/dataflow/plug.py @@ -0,0 +1,219 @@ +# from __builtin__ import False + + +class Plug(object): + """ + A Plug represents an input or output attribute on a dataflow operator + + :param __operator: the operator that contains this plug + :type __operator: dataflow.Operator + """ + + class PlugSide(object): + INPUT = 1 + OUTPUT = 2 + + def __init__(self, attr, data_type, plug_side, operator): + """Constructor + + :param attr: an instance of Attribute + :type attr: msspec.dataflow.Attribute + :param data_type: the type of the attribute + :type data_type: IDataType + :param plug_side: tells if this plug is an input plug or an output plug + :type plug_side: Plug.PlugSide enum + :param operator: the operator that contains this plug + :type operator: msspec.dataflow.Operator + """ + self._attr = attr + self._data_type = data_type + self._plug_side = plug_side + self._operator = operator + self._outgoing_wires = [] + self._incoming_wire = None + self._value = None + + @property + def name(self): + """ + :rtype: str + """ + return self._attr.name + + @property + def id(self): + """ + :rtype: str + """ + return '%s.%s' % (self.operator.name, self.name) + + @property + def data_type(self): + return self._data_type + + @property + def operator(self): + """ + :rtype: msspec.dataflow.Operator + """ + return self._operator + + @property + def is_pluggable(self): + return self._attr.is_pluggable + + def get_value(self): + print("getting value of plug %s" % self.id) + assert self.value_is_available() + if self.is_dirty(): + self._update_value() + assert not self.is_dirty() + return self._value + + def set_value(self, value): + """ + :type value: any type of data that is compatible with this plug's datatype + """ + assert isinstance(value, self._data_type.get_python_class()) + if self.is_pluggable: + assert self.is_dirty() # we expect to only have to use this method when this plug is dirty + self._value = value + + def value_is_available(self): + """ + indicates if the value of this plug can be computed + """ + if self.is_destination(): + if not self.is_pluggable: + return True # if this plug is not pluggable, then its value is available since it doesn't depend on the result of other operators + # print('value_is_available: self.is_connected() = %s' % str(self.is_connected())) + if self.is_connected(): + src_plug = self.get_incoming_plug() + return src_plug.value_is_available() + else: + return False + else: + # this is an output plug; its value is available if all the operators's input plugs are available + return self.operator.all_inputs_are_available() + + def set_dirty(self): + """ + indicates that the value of this plug is obsolete and needs to be recomputed + """ + print("setting plug %s as dirty" % self.id) + self._value = None + if self.is_output_plug(): + if self.is_connected(): + for connected_plug in self.get_outgoing_plugs(): + connected_plug.set_dirty() + else: + # this is an operator's input plug. Propagate the dirtiness to its out plugs + self.operator.set_dirty() + + def is_dirty(self): + """ + indicates if the value needs to be computed + """ + assert self.value_is_available() + if not self.is_pluggable: + return False # a non-pluggable plug is never dirty, it always has a valid value + return self._value is None + + def _update_value(self): + print("updating value of plug %s" % self.id) + assert self.value_is_available() + assert self.is_dirty() + if self.is_destination(): + if self.is_connected(): + self._value = self.get_incoming_plug().get_value() + else: + assert False # if we are in this case, this would mean that the value is not available + else: + print("updating operator %s" % self._operator.name) + self._operator.update() + assert not self.is_dirty() + + def is_connected(self): + if self.is_source(): + return len(self._outgoing_wires) != 0 + else: + return self._incoming_wire is not None + + def is_source(self): + return self._plug_side == Plug.PlugSide.OUTPUT + + def is_destination(self): + return self._plug_side == Plug.PlugSide.INPUT + + def is_output_plug(self): + return self._plug_side == Plug.PlugSide.OUTPUT + + def is_input_plug(self): + return self._plug_side == Plug.PlugSide.INPUT + + def connect_to(self, other_plug): + """ + :type other_plug: dataflow.Plug + :rtype: dataflow.Wire + """ + return self._operator.data_flow.create_wire(self, other_plug) + + def add_outgoing_wire(self, wire): + """ + :type wire: dataflow.Wire + """ + assert self.is_source() + self._outgoing_wires.append(wire) + + @property + def incoming_wire(self): + assert self.is_destination() + assert self.is_connected() + return self._incoming_wire + + @incoming_wire.setter + def incoming_wire(self, wire): + """ + :type wire: dataflow.Wire + """ + assert self.is_destination() + self._incoming_wire = wire + self.operator.set_dirty() # one of the operator's input plugs has changed, therefore its output plugs values are obsolete + + @property + def outgoing_wires(self): + """ + :return list(dataflow.Wire): + """ + assert self.is_source() + assert self.is_connected() + return self._outgoing_wires + + def detach_wire(self, wire): + """ + :param msspec.dataflow.Wire wire: + """ + assert self.is_connected() + if self.is_destination(): + assert self._incoming_wire == wire + self.incoming_wire = None + self.set_dirty() # the data on this plug is no longer available + else: + assert self.is_source() + self._outgoing_wires.remove(wire) + + def get_incoming_plug(self): + assert self.is_destination() + assert self.is_connected() + return self.incoming_wire.input_plug # (scenegraph_group.setter seen as a method, see https://github.com/PyCQA/pylint/issues/870) pylint: disable=no-member + + def get_outgoing_plugs(self): + """ + :rtype: list(dataflow.Plug) + """ + assert self.is_source() + assert self.is_connected() + outgoing_plugs = [] + for wire in self._outgoing_wires: + outgoing_plugs.append(wire.output_plug) + return outgoing_plugs diff --git a/src/msspec/msspecgui/dataflow/wire.py b/src/msspec/msspecgui/dataflow/wire.py new file mode 100644 index 0000000..acf611c --- /dev/null +++ b/src/msspec/msspecgui/dataflow/wire.py @@ -0,0 +1,33 @@ +''' +Created on Jul 1, 2016 + +@author: graffy +''' + + +class Wire(object): + """ + a wire connects an input plug to an output plug + """ + + def __init__(self, input_plug, output_plug): + """ + :type input_plug: dataflow.Plug + :type output_plug: dataflow.Plug + """ + self.input_plug = input_plug + self.output_plug = output_plug + + @property + def data_type(self): + """ + :return IDataType: the datatype of this wire + """ + return self.input_plug.data_type + + @property + def data_flow(self): + """ + :return msspecgui.dataflow.DataFlow + """ + return self.input_plug.operator.data_flow diff --git a/src/msspec/msspecgui/datafloweditor/__init__.py b/src/msspec/msspecgui/datafloweditor/__init__.py new file mode 100644 index 0000000..44b33b7 --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/__init__.py @@ -0,0 +1,6 @@ +from .dataflowview import DataflowView +from .operatorwidget import OperatorWidget +from .plugwidget import PlugWidget +from .wirewidget import WireWidget +from .operatorgui import OperatorGui +from msspecgui.datafloweditor.dotlayoutmanager import DotLayoutManager diff --git a/src/msspec/msspecgui/datafloweditor/dataflowview.py b/src/msspec/msspecgui/datafloweditor/dataflowview.py new file mode 100644 index 0000000..a79b9ab --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/dataflowview.py @@ -0,0 +1,342 @@ +""" +a graphical editor for dataflow +""" +from __future__ import print_function +# import wx +import wx.lib.wxcairo +import cairo +# from wx.lib.scrolledpanel import ScrolledPanel +# import scenegraph2d.xml +import msspecgui.scenegraph2d.cairo + +# import dataflow +import msspecgui.dataflow as dataflow +# import msspecgui.datafloweditor as datafloweditor + +from .plugwidget import PlugWidget +from .wirewidget import WireWidget +from msspecgui.datafloweditor.dotlayoutmanager import DotLayoutManager +# class DataflowView(wx.ScrolledWindow): + + +class DataflowView(wx.Panel): + ''' + a dataflow Graphical User Interface + + :type self.wire_being_created_widget: WireWidget + ''' + + # see https://wiki.wxwidgets.org/Scrolling + + class DataflowEventsHandler(dataflow.DataFlow.IDataFlowEventsHandler): + """ + handles dataflow events + """ + def __init__(self, data_flow_view): + """ + :param msspec.datafloweditor.DataflowView data_flow_view: + """ + super(DataflowView.DataflowEventsHandler, self).__init__() + self.data_flow_view = data_flow_view + + def on_added_operator(self, operator): + super(DataflowView.DataflowEventsHandler, self).on_added_operator(operator) + # a new operator has just been added to the dataflow + # create a new widget to graphically manipulate the added operator + self.data_flow_view.add_operator_widget(msspecgui.datafloweditor.OperatorWidget(operator, self.data_flow_view)) + + def on_deleted_operator(self, operator): + super(DataflowView.DataflowEventsHandler, self).on_deleted_operator(operator) + self.data_flow_view.delete_widget_for_operator(operator) + self.data_flow_view.update_appearance() # possibly update the appearance of the plugs that have now become available + + def on_added_wire(self, wire): + super(DataflowView.DataflowEventsHandler, self).on_added_wire(wire) + # create a new widget to graphically represent and manipulate the added wire + wire_widget = self.data_flow_view.add_wire_widget(wire) # @UnusedVariable + self.data_flow_view.update_appearance() # possibly update the appearance of the plugs that have now become available + + def on_deleted_wire(self, wire): + super(DataflowView.DataflowEventsHandler, self).on_deleted_wire(wire) + self.data_flow_view.delete_widget_for_wire(wire) + self.data_flow_view.update_appearance() # possibly update the appearance of the plugs that have now become available + + def __init__(self, parent, data_flow, log): + """ + :type parent: wx.Window + :type data_flow: DataFlow + """ + wx.Panel.__init__(self, parent, -1) + self.scenegraph_group_to_widget = {} # this array associates a datafloweditor.Widget instance to a scenegraph group that represents this widget + self.layout_is_enabled = True + + self.log = log + self.layout_manager = DotLayoutManager() + self.scene = None # the 2d scenegraph that describes the graphical aspect of the dataflow + self.scene = msspecgui.scenegraph2d.Group() + # with open('/Users/graffy/ownCloud/ipr/msspec/rectangle.svg') as f: + # self.scene = scenegraph2d.xml.parse(f.read()) + self.operator_to_widget = {} + self.wire_to_widget = {} + + self.dataflow = data_flow + + # self.selected_widget = None + self.hovered_widget = None # the widget hovered on by the mouse pointer + self.plug_being_connected = None # when the user creates a wire, memorizes the first selected plug + self.wire_being_created_widget = None # while the use creates a wire, the widget that is used to represent it + self.is_left_down = False + + self.Bind(wx.EVT_PAINT, self.on_paint) + self.Bind(wx.EVT_LEFT_DOWN, self.on_left_down) + self.Bind(wx.EVT_LEFT_UP, self.on_left_up) + self.Bind(wx.EVT_MOTION, self.on_move) + self.Bind(wx.EVT_CONTEXT_MENU, self.on_context_menu) + + self.data_flow_view_updater = DataflowView.DataflowEventsHandler(self) + self.layout_is_enabled = False # temporarily disable the layout manager for efficiency (prevent complete layout computation for each operator in the data_flow) + data_flow.add_dataflow_events_handler(self.data_flow_view_updater) + # initialize the widgets to reflect the state of the cluster flow + for node in self.dataflow.operators: + self.data_flow_view_updater.on_added_operator(node) + + for wire in self.dataflow.wires: + self.data_flow_view_updater.on_added_wire(wire) + self.layout_is_enabled = True + self.update_operators_position() + + def on_paint(self, evt): # IGNORE:unused-argument + """handler for the wx.EVT_PAINT event + """ + if self.IsDoubleBuffered(): + display_context = wx.PaintDC(self) + else: + display_context = wx.BufferedPaintDC(self) + display_context.SetBackground(wx.Brush('white')) + display_context.Clear() + + self.render(display_context) + + def update_appearance(self): + for operator_widget in self.operator_to_widget.itervalues(): + operator_widget.update_appearance() + + def update_operators_position(self): + if self.layout_is_enabled: + op_pos = self.layout_manager.compute_operators_position(self.dataflow) + dodgy_offset = (20.0, 20.0) # TODO: make it better + dodgy_scale = 1.5 + for op, pos in op_pos.iteritems(): + x, y = pos + print("update_operators_position : %f %f" % (x, y)) + if op in self.operator_to_widget: # while loading the dataflow, there are operators that don't have widgets yet + op_widget = self.operator_to_widget[op] + op_widget.set_position(x * dodgy_scale + dodgy_offset[0], y * dodgy_scale + dodgy_offset[1]) + + def add_operator_widget(self, operator_widget): + """ + :type operator_widget: an instance of OperatorWidget + """ + self.operator_to_widget[operator_widget.operator] = operator_widget + widget_root = msspecgui.scenegraph2d.Group() + self.scene.add_child(widget_root) + # widget_root.transform = [msspecgui.scenegraph2d.Translate(operator_widget.get_id() * 100.0 + 50.0, 60.0)] + operator_widget.render_to_scene_graph(widget_root) + self.update_operators_position() + # self.UpdateWindowUI(wx.UPDATE_UI_RECURSE) + # print("self.UpdateWindowUI has executed") + # self.Refresh() + + def delete_widget_for_operator(self, operator): + """ + :param Operator operator: the operator for which we want to delete the widget + """ + op_widget = self.get_operator_widget(operator) + op_widget.remove_from_scene_graph() + + self.operator_to_widget.pop(operator) + + def add_wire_widget(self, wire): + """ + creates a wire widget and adds it to this dataflow view + :param wire: the wire represented by the widget to create + :type wire: Wire + :rtype: WireWidget + """ + wire_widget = WireWidget(self) + wire_widget.source_plug_widget = self.get_plug_widget(wire.input_plug) + wire_widget.dest_plug_widget = self.get_plug_widget(wire.output_plug) + self.wire_to_widget[wire] = wire_widget + widget_root = msspecgui.scenegraph2d.Group() + self.scene.add_child(widget_root) + wire_widget.render_to_scene_graph(widget_root) + self.update_operators_position() + return wire_widget + + def delete_widget_for_wire(self, wire): + """ + :param Wire wire: the wire for which we want to delete the widget + """ + wire_widget = self.get_wire_widget(wire) + wire_widget.remove_from_scene_graph() + # widget_root = wire_widget.parent() + # self.scene.remove_child(widget_root) + + self.wire_to_widget.pop(wire) + self.update_operators_position() + + def get_wire_widget(self, wire): + """ + Returns the widget associated with the given wire + :param Wire wire: + :return WireWidget: + """ + return self.wire_to_widget[wire] + + def get_operator_widget(self, operator): + """ + Returns the operator widget associated with the given operator + :param Operator operator: + :return OperatorWidget: + """ + return self.operator_to_widget[operator] + + def get_plug_widget(self, plug): + """ + Returns the plug widget associated with the given plug + :type plug: Plug + :rtype: PlugWidget + """ + operator_widget = self.get_operator_widget(plug.operator) + plug_widget = operator_widget.get_plug_widget(plug) + return plug_widget + + def render(self, display_context): + """ + renders this dataflow view in the given drawing context + + :param display_context: the drawing context in which to render the dataflow + :type display_context: a wx context + """ + #cairo_context = wx.lib.wxcairo.ContextFromDC(display_context) + w, h = self.GetClientSize() + surface = cairo.ImageSurface(cairo.FORMAT_ARGB32, w, h) + cairo_context = cairo.Context(surface) + + msspecgui.scenegraph2d.cairo.render_scene(self.scene, cairo_context) + + bitmap = wx.lib.wxcairo.BitmapFromImageSurface(surface) + display_context.DrawBitmap(bitmap, 0, 0) + + def get_pointed_widget(self, pointer_position): + """ + returns the widget that is at the position pointer_position + """ + hits = self.scene.pick(pointer_position[0], pointer_position[1]) + if len(hits) > 0: + svg_path, local_pos = hits[-1] # @UnusedVariable + # print("hit svg node stack : %s" % str(svg_path)) + for svg_node in reversed(svg_path): + if svg_node in self.scenegraph_group_to_widget: + return self.scenegraph_group_to_widget[svg_node] + + # for widget in self.operator_to_widget.itervalues(): + # if widget.get_bounding_box().Contains(pointer_position): + # return widget + return None + +# def select_widget(self, widget): +# if self.selected_widget is not None: +# self.selected_widget.set_selected_state(False) +# self.selected_widget = widget +# self.selected_widget.set_selected_state(True) + + def on_left_down(self, event): + pos = event.GetPositionTuple() + display_context = wx.ClientDC(self) + display_context.DrawCircle(pos[0], pos[1], 5) + widget = self.get_pointed_widget(pos) + if widget is not None: + # self.select_widget(widget) + if isinstance(widget, PlugWidget): + plug_widget = widget + if plug_widget.is_connectable(): + self.plug_being_connected = plug_widget + wire_widget = WireWidget(self) + if plug_widget.plug.is_source(): + wire_widget.source_plug_widget = plug_widget + else: + wire_widget.dest_plug_widget = plug_widget + self.wire_being_created_widget = wire_widget + self.wire_being_created_widget.render_to_scene_graph(self.scene) + self.is_left_down = True + self.Refresh() + + def on_left_up(self, event): + self.is_left_down = False + self.plug_being_connected = None + + if self.wire_being_created_widget is not None: + pos = event.GetPositionTuple() + pointed_widget = self.get_pointed_widget(pos) + if pointed_widget is not None and isinstance(pointed_widget, PlugWidget): + if self.wire_being_created_widget.is_valid_final_plug_widget(pointed_widget): + self.wire_being_created_widget.set_final_plug_widget(pointed_widget) + self.dataflow.create_wire(self.wire_being_created_widget.source_plug_widget.plug, self.wire_being_created_widget.dest_plug_widget.plug) + self.wire_being_created_widget.remove_from_scene_graph() + self.wire_being_created_widget = None + self.Refresh() + + def on_move(self, event): + pos = event.GetPositionTuple() + if self.wire_being_created_widget is not None: + self.wire_being_created_widget.set_pointer_pos(pos) + widget = self.get_pointed_widget(pos) + # print('widget at (%d,%d) : %s\n' % (pos[0], pos[1], widget)) + if self.hovered_widget is not None: + if self.hovered_widget != widget: + self.hovered_widget.on_hover(False) + self.hovered_widget = None + if widget is not None: + if self.hovered_widget is None: + widget.on_hover(True) + self.hovered_widget = widget + + if self.is_left_down: + display_context = wx.ClientDC(self) + display_context.DrawCircle(pos[0], pos[1], 3) + self.Refresh() + + def on_context_menu(self, event): + pos = self.ScreenToClient(event.GetPosition()) + + for wire_widget in self.wire_to_widget.itervalues(): + if wire_widget.get_bounding_box(border=5).Contains(pos): + self.on_wire_context_menu(event, wire_widget.wire) + return + + for operator_widget in self.operator_to_widget.itervalues(): + if operator_widget.get_bounding_box().Contains(pos): + self.on_operator_context_menu(event, operator_widget.operator) + return + + self.on_background_context_menu(event) + + def on_operator_context_menu(self, event, operator): + ''' + called whenever the user right-clicks in an operator of the dataflow + ''' + pass # possibly implemented in derived classes + + def on_wire_context_menu(self, event, wire): + ''' + called whenever the user right-clicks in an operator of the dataflow + :param msspec.dataflow.Wire wire: the wire on which the context menu is supposed to act + ''' + pass # possibly implemented in derived classes + + def on_background_context_menu(self, event): + ''' + called whenever the user right-clicks in the background of the dataflow + ''' + pass # possibly implemented in derived classes diff --git a/src/msspec/msspecgui/datafloweditor/dotlayoutmanager.py b/src/msspec/msspecgui/datafloweditor/dotlayoutmanager.py new file mode 100644 index 0000000..01fd7a2 --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/dotlayoutmanager.py @@ -0,0 +1,193 @@ +from __future__ import print_function +import json +import tempfile +# from pprint import pprint +import pydot +from .ilayoutmanager import ILayoutManager + +# def pydot_sample(): +# import pydot # import pydot or you're not going to get anywhere my friend :D +# +# # first you create a new graph, you do that with pydot.Dot() +# graph = pydot.Dot(graph_type='graph') +# +# # the idea here is not to cover how to represent the hierarchical data +# # but rather how to graph it, so I'm not going to work on some fancy +# # recursive function to traverse a multidimensional array... +# # I'm going to hardcode stuff... sorry if that offends you +# +# # let's add the relationship between the king and vassals +# for i in range(3): +# # we can get right into action by "drawing" edges between the nodes in our graph +# # we do not need to CREATE nodes, but if you want to give them some custom style +# # then I would recomend you to do so... let's cover that later +# # the pydot.Edge() constructor receives two parameters, a source node and a destination +# # node, they are just strings like you can see +# edge = pydot.Edge("king", "lord%d" % i) +# # and we obviosuly need to add the edge to our graph +# graph.add_edge(edge) +# +# # now let us add some vassals +# vassal_num = 0 +# for i in range(3): +# # we create new edges, now between our previous lords and the new vassals +# # let us create two vassals for each lord +# for j in range(2): +# edge = pydot.Edge("lord%d" % i, "vassal%d" % vassal_num) +# graph.add_edge(edge) +# vassal_num += 1 +# +# # ok, we are set, let's save our graph into a file +# graph.write_png('/tmp/example1.png') # .write_png('example1_graph.png') +# +# # and we are done! + +# def graphviz_sample(): +# from graphviz import Digraph +# +# dot = Digraph(comment='The Round Table') +# dot.node('A', 'King Arthur') +# dot.node('B', 'Sir Bedevere the Wise') +# dot.node('L', 'Sir Lancelot the Brave') +# +# dot.edges(['AB', 'AL']) +# dot.edge('B', 'L', constraint='false') +# +# # print(dot.source) +# # // The Round Table +# # digraph { +# # A [label="King Arthur"] +# # B [label="Sir Bedevere the Wise"] +# # L [label="Sir Lancelot the Brave"] +# # A -> B +# # A -> L +# # B -> L [constraint=false] +# # } +# +# dot.render('/tmp/round-table.png', view=True) + + +class DotLayoutManager(ILayoutManager): + """A layout manager that uses graphviz's dot + """ + + def __init__(self): + super(DotLayoutManager, self).__init__() + self._method = 'plain' # at the moment we use the plain method instead of the more robust json method because json method is too recent to be supported on all platforms (on windows, graphviz 2.38 doesn't yet supports json output format) + self._tmp_file_path = tempfile.mktemp(suffix='.%s' % self._method, prefix='msspec_layout_') + print('DotLayoutManager.__init__ : self._tmp_file_path = %s' % self._tmp_file_path) + + def compute_operators_position(self, data_flow): + """ + :param DataFlow data_flow: + """ + # pydot_sample() + graph = pydot.Dot(graph_type='graph') + + # node [shape = record,height=.1]; + + # attr_to_label = {} + + graph.set_node_defaults(shape='record') + for op in data_flow.operators: + node = pydot.Node(op.name) + label = '"' + plug_index = 0 + for plug in op.get_input_plugs() + op.get_output_plugs(): + if plug.is_pluggable: + if len(label) > 1: + label += '|' + # label += "<%s> %s" % (plug.name, plug.name) + label += "<%s> " % (plug.name) + plug_index += 1 + label += '"' + node.set('label', label) + graph.add_node(node) + + for wire in data_flow.wires: + #: :type wire: Wire + src_plug = wire.input_plug + dst_plug = wire.output_plug + + src_op = src_plug.operator + dst_op = dst_plug.operator + + # print("src_op.name = %s" % src_op.name) + # print("dst_op.name = %s" % dst_op.name) + edge = pydot.Edge('"%s":%s' % (src_op.name, src_plug.name), '"%s":%s' % (dst_op.name, dst_plug.name)) + graph.add_edge(edge) + + # print(graph.to_string()) + # graph.write('/tmp/toto.pdf', format='pdf') + func = {'plain': self._graph_to_pos_plain, 'json': self._graph_to_pos_json}[self._method] + return func(graph, data_flow) + + def _graph_to_pos_plain(self, graph, data_flow): + """extracts operator positions from the pydot graph using dot's plain output format + """ + class GraphField(object): + X_SIZE = 2 + Y_SIZE = 3 + + class NodeField(object): + NAME = 1 + X = 2 + Y = 3 + + graph.write(self._tmp_file_path, format='plain') + + # example output + # graph 1 1.9444 2.5417 + # node "ase.lattice.bulk_1" 0.375 2.2847 0.75 0.51389 " " solid record black lightgrey + # node "ase.repeat_2" 0.56944 1.2708 0.75 0.51389 " | " solid record black lightgrey + # node "ase.lattice.bulk_3" 1.5694 1.2708 0.75 0.51389 " " solid record black lightgrey + # node "ase.build.add_adsorbate_4" 1.3056 0.25694 0.83333 0.51389 " | | " solid record black lightgrey + # edge "ase.lattice.bulk_1" "ase.repeat_2" 4 0.375 2.0301 0.375 1.8816 0.375 1.6906 0.375 1.5208 solid black + # edge "ase.repeat_2" "ase.build.add_adsorbate_4" 4 0.76389 1.0208 0.76389 0.76408 1.0278 0.76369 1.0278 0.50694 solid black + # edge "ase.lattice.bulk_3" "ase.build.add_adsorbate_4" 4 1.4344 1.0167 1.3695 0.87155 1.3056 0.68373 1.3056 0.50694 solid black + # stop + + positions = {} #: :type positions: dict(str, (float,float)) + + scale = 100.0 + y_max = None + with open(self._tmp_file_path) as data_file: + for line in data_file.readlines(): + # print(line) + tokens = line.split(' ') + if tokens[0] == 'graph': + y_max = float(tokens[GraphField.Y_SIZE]) + elif tokens[0] == 'node': + op_name = tokens[NodeField.NAME][1:-1] + x = float(tokens[NodeField.X]) + y = float(tokens[NodeField.Y]) + # print( op_name, x, y) + positions[data_flow.find_operator(op_name)] = ((y_max - y) * scale, x * scale) # graphviz' dot lays th flow of arcs in the down direction by default, and we want it on the right + elif tokens[0] == 'edge': + break # for efficiency reason, stop parsing as we're not interested in the rest of the file + return positions + + def _graph_to_pos_json(self, graph, data_flow): + """extracts operator positions from the pydot graph using dot's json output format + """ + graph.write('toto.json', format='json') + + with open('toto.json') as data_file: + data = json.load(data_file) + # pprint(data) + + y_max = float(data["bb"].split(",")[3]) + + positions = {} #: :type positions: dict(str, (float,float)) + if "objects" in data: + for op_node in data["objects"]: + op_name = op_node["name"] + # print(op_node["name"]) + # print(op_node["pos"]) + coords = op_node["pos"].split(',') + x = float(coords[0]) + y = float(coords[1]) + # print( op_name, x, y) + positions[data_flow.find_operator(op_name)] = (y_max - y, x) # graphviz' dot lays th flow of arcs in the down direction by default, and we want it on the right + + return positions diff --git a/src/msspec/msspecgui/datafloweditor/ilayoutmanager.py b/src/msspec/msspecgui/datafloweditor/ilayoutmanager.py new file mode 100644 index 0000000..49a4188 --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/ilayoutmanager.py @@ -0,0 +1,12 @@ +import abc + + +class ILayoutManager(object): + + @abc.abstractmethod + def compute_operators_position(self, data_flow): + """ + :param DataFlow data_flow: the data flow that we want to compute the layout for + :return dict(msspecgui.dataflow.Operator, (int, int)): a (x, y) position for each operator + """ + return {} diff --git a/src/msspec/msspecgui/datafloweditor/operatorgui.py b/src/msspec/msspecgui/datafloweditor/operatorgui.py new file mode 100644 index 0000000..281ade7 --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/operatorgui.py @@ -0,0 +1,142 @@ +import wx +from wx.lib.agw import floatspin as fs +from msspecgui.dataflow import IOperatorCreator + + +# bug 778 on https://www.brainwy.com/tracker/PyDev/# +# autocomplete (code completion) doesn't work for list items inside self members +# Hi, The code below shows a case of code completion that doesn't work although it works on very close cases (see below) +# +# class Toto(object): +# def dummy(self): +# pass +# +# +# class Titi(object): +# def __init__(self, l, s): +# """ +# :param list(Toto) l: +# :param str s: +# """ +# self._l = l +# self._s = s +# +# s.capitalize() # <-- autocomplete works on s +# self._s.capitalize() # <-- autocomplete works on self._s +# +# l.pop() # <-- autocomplete works on l +# for p1 in l: +# p1.dummy() # <-- autocomplete works on p1 +# +# self._l.pop() # <-- autocomplete works on self._l +# for p2 in self._l: +# p2.dummy() # <-- autocomplete doesn't work on p2 + +class PlugsGuiFrame(wx.Dialog): + """ The frame containing the graphical user interface for the given plugs + """ + + def __init__(self, parent, window_title, plugs): + """ + :param wx.Widget parent: window that contains this window + :param str window_title: window title + :param list(msspecgui.dataflow.Plug) plugs: the plugs that this gui allows the user to modify + :param msspecgui.dataflow.Plug plug: the plugs that this gui allows the user to modify + """ + super(PlugsGuiFrame, self).__init__(parent, title=window_title) + self._plugs = plugs + self._widgets = {} #: :type self._widgets: dict(str, wx.Control) + self.initui() + self.Centre() + self.Show() + + def initui(self): + """ + the constructor of the interface + """ + self.vbox = wx.BoxSizer(wx.VERTICAL) + self.panel = wx.Panel(parent=self, id=1) + main_params_sizer = wx.FlexGridSizer(0, 2, 10, 10) + # print("PlugsGuiFrame.initui len(self._plugs) = %d" % len(list(self._plugs))) + + for plug in self._plugs: #: :type plug: msspecgui.dataflow.Plug + if not plug.is_pluggable: + label = wx.StaticText(self.panel, label=plug.name) + main_params_sizer.Add(label) + widget = None + # print("plug.data_type.get_type_id() = %s" % plug.data_type.get_type_id()) + if plug.data_type.get_type_id() == 'int': + widget = wx.SpinCtrl(self.panel) + widget.SetValue(plug.get_value()) + elif plug.data_type.get_type_id() == 'float': + widget = fs.FloatSpin(self.panel, + value=plug.get_value(), size=(180, -1), + min_val=0.1, max_val=10.00, + increment=0.01, + style=fs.FS_CENTRE) + widget.SetFormat("%f") + widget.SetDigits(6) + else: + raise NotImplementedError + main_params_sizer.Add(widget) + self._widgets[plug.name] = widget + + ok_cancel_reset_sizer = wx.BoxSizer(wx.HORIZONTAL) + # reset_btn = wx.Button(self.panel, 2, label="Reset") + # reset_btn.Bind(wx.EVT_BUTTON, self.on_reset) + cancel_btn = wx.Button(self.panel, wx.ID_CANCEL, label="Cancel") + cancel_btn.Bind(wx.EVT_BUTTON, self.on_close, id=wx.ID_CANCEL) + self.ok_btn = wx.Button(self.panel, wx.ID_OK, label="OK") + # self.ok_btn.Bind(wx.EVT_BUTTON, self.on_ok, id=wx.ID_OK) + self.ok_btn.Bind(wx.EVT_BUTTON, self.on_ok, id=wx.ID_OK) + + # ok_cancel_reset_sizer.Add(reset_btn, flag=wx.ALL, border=5) + ok_cancel_reset_sizer.Add(cancel_btn) + ok_cancel_reset_sizer.Add(self.ok_btn, flag=wx.LEFT, border=5) + + self.vbox.Add(main_params_sizer, proportion=2, flag=wx.ALL | wx.EXPAND, border=15) + + self.vbox.Add(ok_cancel_reset_sizer, flag=wx.ALIGN_RIGHT | wx.ALL, border=5) + self.panel.SetSizer(self.vbox) + self.panel.Fit() + self.Fit() + + def on_reset(self, event): + pass + + def on_close(self, event): + event.Skip() # propagate the event so that the dialog closes + + def on_ok(self, event): + # print("PlugsGuiFrame.on_ok len(self._plugs) = %d" % len(list(self._plugs))) + for plug in self._plugs: #: :type plug: msspecgui.dataflow.Plug + # print("plug.data_type.get_type_id() = %s" % plug.data_type.get_type_id()) + if not plug.is_pluggable: + new_value = None + widget = self._widgets[plug.name] + if plug.data_type.get_type_id() == 'int': + new_value = widget.GetValue() + # print("PlugsGuiFrame.on_ok : new_value (int) = %d" % new_value) + elif plug.data_type.get_type_id() == 'float': + new_value = widget.GetValue() + # print("PlugsGuiFrame.on_ok : new_value (float) = %f" % new_value) + plug.set_value(new_value) + event.Skip() # propagate the event so that the dialog closes + + +class OperatorGui(IOperatorCreator.IAction): + """a graphic user interface to allow the user to modify an operator's parameters + + """ + def get_name(self): + return 'properties via gui' + + def execute_on_operator(self, operator): + """ + :param dataflow.operator.Operator operator: the operator related to this action + """ + dialog = PlugsGuiFrame(None, window_title='operator %s' % operator.name, plugs=operator.get_input_plugs()) + result = dialog.ShowModal() + if result == wx.ID_OK: + operator.data_flow.on_modified_operator(operator) + dialog.Destroy() diff --git a/src/msspec/msspecgui/datafloweditor/operatorwidget.py b/src/msspec/msspecgui/datafloweditor/operatorwidget.py new file mode 100644 index 0000000..34989f5 --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/operatorwidget.py @@ -0,0 +1,119 @@ +# import wx.lib.wxcairo +# import math +import msspecgui +from msspecgui import scenegraph2d +from .widget import Widget +# from msspecgui import datafloweditor +# from numpy.distutils.misc_util import cxx_ext_match + + +class OperatorWidget(Widget): + ''' + The widget representing a node in the dataflow + ''' + _g_last_id = 0 + + def __init__(self, operator, data_flow_view): + """ + :param operator: the dataflow operator that this widget graphically represents + :type operator: msspecgui.dataflow.Operator + :param data_flow_view: the dataflowview to which this operator belongs + :type data_flow_view: msspecgui.datafloweditor.DataflowView + + """ + super(OperatorWidget, self).__init__(data_flow_view) + self._operator = operator + self._id = OperatorWidget.get_new_id() + self.is_selected = False + self.widget_background = None + self.main_shape_node = scenegraph2d.Group() + self.plug_to_widget = {} # an associative array that gives the widget associated to each plug name + + for side in ['input', 'output']: + plugs = {'input': self._operator.get_input_plugs(), + 'output': self._operator.get_output_plugs()}[side] + # plug_index = 0 + for plug in plugs: + if plug.is_pluggable: + plug_widget = msspecgui.datafloweditor.PlugWidget(plug, self, data_flow_view) + self.plug_to_widget[plug.name] = plug_widget + # plug_index += 1 + + @classmethod + def get_new_id(cls): + OperatorWidget._g_last_id += 1 + return OperatorWidget._g_last_id + + def get_id(self): + return self._id + + @property + def operator(self): + return self._operator + + def update_appearance(self): + for plug_widget in self.plug_to_widget.itervalues(): + plug_widget.update_appearance(mouse_is_above=False) # FIXME : handle the case where the mouse is over the plug widget + + def get_plug_widget(self, plug): + """ + Returns the plug widget associated with the given plug + :type plug: Plug + :rtype: PlugWidget + """ + plug_widget = self.plug_to_widget[plug.name] + return plug_widget + + def set_selected_state(self, is_selected): + self.is_selected = is_selected + self.widget_background.fill = {False: scenegraph2d.Color(128, 128, 128), True: scenegraph2d.Color(192, 192, 128)}[self.is_selected] + + def set_position(self, x, y): + self.main_shape_node.parent.transform = [msspecgui.scenegraph2d.Translate(x, y)] + assert self.operator is not None + for wire in self.operator.wires: + if wire in self._data_flow_view.wire_to_widget: # while load the dataflow, wires are not guaranteed to have a widget yet + wire_widget = self._data_flow_view.wire_to_widget[wire] + wire_widget.update_position() + + def render_to_scene_graph(self, scenegraph_group): + """ + :param scenegraph_group: the group node that contains the drawing of this element + :type scenegraph_group: scenegraph.Group + """ + rect = scenegraph2d.Rectangle() + rect.width = 70.0 + rect.height = 70.0 + rect.x = -35.0 + rect.y = -35.0 + rect.fill = scenegraph2d.Color(128, 128, 128) + self.widget_background = rect + self.main_shape_node.add_child(rect) + title = "%s (%d)" % (self._operator.creator.get_operator_type_id().split('.')[-1], self.get_id()) + # import my.source.module + # c = my.source.module.Color() + title_text = scenegraph2d.Text(title) + title_text.fill = scenegraph2d.Color.black + title_text.text_anchor = "middle" + self.main_shape_node.add_child(title_text) + + for side in ['input', 'output']: + (cx, plugs) = {'input': (-25.0, self._operator.get_input_plugs()), + 'output': (25.0, self._operator.get_output_plugs())}[side] + plug_index = 0 + for p in plugs: + if p.is_pluggable: + plug_group = scenegraph2d.Group() + plug_group.x = cx + plug_group.y = -25.0 + 10.0 * plug_index + self.main_shape_node.add_child(plug_group) + + plug_widget = self.plug_to_widget[p.name] + plug_widget.render_to_scene_graph(plug_group) + plug_index += 1 + self.scenegraph_group = scenegraph_group + self.scenegraph_group.add_child(self.main_shape_node) + + def remove_from_scene_graph(self): + parent = self.main_shape_node.parent + parent.remove_child(self.main_shape_node) diff --git a/src/msspec/msspecgui/datafloweditor/plugwidget.py b/src/msspec/msspecgui/datafloweditor/plugwidget.py new file mode 100644 index 0000000..870578d --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/plugwidget.py @@ -0,0 +1,83 @@ +from msspecgui import scenegraph2d +from .widget import Widget +# import dataflow + + +class PlugWidget(Widget): + ''' + The widget representing a plug (input or output) of an operator in the dataflow + + ''' + + DATA_IS_UNAVAILABLE_COLOR = scenegraph2d.Color(128, 64, 64) + DATA_IS_AVAILABLE_COLOR = scenegraph2d.Color(64, 128, 64) + HIGHLITED_COLOR = scenegraph2d.Color(128, 255, 128) + + def __init__(self, plug, operator_widget, data_flow_view): + """ + :param plug: the dataflow plug that this widget graphically represents + :type plug: dataflow.Plug + @type plug: dataflow.Plug + :param operator_widget: the operator widget that this plug widget is attached to + :type operator_widget: datafloweditor.OperatorWidget + :param data_flow_view: the dataflowview to which this operator belongs + :type data_flow_view: datafloweditor.DataflowView + + """ + super(PlugWidget, self).__init__(data_flow_view) + self.operator_widget = operator_widget + self._plug = plug + self.main_shape_node = None + + @property + def plug(self): + """ + :rtype: dataflow.plug.Plug + """ + # plug = dataflow.plug.Plug + return self._plug + + @property + def centre_pos(self): + """ Returns the position of the centre of this plug widget + """ + # print('PlugWidget.centre_pos : local_to_parent_matrix = %s' % str(self.scenegraph_group.local_to_parent_matrix())) + # defs = [] + # print('PlugWidget.centre_pos : self.scenegraph_group = %s' % str(self.scenegraph_group._xml(defs))) + # defs = [] + # print('PlugWidget.centre_pos : self.scenegraph_group.parent = %s' % str(self.scenegraph_group.parent._xml(defs))) + + return self.scenegraph_group.local_to_world_matrix().project(x=0, y=0) + + def is_connectable(self): + if self._plug.is_connected(): + return False + if not self._plug.value_is_available(): + return False + return True + + def update_appearance(self, mouse_is_above): + color = {False: self.DATA_IS_UNAVAILABLE_COLOR, + True: self.DATA_IS_AVAILABLE_COLOR}[self._plug.value_is_available()] + if mouse_is_above and self.is_connectable(): + color = self.HIGHLITED_COLOR + + self.main_shape_node.fill = color + + def render_to_scene_graph(self, scenegraph_group): + """ + :param scenegraph_group: the group node that contains the drawing of this element + :type scenegraph_group: scenegraph.Group + """ + + self.scenegraph_group = scenegraph_group + circle_node = scenegraph2d.Circle() + circle_node.cx = 0.0 + circle_node.cy = 0.0 + circle_node.r = 7.0 + self.main_shape_node = circle_node + scenegraph_group.add_child(circle_node) + self.update_appearance(mouse_is_above=False) + + def on_hover(self, is_entering): + self.update_appearance(mouse_is_above=is_entering) diff --git a/src/msspec/msspecgui/datafloweditor/widget.py b/src/msspec/msspecgui/datafloweditor/widget.py new file mode 100644 index 0000000..99d0060 --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/widget.py @@ -0,0 +1,51 @@ +''' +Created on May 20, 2016 + +@author: graffy +''' + +import wx + + +class Widget(object): + ''' + The widget representing an interactive object in the dataflow (an operator, a plug, etc.) + ''' + + def __init__(self, data_flow_view): + """ + :param data_flow_view: the dataflowview to which this operator belongs + :type data_flow_view: datafloweditor.DataflowView + """ + self._container_group = None # the 2d scene graph group node representing this widget + self._data_flow_view = data_flow_view + + @property + def scenegraph_group(self): + """ + :rtype: scenegraph.Group + """ + return self._container_group + + @scenegraph_group.setter + def scenegraph_group(self, scenegraph_group): + """ + :type scenegraph_group: scenegraph.Group + """ + print('Widget.scenegraph_group.setter : scenegraph_group=%s' % str(scenegraph_group)) + self._container_group = scenegraph_group + self._data_flow_view.scenegraph_group_to_widget[scenegraph_group] = self + + def get_bounding_box(self, border=0): + """ + :param int border: the width of the border surrounding the box + :return wx.Rect: the smallest box containing this widget + """ + (x_min, y_min), (x_max, y_max) = self.scenegraph_group.aabbox() # (scenegraph_group.setter seen as a method, see https://github.com/PyCQA/pylint/issues/870) pylint: disable=no-member + return wx.Rect(x_min - border, y_min - border, x_max - x_min + border * 2, y_max - y_min + border * 2) + + def on_hover(self, is_entering): + ''' + :param is_entering: True is the mouse pointer enters this widget, False if it leaves the widget + ''' + pass diff --git a/src/msspec/msspecgui/datafloweditor/wirewidget.py b/src/msspec/msspecgui/datafloweditor/wirewidget.py new file mode 100644 index 0000000..627b8a0 --- /dev/null +++ b/src/msspec/msspecgui/datafloweditor/wirewidget.py @@ -0,0 +1,111 @@ +import msspecgui +from msspecgui import scenegraph2d +# import msspecgui.datafloweditor as datafloweditor +import msspecgui.dataflow as dataflow +import widget + + +class WireWidget(widget.Widget): + ''' + The widget representing a wire (a link connectiong two plugs) + ''' + + def __init__(self, data_flow_view): + """ + :param data_flow_view: the dataflowview to which this operator belongs + :type data_flow_view: datafloweditor.DataflowView + + """ + super(WireWidget, self).__init__(data_flow_view) + # print('WireWidget constructor') + self.main_shape_node = None + self._source_plug_widget = None #: :type self._source_plug_widget: msspecgui.datafloweditor.PlugWidget + self._dest_plug_widget = None + self.main_shape_node = scenegraph2d.Line() + self.main_shape_node.fill = scenegraph2d.Color(0, 255, 255) + + @property + def wire(self): + return self.dest_plug_widget.plug.incoming_wire + + @property + def source_plug_widget(self): + return self._source_plug_widget + + @source_plug_widget.setter + def source_plug_widget(self, plug_widget): + self._source_plug_widget = plug_widget + self._set_from_pos(plug_widget.centre_pos) + + @property + def dest_plug_widget(self): + return self._dest_plug_widget + + @dest_plug_widget.setter + def dest_plug_widget(self, plug_widget): + self._dest_plug_widget = plug_widget + self._set_to_pos(plug_widget.centre_pos) + + def _set_from_pos(self, pos): + (self.main_shape_node.x1, self.main_shape_node.y1) = pos + + def _set_to_pos(self, pos): + (self.main_shape_node.x2, self.main_shape_node.y2) = pos + + def render_to_scene_graph(self, scenegraph_group): + """ + :param scenegraph_group: the group node that contains the drawing of this element + :type scenegraph_group: scenegraph.Group + """ + self.scenegraph_group = scenegraph_group + scenegraph_group.add_child(self.main_shape_node) + + def update_position(self): + self._set_from_pos(self.source_plug_widget.centre_pos) + self._set_to_pos(self.dest_plug_widget.centre_pos) + + def remove_from_scene_graph(self): + parent = self.main_shape_node.parent + parent.remove_child(self.main_shape_node) + + def is_construction_wire(self): + """ Tells if this widget represents a wire being built interactively by the user + """ + return self.source_plug_widget is None or self.dest_plug_widget is None + + def set_pointer_pos(self, pos): + """ + :type pos: a tuple (x,y) + """ + assert(self.is_construction_wire()) # this call only makes sens if this wire widget represents a wire in construction + if self.source_plug_widget is None: + self._set_from_pos(pos) + else: + self._set_to_pos(pos) + + def is_valid_final_plug_widget(self, plug_widget): + """ + checks whether plug_widget is a valid plug to complete this connection + + :type plug_widget: datafloweditor.PlugWidget + """ + assert(isinstance(plug_widget, msspecgui.datafloweditor.PlugWidget)) + assert(self.is_construction_wire()) + if self.source_plug_widget is None: + return plug_widget.plug.is_output_plug() + else: + return plug_widget.plug.is_input_plug() + + def set_final_plug_widget(self, plug_widget): + """ + completes this wire with the given plug_widget + + :type plug_widget: datafloweditor.PlugWidget + """ + assert(isinstance(plug_widget, msspecgui.datafloweditor.PlugWidget)) + assert(self.is_construction_wire()) + assert(self.is_valid_final_plug_widget(plug_widget)) + if self.source_plug_widget is None: + self.source_plug_widget = plug_widget + else: + self.dest_plug_widget = plug_widget diff --git a/src/msspec/msspecgui/dataflowxmlserializer/__init__.py b/src/msspec/msspecgui/dataflowxmlserializer/__init__.py new file mode 100644 index 0000000..07b3f97 --- /dev/null +++ b/src/msspec/msspecgui/dataflowxmlserializer/__init__.py @@ -0,0 +1 @@ +from dataflowxmlserializer import DataflowSerializer diff --git a/src/msspec/msspecgui/dataflowxmlserializer/dataflowxmlserializer.py b/src/msspec/msspecgui/dataflowxmlserializer/dataflowxmlserializer.py new file mode 100644 index 0000000..85848bf --- /dev/null +++ b/src/msspec/msspecgui/dataflowxmlserializer/dataflowxmlserializer.py @@ -0,0 +1,213 @@ +import abc +from xml.dom import minidom + +# from msspecgui.dataflow import Operator +from msspecgui.dataflow import IDataflowSerializer +from msspecgui.dataflow.datatypes import StringDataType +from msspecgui.dataflow.datatypes import FloatDataType +from msspecgui.dataflow.datatypes import BoolDataType +from msspecgui.dataflow.datatypes import IntDataType + + +class IDataTypeSerializer(object): + + @abc.abstractmethod + def get_data_type(self): + """ + :return msspecgui.dataflow.IDatatype: the id of the type this seralize deals with + """ + return None + + @abc.abstractmethod + def value_to_xml(self, value, xml_node): + """ + :param minidom.Element xml_node: the container node of the serialized value + """ + pass + + @abc.abstractmethod + def xml_to_value(self, xml_node): + """ + :param minidom.Element xml_node: the container node of the serialized value + """ + pass + + +class StringSerializer(IDataTypeSerializer): + + def get_data_type(self): + return StringDataType() + + def value_to_xml(self, value, xml_node): + xml_node.setAttribute('value', '%s' % value) + + def xml_to_value(self, xml_node): + return xml_node.GetAttribute('value') + + +class FloatSerializer(IDataTypeSerializer): + + def get_data_type(self): + return FloatDataType() + + def value_to_xml(self, value, xml_node): + xml_node.setAttribute('value', '%f' % value) + + def xml_to_value(self, xml_node): + return float(xml_node.GetAttribute('value')) + + +class BoolSerializer(IDataTypeSerializer): + + def get_data_type(self): + return BoolDataType() + + def value_to_xml(self, value, xml_node): + xml_node.setAttribute('value', {False: 'false', True: 'true'}[value]) + + def xml_to_value(self, xml_node): + value_as_str = xml_node.GetAttribute('value') + return {'false': False, 'true': True}[value_as_str] + + +class IntSerializer(IDataTypeSerializer): + + def get_data_type(self): + return IntDataType() + + def value_to_xml(self, value, xml_node): + xml_node.setAttribute('value', '%d' % value) + + def xml_to_value(self, xml_node): + return int(xml_node.GetAttribute('value')) + + +class DataflowSerializer(IDataflowSerializer): + + FORMAT_VERSION = 1 + + def __init__(self): + super(DataflowSerializer, self).__init__() + self._data_type_serializers = {} #: :type self._data_type_serializers: dict[str, IDataTypeSerializer] + self._register_data_type_serializer(StringSerializer()) + self._register_data_type_serializer(FloatSerializer()) + self._register_data_type_serializer(BoolSerializer()) + self._register_data_type_serializer(IntSerializer()) + + def _register_data_type_serializer(self, data_type_serializer): + """ + :param IDataTypeSerializer data_type_serializer: the datatype serialize that needs to be registered + """ + self._data_type_serializers[data_type_serializer.get_data_type().get_type_id()] = data_type_serializer + + def _get_datatype_serializer(self, data_type_id): + """ + :param str data_type_id: + """ + return self._data_type_serializers[data_type_id] + + def _operator_as_xml(self, operator, xml_doc): + """creates the xml representation of the given operator + + :param msspecgui.dataflow.Operator operator: the operator + :param minidom.Document xml_doc: the xml document that be used to create the xml node + :return minidom.Element: the xml representation of the operator + """ + op_xml_node = xml_doc.createElement('operator') + op_xml_node.setAttribute('nodeId', '%d' % operator.id) + op_xml_node.setAttribute('operatorTypeId', '%s' % operator.creator.get_operator_type_id()) + for plug in operator.get_input_plugs(): + if not plug.is_pluggable: + plug_node = xml_doc.createElement(plug.name) + data_type_id = plug.data_type.get_type_id() + # print('data_type_id = %s' % data_type_id) + data_type_serializer = self._get_datatype_serializer(data_type_id) + data_type_serializer.value_to_xml(plug.get_value(), plug_node) + op_xml_node.appendChild(plug_node) + return op_xml_node + + def _create_operator_from_xml(self, op_xml_node, dataflow): + """ + :param minidom.Element op_xml_node: the xml node describing the operator and its data + :param msspec.dataflow.IDataFlow dataflow: the dataflow that contains the resulting operator + + :return msspec.dataflow.Operator: the created operator + """ + operator_type_id = str(op_xml_node.getAttribute('operatorTypeId')) + operator = dataflow.create_operator(operator_type_id) + operator.id = int(op_xml_node.getAttribute('nodeId')) + dataflow.add_operator(operator) + return operator + + def save_dataflow(self, dataflow, file_path): + """ + :type dataflow: msspecgui.dataflow.DataFlow + + """ + xml_doc = minidom.Document() + root_xml_node = xml_doc.createElement('dataflow') + xml_doc.appendChild(root_xml_node) + + # store a format version so that if the format needs changing, then it will be possible to detect and support old file formats + format_version_xml_node = xml_doc.createElement('formatVersion') + format_version_xml_node.setAttribute('value', '%d' % self.FORMAT_VERSION) + root_xml_node.appendChild(format_version_xml_node) + + last_create_op_id_xml_node = xml_doc.createElement('lastCreatedOperatorId') + last_create_op_id_xml_node.setAttribute('value', '%d' % dataflow.last_created_operator_id) + root_xml_node.appendChild(last_create_op_id_xml_node) + + operators_xml_node = xml_doc.createElement('operators') + root_xml_node.appendChild(operators_xml_node) + + for op in dataflow.operators: + op_xml_node = self._operator_as_xml(op, xml_doc) + operators_xml_node.appendChild(op_xml_node) + + wires_xml_node = xml_doc.createElement('wires') + root_xml_node.appendChild(wires_xml_node) + + for wire in dataflow.wires: #: :type wire: msspec.dataflow.Wire + wire_xml_node = xml_doc.createElement('wire') + + wire_xml_node.setAttribute('fromOperator', '%d' % wire.input_plug.operator.id) + wire_xml_node.setAttribute('fromAttr', wire.input_plug.name) + wire_xml_node.setAttribute('toOperator', '%d' % wire.output_plug.operator.id) + wire_xml_node.setAttribute('toAttr', wire.output_plug.name) + wires_xml_node.appendChild(wire_xml_node) + + print('save_dataflow : saving to %s\n' % file_path) + with open(file_path, 'w') as f: + f.write(xml_doc.toprettyxml()) + + def load_dataflow(self, file_path, dataflow): + """ + :param msspecgui.dataflow.DataFlow dataflow: an empty dataflow that will be filled + + """ + xml_doc = minidom.parse(file_path) + root_xml_node = xml_doc.documentElement + + last_create_op_id_xml_node = root_xml_node.getElementsByTagName('lastCreatedOperatorId')[0] + last_created_operator_id = int(last_create_op_id_xml_node.getAttribute('value')) + dataflow.last_created_operator_id = last_created_operator_id + + operators_xml_node = root_xml_node.getElementsByTagName('operators')[0] + for op_xml_node in operators_xml_node.getElementsByTagName('operator'): + # print('load_dataflow : creating operator') + self._create_operator_from_xml(op_xml_node, dataflow) + + wires_xml_node = root_xml_node.getElementsByTagName('wires')[0] + for wire_xml_node in wires_xml_node.getElementsByTagName('wire'): + from_op_id = int(wire_xml_node.getAttribute('fromOperator')) + from_attr = wire_xml_node.getAttribute('fromAttr') + to_op_id = int(wire_xml_node.getAttribute('toOperator')) + to_attr = wire_xml_node.getAttribute('toAttr') + + from_plug = dataflow.get_operator(from_op_id).get_plug(from_attr) + to_plug = dataflow.get_operator(to_op_id).get_plug(to_attr) + + # print('load_dataflow : creating wire') + dataflow.create_wire(from_plug, to_plug) + + return dataflow diff --git a/src/msspec/msspecgui/msspec/__init__.py b/src/msspec/msspecgui/msspec/__init__.py new file mode 100644 index 0000000..e69de29 diff --git a/src/msspec/msspecgui/msspec/cluster/__init__.py b/src/msspec/msspecgui/msspec/cluster/__init__.py new file mode 100644 index 0000000..b1c193e --- /dev/null +++ b/src/msspec/msspecgui/msspec/cluster/__init__.py @@ -0,0 +1 @@ +from .clusterflow import ClusterFlow diff --git a/src/msspec/msspecgui/msspec/cluster/clusterflow.py b/src/msspec/msspecgui/msspec/cluster/clusterflow.py new file mode 100644 index 0000000..728446c --- /dev/null +++ b/src/msspec/msspecgui/msspec/cluster/clusterflow.py @@ -0,0 +1,34 @@ +''' +Created on Jan 18, 2016 + +@author: graffy +''' +from msspecgui import dataflow +from msspecgui.dataflow.datatypes import StringDataType +from msspecgui.dataflow.datatypes import FloatDataType +from msspecgui.dataflow.datatypes import BoolDataType +from msspecgui.dataflow.datatypes import IntDataType +from .datatypes import ClusterDataType +from .generators import Bulk +from .generators import Repeat +from .generators import AddAdsorbate + + +class ClusterFlow(dataflow.DataFlow): + ''' + a dataflow of cluster generator nodes + ''' + + def __init__(self): + ''' + Constructor + ''' + super(ClusterFlow, self).__init__() + self.register_operator_creator(Bulk.Creator()) + self.register_operator_creator(Repeat.Creator()) + self.register_operator_creator(AddAdsorbate.Creator()) + self.register_data_type(ClusterDataType()) + self.register_data_type(StringDataType()) + self.register_data_type(FloatDataType()) + self.register_data_type(BoolDataType()) + self.register_data_type(IntDataType()) diff --git a/src/msspec/msspecgui/msspec/cluster/datatypes.py b/src/msspec/msspecgui/msspec/cluster/datatypes.py new file mode 100644 index 0000000..9480993 --- /dev/null +++ b/src/msspec/msspecgui/msspec/cluster/datatypes.py @@ -0,0 +1,19 @@ +from msspecgui.dataflow import IDataType +from ase import Atoms + + +class ClusterDataType(IDataType): + def __init__(self): + IDataType.__init__(self) + + def get_type_id(self): + """ + Returns a string uniquely identifying this data type + """ + return 'physics.atomscluster' + + def get_python_class(self): # pylint: disable=no-self-use + """ + see IDataType.get_python_class + """ + return Atoms diff --git a/src/msspec/msspecgui/msspec/cluster/generators/__init__.py b/src/msspec/msspecgui/msspec/cluster/generators/__init__.py new file mode 100644 index 0000000..dc54885 --- /dev/null +++ b/src/msspec/msspecgui/msspec/cluster/generators/__init__.py @@ -0,0 +1,3 @@ +from msspecgui.msspec.cluster.generators.repeat import Repeat +from msspecgui.msspec.cluster.generators.bulk import Bulk +from msspecgui.msspec.cluster.generators.addadsorbate import AddAdsorbate diff --git a/src/msspec/msspecgui/msspec/cluster/generators/addadsorbate.py b/src/msspec/msspecgui/msspec/cluster/generators/addadsorbate.py new file mode 100644 index 0000000..14ebf56 --- /dev/null +++ b/src/msspec/msspecgui/msspec/cluster/generators/addadsorbate.py @@ -0,0 +1,43 @@ +from msspecgui import dataflow +from ase.build import add_adsorbate + + +class AddAdsorbate(dataflow.Operator): + """ + an operator for ase.build.add_absorbate + """ + + class Creator(dataflow.IOperatorCreator): + def __init__(self): + dataflow.IOperatorCreator.__init__(self) + self.add_input_attribute('slab', 'physics.atomscluster', 'the surface onto which the adsorbate should be added') + self.add_input_attribute('adsorbate', 'physics.atomscluster', 'the adsorbate') + self.add_input_attribute('height', 'float', 'height above the surface.', is_pluggable=False) + + self.add_output_attribute('output_cluster', 'physics.atomscluster', 'the resulting cluster') + + def get_operator_type_id(self): + return 'ase.build.add_adsorbate' + + def create_operator(self, dflow): + return AddAdsorbate(dflow, self) + + def __init__(self, data_flow, creator): + ''' + Constructor + + :param data_flow: the dataflow that will contain this operator + ''' + dataflow.Operator.__init__(self, data_flow, creator) + self.get_plug('height').set_value(0.0) + + def update(self): + """ + see dataflow.Operator.update + """ + slab = self.get_plug('slab').get_value() + adsorbate = self.get_plug('adsorbate').get_value() + height = self.get_plug('height').get_value() + output_cluster = slab.copy() + add_adsorbate(output_cluster, adsorbate, height) + self.get_plug('output_cluster').set_value(output_cluster) diff --git a/src/msspec/msspecgui/msspec/cluster/generators/bulk.py b/src/msspec/msspecgui/msspec/cluster/generators/bulk.py new file mode 100644 index 0000000..e257825 --- /dev/null +++ b/src/msspec/msspecgui/msspec/cluster/generators/bulk.py @@ -0,0 +1,131 @@ +from ase.lattice import bulk + +from msspecgui import dataflow + + +class Bulk(dataflow.Operator): + ''' + a cluster creator that performs what ase.lattice.bulk performs + ''' + + class Creator(dataflow.IOperatorCreator): + def __init__(self): + dataflow.IOperatorCreator.__init__(self) + self.add_output_attribute('output_cluster', 'physics.atomscluster', 'the resulting cluster') + + # the following attributes are set via a graphical user interface, hence not pluggable + self.add_input_attribute('atoms', 'string', 'the atoms that constitute this cluster (eg "MgO")', is_pluggable=False) + self.add_input_attribute('structure', 'string', 'the lattice structure (eg "rocksalt")', is_pluggable=False) + self.add_input_attribute('a', 'float', 'the lattice constant a', is_pluggable=False) + self.add_input_attribute('c', 'float', 'the lattice constant c', is_pluggable=False) + self.add_input_attribute('u', 'float', 'the lattice constant u', is_pluggable=False) + self.add_input_attribute('is_cubic', 'bool', 'is the lattice cubic', is_pluggable=False) + self.add_input_attribute('is_orthorombic', 'bool', 'is the lattice orthorhombic', is_pluggable=False) + + def get_operator_type_id(self): + return 'ase.lattice.bulk' + + def create_operator(self, dflow): + return Bulk(dflow, self) + + def __init__(self, data_flow, creator): + ''' + Constructor + + :param data_flow: the dataflow that will contain this operator + ''' + dataflow.Operator.__init__(self, data_flow, creator) + self.atoms = 'MgO' + self.structure = 'rocksalt' + self.a = 4.219 + self.c = 0.0 + self.u = 0.0 + self.is_cubic = True + self.is_orthorombic = False + + @property + def atoms(self): + return self.get_plug('atoms').get_value() + + @atoms.setter + def atoms(self, atoms): + """ + :type atoms: str + """ + self.get_plug('atoms').set_value(atoms) + + @property + def structure(self): + return self.get_plug('structure').get_value() + + @structure.setter + def structure(self, structure): + """ + :type structure: str + """ + self.get_plug('structure').set_value(structure) + + @property + def a(self): + return self.get_plug('a').get_value() + + @a.setter + def a(self, a): + """ + :type a: float + """ + self.get_plug('a').set_value(a) + + @property + def c(self): + return self.get_plug('c').get_value() + + @c.setter + def c(self, c): + """ + :type c: float + """ + self.get_plug('c').set_value(c) + + @property + def u(self): + return self.get_plug('u').get_value() + + @u.setter + def u(self, u): + """ + :type u: float + """ + self.get_plug('u').set_value(u) + + @property + def is_cubic(self): + return self.get_plug('is_cubic').get_value() + + @is_cubic.setter + def is_cubic(self, is_cubic): + """ + :type is_cubic: bool + """ + self.get_plug('is_cubic').set_value(is_cubic) + + @property + def is_orthorombic(self): + return self.get_plug('is_orthorombic').get_value() + + @is_orthorombic.setter + def is_orthorombic(self, is_orthorombic): + """ + :type is_orthorombic: bool + """ + self.get_plug('is_orthorombic').set_value(is_orthorombic) + + def update(self): + """ + see dataflow.Operator.update + """ + # >>> ase.lattice.bulk('MgO', crystalstructure='rocksalt', a=4.219, c=0.1, u=0.1, cubic=True, orthorhombic=False) + # Atoms(symbols='MgOMgOMgOMgO', positions=..., cell=[4.219, 4.219, 4.219], pbc=[True, True, True]) + print('self.atoms = %s (type = %s)' % (self.atoms, type(self.atoms))) + cluster = bulk(self.atoms, crystalstructure=self.structure, a=self.a, c=self.c, u=self.u, cubic=self.is_cubic, orthorhombic=self.is_orthorombic) + self.get_plug('output_cluster').set_value(cluster) diff --git a/src/msspec/msspecgui/msspec/cluster/generators/repeat.py b/src/msspec/msspecgui/msspec/cluster/generators/repeat.py new file mode 100644 index 0000000..4d859f8 --- /dev/null +++ b/src/msspec/msspecgui/msspec/cluster/generators/repeat.py @@ -0,0 +1,48 @@ +from msspecgui import dataflow + + +class Repeat(dataflow.Operator): + """ + an operator that repeats the input cluser a given number of times along each axis + """ + # an operator that removes the atoms of the cluster that are outside the given sphere + + class Creator(dataflow.IOperatorCreator): + def __init__(self): + dataflow.IOperatorCreator.__init__(self) + self.add_input_attribute('input_cluster', 'physics.atomscluster', 'the cluster from which we want to keep the atoms that are inside the given sphere') + self.add_input_attribute('repeat_x', 'int', 'the number of repetitions along x axis', is_pluggable=False) + self.add_input_attribute('repeat_y', 'int', 'the number of repetitions along y axis', is_pluggable=False) + self.add_input_attribute('repeat_z', 'int', 'the number of repetitions along z axis', is_pluggable=False) + + # self.add_input_attribute('inputSphere.center', 'position3', 'the position of the center of the sphere') + # self.add_input_attribute('inputSphere.radius', 'float', 'the radius of the center of the sphere') + self.add_output_attribute('output_cluster', 'physics.atomscluster', 'the resulting cluster') + + def get_operator_type_id(self): + return 'ase.repeat' + + def create_operator(self, dflow): + return Repeat(dflow, self) + + def __init__(self, data_flow, creator): + ''' + Constructor + + :param data_flow: the dataflow that will contain this operator + ''' + dataflow.Operator.__init__(self, data_flow, creator) + self.get_plug('repeat_x').set_value(2) + self.get_plug('repeat_y').set_value(3) + self.get_plug('repeat_z').set_value(4) + + def update(self): + """ + see dataflow.Operator.update + """ + input_cluster = self.get_plug('input_cluster').get_value() + rx = self.get_plug('repeat_x').get_value() + ry = self.get_plug('repeat_y').get_value() + rz = self.get_plug('repeat_z').get_value() + output_cluster = input_cluster.repeat((rx, ry, rz)) + self.get_plug('output_cluster').set_value(output_cluster) diff --git a/src/msspec/msspecgui/msspec/gui/__init__.py b/src/msspec/msspecgui/msspec/gui/__init__.py new file mode 100644 index 0000000..e69de29 diff --git a/src/msspec/msspecgui/msspec/gui/bulk_interface.py b/src/msspec/msspecgui/msspec/gui/bulk_interface.py new file mode 100644 index 0000000..bbae133 --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/bulk_interface.py @@ -0,0 +1,435 @@ +#!/usr/bin/python +# -*- coding: utf-8 -*- +import wx +from wx.lib.agw import floatspin as fs +""" +bulk interface that the user use to create a single cell crystal +""" + + +class StructureDef(object): + # enabled widgets + class EnabledWidgets(object): + covera_flg = 0b00001 + u_flg = 0b00010 + c_flg = 0b00100 + orth_flg = 0b01000 + cubic_flg = 0b10000 + + def __init__(self, ase_name, long_name, min_atoms, max_atoms, default_atoms, enabled_widgets, default_a, default_c=0.1): + """ + :param ase_name: crystal structure identifier used by ase + :param long_name: crystal long name + :param min_atoms: minimal number of atoms allowed in crystal + :param max_atoms: minimal number of atoms allowed in crystal + """ + self.long_name = long_name + self.ase_name = ase_name + self.min_atoms = min_atoms + self.max_atoms = max_atoms + self.default_atoms = default_atoms + self.enabled_widgets = enabled_widgets + self.default_a = default_a + self.default_c = default_c + + +class StructureDefs(object): + + def __init__(self): + ew = StructureDef.EnabledWidgets + self._long_name_to_structure_def = {} + self._ase_name_to_structure_def = {} + self._add_structure_def(StructureDef('sc', 'Simple Cubic', -1, 1, 'Po', ew.cubic_flg | ew.orth_flg, 3.80)) + self._add_structure_def(StructureDef('fcc', 'Face Centered Cubic', -1, 1, 'Cu', ew.cubic_flg | ew.orth_flg, 3.615)) + self._add_structure_def(StructureDef('bcc', 'Body Centered Cubic', -1, 1, 'Fe', ew.cubic_flg | ew.orth_flg, 2.866)) + self._add_structure_def(StructureDef('hcp', 'Hexagonal Close-Pack', 2, -1, 'Mg', ew.cubic_flg | ew.c_flg | ew.covera_flg, 3.209, 5.210)) + self._add_structure_def(StructureDef('diamond', 'Diamond', 2, -1, 'C', ew.cubic_flg | ew.orth_flg, 3.5668)) + self._add_structure_def(StructureDef('zincblende', 'Zincblende', 2, -1, 'ZnS', ew.cubic_flg | ew.orth_flg, 5.420)) + self._add_structure_def(StructureDef('rocksalt', 'Rocksalt', 2, -1, 'NaCl', ew.cubic_flg | ew.orth_flg, 5.630)) + self._add_structure_def(StructureDef('cesiumchloride', 'Cesiumchloride', -1, 2, 'CsCl', ew.cubic_flg, 4.110)) + self._add_structure_def(StructureDef('fluorite', 'Fluorite', -1, 1, 'CaFF', ew.orth_flg | ew.c_flg | ew.covera_flg, 5.463)) + self._add_structure_def(StructureDef('wurtzite', 'Wurtzite', -1, 1, 'ZnS', ew.cubic_flg | ew.c_flg | ew.u_flg | ew.covera_flg, 3.820, 6.260)) + + def _add_structure_def(self, structure_def): + """ + :type structure_def: StructureDef + """ + self._long_name_to_structure_def[structure_def.long_name] = structure_def + self._ase_name_to_structure_def[structure_def.ase_name] = structure_def + + def get_structure_def(self, long_name=None, ase_name=None): + """ + :rtype: StructureDef + """ + assert (long_name is None) ^ (ase_name is None) + if long_name is not None: + return self._long_name_to_structure_def[long_name] + if ase_name is not None: + return self._ase_name_to_structure_def[ase_name] + + +class BulkFrame(wx.Dialog): + """ + :param structure_defs: list of crystal structures + :type structure_defs: dictionary + :param selected_crystal_str: the structure that will be + used to create the cluster + """ + + structure_defs = StructureDefs() + + @classmethod + def get_structure_defs(cls): + """ + """ + return cls.structure_defs + + @classmethod + def get_structure_id(cls, structure_name): + """ + :type structure_name: str + :rtype: str + """ + return cls.structure_defs.get_structure_def(long_name=structure_name).ase_name + + @classmethod + def get_structure_name(cls, structure_id): + """ + :type structure_id: str + :rtype: str + """ + return cls.structure_defs.get_structure_def(ase_name=structure_id).long_name + + def get_crystal_def(self, long_name): + """ + :param long_name : the structure long name (eg 'Face Centered Cubic' + :type long_name : str + :rtype: StructureDef + """ + + return BulkFrame.get_structure_defs().get_structure_def(long_name=long_name) + + selected_crystal_str = "" + + def __init__(self, parent, title, bulk_operator): + """ + :param parent: window that contains this window + :type parent: wx.Widget + :param bulk_operator: the bulk_operator that this gui allows the user to modify + :type bulk_operator: msspec.cluster.generators.Bulk + """ + self._bulk_operator = bulk_operator + super(BulkFrame, self).__init__(parent, title=title) + self.initui() + self.Centre() + self.Show() + + # -------------------------------------------------------------------------- + + def initui(self): + """ + the constructor of the interface + """ + self.vbox = wx.BoxSizer(wx.VERTICAL) + self.panel = wx.Panel(parent=self, id=1) + main_params_sizer = wx.GridBagSizer() + + # all crystal structures that can be selected to create the cluster + self.crystal_structures = ['Simple Cubic', + 'Face Centered Cubic', + 'Body Centered Cubic', + 'Hexagonal Close-Pack', + 'Diamond', + 'Zincblende', + 'Rocksalt', + 'Cesiumchloride', + 'Wurtzite'] + + # crystal structure + crystalstructure_txt = wx.StaticText(self.panel, label="Crystal structure : ") + main_params_sizer.Add(crystalstructure_txt, pos=(1, 0), flag=wx.LEFT | wx.TOP, border=10) + # list of crystal structures + self.crystr_cbx = wx.ComboBox(self.panel, choices=self.crystal_structures) + main_params_sizer.Add(self.crystr_cbx, pos=(1, 1), border=10) + crystal_structure_name = BulkFrame.get_structure_name(self._bulk_operator.structure) + self.crystr_cbx.Select(self.crystal_structures.index(crystal_structure_name)) + # a ToolTip associated to the combobox + self.crystr_cbx.SetToolTip(wx.ToolTip("choose a crystal structure")) + self.crystr_cbx.Bind(wx.EVT_COMBOBOX, self.on_crystal_select) + + # the atoms that constitute the crystal + self.atoms_txt = wx.StaticText(self.panel, label="Atoms : ") + main_params_sizer.Add(self.atoms_txt, pos=(3, 0), flag=wx.LEFT, border=10) + # to insert the name of the cluster + self.atoms_txc = wx.TextCtrl(self.panel) + main_params_sizer.Add(self.atoms_txc, pos=(3, 1), flag=wx.EXPAND, border=10) + # default value is 'MgO' + self.atoms_txc.SetLabel(self._bulk_operator.atoms) + self.atoms_txc.SetToolTip(wx.ToolTip("the atoms that form the crystal (eg MgO or NaCl)")) + self.atoms_txc.Bind(wx.EVT_TEXT, self.alert_crystal_name) + self.numatoms_txt = wx.StaticText(self.panel, label="this crystal is composed of two atoms") + main_params_sizer.Add(self.numatoms_txt, pos=(4, 1), flag=wx.LEFT, border=10) + + # is cubic + self.is_cubic_txt = wx.StaticText(self.panel, label="Cubic : ") + main_params_sizer.Add(self.is_cubic_txt, pos=(5, 0), flag=wx.TOP | wx.LEFT, border=10) + self.is_cubic_chk = wx.CheckBox(self.panel) + main_params_sizer.Add(self.is_cubic_chk, pos=(5, 1), flag=wx.TOP | wx.EXPAND, border=10) + self.is_cubic_chk.SetValue(self._bulk_operator.is_cubic) + + # is othorhombic + self.is_orth_txt = wx.StaticText(self.panel, label="Orthorhombic : ") + main_params_sizer.Add(self.is_orth_txt, pos=(7, 0), flag=wx.TOP | wx.LEFT, border=10) + self.is_orth_chk = wx.CheckBox(self.panel) + main_params_sizer.Add(self.is_orth_chk, pos=(7, 1), flag=wx.TOP | wx.EXPAND, border=10) + self.is_orth_chk.SetValue(self._bulk_operator.is_orthorombic) + + # lattice parameters + lattice_params_sizer = wx.BoxSizer(wx.VERTICAL) + self.lattice_params_stbox = wx.StaticBox(self.panel, label='Lattice Parameters') + lattice_params_subsizer = wx.StaticBoxSizer(self.lattice_params_stbox, wx.VERTICAL) + + lattice_params_subsizer.AddSpacer(3) + + # lattice parameter a + a_sizer = wx.BoxSizer(wx.HORIZONTAL) + a_txt = wx.StaticText(self.panel, label=" a = ") + self.a_fspin = fs.FloatSpin(self.panel, + value=self._bulk_operator.a, size=(180, -1), + min_val=0.1, max_val=10.00, + increment=0.01, + style=fs.FS_CENTRE) + self.a_fspin.SetFormat("%f") + self.a_fspin.SetDigits(6) + self.a_fspin.Bind(fs.EVT_FLOATSPIN, self.alert_a) + self.a_fspin.Bind(wx.EVT_SPINCTRL, self.on_a_changed) + a_sizer.Add(a_txt) + a_sizer.Add(self.a_fspin) + + lattice_params_subsizer.AddSpacer(10) + + # lattice parameter c + c_sizer = wx.BoxSizer(wx.HORIZONTAL) + self.c_txt = wx.StaticText(self.panel, 6, label=" c = ") + self.c_txt.Disable() + self.c_fspin = fs.FloatSpin(self.panel, + value=self._bulk_operator.c, size=(160, -1), + min_val=0.1, max_val=10.00, increment=0.01) + self.c_fspin.SetFormat("%f") + self.c_fspin.SetDigits(6) + self.c_fspin.Bind(wx.EVT_SPINCTRL, self.on_c_changed) + self.c_fspin.Disable() + c_sizer.Add(self.c_txt) + c_sizer.Add(self.c_fspin) + + # lattice parameter u + u_sizer = wx.BoxSizer(wx.HORIZONTAL) + self.u_txt = wx.StaticText(self.panel, 7, label=" u = ") + self.u_txt.Disable() + self.u_fspin = fs.FloatSpin(self.panel, + value=self._bulk_operator.u, size=(160, -1), + min_val=0.1, max_val=10.00, increment=0.01) + self.u_fspin.SetFormat("%f") + self.u_fspin.SetDigits(6) + self.u_fspin.Disable() + u_sizer.Add(self.u_txt) + u_sizer.Add(self.u_fspin) + + # lattice parameter c/a + covera_sizer = wx.BoxSizer(wx.HORIZONTAL) + self.covera_txt = wx.StaticText(self.panel, label="c/a ratio : ") + self.covera_txt.Disable() + self.covera_fspin = fs.FloatSpin(self.panel, + value='0.0', size=(160, -1), + min_val=0.1, max_val=10.00, increment=0.01) + self.covera_fspin.SetFormat("%f") + self.covera_fspin.SetDigits(6) + self.covera_fspin.Bind(wx.EVT_SPINCTRL, self.on_covera_changed) + self.covera_fspin.Disable() + covera_sizer.Add(self.covera_txt) + covera_sizer.Add(self.covera_fspin) + + lattice_params_subsizer.Add(a_sizer) + lattice_params_subsizer.AddSpacer(10) + lattice_params_subsizer.Add(c_sizer) + lattice_params_subsizer.AddSpacer(10) + lattice_params_subsizer.Add(u_sizer) + lattice_params_subsizer.AddSpacer(10) + lattice_params_subsizer.Add(covera_sizer) + lattice_params_subsizer.AddSpacer(10) + + lattice_params_sizer.Add(lattice_params_subsizer, flag=wx.ALL | wx.EXPAND, border=5) + + ok_cancel_reset_sizer = wx.BoxSizer(wx.HORIZONTAL) + reset_btn = wx.Button(self.panel, 2, label="Reset") + reset_btn.Bind(wx.EVT_BUTTON, self.on_reset_crystal_params) + cancel_btn = wx.Button(self.panel, wx.ID_CANCEL, label="Cancel") + cancel_btn.Bind(wx.EVT_BUTTON, self.on_close, id=wx.ID_CANCEL) + self.ok_btn = wx.Button(self.panel, wx.ID_OK, label="OK") + self.ok_btn.Bind(wx.EVT_BUTTON, self.on_ok, id=wx.ID_OK) + ok_cancel_reset_sizer.Add(reset_btn) + ok_cancel_reset_sizer.Add(cancel_btn) + ok_cancel_reset_sizer.Add(self.ok_btn) + + self.vbox.Add(main_params_sizer) + self.vbox.Add(lattice_params_sizer, proportion=1, flag=wx.LEFT | wx.EXPAND, border=10) + self.vbox.Add(ok_cancel_reset_sizer, flag=wx.ALIGN_RIGHT, border=5) + self.panel.SetSizer(self.vbox) + self.panel.Fit() + self.Fit() + + def on_reset_crystal_params(self, event): + self.on_crystal_select(event) + + def on_close(self, event): + event.Skip() # propagate the event so that the dialog closes + + def on_ok(self, event): + a_val = str(self.a_fspin.GetValue()) + c_val = str(self.c_fspin.GetValue()) + u_val = str(self.u_fspin.GetValue()) + covera_val = str(self.covera_fspin.GetValue()) + + print('bulk = (%s,' % self.atoms_txc.GetValue() + + ' %s,' % self.crystr_cbx.GetValue() + ' a= %s,' % a_val + + ' c= %s,' % c_val + + ' u= %s,' % u_val + + ' c/a ratio= %s,' % covera_val + + ' cubic= %s,' % str(self.is_cubic_chk.GetValue()) + + ' orthorombic= %s)' % str(self.is_orth_chk.GetValue())) + + self._bulk_operator.atoms = self.atoms_txc.GetValue().encode('ascii', 'ignore') + self._bulk_operator.structure = BulkFrame.get_structure_id(self.crystr_cbx.GetValue()) + self._bulk_operator.a = float(a_val) + self._bulk_operator.c = float(c_val) + self._bulk_operator.u = float(u_val) + self._bulk_operator.is_cubic = self.is_cubic_chk.GetValue() + self._bulk_operator.is_orthorombic = self.is_orth_chk.GetValue() + event.Skip() # propagate the event so that the dialog closes + + def alert_a(self, event): + if self.a_fspin.GetValue() == 0.00: + wx.MessageBox("Please enter the parameter a", + style=wx.OK | wx.ICON_MASK) + + def alert_crystal_name(self, event): + if self.atoms_txc.GetValue() == '': + wx.MessageBox("Please enter the Atoms that\ncomposed the crystal ", + style=wx.CANCEL | wx.ICON_MASK) + + def on_a_changed(self, event): + """ + change values of c and covera when the user insert the value of the parameter a + """ + self.covera_fspin.SetValue(self.c_fspin.GetValue() / self.a_fspin.GetValue()) + + def on_c_changed(self, event): + """ + change values of a and covera when the user insert the value of the parameter c + """ + self.covera_fspin.SetValue(self.c_fspin.GetValue() / self.a_fspin.GetValue()) + + """ + def change_covera_val(self): + print ("---_cov_---") + # if self.c_fspin.GetValue() != 0.00000: + self.covera_fspin.SetValue( + self.c_fspin.GetValue() / self.a_fspin.GetValue()) + print ("---***_cov_***---") + """ + + def on_covera_changed(self, event): + """ + change values of c and a when the user + insert the value of the parameter covera + """ + self.change_covera_val() + + def change_covera_val(self): + self.c_fspin.SetValue(self.covera_fspin.GetValue() * self.a_fspin.GetValue()) + + def get_atoms_constraint_msg(self, num_atoms_min, num_atoms_max): + """ + return the constraint of atoms number + """ + message = '' + if num_atoms_min != -1: + message += 'minimum %d atoms' % num_atoms_min + if num_atoms_max != -1: + if len(message) > 0: + message += ', ' + message += 'maximum %d atoms' % num_atoms_max + return message + + def update_widgets(self, enabled_widgets): + """ + manage the widgets + """ + ew = StructureDef.EnabledWidgets + + if enabled_widgets & ew.cubic_flg: + self.is_cubic_txt.Enable() + self.is_cubic_chk.Enable() + self.is_cubic_chk.SetValue(False) + else: + self.is_cubic_chk.SetValue(False) + self.is_cubic_txt.Disable() + self.is_cubic_chk.Disable() + + if enabled_widgets & ew.orth_flg: + self.is_orth_txt.Enable() + self.is_orth_chk.Enable() + self.is_orth_chk.SetValue(False) + else: + self.is_orth_chk.SetValue(False) + self.is_orth_txt.Disable() + self.is_orth_chk.Disable() + + if enabled_widgets & ew.c_flg: + self.c_txt.Enable() + self.c_fspin.Enable() + else: + self.c_txt.Disable() + self.c_fspin.Disable() + + if enabled_widgets & ew.u_flg: + self.u_txt.Enable() + self.u_fspin.Enable() + else: + self.u_txt.Disable() + self.u_fspin.Disable() + + if enabled_widgets & ew.covera_flg: + self.covera_txt.Enable() + self.covera_fspin.Enable() + else: + self.covera_txt.Disable() + self.covera_fspin.Disable() + + def on_crystal_select(self, event): + """ + when the user choose one structure this function will be triggered + """ + + self.selected_crystal_str = self.crystr_cbx.GetValue() + # print self.selected_crystal_str + + crystal_def = self.get_crystal_def(self.selected_crystal_str) + # print ('values : %s' % crystal_def) + self.numatoms_txt.SetLabel(str(self.get_atoms_constraint_msg(crystal_def.min_atoms, crystal_def.max_atoms))) + self.update_widgets(crystal_def.enabled_widgets) + self.atoms_txc.SetLabel(crystal_def.default_atoms) + self.a_fspin.SetValue(crystal_def.default_a) + self.c_fspin.SetValue(crystal_def.default_c) + self.covera_fspin.SetValue(crystal_def.default_c / crystal_def.default_a) + + self.a_fspin.Bind(fs.EVT_FLOATSPIN, self.alert_a) + self.lattice_params_stbox.Refresh() + self.vbox.RecalcSizes() + self.panel.SetSizer(self.vbox) + + +if __name__ == '__main__': + app = wx.App() + BulkFrame(None, title="create a single cell", bulk_operator=None) + app.MainLoop() diff --git a/src/msspec/msspecgui/msspec/gui/clustereditor.py b/src/msspec/msspecgui/msspec/gui/clustereditor.py new file mode 100644 index 0000000..78eb663 --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/clustereditor.py @@ -0,0 +1,294 @@ +''' +Created on Jan 18, 2016 + +@author: graffy +''' + +# standard libraries +import os +import functools +# import math +# import sys +# from fileinput import close + +import ase.io +# 3rd party libraries +import wx +# import cairo +# import wx.lib.wxcairo + +# local libraries +import msspecgui.datafloweditor as datafloweditor +import msspecgui.dataflow as dataflow +from msspecgui.dataflow import IDataType +from msspecgui.msspec.gui.bulk_interface import BulkFrame +from msspecgui.msspec.gui.viewmanager import IViewCreator +from msspecgui.datafloweditor import OperatorGui + +# based on example https://github.com/wxWidgets/wxPython/blob/master/demo/Cairo.py + + +class BackgroundContextMenu(wx.Menu): + ''' + the context menu that the user sees when right-clicking on the background of the dataflow + + ''' + def __init__(self, panel): + """ + :type panel: msspecgui.msspec.gui.ClusterEditor + """ + wx.Menu.__init__(self) + self.m_panel = panel + + # wx.ID_ABOUT and wx.ID_EXIT are standard IDs provided by wxWidgets. + # self.add_cluster_modifier_menu_item = self.Append(wx.ID_ANY,"Add Cluster Modifier"," adds a cluster modifier in the cluster editor") + + self.add_cluster_modifier_menu = wx.Menu() + self.add_cluster_modifier_menu_item = self.AppendMenu(wx.ID_ANY, "Add Cluster Modifier...", self.add_cluster_modifier_menu) + + # self.m_panel.Bind(wx.EVT_MENU, self.on_add_cluster_modifier, self.add_cluster_modifier_menu_item) + + data_flow = self.m_panel.get_cluster_flow() + + for creator in data_flow.get_operator_creators(): + operator_type_id = creator.get_operator_type_id() + + menu_item = self.add_cluster_modifier_menu.Append(wx.ID_ANY, operator_type_id, " adds a cluster modifier in the cluster editor") + # self.m_panel.Bind(wx.EVT_MENU, functools.partial( creator.create_operator, dflow = data_flow), menu_item) + self.m_panel.Bind(wx.EVT_MENU, functools.partial(self.on_add_cluster_modifier, operator_type_id=operator_type_id), menu_item) + + def on_add_cluster_modifier(self, event, operator_type_id): + """Callback that is invoked when the user chooses to add a specific cluster modifier using the context menu + + :param operator_type_id: the type of cluster modifier to add (eg 'ipr.msspec.cutsphere') + """ + self.m_panel.create_operator(operator_type_id) + + +class OperatorContextMenu(wx.Menu): + ''' + the context menu that the user sees when right-clicking on an operator of the dataflow + + ''' + def __init__(self, panel, operator): + """ + :type panel: msspecgui.msspec.gui.ClusterEditor + :type operator: dataflow.operator.Operator + """ + wx.Menu.__init__(self) + self.m_panel = panel + + menu_item = self.Append(wx.ID_ANY, 'delete', "deletes this operator") + self.m_panel.Bind(wx.EVT_MENU, functools.partial(self.on_delete_operator, operator=operator), menu_item) + + for action in operator.creator.get_actions(): + + menu_item = self.Append(wx.ID_ANY, action.get_name(), " performs this action on the operator") + # self.m_panel.Bind(wx.EVT_MENU, functools.partial( creator.create_operator, dflow = data_flow), menu_item) + self.m_panel.Bind(wx.EVT_MENU, functools.partial(self.on_perform_operator_action, action=action, operator=operator), menu_item) + + def on_perform_operator_action(self, event, action, operator): + """Callback that is invoked when the user chooses to add a specific cluster modifier using the context menu + + :param operator_type_id: the type of cluster modifier to add (eg 'ipr.msspec.cutsphere') + :type action: dataflow.ioperatorcreator.IOperatorCreator.IAction + :type operator: dataflow.operator.Operator + """ + action.execute_on_operator(operator) + + def on_delete_operator(self, event, operator): + """Callback that is invoked when the user chooses to delete an operator + + :param dataflow.Operator operator: the operator that needs to be deleted + """ + data_flow = operator.data_flow + data_flow.delete_operator(operator) + + +class WireContextMenu(wx.Menu): + ''' + the context menu that the user sees when right-clicking on a wire of the dataflow + + ''' + def __init__(self, panel, wire): + """ + :param msspecgui.msspec.gui.ClusterEditor panel: + :param dataflow.Wire wire: the wire for which this context menu is created + """ + wx.Menu.__init__(self) + self.m_panel = panel + + # # create a menu item for each wire action + # for wire_action in self.m_panel.get_cluster_flow().wire_actions: + # menu_item = self.Append(wx.ID_ANY, data_action.get_name(), " performs this action on the operator") + # self.m_panel.Bind(wx.EVT_MENU, functools.partial(self.on_perform_data_action, data_action=data_action, data=wire.input_plug.get_value()), menu_item) + menu_item = self.Append(wx.ID_ANY, 'delete', "deletes this wire") + self.m_panel.Bind(wx.EVT_MENU, functools.partial(self.on_delete_wire, wire=wire), menu_item) + + for data_action in wire.data_type.get_actions(): + menu_item = self.Append(wx.ID_ANY, data_action.get_name(), " performs this action on the operator") + self.m_panel.Bind(wx.EVT_MENU, functools.partial(self.on_perform_data_action, data_action=data_action, data=wire.input_plug.get_value()), menu_item) + + # def on_perform_wire_action(self, event, wire_action, wire): + # """Callback that is invoked when the user chooses to add a specific cluster modifier using the context menu + # + # :param dataflow.Wire.IAction wire_action: the action to perform + # :param dataflow.Wire wire: the wire on which to perform the action + # """ + # wire_action.execute_on_wire(wire) + + def on_perform_data_action(self, event, data_action, data): + """Callback that is invoked when the user chooses to add a specific data action using the context menu + + :param dataflow.IDataType.IAction data_action: the action to perform on the given data + :param data: the data on which to perform the action + """ + assert isinstance(data, data_action.datatype.get_python_class()) + data_action.execute_on_data(data) + + def on_delete_wire(self, event, wire): + """Callback that is invoked when the user chooses to delete a wire using the context menu + + :param dataflow.Wire wire: the wire that needs to be deleted + """ + data_flow = wire.data_flow + data_flow.delete_wire(wire) + + +def opj(path): + """Convert paths to the platform-specific separator""" + platform_path = apply(os.path.join, tuple(path.split('/'))) + # HACK: on Linux, a leading / gets lost... + if path.startswith('/'): + platform_path = '/' + platform_path + return platform_path + + +class BulkGui(dataflow.IOperatorCreator.IAction): + + def get_name(self): + return 'properties via gui' + + def execute_on_operator(self, operator): + """ + :type operator: dataflow.operator.Operator + """ + dialog = BulkFrame(None, title="create a single cell", bulk_operator=operator) + print("execute_on_operator : before MainLoop") + result = dialog.ShowModal() + if result == wx.ID_OK: + print("execute_on_operator : signaling operator %d as modified" % operator.id) + operator.data_flow.on_modified_operator(operator) + print "OK" + else: + print "Cancel" + dialog.Destroy() + + +class ExportCluster(IDataType.IAction): + + def __init__(self, cluster_flow): + """ + :param msspecgui.cluster.ClusterFlow cluster_flow: + """ + super(ExportCluster, self).__init__(cluster_flow.get_data_type('physics.atomscluster')) + + def get_name(self): + return 'export cluster' + + def execute_on_data(self, data): + """ + :param data: the data on which this action needs to be performed + """ + assert isinstance(data, self.datatype.get_python_class()) + dlg = wx.FileDialog(None, message="Choose a file to store this cluster (the format of the file is defined by the file's extension)", defaultDir='', defaultFile='', style=wx.FD_SAVE) + if dlg.ShowModal() == wx.ID_OK: + cluster_file_path = dlg.GetPath() + ase.io.write(cluster_file_path, data) + dlg.Destroy() + + +class ClusterEditor(datafloweditor.DataflowView): + + class Creator(IViewCreator): + VIEW_TYPE_NAME = 'cluster editor' + + def __init__(self, workspace): + """ + :param msspecgui.msspec.Workspace workspace: the workspace that is associated with the cluster editors created by this creator + """ + self._workspace = workspace + + @property + def view_type_name(self): + """ + :return str: + """ + return self.VIEW_TYPE_NAME + + def create_view(self, parent): + """ + :param wx.Window parent: the wx.Window that owns the view + :return wx.Panel: + """ + return ClusterEditor(parent, self._workspace.get_cluster_flow()) + + def __init__(self, parent, cluster_flow): + """ + :param cluster_flow: the dataflow that this editor manipulates + :type cluster_flow: msspec.cluster.clusterflow.ClusterFlow + + """ + super(ClusterEditor, self).__init__(parent, cluster_flow, -1) + + for operator_creator in cluster_flow.get_operator_creators(): + if operator_creator.get_operator_type_id() == 'ase.lattice.bulk': + operator_creator.register_operator_action(BulkGui()) + else: + operator_creator.register_operator_action(OperatorGui()) + + datatype = cluster_flow.get_data_type('physics.atomscluster') + datatype.register_datatype_action(ExportCluster(cluster_flow)) + + def create_operator(self, operator_type_id): + operator = self.get_cluster_flow().create_operator(operator_type_id) + self.get_cluster_flow().add_operator(operator) + + def get_cluster_flow(self): + """ + :rtype: msspec.cluster.clusterflow.ClusterFlow + """ + return self.dataflow + + def on_background_context_menu(self, event): + ''' + called whenever the user right-clicks in the background of the dataflow + ''' + pos = event.GetPosition() + # print(pos) + pos = self.ScreenToClient(pos) + self.PopupMenu(BackgroundContextMenu(self), pos) + + def on_operator_context_menu(self, event, operator): + ''' + called whenever the user right-clicks in an operator of the dataflow + + :type event: wx.Event + :type operator: dataflow.operator.Operator + ''' + pos = event.GetPosition() + # print(pos) + pos = self.ScreenToClient(pos) + self.PopupMenu(OperatorContextMenu(self, operator), pos) + + def on_wire_context_menu(self, event, wire): + ''' + called whenever the user right-clicks in a wire of the dataflow + + :type event: wx.Event + :param dataflow.Wire wire: + ''' + pos = event.GetPosition() + # print(pos) + pos = self.ScreenToClient(pos) + self.PopupMenu(WireContextMenu(self, wire), pos) diff --git a/src/msspec/msspecgui/msspec/gui/clusterview.py b/src/msspec/msspecgui/msspec/gui/clusterview.py new file mode 100644 index 0000000..fb27467 --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/clusterview.py @@ -0,0 +1,201 @@ + +import wx +from msspecgui.msspec.gui.clusterviewer import ClusterViewer +from msspecgui.dataflow import DataFlow +from msspecgui.msspec.gui.viewmanager import IViewCreator + + +class ClusterView(wx.Window): + """ + a view that allows the user to view a cluster and also to select which cluster is viewed + """ + + class Creator(IViewCreator): + + VIEW_TYPE_NAME = '3d cluster viewer' + + def __init__(self, cluster_flow): + """ + :param msspecgui.msspec.cluster.clusterflow.ClusterFlow cluster_flow: the cluster flow that is associated with the cluster viewers created with this creator + """ + self._cluster_flow = cluster_flow + + @property + def view_type_name(self): + """ + :return str: + """ + return self.VIEW_TYPE_NAME + + def create_view(self, parent): + """ + :param wx.Window parent: the wx.Window that owns the view + :return wx.Panel: + """ + return ClusterView(self._cluster_flow, parent) + + class ClusterFlowEventsHandler(DataFlow.IDataFlowEventsHandler): + + def __init__(self, cluster_view): + """ + :type cluster_view: ClusterView + """ + super(ClusterView.ClusterFlowEventsHandler, self).__init__() + self._cluster_view = cluster_view + # self._selected_cluster_chc = selected_cluster_chc + # self.__dataflow = dataflow + + def on_added_operator(self, operator): + """ + :type operator: Operator + """ + super(ClusterView.ClusterFlowEventsHandler, self).on_added_operator(operator) + self._cluster_view.update_cluster_cbx() + + def on_deleted_operator(self, operator): + """ + :param Operator operator: + """ + super(ClusterView.ClusterFlowEventsHandler, self).on_deleted_operator(operator) + # the available clusters might have changed + self._cluster_view.update_cluster_cbx() + # force an update of the displayed atoms + if self._cluster_view.selected_cluster is not None: + self._cluster_view.selected_cluster = self._cluster_view.selected_cluster + + def on_modified_operator(self, operator): + """ + :type operator: Operator + """ + super(ClusterView.ClusterFlowEventsHandler, self).on_modified_operator(operator) + self._cluster_view.update_cluster_cbx() + # force an update of the displayed atoms + if self._cluster_view.selected_cluster is not None: + self._cluster_view.selected_cluster = self._cluster_view.selected_cluster + + def on_added_wire(self, wire): + super(ClusterView.ClusterFlowEventsHandler, self).on_added_wire(wire) + self._cluster_view.update_cluster_cbx() + + def on_deleted_wire(self, wire): + super(ClusterView.ClusterFlowEventsHandler, self).on_deleted_wire(wire) + self._cluster_view.update_cluster_cbx() + # force an update of the displayed atoms + if self._cluster_view.selected_cluster is not None: + self._cluster_view.selected_cluster = self._cluster_view.selected_cluster + + def __init__(self, cluster_dataflow, *args, **kwargs): + """ + :param msspecgui.msspec.cluster.clusterflow.ClusterFlow cluster_dataflow: the cluster flow to which this view is attached + """ + super(ClusterView, self).__init__(*args, **kwargs) + self._cluster_dataflow = cluster_dataflow + self._available_clusters = None + self._selected_cluster = None + + main_box = wx.BoxSizer(wx.VERTICAL) + self.SetSizer(main_box) + + # add the choice widget that allows the user to select the cluster he wants to view + widgets_border = 1 # number of pixels used as a border between widgets + widgets_spacing = 3 # size of the spacings separating widgets, in pixels + selected_cluster_box = wx.BoxSizer(wx.HORIZONTAL) + selected_cluster_lbl = wx.StaticText(self, id=-1, label=u'Viewed cluster') + selected_cluster_box.Add(selected_cluster_lbl) + selected_cluster_box.AddSpacer(widgets_spacing) + self._selected_cluster_chc = wx.Choice(self, size=wx.Size(400, -1)) + selected_cluster_box.Add(self._selected_cluster_chc) + main_box.Add(selected_cluster_box, proportion=0, flag=wx.TOP | wx.BOTTOM, border=widgets_border) + self._selected_cluster_chc.Bind(wx.EVT_CHOICE, self.on_cluster_selection_changed) + + main_box.AddSpacer(widgets_spacing) + + self._cluster_viewer = ClusterViewer(self) + #self._cluster_viewer.light_mode_threshold = 2 + main_box.Add(self._cluster_viewer, proportion=1, flag=wx.EXPAND | wx.TOP | wx.BOTTOM, border=widgets_border) + + self._clusterflow_events_handler = ClusterView.ClusterFlowEventsHandler(self) + self._cluster_dataflow.add_dataflow_events_handler(self._clusterflow_events_handler) + self._clusterflow_events_handler.on_added_operator(operator=None) + self.Bind(wx.EVT_CLOSE, self.on_close) + + def on_close(self, event): + print("ClusterView.on_close") + self._cluster_dataflow.remove_dataflow_events_handler(self._clusterflow_events_handler) + self.Close(True) + + @property + def cluster_viewer(self): + return self._cluster_viewer + + @classmethod + def _get_cluster_id_string(cls, plug): + """ + :type plug: Plug + :rtype: str + """ + op = plug.operator + cluster_id = '%s(%d).%s' % (op.creator.get_operator_type_id(), op.id, plug.name) + return cluster_id + + def update_cluster_cbx(self): + """update the widget that allows the user to choose the viewed cluster + """ + print('update_cluster_cbx') + available_clusters = [] + + for op in self._cluster_dataflow.operators: + # cluster_id = '%s (%d)' % (op.creator.get_operator_type_id(), op.id) + for plug in op.get_output_plugs(): + # cluster_id += '.' + plug.name + # available_clusters.append(self._get_cluster_id_string(plug)) + if plug.value_is_available(): # only propose the clusters that can be computed + available_clusters.append(plug) + # if len(available_clusters) == 0: + # available_clusters.append('no cluster available') + self._selected_cluster_chc.SetItems([self._get_cluster_id_string(plug) for plug in available_clusters]) + self._available_clusters = dict(enumerate(available_clusters)) + + # keep the selected cluster in the choices, if possible + if self._selected_cluster is not None: + selected_cluster_indices = [k for k, plug in self._available_clusters.items() if plug == self._selected_cluster] + if len(selected_cluster_indices) != 0: + selected_cluster_index = selected_cluster_indices[0] + self._selected_cluster_chc.SetSelection(selected_cluster_index) + else: + # the selected cluster is no longer available (for example because its operator has been deleted) + self._selected_cluster_chc.SetSelection(wx.NOT_FOUND) + self.selected_cluster = None + + @property + def selected_cluster(self): + """ + :rtype: dataflow.Plug + """ + return self._selected_cluster + + @selected_cluster.setter + def selected_cluster(self, selected_cluster): + """ + :param dataflow.Plug selected_cluster: + """ + self._selected_cluster = selected_cluster + if selected_cluster is not None: + # print('ClusterView.selected_cluster : setting self._selected_cluster to %s' % selected_cluster.name) + + # print("ClusterView.selected_cluster : updating viewed atoms") + self._cluster_viewer.set_atoms(selected_cluster.get_value(), rescale=True) + else: + self._cluster_viewer.set_atoms(None, rescale=True) + + def on_cluster_selection_changed(self, event): + """ + callback when the user changes the selected cluster in the choice widget + + :type event: wx.CommandEvent + """ + if len(self._available_clusters) != 0: + new_selected_cluster = self._available_clusters[event.GetInt()] + else: + new_selected_cluster = None + self.selected_cluster = new_selected_cluster diff --git a/src/msspec/msspecgui/msspec/gui/clusterviewer.py b/src/msspec/msspecgui/msspec/gui/clusterviewer.py new file mode 100644 index 0000000..2031ade --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/clusterviewer.py @@ -0,0 +1,897 @@ +# -*- encoding: utf-8 -*- +# vim: set fdm=indent ts=2 sw=2 sts=2 et tw=80 cc=+1 mouse=a nu : # +# import wx + +import numpy as np +# from time import clock +# import copy + +import cairo +import wx.lib.wxcairo + +# import ase +from ase.data import covalent_radii +from ase.data.colors import jmol_colors + + +class ClusterViewer(wx.Window): + """ + :param mx: last mouse position in x + :param my: last mouse position in y + """ + MODE_NONE = 0b0000000 + MODE_SELECTION = 0b0000001 + MODE_SELECTION_BOX = 0b0000010 + MODE_SELECTION_APPEND = 0b0000100 + MODE_SELECTION_TOGGLE = 0b0001000 + MODE_TRANSLATION = 0b0010000 + MODE_ROTATION = 0b0100000 + + def __init__(self, *args, **kwargs): + kwargs['style'] = wx.NO_FULL_REPAINT_ON_RESIZE | wx.CLIP_CHILDREN + wx.Window.__init__(self, *args, **kwargs) + + self.ox = self.oy = 0 # offset in x and y + self.im_ox = self.im_oy = 0 # image offset in x and y + self.last_mouse_move_x = self.last_mouse_move_y = 0 # last mouse move + self.mx = self.my = 0 # last mouse position + self.theta = self.phi = 0 + self.scale = self.scale0 = 100 + self.im_factor = self.im_scale = 1 + self.atoms = None + # self.do_rescale = False + # self.do_center = False + self.atoms_center_of_mass = np.zeros(3) + self.atoms_largest_dimension = 1.0 # float, in angstrom + self.selection = [] + self.selection_box = None + self.__outer_margin = 0 + self.surface = None + self.busy = False + self.refresh_delay = 200 + self.back_buffer = None + self.screenshot = None + self.atom_numbers = None + self.atom_surfaces = None + self.atoms_sprite = None + self.background_sprite = None + + self.mode = self.MODE_NONE + + self.colors = { + 'selection_box': (0.0, 0.4, 1.0), + 'boulding_box_line': (0.0, 0.4, 1.0, 1.0), + 'boulding_box_fill': (0.0, 0.4, 1.0, 0.3), + } + self.sprites_opts = {'alpha': 1, 'glow': True} + + self.light_mode = False + self.light_mode_threshold = 2000 + + self.rotation_matrix = np.identity(4) + self.scale_matrix = np.identity(4) + self.translation_matrix = np.identity(4) + self.model_matrix = np.identity(4) + self.projection_matrix = np.identity(4) + # model to world matrix + self.m2w_matrix = np.identity(4) + # world to view matrix + self.w2v_matrix = np.identity(4) + # view to projection matrix + viewport = (-1., 1., -1., 1., -1., 1.) + self.v2p_matrix = self.create_v2p_matrix(*viewport) + + self.projections = None + + self.timer = wx.Timer(self) + self.Bind(wx.EVT_PAINT, self.__evt_paint_cb) + self.Bind(wx.EVT_SIZE, self.__evt_size_cb) + self.Bind(wx.EVT_MOUSEWHEEL, self.__evt_mousewheel_cb) + self.Bind(wx.EVT_MOTION, self.__evt_motion_cb) + self.Bind(wx.EVT_LEFT_DOWN, self.__evt_left_down_cb) + self.Bind(wx.EVT_LEFT_UP, self.__evt_left_up_cb) + self.Bind(wx.EVT_RIGHT_UP, self.__evt_right_up_cb) + self.Bind(wx.EVT_TIMER, self.__evt_timer_cb, self.timer) + + def show_emitter(self, show=True): + _opts = self.sprites_opts.copy() + if show: + self.sprites_opts['alpha'] = 0.25 + self.sprites_opts['glow'] = False + else: + self.sprites_opts = _opts.copy() + + def set_atoms(self, atoms, rescale=False, center=True): + """ + Attach an Atoms object to the view. + + This will translate the model to the center of mass, move the model center + to the center of screen and adjust the scale to the largest dimension of the + model + + :param rescale: if True, the zoom is computed to view the atoms; if False, a fixed zoom value is used + """ + if atoms is None: + self.light_mode = False + self.atoms_center_of_mass = np.zeros(3) + self.atoms_largest_dimension = 1.0 + self.atom_numbers = None + self.atom_surfaces = None + self.atoms_sprite = None + self.projections = None + else: + # Set the light mode according to the number of atoms + if len(atoms) > self.light_mode_threshold: # pylint: disable=simplifiable-if-statement + self.light_mode = True + else: + self.light_mode = False + + # get the center of mass + self.atoms_center_of_mass = atoms.get_center_of_mass() + # get the largest dimension + p = atoms.get_positions() + self.atoms_largest_dimension = np.max(np.amax(p, axis=0) - np.amin(p, axis=0)) + if self.atoms_largest_dimension == 0: + self.atoms_largest_dimension = 1.0 + + # make atoms a class attribute + self.atoms = atoms + # self.do_rescale = rescale + # self.do_center = center + self.update_camera(center=center, rescale=rescale) + # create the textures + self.create_atom_sprites() + # finally update the view + self.update_drawing() + + def rotate_atoms(self, dtheta, dphi): + self.theta += dtheta + self.phi += dphi + + tx, ty = (self.theta, self.phi) + m_mat = np.zeros((4, 4)) + m_mat[0, 0] = m_mat[3, 3] = 1 + m_mat[1, 1] = m_mat[2, 2] = np.cos(np.radians(tx)) + m_mat[2, 1] = -np.sin(np.radians(tx)) + m_mat[1, 2] = np.sin(np.radians(tx)) + + n_mat = np.zeros((4, 4)) + n_mat[1, 1] = n_mat[3, 3] = 1 + n_mat[0, 0] = n_mat[2, 2] = np.cos(np.radians(ty)) + n_mat[0, 2] = -np.sin(np.radians(ty)) + n_mat[2, 0] = np.sin(np.radians(ty)) + + self.rotation_matrix = np.dot(m_mat, n_mat) + self.update_model_matrix() + self.scale_atoms(self.scale) + + def scale_atoms(self, factor): + self.scale = factor + self.scale_matrix[(0, 1, 2), (0, 1, 2)] = factor + self.create_atom_sprites() + self.update_projection_matrix() + + def translate_atoms(self, x, y): + """ + sets the translation of the atoms + """ + # print('translate_atoms : x=%f, y=%f' % (x, y)) + self.ox = x + self.oy = y + self.im_ox += self.last_mouse_move_x + self.im_oy += self.last_mouse_move_y + self.last_mouse_move_x = self.last_mouse_move_y = 0 + self.translation_matrix[-1, (0, 1)] = (x, y) + self.update_projection_matrix() + # print('translate_atoms : self.projection_matrix=%s' % str(self.projection_matrix)) + + def select_atoms(self, x, y, w=None, h=None, append=False, + toggle=False): + selection = np.array([]) + if w is None and h is None: + # get the projections + p = self.projections.copy() + # translate to the event point + p[:, :2] -= (x, y) + # compute the norm and the radius for each projected atom + norm = np.linalg.norm(p[:, :2], axis=1) + radii = covalent_radii[p[:, 4].astype(int)] * self.scale + # search where the norm is inside an atom + i = np.where(norm < radii) + # pick up the atom index of the one with the z min + try: + selection = np.array([int(p[i][np.argmin(p[i, 2]), 5])]) + # self.selection = np.array([selection]) + except: + pass + else: + if w < 0: + x += w + w = abs(w) + if h < 0: + y += h + h = abs(h) + p = self.projections.copy() + p = p[np.where(p[:, 0] > x)] + p = p[np.where(p[:, 0] < x + w)] + p = p[np.where(p[:, 1] > y)] + p = p[np.where(p[:, 1] < y + h)] + selection = p[:, -1].astype(int) + + if toggle: + print(self.selection) + # whether atoms in the current selection were previously selected + i = np.in1d(self.selection, selection) + print(i) + self.selection = self.selection[np.invert(i)] + + if append: + self.selection = np.append(self.selection, selection) + self.selection = np.unique(self.selection) + else: + self.selection = selection + + def __evt_paint_cb(self, event): + self.swap_buffers() + + def __evt_size_cb(self, event): + self.timer.Stop() + self.timer.Start(self.refresh_delay) + size = self.GetClientSize() + self.back_buffer = cairo.ImageSurface(cairo.FORMAT_RGB24, *size) + self.create_background_sprite(*size) + self.update_drawing() + + def __evt_timer_cb(self, event): + self.update_drawing(light=False) + self.timer.Stop() + + def __evt_left_down_cb(self, event): + self.mx = event.GetX() + self.my = event.GetY() + self.capture_screen() + if event.ControlDown(): + self.mode |= self.MODE_SELECTION + if event.ShiftDown(): + self.mode |= self.MODE_SELECTION_APPEND + if event.AltDown(): + self.mode |= self.MODE_SELECTION_TOGGLE + + def __evt_left_up_cb(self, event): + if self.mode & self.MODE_SELECTION: + self.mode ^= self.MODE_SELECTION + # search for atoms in the selection box + x, y = event.GetPosition() + w = h = None + if self.mode & self.MODE_SELECTION_BOX: + self.mode ^= self.MODE_SELECTION_BOX + x, y, w, h = self.selection_box + + append = False + if self.mode & self.MODE_SELECTION_APPEND: + self.mode ^= self.MODE_SELECTION_APPEND + append = True + + toggle = False + if self.mode & self.MODE_SELECTION_TOGGLE: + self.mode ^= self.MODE_SELECTION_TOGGLE + toggle = True + + self.select_atoms(x, y, w, h, append=append, toggle=toggle) + + if self.mode == self.MODE_TRANSLATION: + self.mode ^= self.MODE_TRANSLATION + + self.update_drawing(light=False) + + def __evt_right_up_cb(self, event): + if self.mode & self.MODE_ROTATION: + self.mode ^= self.MODE_ROTATION + self.update_drawing(light=False) + + def __evt_motion_cb(self, event): + self.timer.Stop() + self.timer.Start(self.refresh_delay) + if event.LeftIsDown(): + mx, my = event.GetPosition() + dx, dy = (mx - self.mx, my - self.my) + # if event.ControlDown(): + if self.mode & self.MODE_SELECTION: + self.mode |= self.MODE_SELECTION_BOX + # if event.ShiftDown(): + # self.mode |= self.MODE_SELECTION_APPEND + self.selection_box = [self.mx, self.my, dx, dy] + else: + self.mode = self.MODE_TRANSLATION + self.mx, self.my = (mx, my) + self.last_mouse_move_x = int(dx) + self.last_mouse_move_y = int(dy) + self.ox = int(self.ox + dx) + self.oy = int(self.oy + dy) + self.translate_atoms(self.ox, self.oy) + self.update_drawing() + elif event.RightIsDown(): + self.mode = self.MODE_ROTATION + theta = 2. * (float(self.scale0) / self.scale) + theta = max(1., theta) + mx, my = event.GetPosition() + dx, dy = (mx - self.mx, my - self.my) + self.mx, self.my = (mx, my) + + tx = theta * np.sign(dy) + ty = theta * np.sign(dx) + self.rotate_atoms(tx, ty) + + self.update_drawing() + + def __evt_mousewheel_cb(self, event): + rot = event.GetWheelRotation() + self.timer.Stop() + self.timer.Start(self.refresh_delay) + if rot > 0: + factor = self.scale * 1.1 + im_factor = 1 * 1.1 + elif rot < 0: + factor = self.scale / 1.1 + im_factor = 1 / 1.1 + self.im_factor = im_factor + self.scale_atoms(factor) + self.update_drawing() + + def capture_screen(self): + # get size of screen + w, h = self.GetClientSize() + # create a cairo surface and context + surface = cairo.ImageSurface(cairo.FORMAT_RGB24, w, h) + ctx = cairo.Context(surface) + # trick here: blit the last back_buffer onto the newly created surface + ctx.set_source_surface(self.back_buffer) + ctx.paint() + # store it as an attribute + self.screenshot = surface + + def create_atom_sprites(self): + """ + This function creates a list of cairo surfaces for each kind + of atoms + """ + + # Get out if there are no atoms + if not self.atoms: + return + + # First get an array of all atoms numbers + atom_numbers = np.unique(self.atoms.numbers) + + # Now, for each kind of atoms create a surface in memory + atom_surfaces = np.empty((2, len(atom_numbers)), dtype=object) + self.__outer_margin = 0 + def create_surface(atom_number, alpha=1, glow=True): + #global margin + # get the radius, and the color + radius = int(covalent_radii[atom_number] * 1. * self.scale) + r, g, b = jmol_colors[atom_number] + # actually create the surface + size = 2 * radius #+ 4 + self.__outer_margin = np.maximum(self.__outer_margin, size / 2.) + surface = cairo.ImageSurface(cairo.FORMAT_ARGB32, size, size) + # draw the ball + ctx = cairo.Context(surface) + # ctx.set_antialias(cairo.ANTIALIAS_NONE) + ctx.set_line_width(1.) + ctx.set_source_rgba(r, g, b, alpha) + ctx.arc(radius, radius, radius - 0.5, 0, 2 * np.pi) + ctx.fill_preserve() + if glow: + gradient = cairo.RadialGradient(radius, radius, radius / 2, + radius, radius, radius) + gradient.add_color_stop_rgba(0., 1., 1., 1., .5) + gradient.add_color_stop_rgba(0.5, 1., 1., 1., 0) + gradient.add_color_stop_rgba(1., 1., 1., 1., 0.) + ctx.set_source(gradient) + ctx.fill_preserve() + ctx.set_source_rgba(0., 0., 0., alpha) + ctx.stroke() + + # Create the overlay for selection + overlay = cairo.ImageSurface(cairo.FORMAT_ARGB32, size, size) + # draw the circle + ctx = cairo.Context(overlay) + ctx.set_source_surface(surface) + ctx.paint() + ctx.set_line_width(2.) + ctx.set_source_rgb(1 - r, 1 - g, 1 - b) + ctx.arc(radius, radius, radius - 2., 0, 2 * np.pi) + ctx.stroke() + + return surface, overlay + + for i, a in enumerate(atom_numbers): + surface, overlay = create_surface(a, alpha=self.sprites_opts['alpha'], + glow=self.sprites_opts['glow']) + atom_surfaces[0, i] = surface + atom_surfaces[1, i] = overlay + """ + # get the radius, and the color + radius = int(covalent_radii[a] * 1. * self.scale) + # b, g, r = jmol_colors[a] + r, g, b = jmol_colors[a] + # actually create the surface + size = 2 * radius + 4 + margin = np.maximum(margin, size / 2.) + surface = cairo.ImageSurface(cairo.FORMAT_ARGB32, size, size) + # draw the ball + ctx = cairo.Context(surface) + # ctx.set_antialias(cairo.ANTIALIAS_NONE) + ctx.set_line_width(1.) + ctx.set_source_rgba(r, g, b, self.sprites_opts['alpha']) + ctx.arc(radius, radius, radius - 0.5, 0, 2 * np.pi) + ctx.fill_preserve() + if self.sprites_opts['glow']: + gradient = cairo.RadialGradient(radius, radius, radius / 2, + radius, radius, radius) + gradient.add_color_stop_rgba(0., 1., 1., 1., .5) + gradient.add_color_stop_rgba(0.5, 1., 1., 1., 0) + gradient.add_color_stop_rgba(1., 1., 1., 1., 0.) + ctx.set_source(gradient) + ctx.fill_preserve() + ctx.set_source_rgba(0., 0., 0., self.sprites_opts['alpha']) + ctx.stroke() + # store it + atom_surfaces[0, i] = surface + + # Create the overlay for selection + overlay = cairo.ImageSurface(cairo.FORMAT_ARGB32, size, size) + # draw the circle + ctx = cairo.Context(overlay) + ctx.set_source_surface(surface) + ctx.paint() + ctx.set_line_width(2.) + ctx.set_source_rgb(1 - r, 1 - g, 1 - b) + ctx.arc(radius, radius, radius - 2., 0, 2 * np.pi) + ctx.stroke() + atom_surfaces[1, i] = overlay + """ + + self.atom_numbers = atom_numbers + self.atom_surfaces = atom_surfaces + try: + absorber_number = self.atoms[self.atoms.info['absorber']].number + self.absorber_surface = create_surface(absorber_number, alpha=1, glow=True) + except: + self.atoms.info['absorber'] = -1 + self.__outer_margin *= 1.1 + + def create_background_sprite(self, w, h): + + surface = cairo.ImageSurface(cairo.FORMAT_ARGB32, w, h) + ctx = cairo.Context(surface) + + if True: # pylint: disable=using-constant-test + g = cairo.LinearGradient(0, 0, 0, h) + g.add_color_stop_rgba(0.0, 1.0, 1.0, 1.0, 1.0) + g.add_color_stop_rgba(0.7, 1.0, 1.0, 1.0, 1.0) + g.add_color_stop_rgba(1.0, 0.5, 0.5, 0.5, 1.0) + ctx.set_source(g) + ctx.rectangle(0, 0, w, h) + ctx.fill() + + g = cairo.LinearGradient(0, 0, 0, h) + #g.add_color_stop_rgba(0., 1., 1., 1., 1.) + #g.add_color_stop_rgba(2 / 3., 0.5, 0.5, 0.5, 1) + #g.add_color_stop_rgba(0.0, 1.0, 1.0, 1.0, 1.0) + #g.add_color_stop_rgba(0.9, 0.8, 0.8, 0.8, 1.0) + #g.add_color_stop_rgba(1.0, 0.2, 0.2, 0.2, 1.0) + #ctx.set_source(g) + ctx.set_source_rgb(1, 1, 1) + ctx.rectangle(0, 0, w, h) + ctx.fill() + + ctx.save() + + if False: + ctx.set_source_rgb(0.8, 0.8, 0.8) + rect = (0, 2 * h / 3, w, h / 3) + ctx.rectangle(*rect) + ctx.clip() + ctx.paint() + ctx.set_line_width(1.) + for i in np.arange(0, 2 * np.pi, np.pi / 30): + ctx.move_to(w / 2, 2 * h / 3) + x1 = w * np.cos(i) + y1 = w * np.sin(i) + ctx.rel_line_to(x1, y1) + for i in np.arange(2 * h / 3, h, 10): + ctx.move_to(0, i) + ctx.line_to(w, i) + + ctx.set_source_rgb(0.7, 0.7, 0.7) + ctx.stroke() + ctx.restore() + + self.background_sprite = surface + + @classmethod + def create_v2p_matrix(cls, left, right, bottom, top, near, far): + """ + creates the matrix that transforms coordinates from view space (space defined by the bounding box passed as argument) to projection space + + this transformation is a scale and offset that maps [left; right], [bottom; top], [near; far] to [-1;1], [-1;1], [0;1] + """ + v2p_matrix = np.eye(4) + v2p_matrix[0, 0] = 2. / (right - left) + v2p_matrix[1, 1] = 2. / (right - left) + v2p_matrix[2, 2] = 1. / (near - far) + v2p_matrix[3, 0] = (left + right) / (left - right) + v2p_matrix[3, 1] = (top + bottom) / (bottom - top) + v2p_matrix[3, 2] = near / (near - far) + return v2p_matrix + + def update_projection_matrix(self): + # print('update_projection_matrix : self.v2p_matrix=%s' % str(self.v2p_matrix)) + # print('update_projection_matrix : self.translation_matrix=%s' % str(self.translation_matrix)) + m_matrix = np.dot(self.v2p_matrix, self.scale_matrix) + m_matrix = np.dot(m_matrix, self.translation_matrix) + self.projection_matrix = m_matrix + # print('update_projection_matrix : self.projection_matrix=%s' % str(self.projection_matrix)) + + def update_model_matrix(self): + m_matrix = np.dot(self.m2w_matrix, self.rotation_matrix) + self.model_matrix = m_matrix + + def get_projections(self, points, save=False): + m_matrix = np.dot(self.model_matrix, self.projection_matrix) + # print('get_projections : self.model_matrix = %s' % str(self.model_matrix)) + # print('get_projections : self.projection_matrix = %s' % str(self.projection_matrix)) + # print('get_projections : m_matrix = %s' % str(m_matrix)) + + p = points[:, :4] + v = np.dot(p, m_matrix) + v = v / v[:, -1, None] + + # add the other columns + v = np.c_[v, points[:, 4:]] + # and sort by Z + # v = v[v[:,2].argsort()[::-1]] + + if save: + self.projections = v + return v + + def filter_projections(self, projections, w, h): + try: + # filtering + margin = self.__outer_margin + projections = projections[projections[:, 0] >= -1 * margin, :] + projections = projections[projections[:, 0] <= w + margin, :] + projections = projections[projections[:, 1] >= -1 * margin, :] + projections = projections[projections[:, 1] <= h + margin, :] + return projections + + except: + pass + + def render_background(self, ctx): + surface = self.background_sprite + ctx.set_source_surface(surface, 0, 0) + ctx.paint() + + def render_scalebar(self, ctx): + x, y, w, h = ctx.clip_extents() # @UnusedVariable + scalebar_bb_width = 200 + scalebar_bb_height = 20 + ctx.set_source_rgba(0., 0., 0., 0.7) + ctx.rectangle(x + w - scalebar_bb_width - 6, h - scalebar_bb_height - 6, scalebar_bb_width, scalebar_bb_height) + ctx.fill() + + ctx.set_source_rgb(1, 1, 1) + ctx.rectangle(x + w - scalebar_bb_width, h - scalebar_bb_height, 100, scalebar_bb_height - 12) + ctx.fill() + + ctx.move_to(x + w - scalebar_bb_width / 2 + 6, h - 9) + ctx.set_source_rgb(1, 1, 1) + ctx.set_font_size(16) + ctx.show_text("%.2f \xc5" % (100. / self.scale)) + + def render_axes(self, ctx): + _, _, w, h = ctx.clip_extents() # @UnusedVariable + m_matrix = np.dot(self.rotation_matrix, self.v2p_matrix) + + d = 20 + offset = 12 + + origin = np.array([0, 0, 0, 1]) # @UnusedVariable + x_axis = np.array([d, 0, 0, 1]) + y_axis = np.array([0, d, 0, 1]) + z_axis = np.array([0, 0, d, 1]) + + # translation = np.array([[1, 0, 0, d + offset], # @UnusedVariable + # [0, 1, 0, h - offset], + # [0, 0, 1, 1 ], + # [0, 0, 0, 1 ]]) + + red = (1, 0, 0) + green = (0, 0.7, 0) + blue = (0, 0, 1) + + # draw a white circle + so = np.array([d + offset, h - d - offset, 0]) + ctx.move_to(d + offset, h - d - offset) + ctx.arc(d + offset, h - d - offset, d + offset - 2, 0, 2 * np.pi) + #ctx.set_source_rgb(1, 1, 1) + ctx.set_source_rgba(0., 0., 0., 0.7) + ctx.set_line_width(1) + #ctx.stroke_preserve() + ctx.set_source_rgba(0.95, 0.95, 0.95, 1) + ctx.fill() + + for axis, color, label in ((x_axis, red, 'X'), + (y_axis, green, 'Y'), + (z_axis, blue, 'Z')): + axis = np.dot(axis, m_matrix) + axis /= axis[-1] + ctx.move_to(*so[:2]) + ctx.rel_line_to(*axis[:2]) + ctx.set_source_rgb(*color) + ctx.set_line_width(2) + ctx.set_font_size(10) + ctx.show_text(label) + ctx.stroke() + + def render_atoms(self, ctx): + try: + atoms = self.atoms + except: + return + + # create a points matrix with homogeneous coordinates + # x,y,z,w and the atom number and index + points = atoms.get_positions() + points = np.c_[points, np.ones(len(points))] + points = np.c_[points, atoms.numbers] + points = np.c_[points, np.arange(len(atoms))] + + # Get the points array projected to the screen display + projections = self.get_projections(points, save=True) + # print('render_atoms : len(projections) = %d' % len(projections)) + # print('render_atoms : projections = %s' % str(projections)) + + # Reduce the number of atoms to be drawn if outside the viewport + w, h = self.GetClientSize() + # print('render_atoms : w = %f, h = %f' % (w, h)) + projections = self.filter_projections(projections, w, h) + # self.projections = projections + + if len(projections) == 0: + print('render_atoms : no atom is visible') + return # no atom is visible from the camera + + # sort by z + projections = projections[projections[:, 2].argsort()[::-1]] + + margin = self.__outer_margin + xmin, ymin = np.min(projections[:, :2], axis=0) + xmax, ymax = np.max(projections[:, :2], axis=0) + sw = xmax - xmin + 2 * margin + sh = ymax - ymin + 2 * margin + surface = cairo.ImageSurface(cairo.FORMAT_ARGB32, int(sw), int(sh)) + surface_ctx = cairo.Context(surface) + + # set the local references + set_source_surface = surface_ctx.set_source_surface + paint = surface_ctx.paint + selection = self.selection + atom_numbers = self.atom_numbers + atom_surfaces = self.atom_surfaces + + self.im_ox = int(xmin - margin) + self.im_oy = int(ymin - margin) + surface_ctx.translate(-self.im_ox, -self.im_oy) + # surface_ctx.set_source_rgb(1,1,0) + # surface_ctx.set_line_width(2.) + # surface_ctx.rectangle(self.im_ox, self.im_oy, int(sw), int(sh)) + # surface_ctx.stroke() + for i, p in enumerate(projections): # @UnusedVariable + x, y, z, w, n, index = p # @UnusedVariable + # load the surface + if index in selection: + if index == self.atoms.info['absorber']: + sprite = self.absorber_surface[1] + else: + sprite = atom_surfaces[1, np.where(atom_numbers == n)[0][0]] + else: + if index == self.atoms.info['absorber']: + sprite = self.absorber_surface[0] + else: + sprite = atom_surfaces[0, np.where(atom_numbers == n)[0][0]] + + sx = x - sprite.get_width() / 2. + sy = y - sprite.get_height() / 2. + set_source_surface(sprite, int(sx), int(sy)) + paint() + if False: # pylint: disable=using-constant-test + ctx.set_source_rgb(0., 0., 0.) + r = sprite.get_width() / 2 + ctx.arc(x, y, r, 0, 2 * np.pi) + ctx.stroke_preserve() + ctx.set_source_rgb(0.8, 0.8, 0.8) + ctx.fill() + ctx.move_to(x, y) + ctx.set_source_rgb(0, 0, 0) + ctx.set_font_size(14) + ctx.show_text("%d" % index) + + # save the rendering + self.atoms_sprite = surface + ctx.set_source_surface(surface, self.im_ox, self.im_oy) + ctx.paint() + + def render_selection_box(self, ctx): + r, g, b = self.colors['selection_box'] + ctx.set_source_surface(self.screenshot, 0, 0) + ctx.paint() + ctx.set_source_rgba(r, g, b, 0.3) + ctx.rectangle(*self.selection_box) + ctx.fill_preserve() + ctx.set_source_rgb(r, g, b) + ctx.stroke() + + def render_boundingbox(self, ctx): + # print('render_boundingbox : start') + try: + atoms = self.atoms + except: + return + + # create a points matrix with homogeneous coordinates + # x,y,z,w for atoms extrema + points = atoms.get_positions() + margin = self.__outer_margin / float(self.scale) + xmin, ymin, zmin = np.min(points, axis=0) - margin + xmax, ymax, zmax = np.max(points, axis=0) + margin + points = np.array([ + [xmax, ymax, zmax, 1], + [xmax, ymin, zmax, 1], + [xmin, ymax, zmax, 1], + [xmin, ymin, zmax, 1], + [xmax, ymax, zmin, 1], + [xmax, ymin, zmin, 1], + [xmin, ymax, zmin, 1], + [xmin, ymin, zmin, 1]]) + + # Get the points array projected to the screen display + projections = self.get_projections(points) + x0, y0 = (np.min(projections[:, :2], axis=0)).astype(int) + x1, y1 = (np.max(projections[:, :2], axis=0)).astype(int) + + # Declare the 6 faces with their vertex index + # the order of the numbers define if the normal plane points outward or not + faces = np.array([ + [6, 7, 5, 4], + [2, 3, 7, 6], + [3, 1, 5, 7], + [2, 6, 4, 0], + [0, 4, 5, 1], + [2, 0, 1, 3]]) + + # kind of backface culling + ind = [] + for i, f in enumerate(faces): + # Get 2 vectors of the plane + v1 = projections[f[1], :3] - projections[f[0], :3] + v2 = projections[f[3], :3] - projections[f[0], :3] + # cross multiply them to get the normal + n = np.cross(v2, v1) + # If the normal z coordinate is <0, the plane is not visible, so, draw it + # first, otherwise draw it last + if n[-1] > 0: + ind.append(i) + else: + ind.insert(0, i) + # faces are now re-ordered + faces = faces[ind] + + # plane transparency and color + color_plane = self.colors['boulding_box_fill'] + color_line = self.colors['boulding_box_line'] + + ctx.save() + #ctx.set_source_rgb(1, 0, 0) + #ctx.rectangle(x0, y0, x1 - x0, y1 - y0) + #ctx.stroke() + ctx.set_fill_rule(cairo.FILL_RULE_EVEN_ODD) + ctx.set_line_join(cairo.LINE_JOIN_ROUND) + ctx.set_line_width(1.) + ctx.set_dash([8., 8.]) + for i, p in enumerate(faces): + # remove dash for front faces + if i > 2: + ctx.set_dash([]) + if i == 3 and not(self.mode & self.MODE_ROTATION): # pylint: disable=superfluous-parens + try: + f = self.scale / self.scale0 + # sprite_w = self.atoms_sprite.get_width() + # sprite_h = self.atoms_sprite.get_height() + # m = self.__outer_margin + # sw = float(sprite_w) / (x1 - x0) + # sh = float(sprite_h) / (y1 - y0) + ctx.save() + # ctx.translate((x0 + x1 - sprite_w)/2. , + # (y0 + y1 - sprite_h)/2.) + ctx.set_source_surface(self.atoms_sprite, self.im_ox, self.im_oy) + ctx.paint() + ctx.restore() + except: + pass + ctx.set_source_rgba(*color_plane) + # get the projected points + p0, p1, p2, p3 = projections[p, :2] + # move to the first + ctx.move_to(*p0) + # line to the others + list(map(lambda _: ctx.line_to(*_), (p1, p2, p3))) + # close the polygon + ctx.close_path() + # fill it and stroke the path + ctx.fill_preserve() + ctx.set_source_rgba(*color_line) + ctx.stroke() + ctx.restore() + + def update_camera(self, rescale=False, center=False): + # update the scale + w, h = self.GetClientSize() + l = min(w, h) + # print('set_atoms : w=%d h = %d l = %f' % (w, h, l)) + self.scale0 = int(.5 * l / self.atoms_largest_dimension) + 1 + + # move the model to the center of mass + t_matrix = np.eye(4) + t_matrix[-1, :-1] = -1 * self.atoms_center_of_mass + self.m2w_matrix = t_matrix # self.m2w_matrix.dot(t_matrix) + self.update_model_matrix() + + if rescale: + assert self.scale0 > 0.0 + self.scale = self.scale0 + + #print "scale = ", self.scale, "scale0 = ", self.scale0 + #self.scale_atoms(1.) + + if center: + self.translate_atoms(w / 2, h / 2) + + def update_drawing(self, light=None): + # print('update_drawing : light=%s' % str(light)) + + try: + ctx = cairo.Context(self.back_buffer) + except: + #self.scale = self.scale0 = 10 + return + + light_mode = self.light_mode if light is None else light + + if self.mode & self.MODE_SELECTION: + self.render_selection_box(ctx) + else: + self.render_background(ctx) + if self.atoms: + if light_mode: + self.render_boundingbox(ctx) + else: + self.render_atoms(ctx) + self.render_scalebar(ctx) + self.render_axes(ctx) + + self.Refresh(eraseBackground=False) + + def swap_buffers(self): + if self.back_buffer: + back_buffer = self.back_buffer + # w = back_buffer.get_width() + # h = back_buffer.get_height() + + bitmap = wx.lib.wxcairo.BitmapFromImageSurface(back_buffer) + dc = wx.PaintDC(self) + dc.DrawBitmap(bitmap, 0, 0) diff --git a/src/msspec/msspecgui/msspec/gui/clusterviewer3d/GLPanel.py b/src/msspec/msspecgui/msspec/gui/clusterviewer3d/GLPanel.py new file mode 100644 index 0000000..e98caaf --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/clusterviewer3d/GLPanel.py @@ -0,0 +1,286 @@ +import wx +from wx import glcanvas +from OpenGL.GL import * +from OpenGL.GLU import * +from OpenGL.GLUT import * +import sys + +from ase import Atom, Atoms +from ase.data import covalent_radii +from ase.data.colors import jmol_colors + +from ase.build import molecule + +import numpy as np + +class GLPanel(wx.Panel): + def __init__(self, *args, **kwargs): + #style = wx.DEFAULT_FRAME_STYLE | wx.NO_FULL_REPAINT_ON_RESIZE + wx.Panel.__init__(self, *args, **kwargs) + + self.GLinitialized = False + attribList = (glcanvas.WX_GL_RGBA, # RGBA + glcanvas.WX_GL_DOUBLEBUFFER, # Double Buffered + glcanvas.WX_GL_DEPTH_SIZE, 24) # 24 bit + # Create the canvas + self.canvas = glcanvas.GLCanvas(self, attribList=attribList) + self.glcontext = glcanvas.GLContext(self.canvas) + # Set the event handlers. + self.canvas.Bind(wx.EVT_SIZE, self.onSizeEvent) + self.canvas.Bind(wx.EVT_PAINT, self.onPaintEvent) + + szr = wx.BoxSizer(wx.HORIZONTAL) + szr.Add(self.canvas, 1, wx.EXPAND|wx.ALL, 0) + self.SetSizer(szr) + + self.Bind(wx.EVT_MOUSEWHEEL, self.onMouseWheelEvent) + self.canvas.Bind(wx.EVT_MOTION, self.onMotionEvent) + self.canvas.Bind(wx.EVT_LEFT_DOWN, self.onLeftDownEvent) + #self.Bind(wx.EVT_LEFT_UP, self.__evt_left_up_cb) + #self.Bind(wx.EVT_RIGHT_UP, self.__evt_right_up_cb) + self.canvas.Bind(wx.EVT_RIGHT_DOWN, self.onRightDownEvent) + + self.atoms = None + self.scale = 1. + self.theta = self.phi = 0. + self.tx = self.ty = 0 + self.tx0 = self.ty0 = 0. + self.znear = 1. + self.zfar = -1. + self.coords = [0., 0., 0.] + self.translation = [0., 0., 0] + + def set_atoms(self, atoms): + self.atoms = atoms + self.com = atoms.get_center_of_mass() + self.sorted_indices = np.argsort(atoms.numbers) + self.theta = 45 + self.phi = -45 + + + def onMouseWheelEvent(self, event): + rotation = event.GetWheelRotation() + if rotation > 0: + self.scale *= 1.1 + else: + self.scale /= 1.1 + #self._gl_scale() + print self.scale + w, h = self.canvas.GetClientSize() + self._gl_init_view(w, h) + self._gl_draw() + + def onRightDownEvent(self, event): + self.mx0, self.my0 = event.GetPosition() + + def onLeftDownEvent(self, event): + mvmatrix = glGetDoublev(GL_MODELVIEW_MATRIX) + projmatrix = glGetDoublev(GL_PROJECTION_MATRIX) + viewport = glGetIntegerv(GL_VIEWPORT) + winx, winy = event.GetPosition() + winy = viewport[3] - winy + winz = glReadPixels(winx, winy, 1, 1, GL_DEPTH_COMPONENT, GL_FLOAT)[0][0] + coords = gluUnProject(winx, winy, winz, mvmatrix, projmatrix, viewport) + self.coords0 = coords + print "coords0 = ", coords + + + def onMotionEvent(self, event): + w, h = self.canvas.GetClientSize() + if event.RightIsDown(): + mx, my = event.GetPosition() + dy = my - self.my0 + dx = mx - self.mx0 + self.my0 = my + self.mx0 = mx + self.theta += dx + self.phi += dy + elif event.LeftIsDown(): + mvmatrix = glGetDoublev(GL_MODELVIEW_MATRIX) + projmatrix = glGetDoublev(GL_PROJECTION_MATRIX) + viewport = glGetIntegerv(GL_VIEWPORT) + + # get x0, y0 and z0 + #x0, y0, z0 = gluUnProject(self.tx0, self.ty0, self.tz0, mvmatrix, projmatrix, viewport) + + winx, winy = event.GetPosition() + winy = viewport[3] - winy + winz = glReadPixels(winx, winy, 1, 1, GL_DEPTH_COMPONENT, GL_FLOAT)[0][0] + x, y, z = gluUnProject(winx, winy, winz, mvmatrix, projmatrix, viewport) + + #translation = [x - x0, y - y0, 0] + translation = [x - self.coords0[0], y - self.coords0[1], 0] + #print x, y, z#translation + if winx < w and winx > 0 and winy < h and winy > 0: + print 'here' + glTranslatef(*translation) + #self.translation = translation + print translation + + self._gl_draw() + + def onSizeEvent(self, event): + """Process the resize event.""" + width, height = self.canvas.GetClientSize() + self._gl_resize(width, height) + self.canvas.Refresh(False) + event.Skip() + + def onPaintEvent(self, event): + """Process the drawing event.""" + if not self.GLinitialized: + w, h = self.canvas.GetClientSize() + self._gl_init(w, h) + + self._gl_draw() + event.Skip() + + # GLFrame OpenGL Event Handlers + def _gl_init(self, width, height): + """Initialize OpenGL for use in the window.""" + self.canvas.SetCurrent(self.glcontext) + + self.quadric = gluNewQuadric() + gluQuadricNormals(self.quadric, GLU_SMOOTH) + + glClearColor(1., 1., 1., 1.) + glClearDepth(1.) + glDepthFunc(GL_LESS) + glEnable(GL_DEPTH_TEST) + glEnable(GL_MULTISAMPLE) + glShadeModel(GL_SMOOTH) + + #glEnable(GL_BLEND) + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA) + + + + #glLightfv(GL_LIGHT0, GL_AMBIENT, (0.5, 0.5, 0.5, 1.0)) + a = 0.4 + d = 0.4 + s = 1. + glLightfv(GL_LIGHT0, GL_AMBIENT, (a, a, a, 1.0)) + glLightfv(GL_LIGHT0, GL_DIFFUSE, (d, d, d, 1.0)) + glLightfv(GL_LIGHT0, GL_SPECULAR, (s, s, s, 1.0)) + glLightfv(GL_LIGHT0, GL_POSITION, (0.0, 100.0, 10., 1.0)) + glEnable(GL_LIGHT0) + + glColorMaterial(GL_FRONT_AND_BACK, GL_AMBIENT_AND_DIFFUSE) + #glLightfv(GL_LIGHT1, GL_AMBIENT, (0.3, 0.3, 0.3, 1.0)) + #glLightfv(GL_LIGHT1, GL_DIFFUSE, (.2, .2, .2, 1.0)) + #glLightfv(GL_LIGHT1, GL_POSITION, (0.0, -10.0, 0., 1.0)) + #glEnable(GL_LIGHT1) + + glEnable(GL_LIGHTING) + glEnable(GL_COLOR_MATERIAL) + + self._gl_init_view(width, height) + self._gl_resize(width, height) + self.GLinitialized = True + + def _gl_init_view(self, width, height): + glViewport(0, 0, width, height) + glMatrixMode(GL_PROJECTION) + glLoadIdentity() + gluPerspective(45., float(width) / float(height), self.znear, self.zfar) + # find the largest cluster dimension + max_d = np.max(np.linalg.norm(self.atoms.get_positions(), axis=1)) + # set the scale accordingly + gluLookAt(0, 0, 5*max_d*self.scale, 0, 0, 0, 0, 1, 0) + #gluLookAt(0, 0, self.scale, 0, 0, 0, 0, 1, 0) + glMatrixMode(GL_MODELVIEW) + + + def _gl_resize(self, width, height): + """Reshape the OpenGL viewport based on the dimensions of the window.""" + if height == 0: + height = 1 + self._gl_init_view(width, height) + + def _gl_draw(self, *args, **kwargs): + "Draw the window." + #glClear(GL_COLOR_BUFFER_BIT) + glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT) + + # Drawing an example triangle in the middle of the screen + + #glBegin(GL_TRIANGLES) + #glColor(0, 0, 0) + #color = [1.0, 0.0, 0.0, 1.0] + #glMaterialfv(GL_FRONT, GL_DIFFUSE, color) + #glVertex3f(-.25, -.25, 0.) + #glVertex3f(.25, -.25, 0.) + #glVertex3f(0., .25, 0.) + ##glVertex(-.25, -.25) + ##glVertex(.25, -.25) + ##glVertex(0., .25) + #glEnd() + + def draw_circle(radius, n): + theta = 2*np.pi/float(n) + c = np.cos(theta) + s = np.sin(theta) + + x = radius + y = 0 + + glBegin(GL_LINE_LOOP) + for i in range(n): + glVertex2f(x , y ) + t = x + x = c * x - s * y + y = s * t + c * y + glEnd() + + def render_atom(atom): + glPushMatrix() + + glRotate(self.theta, 0, 1, 0) + glRotate(self.phi, 1, 0, 0) + glTranslatef(-self.com[0], -self.com[1], -self.com[2]) + + glTranslatef(*atom.position) + #r, g, b = jmol_colors[atom.number] + radius = covalent_radii[atom.number] + #color = [r, g, b, 1.0] + #glMaterialfv(GL_FRONT_AND_BACK, GL_SPECULAR, (.1, .1, .1, 1)) + #glMaterialfv(GL_FRONT_AND_BACK, GL_EMISSION, (0, 0, 0, 1)) + #glColor3f(r, g, b) + resolution = 16 + gluSphere(self.quadric, radius, resolution, resolution) + #draw_circle(radius, 32) + glPopMatrix() + + def set_material(number): + r, g, b = jmol_colors[number] + color = [r, g, b, 1.0] + s = 0.7 + glMaterialfv(GL_FRONT, GL_SPECULAR, (s, s, s, 1)) + glMaterialfv(GL_FRONT, GL_EMISSION, (0., 0., 0., 1)) + glMateriali(GL_FRONT, GL_SHININESS, 30) + glColor4f(r, g, b, 0.5) + + last_number = -1 + #glPushMatrix() + #glLoadIdentity() + #glTranslatef(*self.translation) + #glRotate(self.theta, 0, 1, 0) + #glRotate(self.phi, 1, 0, 0) + #glTranslatef(-self.com[0], -self.com[1], -self.com[2]) + + #glPopMatrix() + for i in self.sorted_indices: + atom = self.atoms[i] + number = atom.number + if number != last_number: + set_material(number) + render_atom(atom) + + self.canvas.SwapBuffers() + + def _gl_scale(self): + scale = self.scale + glScale(scale, scale, scale) + self._gl_draw() + + diff --git a/src/msspec/msspecgui/msspec/gui/clusterviewer3d/__init__.py b/src/msspec/msspecgui/msspec/gui/clusterviewer3d/__init__.py new file mode 100644 index 0000000..e69de29 diff --git a/src/msspec/msspecgui/msspec/gui/clusterviewer3d/clusterviewer3d.zip b/src/msspec/msspecgui/msspec/gui/clusterviewer3d/clusterviewer3d.zip new file mode 100644 index 0000000..810e376 Binary files /dev/null and b/src/msspec/msspecgui/msspec/gui/clusterviewer3d/clusterviewer3d.zip differ diff --git a/src/msspec/msspecgui/msspec/gui/clusterviewer3d/main_window.py b/src/msspec/msspecgui/msspec/gui/clusterviewer3d/main_window.py new file mode 100644 index 0000000..cbcb83a --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/clusterviewer3d/main_window.py @@ -0,0 +1,30 @@ +# coding: utf-8 + +import wx +from GLPanel import GLPanel +from msspec.utils import hemispherical_cluster +from ase.build import bulk + + +class GLFrame(wx.Frame): + def __init__(self, *args, **kwargs): + wx.Frame.__init__(self, *args, **kwargs) + self.pnl = GLPanel(self) + + def set_atoms(self, atoms): + self.pnl.set_atoms(atoms) + + +if __name__ == "__main__": + + lattice = bulk('MgO', crystalstructure='rocksalt', a=4.21, cubic=True) + cluster = hemispherical_cluster(lattice, 0, 0, diameter=20.) + + + app = wx.App(False) + frame = GLFrame(None, -1, 'GL Window', size=(640, 480)) + frame.set_atoms(cluster) + frame.Show() + + app.MainLoop() + app.Destroy() \ No newline at end of file diff --git a/src/msspec/msspecgui/msspec/gui/example11.py b/src/msspec/msspecgui/msspec/gui/example11.py new file mode 100644 index 0000000..cd8ceb5 --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/example11.py @@ -0,0 +1,38 @@ +# -*- encoding: utf-8 -*- +# vim: set fdm=indent ts=2 sw=2 sts=2 et tw=80 cc=+1 mouse=a nu : # + +# import sys +# sys.path.append('/home/sylvain/dev/msspec/trunk/src/python/MsSpecGui/') + +import wx +from clusterviewer import ClusterViewer + +from ase.lattice import bulk + + +class MyFrame(wx.Frame): + def __init__(self, **kwargs): + p = {} + p.setdefault('parent', None) + p.setdefault('title', 'Test Frame') + p.setdefault('size', (640, 480)) + p.update(kwargs) + + wx.Frame.__init__(self, **p) + + self.Window = ClusterViewer(self) + self.Show() + +# display an MgO cell +MgO = bulk('MgO', crystalstructure='rocksalt', orthorhombic=True, a=4.21) +MgO = MgO.repeat((20, 20, 30)) + +app = wx.App(False) +frame = MyFrame(title='MsSpec Viewer') +frame.Window.light_mode_threshold = 2 +frame.Window.set_atoms(MgO, rescale=True) + +frame.Show() + +app.MainLoop() +app.Destroy() diff --git a/src/msspec/msspecgui/msspec/gui/filemenu.py b/src/msspec/msspecgui/msspec/gui/filemenu.py new file mode 100644 index 0000000..bbba86b --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/filemenu.py @@ -0,0 +1,88 @@ +''' +Created on Jan 4, 2016 + +@author: graffy +''' + +import wx +import msspecgui.msspec.workspace + + +class FileMenu(wx.Menu): + def __init__(self, main_frame): + wx.Menu.__init__(self) + self._main_frame = main_frame + + # wx.ID_ABOUT and wx.ID_EXIT are standard IDs provided by wxWidgets. + self._new_workspace_menu_item = self.Append(wx.ID_ANY, "N&ew workspace", " create a new workspace") + self._open_workspace_menu_item = self.Append(wx.ID_ANY, "O&pen workspace", " load an existing workspace") + self.AppendSeparator() + self._save_workspace_menu_item = self.Append(wx.ID_ANY, "S&ave workspace", " save the current workspace") + self._close_workspace_menu_item = self.Append(wx.ID_ANY, "C&lose workspace", " close the current workspace") + self.AppendSeparator() + self._about_menu_item = self.Append(wx.ID_ABOUT, "&About", " Information about this program") + self.AppendSeparator() + self._exit_menu_item = self.Append(wx.ID_EXIT, "E&xit", " Terminate the program") + + self._main_frame.Bind(wx.EVT_MENU, self.on_about, self._about_menu_item) + self._main_frame.Bind(wx.EVT_MENU, self.on_exit, self._exit_menu_item) + + self._main_frame.Bind(wx.EVT_MENU, self.on_new_workspace, self._new_workspace_menu_item) + self._main_frame.Bind(wx.EVT_MENU, self.on_open_workspace, self._open_workspace_menu_item) + self._main_frame.Bind(wx.EVT_MENU, self.on_save_workspace, self._save_workspace_menu_item) + self._main_frame.Bind(wx.EVT_MENU, self.on_close_workspace, self._close_workspace_menu_item) + + self.update() + + def update(self): + self._close_workspace_menu_item.Enable(self._main_frame.m_workspace is not None) + self._save_workspace_menu_item.Enable(self._main_frame.m_workspace is not None) + + def on_new_workspace(self, event): + if self.on_close_workspace(event=None): + default_path = '' + dlg = wx.DirDialog(self._main_frame, "Choose location to store this new workspace", default_path) + if dlg.ShowModal() == wx.ID_OK: + workspace_path = dlg.GetPath() + self._main_frame.set_workspace(msspecgui.msspec.workspace.Workspace(workspace_path, is_new_workspace=True)) + + # f = open(, 'r') + # self.control.SetValue(f.read()) + # f.close() + dlg.Destroy() + self.update() + + def on_open_workspace(self, event): + if self.on_close_workspace(event=None): + default_path = '' + dlg = wx.DirDialog(self._main_frame, "Choose the workspace location", default_path) + if dlg.ShowModal() == wx.ID_OK: + workspace_path = dlg.GetPath() + workspace = msspecgui.msspec.workspace.Workspace(workspace_path, is_new_workspace=False) + self._main_frame.set_workspace(workspace) + + # f = open(, 'r') + # self.control.SetValue(f.read()) + # f.close() + dlg.Destroy() + self.update() + + def on_save_workspace(self, event): + print('FileMenu.on_save_workspace') + self._main_frame.save_workspace() + self.update() + + def on_close_workspace(self, event): + self._main_frame.close_workspace() + self.update() + return True + + def on_about(self, event): + # A message dialog box with an OK button. wx.OK is a standard ID in wxWidgets. + dlg = wx.MessageDialog(self._main_frame, "A multiple-scattering package for spectroscopies using electrons to probe materials", "MsSpec 1.1", wx.OK) + dlg.ShowModal() # Show it + dlg.Destroy() # finally destroy it when finished. + + def on_exit(self, event): + self.on_close_workspace(event=event) + self._main_frame.Close(True) # Close the frame. diff --git a/src/msspec/msspecgui/msspec/gui/main.py b/src/msspec/msspecgui/msspec/gui/main.py new file mode 100644 index 0000000..88b3872 --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/main.py @@ -0,0 +1,70 @@ +''' +Created on Dec 23, 2015 + +@author: graffy + +how to install ase on osx macports + [OK]graffy@pr079234:~/ownCloud/ipr/msspec/toto[12:50:42]>export ASE_TAGS=https://svn.fysik.dtu.dk/projects/ase/tags/ + [OK]graffy@pr079234:~/ownCloud/ipr/msspec/toto[12:50:57]>svn co -r 4567 $ASE_TAGS/3.9.1 ase-3.9.1 + [OK]graffy@pr079234:~[12:52:41]>cd ownCloud/ipr/msspec/toto/ase-3.9.1 + sudo /opt/local/bin/python setup.py install +''' +import sys +# import re +# sudo port install py27-wxpython-3.0 +# import os + +sys.path.append('../../') +import wx # @IgnorePep8 +import ase # @IgnorePep8 +# import msspec +import msspecgui.msspec.gui.mainwindow as mainwindow # @IgnorePep8 +# import cairosvg + + +def view_atoms(atoms): + '''Displays the atoms. + + This is the equivalent of ase.visualize.view(molecule), but this function doesn't make use of the external python program ase-3.9.1/tools/ase-gui. It was built by looking at what ase.visualize.view does. + + ''' + import ase.gui.gui # IGNORE:redefined-outer-name + # import ase.gui.ag + import ase.io + # import ase.gui.gtkexcepthook + # from ase.visualize import view + # from ase.io import write + # from ase.gui.ag import main + # http://wiki.wxpython.org/Getting%20Started + + import ase.gui.images + file_format = 'traj' + file_path = '/tmp/toto.%s' % file_format + # ase.io.write(file_path, molecule, file_format) + ase.io.write(file_path, images=atoms, format=file_format) + + images = ase.gui.images.Images() + images.read([file_path], ase.io.string2index(':')) + gui = ase.gui.gui.GUI(images, '', 1, False) + gui.run(None) + + +def test_ase(): + d = 1.10 + molecule = ase.Atoms('2N', positions=[(0., 0., 0.), (0., 0., d)]) + view_atoms(molecule) + + +def main(): + print('hello, world') + app = wx.App(False) # Create a new app, don't redirect stdout/stderr to a window. + app.SetAppName('MsSpec') + # app.SetAppDisplayName('MsSpec') + frame = mainwindow.MainWindow(None, 'MsSpec') # A Frame is a top-level window. @UnusedVariable + + # test_ase() + app.MainLoop() + + +if __name__ == '__main__': + main() diff --git a/src/msspec/msspecgui/msspec/gui/mainwindow.py b/src/msspec/msspecgui/msspec/gui/mainwindow.py new file mode 100644 index 0000000..0df118a --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/mainwindow.py @@ -0,0 +1,83 @@ +''' +Created on Jan 4, 2016 + +@author: graffy +''' +import wx +from .filemenu import FileMenu +# import clustermenu +from msspecgui.msspec.gui.viewmanager import ViewFactory +from msspecgui.msspec.gui.viewmanager import ViewManager +from msspecgui.msspec.gui.clustereditor import ClusterEditor +from msspecgui.msspec.gui.clusterview import ClusterView + + +class MainWindow(wx.Frame): + def __init__(self, parent, title): + wx.Frame.__init__(self, parent, title=title, size=(300, 300)) + # self.c ontrol = wx.TextCtrl(self, style=wx.TE_MULTILINE) + self.CreateStatusBar() # A Statusbar in the bottom of the window + + self.view_manager = None + self.set_workspace(None) + + self._file_menu = FileMenu(self) + # self.m_clusterMenu = clustermenu.ClusterMenu(self) + + # Creating the menubar. + menu_bar = wx.MenuBar() + menu_bar.Append(self._file_menu, "&File") # Adding the "fileMenu" to the MenuBar + # menu_bar.Append(self.m_clusterMenu,"&Cluster") # Adding the "fileMenu" to the MenuBar + self.SetMenuBar(menu_bar) # Adding the MenuBar to the Frame content. + + self.Bind(wx.EVT_CLOSE, self.on_close) + self.Show(True) # Show the frame. + + def set_workspace(self, workspace): + """ + :type workspace: Workspace + """ + self.m_workspace = workspace + window_title = 'MsSpecGui' + if workspace is not None: + window_title += ' - ' + workspace.workspace_path + self.SetTitle(window_title) + + if workspace is None: + if self.view_manager is not None: + self.view_manager.Destroy() + self.view_manager = None + else: + view_factory = ViewFactory() + view_factory.register_view_creator(ClusterEditor.Creator(self.get_workspace())) + view_factory.register_view_creator(ClusterView.Creator(self.get_workspace().get_cluster_flow())) + self.view_manager = ViewManager(self, view_factory) + self.view_manager.views[0].set_view_type(ClusterEditor.Creator.VIEW_TYPE_NAME) + view2 = self.view_manager.add_view() + view2.set_view_type(ClusterView.Creator.VIEW_TYPE_NAME) + self.Hide() # without this call, I couldn't make the workspace window updated (at least on osx); as a result, I had to drag the corner of the window to force a refresh + self.Show() + + def get_workspace(self): + return self.m_workspace + + def close_workspace(self, ask_confirmation=True): + if self.m_workspace is not None: + dlg = wx.MessageDialog(self, message="Do you want to save your workspace before closing it ?", + caption="Save current workspace ?", + style=wx.YES_NO | wx.CANCEL | wx.YES_DEFAULT | wx.ICON_QUESTION) + clicked_button_id = dlg.ShowModal() # Show it + dlg.Destroy() # finally destroy it when finished. + if clicked_button_id == wx.ID_YES: + self.save_workspace() + elif clicked_button_id == wx.ID_CANCEL: + return False + self.set_workspace(None) + + def save_workspace(self): + self.m_workspace.save() + + def on_close(self, event): + print("MainWindow.on_close") + self.close_workspace(ask_confirmation=True) + event.Skip() # propagate the event so that the dialog closes diff --git a/src/msspec/msspecgui/msspec/gui/test/scrolled_panel.py b/src/msspec/msspecgui/msspec/gui/test/scrolled_panel.py new file mode 100644 index 0000000..e563188 --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/test/scrolled_panel.py @@ -0,0 +1,51 @@ +import wx +import wx.lib.scrolledpanel as scrolled + +######################################################################## +class MyForm(wx.Frame): + + #---------------------------------------------------------------------- + def __init__(self): + wx.Frame.__init__(self, None, wx.ID_ANY, "Tutorial", size=(200,500)) + + # Add a panel so it looks the correct on all platforms + self.panel = wx.Panel(self, wx.ID_ANY) + + # -------------------- + # Scrolled panel stuff + self.scrolled_panel = scrolled.ScrolledPanel(self.panel, -1, + style = wx.TAB_TRAVERSAL|wx.SUNKEN_BORDER, name="panel1") + self.scrolled_panel.SetAutoLayout(1) + self.scrolled_panel.SetupScrolling() + + words = "A Quick Brown Insane Fox Jumped Over the Fence and Ziplined to Cover".split() + self.spSizer = wx.BoxSizer(wx.VERTICAL) + for word in words: + text = wx.TextCtrl(self.scrolled_panel, value=word) + self.spSizer.Add(text) + self.scrolled_panel.SetSizer(self.spSizer) + # -------------------- + + btn = wx.Button(self.panel, label="Add Widget") + btn.Bind(wx.EVT_BUTTON, self.onAdd) + + panelSizer = wx.BoxSizer(wx.VERTICAL) + panelSizer.AddSpacer(50) + panelSizer.Add(self.scrolled_panel, 1, wx.EXPAND) + panelSizer.Add(btn) + self.panel.SetSizer(panelSizer) + + #---------------------------------------------------------------------- + def onAdd(self, event): + """""" + print "in onAdd" + new_text = wx.TextCtrl(self.scrolled_panel, value="New Text") + self.spSizer.Add(new_text) + self.scrolled_panel.Layout() + self.scrolled_panel.SetupScrolling() + +# Run the program +if __name__ == "__main__": + app = wx.App(False) + frame = MyForm().Show() +app.MainLoop() \ No newline at end of file diff --git a/src/msspec/msspecgui/msspec/gui/test/scrolled_window.py b/src/msspec/msspecgui/msspec/gui/test/scrolled_window.py new file mode 100644 index 0000000..a843b0f --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/test/scrolled_window.py @@ -0,0 +1,103 @@ + +import wx + +class ScrolledImageComponent(wx.ScrolledWindow): + + def __init__(self, parent, id, image_path): + wx.ScrolledWindow.__init__(self, parent, id) + + image = wx.Image(image_path) + if not image.IsOk(): + wx.MessageBox("there was an error loading the image") + return + + self.w = image.GetWidth() + self.h = image.GetHeight() + + # init scrolled area size, scrolling speed, etc. */ + self.SetScrollbars(1,1, self.w, self.h, 0, 0) + + self.bitmap = wx.Bitmap(image_path) + + def OnDraw(self, dc): + """ + render the image - in a real app, if your scrolled area + is somewhat big, you will want to draw only visible parts, + not everything like below + """ + dc.DrawBitmap(self.bitmap, 0, 0, False) + + #// also check wxScrolledWindow::PrepareDC + +# Run the program +if __name__ == "__main__": + app = wx.App(False) + wx.InitAllImageHandlers(); + frame = wx.Frame(None) + sizer = wx.BoxSizer(wx.HORIZONTAL) + my_image = ScrolledImageComponent(frame, wx.ID_ANY, "/Users/graffy/data/Perso/mms_img1041085029.jpg") + sizer.Add(my_image, 1, wx.ALL | wx.EXPAND, 120) + frame.SetSizer(sizer); + frame.Show() + app.MainLoop() + +""" +class ScrolledImageComponent : public wxScrolledWindow +{ + wxBitmap* bitmap; + int w,h; +public: + ScrolledImageComponent(wxWindow* parent, wxWindowID id, wxString image_path) : wxScrolledWindow(parent, id) + { + wxImage image(image_path); + if(!image.IsOk()) + { + wxMessageBox(wxT("there was an error loading the image")); + return; + } + + w = image.GetWidth(); + h = image.GetHeight(); + + /* init scrolled area size, scrolling speed, etc. */ + SetScrollbars(1,1, w, h, 0, 0); + + bitmap = new wxBitmap( image ); + } + ~ScrolledImageComponent() + { + delete bitmap; + } + void OnDraw(wxDC& dc) + { + /* render the image - in a real app, if your scrolled area + is somewhat big, you will want to draw only visible parts, + not everything like below */ + dc.DrawBitmap(*bitmap, 0, 0, false); + + // also check wxScrolledWindow::PrepareDC + } +}; + + +class MyApp: public wxApp +{ + wxFrame *frame; +public: + + bool OnInit() + { + wxInitAllImageHandlers(); + wxBoxSizer* sizer = new wxBoxSizer(wxHORIZONTAL); + frame = new wxFrame((wxFrame *)NULL, -1, wxT("Scrolling an Image"), wxPoint(50,50), wxSize(650,650)); + + ScrolledImageComponent* my_image = new ScrolledImageComponent(frame, wxID_ANY, wxT("my_image.jpg") ); + sizer->Add(my_image, 1, wxALL | wxEXPAND, 120); + frame->SetSizer(sizer); + + frame->Show(); + return true; + } +}; + """ + \ No newline at end of file diff --git a/src/msspec/msspecgui/msspec/gui/viewmanager.py b/src/msspec/msspecgui/msspec/gui/viewmanager.py new file mode 100644 index 0000000..cdf8268 --- /dev/null +++ b/src/msspec/msspecgui/msspec/gui/viewmanager.py @@ -0,0 +1,246 @@ +from __future__ import print_function +import abc +import functools +import wx.lib.agw.aui as aui +import wx + + +class IViewCreator(object): + + @abc.abstractproperty + def view_type_name(self): + """ + :return str: + """ + pass + + @abc.abstractmethod + def create_view(self, parent): + """ + :param wx.Window parent: the wx.Window that owns the view + :return wx.Panel: + """ + pass + + +class ViewFactory(object): + + def __init__(self): + self._view_creators = {} #: :type self._view_creators: dict(str, IViewCreator) + + def register_view_creator(self, view_creator): + """ + :param IViewCreator view_creator: + """ + self._view_creators[view_creator.view_type_name] = view_creator + + def get_view_type_names(self): + return list(self._view_creators.iterkeys()) + + def create_view(self, view_type_name, container_window): + """ + :param str view_type_name: the type of view to create + :param wx.Window container_window: the parent wx window + """ + return self._view_creators[view_type_name].create_view(container_window) + + +class View(wx.Panel): + """ + panel who will be used to create the interface + """ + + def __init__(self, view_manager, view_id): + """ + :param ViewManager view_manager: the manager that manages this view + :param int id: a number uniquely identifying this view in its view manager + """ + wx.Panel.__init__(self, view_manager, -1) + self.view_manager = view_manager + self.id = view_id + + vbox = wx.BoxSizer(wx.VERTICAL) + self.SetSizer(vbox) + self.panel = None + + @property + def view_factory(self): + return self.view_manager.view_factory + + def set_view_type(self, view_type): + """ + :param str view_type: + """ + self.on_view_set(None, view_type) + + def on_view_set(self, evt, view_type_name): + """ + called when the menu item that assigns a view type to this view is clicked by the user + + :param str view_type_name: the type of view that the user just chose for this view + """ + + pane = self.view_manager.aui_manager.GetPaneByWidget(self) + + index = self.view_manager.get_free_pane_index(view_type_name) + + pane_name = view_type_name + ("" if index == 0 else " " + str(index)) + pane.caption = pane_name + + if self.panel is not None: + self.panel.Destroy() + self.panel = None + + self.panel = self.view_factory.create_view(view_type_name, self) + self.GetSizer().Add(self.panel, proportion=1, flag=wx.EXPAND) # the new panel is the only item in the vbox sizer that is allowed to change its size, so any value other than 0 will do + +# self.Update() +# self.Refresh() +# self.view_manager.Update() + # self.view_manager.Refresh() + self.view_manager.aui_manager.Update() + self.view_manager.update_view_menu() + # print self.selected_crystal_str + + +class ViewManager(wx.Panel): + """a user interface that contains views + """ + + def __init__(self, parent, view_factory): + """ + :param ViewFactory view_factory: the factory that is used to create views + """ + super(ViewManager, self).__init__(parent) + self.view_factory = view_factory + + self.parent = parent + + # manages the panes associated with it for a particular wxFrame + self.aui_manager = aui.AuiManager(self) + self.last_created_view_id = 0 + self.views = [] + self.view_set_menu = None # :param wxMenu self.view_set_menu: the menu View->Set that allows the user to assign a view type to a view + + view = self.add_view(False, False) # @UnusedVariable the 1st view is special : it's not closable nor movable (to avoid holes) + + self.aui_manager.Update() + self.update_view_menu() + + def pane_exists(self, panes, pane_name_prefix, pane_index): + for pane_info in panes: + if pane_info.caption == "%s %d" % (pane_name_prefix, pane_index): + return True + return False + + def get_free_pane_index(self, pane_name_prefix): + """ + finds a non-used integer to uniquely identify a pane that we want to name " " + + :param str pane_name_prefix: the pane name prefix (usually the view type name) + """ + index = 1 + while self.pane_exists(self.aui_manager.GetAllPanes(), pane_name_prefix, index): + index += 1 + return index + + def add_view(self, movable=True, enable_close_button=True): + """ + :param bool movable: if True, the view is movable + :param bool enable_close_button: if True a close button is added to the view + :return View: + """ + self.last_created_view_id += 1 + view = View(self, self.last_created_view_id) + + index = self.get_free_pane_index("Empty") + + caption = 'Empty %d' % (index) + pane_info = aui.AuiPaneInfo().Movable(movable).Floatable(False).CloseButton(enable_close_button).Caption(caption).DestroyOnClose(True) + if view.id % 2 == 1: + pane_info = pane_info.Center() + else: + pane_info = pane_info.Right() + pane_info = pane_info.Layer(1) + self.aui_manager.AddPane(view, pane_info) + + self.aui_manager.Bind(aui.EVT_AUI_PANE_CLOSE, self.on_close_pane) + + self.aui_manager.OnFloatingPaneResized(view, None) + self.aui_manager.Update() + self.views.append(view) + self.update_view_menu() + return view + + def on_close_pane(self, event): + """ + :param wx.Event event: + """ + pane = event.GetPane() + self.views.remove(pane.window) + items = self.view_set_menu.GetMenuItems() + for i in items: + if i.GetText() == pane.caption: + self.view_set_menu.DestroyItem(i) + + def update_view_menu(self): + """ + builds and updates the view menu to reflect the views in the view manager + """ + def populate_view_set_submenu(view_set_submenu, views, aui_manager, view_type_names, window_receiving_events): + """ + populate the View/Set menu + + :param wxMenu view_set_submenu: the menu View/Set + :param list(View) views: the list of existing views in the view manager + :param wxAuiManager aui_manager: the aui manager that manages the views (which are widgets) + :param list(str) view_type_names: the list of available view types + :param wxWindow window_receiving_events: the window that receives the menu events + """ + for view in views: + view_item = wx.Menu() + view_set_submenu.AppendSubMenu(view_item, aui_manager.GetPaneByWidget(view).caption) + for view_type_name in view_type_names: + menu_item_id = wx.NewId() + view_type_item = wx.MenuItem(view_item, menu_item_id, view_type_name) + view_item.AppendItem(view_type_item) + window_receiving_events.Bind(wx.EVT_MENU, functools.partial(view.on_view_set, view_type_name=view_type_name), view_type_item) + + # create the menu bar if it doesn't exist yet + if self.parent.GetMenuBar(): + menu_bar = self.parent.GetMenuBar() + else: + menu_bar = wx.MenuBar() + + # delete the View menu if it already exists, as we are going to re-create it + i = 0 + while i < menu_bar.GetMenuCount(): + if menu_bar.GetMenuLabelText(i) == "View": + menu_bar.Remove(i) + i += 1 + + # create the view menu + menu_view = wx.Menu() + self.view_set_menu = wx.Menu() + + # create the menu item that allows the user to add a view to the view manager + add_view_menu_item = wx.MenuItem(menu_view, wx.NewId(), "Add") + menu_view.AppendItem(add_view_menu_item) + # create the sub menu that allows the user to assign a view type to a view + menu_view.AppendSubMenu(self.view_set_menu, "Set") + menu_bar.Append(menu_view, "View") + self.parent.Bind(wx.EVT_MENU, self.add_view, add_view_menu_item) + self.parent.SetMenuBar(menu_bar) + + populate_view_set_submenu(self.view_set_menu, self.views, self.aui_manager, self.view_factory.get_view_type_names(), self.parent) + + """ + def close_win(self, event): + self.Close() + + def maximize(self, event): + self.Maximize(True) + + def minimize(self, event): + self.Maximize(False) + """ diff --git a/src/msspec/msspecgui/msspec/workspace.py b/src/msspec/msspecgui/msspec/workspace.py new file mode 100644 index 0000000..e1dfea8 --- /dev/null +++ b/src/msspec/msspecgui/msspec/workspace.py @@ -0,0 +1,54 @@ +''' +Created on Dec 23, 2015 + +@author: graffy +''' + +import msspecgui.msspec.cluster.clusterflow +# import sys +import msspecgui.dataflowxmlserializer + + +class Workspace(object): + ''' + classdocs + ''' + + SETTINGS_FILE_NAME = 'settings.xml' + + def __init__(self, workspace_path, is_new_workspace): + '''Constructor + + :param workspace_path: the file path to the workspace directory + :type workspace_path: str + :param is_new_workspace: if True, the workspace is created, otherwise the workspace is loaded from it path + + ''' + self._workspace_path = workspace_path + if not is_new_workspace: + self.load() + else: + self._cluster_flow = msspecgui.msspec.cluster.clusterflow.ClusterFlow() + debugging = False + if debugging is True: + serializer = msspecgui.dataflowxmlserializer.DataflowSerializer() + serializer.save_dataflow(self._cluster_flow, '%s/%s' % (self._workspace_path, self.SETTINGS_FILE_NAME)) + + def load(self): + '''Loads the workspace + ''' + print('Workspace.load') + serializer = msspecgui.dataflowxmlserializer.DataflowSerializer() + self._cluster_flow = msspecgui.msspec.cluster.clusterflow.ClusterFlow() + serializer.load_dataflow('%s/%s' % (self._workspace_path, self.SETTINGS_FILE_NAME), self._cluster_flow) + + def save(self): + serializer = msspecgui.dataflowxmlserializer.DataflowSerializer() + serializer.save_dataflow(self._cluster_flow, '%s/%s' % (self._workspace_path, self.SETTINGS_FILE_NAME)) + + def get_cluster_flow(self): + return self._cluster_flow + + @property + def workspace_path(self): + return self._workspace_path diff --git a/src/msspec/msspecgui/scenegraph2d/__init__.py b/src/msspec/msspecgui/scenegraph2d/__init__.py new file mode 100644 index 0000000..a296fdb --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/__init__.py @@ -0,0 +1,4 @@ +# -*- coding: utf-8 -*- + +"""seagull module""" +from scenegraph import * diff --git a/src/msspec/msspecgui/scenegraph2d/cairo/__init__.py b/src/msspec/msspecgui/scenegraph2d/cairo/__init__.py new file mode 100644 index 0000000..21550c1 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/cairo/__init__.py @@ -0,0 +1 @@ +from render import render_scene diff --git a/src/msspec/msspecgui/scenegraph2d/cairo/render.py b/src/msspec/msspecgui/scenegraph2d/cairo/render.py new file mode 100644 index 0000000..fd086bd --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/cairo/render.py @@ -0,0 +1,347 @@ +# encoding:utf-8 +''' +Created on Feb 19, 2016 + +@author: graffy +''' +import cairo +import math +import re +from ..scenegraph.element._path import _quadric + + +def scenegraph_matrix_to_cairo_matrix(sg_matrix): + """ + :type sg_matrix: scenegraph._Transform + """ + return cairo.Matrix(*sg_matrix.abcdef) + +# from logging import log + + +def render_group(group, cairo_context): + """ renders the scenegraph group 'group' in the cairo drawing context 'cairo_context' + + :param group: the scenegraph group to render + :type group: scenegraph2d.Group + :param cairo_context: the cairo drawing context + :type cairo_context: cairo.Context + """ + # print('rendering group') + cairo_context.transform(scenegraph_matrix_to_cairo_matrix(group.local_to_parent_matrix())) + for child in group.children: + render_node(child, cairo_context) + + +def render_rectangle(rect, cairo_context): + """ renders the scenegraph rectangle 'rect' in the cairo drawing context 'cairo_context' + + :param rect: the scenegraph rectangle to render + :type rect: scenegraph2d.Rectangle + :param cairo_context: the cairo drawing context + """ + # cairo_context.set_source_rgb(0.5, 0.5, 0.5) + cairo_context.rectangle(rect.x, rect.y, rect.width, rect.height) + cairo_context.fill() + + # print('rendering rectangle') + + +def render_path(path, cairo_context): + """ renders the scenegraph path 'path' in the cairo drawing context 'cairo_context' + + :param path: the scenegraph path to render + :type path: scenegraph2d.Path + :param cairo_context: the cairo drawing context + :type cairo_context: cairo.Context + """ + color = path.fill + cairo_context.set_source_rgb(*color.rgb) + path_as_svg_code = path.d + # print('render_path : rendering path %s' % str(path_as_svg_code)) + paths = [] + path = [] + joins = [] + du2 = 1. + path_data_iter = iter(path_as_svg_code) + + def next_d(): + return next(path_data_iter) + + def findCircleCenterPassingThroughPoints(p1, p2, r): + """ + the set of points (x,y) that are at a distance r from p1=(x1,y1) satisfy : + (x-x1)^2 + (y-y1)^2 = r^2 + + the set of points (x,y) that are at a distance r from p2=(x2,y2) satisfy : + (x-x2)^2 + (y-y2)^2 = r^2 + + + So here's another idea for solving the problem. It should lead to the + same answer and the algebra will be less tedious. This method, + however, uses some fancy ideas from "vector theory", which are + probably strange and unfamiliar to you. + + Think of the geometry. You know that for any two points there's a + "mirror line" that goes halfway between them. Technically, the line + consists of the locus of all points that are equidistant from your two + circle points; you can think of the line as a mirror where each of + your two points appears as a reflection of the other. + + Well, this line will help us a lot in constructing our center, because + we know that the center is on the line AND because we can use + Pythagoras to tell us where on the line the point is. Here's how we + can do all that with algebra. + + First, find the distance between points 1 and 2. We'll call that q, + and it's given by sqrt((x2-x1)^2 + (y2-y1)^2). + + Second, find the point halfway between your two points. We'll call it + (x3, y3). x3 = (x1+x2)/2 and y3 = (y1+y2)/2. + + Now find the direction of the line between point 1 and point 2. That + direction is (x1-x2, y1-y2). + + What we really want to know is the direction of the mirror line, which + is perpendicular to the line between point 1 and point 2. + + Here's a crucial trick: you can find the direction of a perpendicular + to a line just by swapping x with y and changing the sign of one. In + other words, if the direction of the joining line was (x1-x2, y1-y2) + then the direction of the mirror line is (y1-y2,x2-x1). + + It will be helpful to "normalize" our direction which means to make + the length of the line equal to 1. You do this just by dividing both + the (y1-y2) and the (x2-x1) by q. + + The two circle centers will both be on the mirror line, and we can use + geometry to find how far they are from the point (x3,y3): First + notice that the distance from point (x3,y3) to either point 1 or point + 2 is just half of q. Then the distance to move along the mirror line + is: + sqrt(r^2-(q/2)^2) + + Move up the mirror line by adding a multiple of the direction line to + the point (x3,y3) or move down the mirror line by subtracting the same + multiple. + + One answer will be: + + x = x3 + sqrt(r^2-(q/2)^2)*(y1-y2)/q + y = y3 + sqrt(r^2-(q/2)^2)*(x2-x1)/q + + The other will be: + + x = x3 - sqrt(r^2-(q/2)^2)*(y1-y2)/q + y = y3 - sqrt(r^2-(q/2)^2)*(x2-x1)/q + + """ + # + q = math.sqrt((p2[1] - p1[1]) ** 2 + (p2[0] - p1[0]) ** 2) # @UnusedVariable + # let p3 be the midpoint between p1 and p2 + p3 = ((p1[0] + p2[0]) * 0.5, (p1[1] + p2[1]) * 0.5) # @UnusedVariable + assert(False) # todo : finish this implementation + + pn = p0 = (0., 0.) + cn = None + for c in path_data_iter: + x0, y0 = p0 + xn, yn = pn + + if c.islower(): # coordinates are then relative coordinates + def next_p(): + dx, dy = next_d() + return (x0 + dx, y0 + dy) + + def next_x(): + dx = next_d() + return x0 + dx + + def next_y(): + dy = next_d() + return y0 + dy + c = c.upper() + else: + next_x = next_y = next_p = next_d + + if c == 'M': # Moveto + p1 = next_p() + # if path: + # paths.append((path, False, joins)) + # path = [p1] + # joins = [] + cairo_context.move_to(*p1) + + pn, p0 = p0, p1 + + elif c in "LHV": + if c == 'L': # Lineto + p1 = next_p() + elif c == 'H': # Horizontal Lineto + p1 = (next_x(), y0) + elif c == 'V': # Vertical Lineto + p1 = (x0, next_y()) + cairo_context.line_to(*p1) + # path.append(p1) + pn, p0 = p0, p1 + + elif c in "CS": # cubic bezier curve + if c == 'C': + p1 = next_p() + else: # 'S' + p1 = (2. * x0 - xn, 2 * y0 - yn) if cn in "CS" else p0 + p2, p3 = next_p(), next_p() + # path += _cubic(p0, p1, p2, p3, du2) + cairo_context.rel_curve_to(p1, p2, p3) + + pn, p0 = p2, p3 + + elif c in 'QT': # quadratic bezier curve + if c == 'Q': + p1 = next_p() + else: # 'T' + p1 = (2. * x0 - xn, 2 * y0 - yn) if cn in "QT" else p0 + p2 = next_p() + path += _quadric(p0, p1, p2, du2) + pn, p0 = p1, p2 + + elif c == 'A': # Arcto + rs, phi, flags = next_d(), next_d(), next_d() # @UnusedVariable + # rs = (rx, ry) : radius in each direction + # phi = rotation of the axis of the ellipse + # flags = (large-arc-flag, sweep-flag) + # large-arc-flag, indique si on doit afficher l’arc dont la mesure fait plus de la moitié du périmètre de l’ellipse (dans ce cas, la valeur est 1), ou l’arc dont la mesure fait moins de la moitié du périmètre (valeur : 0). + # sweep-flag, indique quant à lui si l’arc doit être dessiné dans la direction négative des angles (dans lequel cas sa valeur est 0) ou dans la direction positive des angles (valeur : 1) + p1 = next_p() + # p1 : end point + # path += _arc(p0, rs, phi, flags, p1, du2) + assert(False) # incomplete implementation + # cairo_context.rel_curve_to + pn, p0 = p0, p1 + + elif c == 'Z': # Closepath + x1, y1 = p1 = path[0] + dx, dy = x1 - x0, y1 - y0 + if (dx * dx + dy * dy) * du2 > 1.: + path.append(p1) + paths.append((path, True, joins)) + path = [] + joins = [] + pn, p0 = p0, p1 + + cn = c + joins.append(len(path) - 1) + + if path: + paths.append((path, False, joins)) + cairo_context.stroke() + cairo_context.fill() + + # print('rendering path') + + +def render_circle(circle_node, cairo_context): + """ renders the scenegraph circle 'circle_node' in the cairo drawing context 'cairo_context' + + :param circle_node: the scenegraph text to render + :type circle_node: scenegraph2d.Circle + :param cairo_context: the cairo drawing context + """ + color = circle_node.fill + cairo_context.set_source_rgb(*color.rgb) + cairo_context.arc(circle_node.cx, circle_node.cy, circle_node.r, 0.0, math.pi * 2.0) + cairo_context.fill() + + # print('render_circle : rendering circle (%f, %f, %f)' % (circle_node.cx, circle_node.cy, circle_node.r)) + + +def render_text(text_node, cairo_context): + """ renders the scenegraph text 'text' in the cairo drawing context 'cairo_context' + + :param text_node: the scenegraph text to render + :type text_node: scenegraph2d.Text + :param cairo_context: the cairo drawing context + """ + # face = wx.lib.wxcairo.FontFaceFromFont(wx.FFont(10, wx.SWISS, wx.FONTFLAG_BOLD)) + # ctx.set_font_face(face) + cairo_context.set_font_size(10) + (x, y, width, height, dx, dy) = cairo_context.text_extents(text_node.text) # @UnusedVariable + # ctx.move_to(*center.Get()) + # cairo_context.move_to(center.x - width/2, center.y + height/2) + # cairo_context.set_source_rgb(0, 0, 0) + + cairo_context.move_to(text_node._anchor(), 0.0) + cairo_context.show_text(text_node.text) + + # print('rendering text') + + +def render_node(node, cairo_context): + """ renders the scenegraph node 'node' in the cairo drawing context 'cairo_context' + + :param node: the scenegraph node to render + :type node: scenegraph2d.Element + :param cairo_context: the cairo drawing context + :type cairo_context: cairo.Context + """ + # print node.tag + try: + handler = { + # "svg": render_group, + "g": render_group, + # "symbol": render_group, + # "a": render_group, + # "defs": render_group, + # "clipPath": render_group, + # "mask": render_group, + # "path": sg.Path, + "rect": render_rectangle, + "circle": render_circle, + # "ellipse": sg.Ellipse, + "line": render_path, + # "polyline": sg.Polyline, + # "polygon": sg.Polygon, + "text": render_text, + }[node.tag] + except KeyError: + # log.warning("unhandled tag : %s" % node.tag) + print("unhandled tag : %s" % node.tag) + return + + # save the parent transform matrix + # parent_matrix = cairo_context.get_matrix() + cairo_context.save() + + if(hasattr(node, 'fill')): + # print("node.fill = %s" % str(node.fill)) + if (isinstance(node.fill, str)): + assert(False) # this shouldn't happen now that fill attribute is set to a Color node + match = re.match('^rgb\((?P[0-9]+),(?P[0-9]+),(?P[0-9]+)\)', node.fill) + if match: + r = float(match.group('r')) / 255.0 + g = float(match.group('g')) / 255.0 + b = float(match.group('b')) / 255.0 + else: + assert(False) + else: + r, g, b = node.fill.get_rgb() + cairo_context.set_source_rgb(r, g, b) + + # render the node + handler(node, cairo_context) + + cairo_context.restore() + + # restore the parent transform matrix (so that brother nodes car render relative to their parent) + # cairo_context.set_matrix(parent_matrix) + + +def render_scene(scene, cairo_context): + """ renders the scenegraph 'scene' in the cairo drawing context 'cairo_context' + + :param scene: the scenegraph to render + :type scene: scenegraph2d.Group + :param cairo_context: the cairo drawing context + :type cairo_context: cairo.Context + """ + render_node(scene, cairo_context) diff --git a/src/msspec/msspecgui/scenegraph2d/font/__init__.py b/src/msspec/msspecgui/scenegraph2d/font/__init__.py new file mode 100644 index 0000000..d5ab6e4 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/font/__init__.py @@ -0,0 +1,163 @@ +# -*- coding: utf-8 -*- + +"""font abstraction""" + + +# imports #################################################################### + +from itertools import chain + +from ctypes import byref, string_at + +from .utils import get_font + +from . import freetype2 as _ft2 +_FT = _ft2.FT +_library = _ft2._library + + +# globals #################################################################### + +def _on(tag): + return bool(tag & 1) + + +def _cubic(tag): + return bool(tag & 2) + + +# face ####################################################################### + +class Face(object): + def __init__(self, font_families, font_weight, font_style, px=10): + font_name, index = get_font(font_families, font_weight, font_style) + self.face = _ft2.Face() + self.pen = _ft2.Vector() + print('_library = %s' % str(_library)) + print('font_name = %s' % str(font_name)) + print('font_name.encode() = %s' % str(font_name.encode())) + if _FT.New_Face(_library, font_name.encode(), index, byref(self.face)) != 0: + raise ValueError("unable to create '%s' face" % font_name) + _FT.Select_Charmap(self.face, _ft2.ENCODING_UNICODE) + if px is not None: + self.set_size(px) + self._FT = _FT # keep a ref for finalizer + + def __del__(self): + try: + self._FT.Done_Face(self.face) + except AttributeError: + pass + + def set_size(self, px): + _FT.Set_Pixel_Sizes(self.face, 0, px) + + def set_transform(self, a=1., b=0., c=0., d=1., e=0., f=0.): + matrix = _ft2.Matrix() + matrix.xx, matrix.xy = int(a * 0x10000), int(b * 0x10000) + matrix.yx, matrix.yy = int(c * 0x10000), int(d * 0x10000) + self.pen.x = int(e * 64) + self.pen.y = int(-f * 64) + _FT.Set_Transform(self.face, byref(matrix), byref(self.pen)) + + def _glyph(self, uc): + glyph_index = _FT.Get_Char_Index(self.face, ord(uc)) + _FT.Load_Glyph(self.face, glyph_index, _ft2.LOAD_DEFAULT) + return self.face.contents.glyph.contents + + def get_hkerning(self, ucl, ucr): + if ucl is None: + return 0. + + left_glyph = _FT.Get_Char_Index(self.face, ord(ucl)) + right_glyph = _FT.Get_Char_Index(self.face, ord(ucr)) + kerning = _ft2.Vector() + _FT.Get_Kerning(self.face, left_glyph, right_glyph, + _ft2.KERNING_DEFAULT, byref(kerning)) + return kerning.x / 64. + + def get_bbox(self, text): + width = 0 + top, bottom = 0, 0 + up = None + glyph = None + for uc in text: + width += self.get_hkerning(up, uc) + up = uc + + glyph = self._glyph(uc) + width += glyph.metrics.horiAdvance / 64. + top = max(top, glyph.metrics.horiBearingY / 64.) + bottom = min(bottom, (glyph.metrics.horiBearingY - + glyph.metrics.height) / 64.) + if glyph: + width += (glyph.metrics.horiBearingX + glyph.metrics.width - + glyph.metrics.horiAdvance) / 64. + return (0., -top), (width, top - bottom) + + def bitmap(self, uc): + glyph = self._glyph(uc) + _FT.Render_Glyph(byref(glyph), _ft2.RENDER_MODE_NORMAL) + + origin = glyph.bitmap_left, -glyph.bitmap_top + bitmap = glyph.bitmap + assert bitmap.pixel_mode == _ft2.PIXEL_MODE_GRAY, bitmap.pixel_mode + + rows, columns = bitmap.rows, bitmap.pitch + size = columns, rows + offset = glyph.advance.x / 64., -glyph.advance.y / 64. + data = string_at(bitmap.buffer, rows * columns) + data = bytes(chain(*([255, 255, 255, c] for c in data))) + return origin, size, offset, data + + def outline(self, uc): + glyph = self._glyph(uc) + + outline = glyph.outline + + data = [] + b = 0 + for c in range(outline.n_contours): + e = outline.contours[c] + + # ensure we start with an 'on' point + for s in range(b, e + 1): + if _on(outline.tags[s]): + break + + # generate path data + contour = [] + command, offs = 'M', [] + for i in chain(range(s, e + 1), range(b, s + 1)): + point, tag = outline.points[i], outline.tags[i] + point = (point.x / 64., -point.y / 64.) + if _on(tag): # 'on' point + contour.append(command) + if command is 'Q' and len(offs) >= 2: + (x0, y0) = offs[0] + for (x1, y1) in offs[1:]: + contour += [(x0, y0), ((x0 + x1) / 2, (y0 + y1) / 2), 'Q'] + x0, y0 = x1, y1 + contour.append((x0, y0)) + else: # 'off' point + contour += offs + contour.append(point) + command, offs = 'L', [] + else: + offs.append(point) + command = 'C' if _cubic(tag) else 'Q' + if contour: + contour.append('Z') + data += contour + b = e + 1 + + # bbox + bbox = _ft2.BBox() + _FT.Outline_Get_BBox(byref(outline), byref(bbox)) + xmin, xmax = bbox.xMin / 64., bbox.xMax / 64. + ymin, ymax = bbox.yMin / 64., bbox.yMax / 64. + + origin = xmin, -ymax + size = xmax - xmin, ymax - ymin + offset = glyph.advance.x / 64., -glyph.advance.y / 64. + return origin, size, offset, data diff --git a/src/msspec/msspecgui/scenegraph2d/font/_cocoa.py b/src/msspec/msspecgui/scenegraph2d/font/_cocoa.py new file mode 100644 index 0000000..50d1c40 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/font/_cocoa.py @@ -0,0 +1,48 @@ +# -*- coding: utf-8 -*- + +"""Cocoa implementation of get_font""" + + +# imports #################################################################### + +from CoreText import ( # pylint: disable=import-error + CTFontCollectionCreateFromAvailableFonts, # @UnresolvedImport + CTFontCollectionCreateMatchingFontDescriptors, # @UnresolvedImport + kCTFontFamilyNameAttribute, # @UnresolvedImport + kCTFontTraitsAttribute, # @UnresolvedImport + kCTFontURLAttribute, # @UnresolvedImport + kCTFontSymbolicTrait, # @UnresolvedImport + kCTFontItalicTrait, # @UnresolvedImport + kCTFontBoldTrait, # @UnresolvedImport +) + + +# fonts ###################################################################### + +_font_collection = CTFontCollectionCreateFromAvailableFonts({}) +_font_descriptors = CTFontCollectionCreateMatchingFontDescriptors(_font_collection) + +_FONTS = {} +_FONT_NAMES = {} +for _font in _font_descriptors: + family = _font[kCTFontFamilyNameAttribute] + _fonts = _FONTS.get(family, {}) + _traits = _font[kCTFontTraitsAttribute] + _bold = bool(_traits[kCTFontSymbolicTrait] & kCTFontBoldTrait) + _italic = bool(_traits[kCTFontSymbolicTrait] & kCTFontItalicTrait) + _font_name = _font[kCTFontURLAttribute].path() + _key = _italic, _bold + _fonts[_key] = _font_name + _names = _FONT_NAMES.get(_font_name, []) + _names.append(_key) # TODO: no idea how to retreive fonst index in dfont file + _names.sort() # so rely on arbitrary assunption + _FONT_NAMES[_font_name] = _names + _FONTS[family] = _fonts + + +# utils ###################################################################### + +def _get_font(family, bold, italic): + key = italic, bold + font_name = _FONTS[family][key] + return font_name, _FONT_NAMES[font_name].index(key) diff --git a/src/msspec/msspecgui/scenegraph2d/font/freetype2.py b/src/msspec/msspecgui/scenegraph2d/font/freetype2.py new file mode 100644 index 0000000..a3d3fa6 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/font/freetype2.py @@ -0,0 +1,304 @@ +# -*- coding: utf-8 -*- + +"""freetype2.""" + + +# imports #################################################################### + +from ctypes import cdll, c_int, c_short, c_long, c_uint, c_ushort, c_char, c_byte, c_ubyte, c_void_p, Structure, POINTER, CFUNCTYPE, byref +from ctypes.util import find_library + + +# platform libraries ######################################################### + +from sys import platform as _platform +if _platform == "darwin": + # patching find_library to look into X11 libs + X11lib = "/usr/X11/lib" + from os import environ + try: + DYLD_LIBRARY_PATH = environ["DYLD_LIBRARY_PATH"] + except KeyError: + environ["DYLD_LIBRARY_PATH"] = X11lib + else: + environ["DYLD_LIBRARY_PATH"] = ":".join([DYLD_LIBRARY_PATH, + X11lib]) + + +class FreetypeWrapper(object): + def __init__(self, ft): + self.ft = ft + + def __getattr__(self, name): + return getattr(self.ft, "FT_%s" % name) + +FT = FreetypeWrapper(cdll.LoadLibrary(find_library("freetype"))) + +if _platform == "darwin": + try: + environ["DYLD_LIBRARY_PATH"] = DYLD_LIBRARY_PATH + del DYLD_LIBRARY_PATH + except NameError: + del environ["DYLD_LIBRARY_PATH"] + + +# types ###################################################################### + +Int = c_int +Short = c_short +Long = c_long +UInt = c_uint +UShort = c_ushort +String = c_char + +Fixed = c_long +Pos = c_long + + +class Vector(Structure): + _fields_ = [("x", Pos), + ("y", Pos)] + + +class Matrix(Structure): + _fields_ = [("xx", Fixed), + ("xy", Fixed), + ("yx", Fixed), + ("yy", Fixed)] + + +class Bitmap(Structure): + _fields_ = [("rows", c_int), + ("width", c_int), + ("pitch", c_int), + ("buffer", POINTER(c_ubyte)), # c_void_p), + ("num_grays", c_short), + ("pixel_mode", c_char), + ("palette_mode", c_char), + ("palette", c_void_p)] + + +class Outline(Structure): + _fields_ = [("n_contours", c_short), + ("n_points", c_short), + ("points", POINTER(Vector)), + ("tags", POINTER(c_byte)), + ("contours", POINTER(c_short)), + ("flags", c_int)] + + +class Size_Metrics(Structure): + _fields_ = [("x_ppem", UShort), + ("y_ppem", UShort), + ("x_scale", Fixed), + ("y_scale", Fixed), + ("ascender", Pos), + ("descender", Pos), + ("height", Pos), + ("max_advance", Pos)] + + +class Bitmap_Size(Structure): + _fields_ = [("height", Short), + ("width", Short), + ("size", Pos), + ("x_ppem", Pos), + ("y_ppem", Pos)] + + +class BBox(Structure): + _fields_ = [("xMin", Pos), + ("yMin", Pos), + ("xMax", Pos), + ("yMax", Pos)] + + +class Glyph_Metrics(Structure): + _fields_ = [("width", Pos), + ("height", Pos), + ("horiBearingX", Pos), + ("horiBearingY", Pos), + ("horiAdvance", Pos), + ("vertBearingX", Pos), + ("vertBearingY", Pos), + ("vertAdvance", Pos)] + + +Generic_Finalizer = CFUNCTYPE(c_void_p, c_void_p) + + +class Generic(Structure): + _fields_ = [("data", c_void_p), + ("finalizer", Generic_Finalizer)] + + +class Glyph_Format(c_int): + def __repr__(self): + v = self.value + return "".join(chr((v >> 8 * i) & 255) for i in reversed(range(4))) + +Encoding = c_int # enum + +SubGlyph = c_void_p # POINTER(SubGlyphRec) +Slot_Internal = c_void_p # POINTER(Slot_InternalRec) +Size_Internal = c_void_p # POINTER(Size_InternalRec) + + +class CharMapRec(Structure): + pass +CharMap = POINTER(CharMapRec) + + +class GlyphSlotRec(Structure): + pass +GlyphSlot = POINTER(GlyphSlotRec) + + +class SizeRec(Structure): + pass +Size = POINTER(SizeRec) + + +class FaceRec(Structure): + pass +Face = POINTER(FaceRec) + + +Library = c_void_p + + +CharMapRec._fields_ = [ + ("face", Face), + ("encoding", Encoding), + ("platform_id", UShort), + ("encoding_id", UShort) +] + +GlyphSlotRec._fields_ = [ + ("library", Library), + ("face", Face), + ("next", GlyphSlot), + ("reserved", UInt), + ("generic", Generic), + ("metrics", Glyph_Metrics), + ("linearHoriAdvance", Fixed), + ("linearVertAdvance", Fixed), + ("advance", Vector), + ("format", Glyph_Format), + ("bitmap", Bitmap), + ("bitmap_left", Int), + ("bitmap_top", Int), + ("outline", Outline), + ("num_subglyphs", UInt), + ("subglyphs", SubGlyph), + ("control_data", c_void_p), + ("control_len", c_long), + ("lsb_delta", Pos), + ("rsb_delta", Pos), + ("other", c_void_p), + ("internal", Slot_Internal), +] + +SizeRec._fields_ = [ + ("face", Face), + ("generic", Generic), + ("metrics", Size_Metrics), + ("internal", Size_Internal), +] + +FaceRec._fields_ = [ + ("num_faces", Long), + ("face_index", Long), + ("face_flags", Long), + ("style_flags", Long), + ("num_glyphs", Long), + ("family_name", POINTER(String)), + ("style_name", POINTER(String)), + ("num_fixed_sizes", Int), + ("available_sizes", POINTER(Bitmap_Size)), + ("num_charmaps", Int), + ("charmaps", POINTER(CharMap)), + ("generic", Generic), + ("bbox", BBox), + ("unit_per_EM", UShort), + ("ascender", Short), + ("descender", Short), + ("height", Short), + ("max_advance_width", Short), + ("max_advance_height", Short), + ("underline_position", Short), + ("underline_thickness", Short), + ("glyph", GlyphSlot), + ("size", Size), + ("charmap", CharMap), +] + + +# constants ################################################################## + +LOAD_DEFAULT = 0x0 # @IgnorePep8 +LOAD_NO_SCALE = 0x1 # @IgnorePep8 +LOAD_NO_HINTING = 0x2 # @IgnorePep8 +LOAD_RENDER = 0x4 # @IgnorePep8 +LOAD_NO_BITMAP = 0x8 # @IgnorePep8 +LOAD_VERTICAL_LAYOUT = 0x10 # @IgnorePep8 +LOAD_FORCE_AUTOHINT = 0x20 # @IgnorePep8 +LOAD_CROP_BITMAP = 0x40 # @IgnorePep8 +LOAD_PEDANTIC = 0x80 # @IgnorePep8 +LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = 0x200 +LOAD_NO_RECURSE = 0x400 # @IgnorePep8 +LOAD_IGNORE_TRANSFORM = 0x800 # @IgnorePep8 +LOAD_MONOCHROME = 0x1000 # @IgnorePep8 +LOAD_LINEAR_DESIGN = 0x2000 # @IgnorePep8 + +[ + PIXEL_MODE_NONE, + PIXEL_MODE_MONO, + PIXEL_MODE_GRAY, + PIXEL_MODE_GRAY2, + PIXEL_MODE_GRAY4, + PIXEL_MODE_LCD, + PIXEL_MODE_LCD_V, + PIXEL_MODE_MAX +] = [bytes([i]) for i in range(8)] + +[ + RENDER_MODE_NORMAL, + RENDER_MODE_LIGHT, + RENDER_MODE_MONO, + RENDER_MODE_LCD, + RENDER_MODE_LCD_V, + RENDER_MODE_MAX +] = range(6) + +[ + KERNING_DEFAULT, + KERNING_UNFITTED, + KERNING_UNSCALED, +] = range(3) + + +def LOAD_TARGET_(x): + return ((x) & 15) << 16 + +LOAD_TARGET_NORMAL = LOAD_TARGET_(RENDER_MODE_NORMAL ) # @IgnorePep8 +LOAD_TARGET_LIGHT = LOAD_TARGET_(RENDER_MODE_LIGHT ) # @IgnorePep8 +LOAD_TARGET_MONO = LOAD_TARGET_(RENDER_MODE_MONO ) # @IgnorePep8 +LOAD_TARGET_LCD = LOAD_TARGET_(RENDER_MODE_LCD ) # @IgnorePep8 +LOAD_TARGET_LCD_V = LOAD_TARGET_(RENDER_MODE_LCD_V ) # @IgnorePep8 + + +def ENC_TAG(s): + a, b, c, d = s + return (ord(a) << 24 | + ord(b) << 16 | + ord(c) << 8 | # @IgnorePep8 + ord(d)) + +ENCODING_UNICODE = ENC_TAG("unic") + + +# initialisation ############################################################# + +_library = Library() +FT.Init_FreeType(byref(_library)) diff --git a/src/msspec/msspecgui/scenegraph2d/font/utils.py b/src/msspec/msspecgui/scenegraph2d/font/utils.py new file mode 100644 index 0000000..58ccefe --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/font/utils.py @@ -0,0 +1,77 @@ +# -*- coding: utf-8 -*- + +# imports #################################################################### + +import os + +from sys import platform as _platform + +if _platform == "darwin": + try: + from ._cocoa import _get_font + except ImportError: + pass + +try: + _get_font +except NameError: + def _get_font(family, bold, italic): # pylint: disable=function-redefined + raise LookupError + + +# constants ################################################################## + +_CONTRIBS_PATH = os.path.abspath(os.path.join(os.path.dirname(__file__), + "..", "..", + "contribs", "freefont-20120503")) + +_FALLBACK_FONTS = { + "sans-serif": { + (False, False): os.path.join(_CONTRIBS_PATH, "FreeSans.otf"), + (False, True): os.path.join(_CONTRIBS_PATH, "FreeSansOblique.otf"), + (True, False): os.path.join(_CONTRIBS_PATH, "FreeSansBold.otf"), + (True, True): os.path.join(_CONTRIBS_PATH, "FreeSansBoldOblique.otf"), + }, + "serif": { + (False, False): os.path.join(_CONTRIBS_PATH, "FreeSerif.otf"), + (False, True): os.path.join(_CONTRIBS_PATH, "FreeSerifItalic.otf"), + (True, False): os.path.join(_CONTRIBS_PATH, "FreeSerifBold.otf"), + (True, True): os.path.join(_CONTRIBS_PATH, "FreeSerifBoldItalic.otf"), + }, + "mono": { + (False, False): os.path.join(_CONTRIBS_PATH, "FreeMono.otf"), + (False, True): os.path.join(_CONTRIBS_PATH, "FreeMonoOblique.otf"), + (True, False): os.path.join(_CONTRIBS_PATH, "FreeMonoBold.otf"), + (True, True): os.path.join(_CONTRIBS_PATH, "FreeMonoBoldOblique.otf"), + }, +} + + +# font lookup ################################################################ + + +def _get_fallback_font(family, bold=False, italic=False): + return _FALLBACK_FONTS[family][bold, italic], 0 + + +def get_font(families, weight="normal", style="normal"): + bold = weight in ["bold", "bolder", "600", "700", "800", "900"] + italic = style in ["italic", "oblique"] + families = [family.strip() for family in families.split(',')] + ["sans-serif"] + font_name, index = None, 0 + for font_getter in [_get_font, _get_fallback_font]: + for family in families: + try: + font_name, index = font_getter(family, bold, italic) + except LookupError: + continue + break + else: + continue + break + return font_name, index + + +__all__ = [ + "get_font", +] diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/__init__.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/__init__.py new file mode 100644 index 0000000..9b7c047 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/__init__.py @@ -0,0 +1,10 @@ +# -*- coding: utf-8 -*- + +"""seagull.scenegraph module""" + +from .paint import Color, LinearGradient, RadialGradient, Pattern +from .transform import Translate, Scale, Rotate, SkewX, SkewY, Matrix +from .element import (Use, Group, Path, + Rectangle, Circle, Ellipse, + Line, Polyline, Polygon, + Text, Image) diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/_common.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/_common.py new file mode 100644 index 0000000..0659fcb --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/_common.py @@ -0,0 +1,110 @@ +# -*- coding: utf-8 -*- + +""" +misc utility functions and classes +""" + + +# utils ###################################################################### + +def _indent(s, level=1, tab="\t"): + """indent blocks""" + indent = tab * level + return "\n".join("%s%s" % (indent, line) for line in s.split("\n")) + + +def _u(v, encoding="utf8"): + """provides a unicode string from anything.""" + if isinstance(v, str): + return v + elif isinstance(v, (list, tuple)): + return " ".join(_u(vi, encoding) for vi in v) + elif v is None: + return "none" + else: + return str(v) + + +# base classes ############################################################### + +class _Base(object): + """equality based on state rather than id""" + + _state_attributes = [] + + def _state(self): + return {name: getattr(self, name) + for name in self._state_attributes} + + def __eq__(self, other): + try: + return other._state() == self._state() + except AttributeError: + return False + + def __ne__(self, other): + return not self.__eq__(other) + +# def __hash__(self): return hash(self._state()) + + def __hash__(self): + raise RuntimeError("state is not hashable") + + +class _Element(_Base): + """element with xml serialization support""" + + _state_attributes = ["tag"] + attributes = [] + + def __init__(self): + super(_Element, self).__init__() + self.id = None + + @property + def tag(self): + """the svg tag that represents this element + """ + raise NotImplementedError # this tag is suppsed to be defined in derived classes + + def _xml(self, defs): + """xml serialization""" + u = "<%s %s" % (self.tag, self._xml_attributes(defs)) + content = self._xml_content(defs) + if content.strip(): + u += ">\n" + \ + _indent(content) + "\n" + \ + "" % self.tag + else: + u += "/>" + return u + + def _xml_content(self, defs): + """xml serialization of content""" + return "" + + def _xml_attributes(self, defs): + """xml serialization of attributes""" + return " ".join(self._xml_attribute(name, defs) for name in self.attributes) + + def _xml_attribute(self, name, defs): + """unicode serialization of attribute/value pair""" + attribute = getattr(self, name) + if name == "href": + name = "xlink:href" + try: + href = "#%s" % attribute.id + except: + pass + else: + defs.append(attribute) + attribute = href + try: + u = attribute._xml_attr(defs) + except AttributeError: + u = _u(attribute) + return "%s='%s'" % (name.replace("_", "-"), u) if u else "" + + def _xml_attr(self, defs): + defs.append(self) + return "url(#%s)" % self.id diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/__init__.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/__init__.py new file mode 100644 index 0000000..2af8c00 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/__init__.py @@ -0,0 +1,294 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element +""" + +# imports #################################################################### + +from weakref import WeakValueDictionary as _weakdict + +# from ...opengl.utils import OffscreenContext +from .._common import _Element +from ..paint import Color, _Texture, _MaskContext +from ..transform import Matrix, Translate, stretch, product + + +# element #################################################################### + +_elements_by_id = _weakdict() + + +def _id(element): + element_id = getattr(element, "_id", "%X" % id(element)) + _elements_by_id[element_id] = element + return element_id + + +def get_element_by_id(element_id): + return _elements_by_id[element_id] + +""" + List of all possible attributes for svg nodes +""" +_ATTRIBUTES = [ + "id", "href", + "x", "y", + "width", "height", + "r", "rx", "ry", + "cx", "cy", + "points", + "x1", "x2", "y1", "y2", + "opacity", "color", + "fill", "fill_opacity", "fill_rule", + "stroke", "stroke_opacity", "stroke_width", + "stroke_linecap", "stroke_linejoin", "stroke_miterlimit", + "stroke_dasharray", "stroke_dashoffset", + "font_family", "font_weight", "font_style", "font_size", + "text_anchor", + "transform", + "clip_path", + "mask", + "d", +] + +_INHERITEDS = { + "color": Color.black, + "fill": Color.black, + "fill_opacity": 1., + "fill_rule": 'nonzero', + "stroke": Color.none, + "stroke_opacity": 1., + "stroke_width": 1, + "stroke_linecap": 'butt', + "stroke_linejoin": 'miter', + "stroke_miterlimit": 4., + "stroke_dasharray": None, + "stroke_dashoffset": 0., + "font_family": 'sans-serif', + "font_weight": 'normal', + "font_style": 'normal', + "font_size": 10, + "text_anchor": 'start', +} + + +class Element(_Element): + """ A node in the svg tree + """ + x, y = 0, 0 + transform = None + + opacity = 1. + clip_path = None + mask = None + + _state_attributes = _Element._state_attributes + list(_INHERITEDS) + [ + "x", "y", "transform", + "opacity", "clip_path", "mask" + ] + + def __init__(self, **attributes): + """ + :param attributes: svg attributes (eg for a circle element : { 'cx':'5.0', 'cy':'10.0', 'r':'6.0', 'transform':'translate(30,40) rotate(45)' }) + """ + self._attributes = set() + self._inheriteds = _INHERITEDS + for attribute in attributes: + setattr(self, attribute, attributes[attribute]) + # the transform attribute contains a list of transformations associated to this Element. It doesn't take into account its parents transforms. + if self.transform is None: + # empty list of transforms if the transform svg attribute is not present in the svg node + self.transform = [] + self._parent = None # the svg group containing this element + + def __setattr__(self, attribute, value): + if attribute in _ATTRIBUTES: + self._attributes.add(attribute) + super(Element, self).__setattr__(attribute, value) + + def __delattr__(self, attribute): + super(Element, self).__delattr__(attribute) + if attribute in _ATTRIBUTES: + self._attributes.remove(attribute) + + def __getattr__(self, attribute): + if attribute in _INHERITEDS: + return self._inheriteds[attribute] + try: + return super(Element, self).__getattr__(attribute) + except AttributeError: + return super(Element, self).__getattribute__(attribute) + + def _inherit(self, inheriteds): + self._inheriteds = inheriteds + return {attr: getattr(self, attr) for attr in _INHERITEDS} + + @property + def id(self): + self._attributes.add("id") + return _id(self) + + @property + def attributes(self): + return (name for name in _ATTRIBUTES if name in self._attributes) + + def __hash__(self): + return id(self) # hash((self.name, self.location)) + + def __eq__(self, other): + return id(self) == id(other) + + def __ne__(self, other): + # Not strictly necessary, but to avoid having both x==y and x!=y + # True at the same time + return not(self == other) + + @property + def parent(self): + """ + :rtype: scenegraph.Element + """ + return self._parent + + @parent.setter + def parent(self, parent_group): + self._parent = parent_group + + # transformations + + def local_to_parent_matrix(self): + """returns the matrix that converts coordinates in this node's space to its parent's space + + :rtype: scenegraph.Matrix + """ + return product(*self.transform + [Translate(self.x, self.y)]) + + def parent_to_world_matrix(self): + """returns the matrix that converts coordinates in this node's parent's space to the world space + + :rtype: scenegraph.Matrix + """ + if self.parent is None: + return Matrix() + else: + return self.parent.parent_to_world_matrix() * self.parent.local_to_parent_matrix() # pylint: disable=no-member + + def local_to_world_matrix(self): + """returns the matrix that converts coordinates in this node's space to the world space + + :rtype: scenegraph.Matrix + """ + return self.parent_to_world_matrix() * self.local_to_parent_matrix() # pylint: disable=no-member + + # axis-aligned bounding box + + def aabbox(self, transform=Matrix(), inheriteds=_INHERITEDS): + """returns the axis-aligned bounding box of this xml element + """ + inheriteds = self._inherit(inheriteds) + return self._aabbox(transform * self.local_to_parent_matrix(), inheriteds) + + def _aabbox(self, transform, inheriteds): + raise NotImplementedError + + def _units(self, elem, attr, default="userSpaceOnUse"): + units = getattr(elem, attr, default) + if units == "userSpaceOnUse": + transform = Matrix() + elif units == "objectBoundingBox": + (x_min, y_min), (x_max, y_max) = self.aabbox() + transform = stretch(x_min, y_min, x_max - x_min, y_max - y_min) + else: + raise ValueError("unknown units %s" % units) + return product(*self.transform) * transform + + # rendering + + def _color(self, color): + if color == Color.current: + return self.color + return color + + def render(self, transform=Matrix(), inheriteds=_INHERITEDS, context=None, + clipping=True, masking=True, opacity=True): + inheriteds = self._inherit(inheriteds) + if context is None: + # context = OffscreenContext() + assert False + + if (clipping and self.clip_path) or (masking and self.mask): + if clipping and self.clip_path: + clipping = False + mask, units = self.clip_path, "clipPathUnits" + else: + masking = False + mask, units = self.mask, "maskContentUnits" + + mask_transform = self._units(mask, units) + with context(mask.aabbox(transform * mask_transform), + (0., 0., 0., 0.)) as ((x, y), (width, height), + mask_texture_id): + if not mask_texture_id: + return + mask.render(transform * mask_transform, context=context) + + with _MaskContext((x, y), (width, height), mask_texture_id): + self.render(transform, inheriteds, context, + clipping=clipping, masking=masking, opacity=opacity) + + elif opacity and self.opacity < 1.: + with context(self.aabbox(transform, inheriteds)) as \ + ((x, y), (width, height), elem_texture_id): + if not elem_texture_id: + return + self.render(transform, inheriteds, context, + clipping=clipping, masking=masking, opacity=False) + + Rectangle(x=x, y=y, width=width, height=height, + fill=_Texture(elem_texture_id), + fill_opacity=self.opacity).render(context=context) + + else: + self._render(transform * self.local_to_parent_matrix(), inheriteds, context) + + def _render(self, transform, inheriteds, context): + raise NotImplementedError + + # picking + + def _hit_test(self, x, y, transform): + """tests if the position (x,y) collides with this shape (not its children) + """ + return [] + + def pick(self, x=0, y=0, parent_to_world=Matrix()): + """ + returns the list of svg nodes that are hit when picking at position x,y + + :param parent_to_world: the transformation matrix that converts coordinates from this element's parent space to the scene's world space (the space in which x and y coordinates are expressed) + """ + parent_to_world = parent_to_world * self.local_to_parent_matrix() + hits = self._hit_test(x, y, parent_to_world) + hits += [([self] + e, p) for e, p in self._pick_content(x, y, parent_to_world)] + return hits + + def _pick_content(self, x, y, transform): + """tests if the position (x,y) collides with the children shapes of this shape + """ + return [] + + +# elements ################################################################### + +from .use import Use # @IgnorePep8 +from .group import Group # @IgnorePep8 +from .rectangle import Rectangle # @IgnorePep8 +from .circle import Circle # @IgnorePep8 +from .ellipse import Ellipse # @IgnorePep8 +from .line import Line # @IgnorePep8 +from .polyline import Polyline # @IgnorePep8 +from .polygon import Polygon # @IgnorePep8 +from .path import Path # @IgnorePep8 +from .text import Text # @IgnorePep8 +from .image import Image # @IgnorePep8 diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/_path.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/_path.py new file mode 100644 index 0000000..c762061 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/_path.py @@ -0,0 +1,361 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element._path + +Low level path utility functions suitable for optimizations based on typing. +""" + + +# imports #################################################################### + +from math import hypot, sqrt, pi, cos, sin, atan2, radians + + +# constants ################################################################## + +INF = float("inf") + + +# geometry ################################################################### + + +def _line(p0, p1): + """equation of (p0, p1) in the ax+by+c=0 form.""" + (x0, y0), (x1, y1) = p0, p1 + dx, dy = x1 - x0, y1 - y0 + return dy, -dx, y0 * dx - x0 * dy + + +def _intersection(l0, l1, e=1e-6): + """intersection of lines.""" + a0, b0, c0 = l0 + a1, b1, c1 = l1 + w = a0 * b1 - a1 * b0 + x = b0 * c1 - b1 * c0 + y = c0 * a1 - c1 * a0 + if abs(w) < e: + raise ZeroDivisionError + return x / w, y / w + + +def _parallel(l, p): + """parallel to l passing by p.""" + a, b, c = l # @UnusedVariable + x, y = p + return a, b, -(a * x + b * y) + + +def _h(p0, p1): + """distance between two points.""" + (x0, y0), (x1, y1) = p0, p1 + return hypot(x1 - x0, y1 - y0) + + +def _lerp(p0, p1, t=.5): + (x0, y0), (x1, y1) = p0, p1 + return x0 + t * (x1 - x0), y0 + t * (y1 - y0) + + +# flattening ################################################################# + +# Bézier splines + +_L2_RATIO = 4 # trade-off precision for polygons + + +def _casteljau(p0, p1, p2, p3, t=.5): + """de Casteljau subdivision of cubic Bézier curve.""" + p01, p12, p23 = _lerp(p0, p1, t), _lerp(p1, p2, t), _lerp(p2, p3, t) + p012, p123 = _lerp(p01, p12, t), _lerp(p12, p23, t) + p0123 = _lerp(p012, p123, t) + return p01, p12, p23, p012, p123, p0123 + + +def _cubic(p0, p1, p2, p3, du2): + """cubic Bézier spline flattenization.""" + if (p0, p2) == (p1, p3): + return [p3] + + (x0, y0), (x1, y1), (x2, y2), (x3, y3) = p0, p1, p2, p3 + d1 = (x3 - x0) * (y1 - y0) - (y3 - y0) * (x1 - x0) + d2 = (x3 - x0) * (y2 - y0) - (y3 - y0) * (x2 - x0) + dd03 = (x3 - x0) * (x3 - x0) + (y3 - y0) * (y3 - y0) + if (d1 * d1 + d2 * d2) * du2 < dd03 * _L2_RATIO: + return [_lerp(p1, p2), p3] + else: + p01, p12, p23, p012, p123, p0123 = _casteljau(p0, p1, p2, p3) # @UnusedVariable + return _cubic(p0, p01, p012, p0123, du2) + \ + _cubic(p0123, p123, p23, p3, du2) + + +def _quadric(p0, p1, p2, du2): + """quadric Bézier spline flattenization by transforming it to cubic.""" + return _cubic(p0, _lerp(p0, p1, 2 / 3.), _lerp(p1, p2, 1 / 3.), p2, du2) + + +# arc + +def _arc(p0, rs, phi, flags, p1, du2): + """arc flatenization. + + implementation derived from + + """ + if p0 == p1: + return [] + + rx, ry = rs + if rx == 0 or ry == 0: + return [p1] + rx, ry = abs(rx), abs(ry) + + phi = radians(phi) % pi + c, s = cos(phi), sin(phi) + + large_arc, sweep = map(bool, flags) + + (x0, y0), (x1, y1) = p0, p1 + + ux, uy = .5 * (x0 - x1), .5 * (y0 - y1) + X, Y = c * ux + s * uy, -s * ux + c * uy + + X2, Y2, r2x, r2y = X * X, Y * Y, rx * rx, ry * ry + L2 = X2 / r2x + Y2 / r2y + + if L2 > 1.: + L = sqrt(L2) + rx, ry = L * rx, L * ry + r2x, r2y = L2 * r2x, L2 * r2y + + K = sqrt(max(0., (r2x * r2y - r2x * Y2 - r2y * X2) / (r2x * Y2 + r2y * X2))) + if large_arc == sweep: + K = -K + Xc, Yc = K * Y * rx / ry, -K * X * ry / rx + + a0 = atan2(-(Yc - Y) / ry, -(Xc - X) / rx) + da = atan2(-(Yc + Y) / ry, -(Xc + X) / rx) - a0 + if sweep: + if da < 0: + da += 2 * pi + else: + if da > 0: + da -= 2 * pi + + path = [] + xc, yc = c * Xc - s * Yc + ux + x1, s * Xc + c * Yc + uy + y1 + N = int((((r2x + r2y) * du2) ** .25) * abs(da)) + for i in range(N - 1): + a = a0 + da * (i + 1) / N + X, Y = rx * cos(a), ry * sin(a) + path.append((c * X - s * Y + xc, s * X + c * Y + yc)) + path.append(p1) # i in range(N) introduce numerical errors for p1 + + return path + + +# stroking ################################################################### + +# caps + +def _offset(p0, p1, hw): + if p0 == p1: + return 0., hw + (x0, y0), (x1, y1) = p0, p1 + dx, dy = x1 - x0, y1 - y0 + w = hw / hypot(dx, dy) + return dy * w, -dx * w + + +def _caps_butt(p0, p1, hw, du=1, start=True): + """compute butt cap of width 2*hw for [p0,p1].""" + aw, bw = _offset(p0, p1, hw) + if start: + x, y = p0 + else: + x, y = p1 + return [(x + aw, y + bw), (x - aw, y - bw)] + + +def _caps_square(p0, p1, hw, du=1, start=True): + """compute square cap of width 2*hw for [p0,p1].""" + aw, bw = _offset(p0, p1, hw) + if start: + x, y = p0 + return [(x + aw + bw, y + bw - aw), (x - aw + bw, y - bw - aw), + (x + aw, y + bw), (x - aw, y - bw)] + else: + x, y = p1 + return [(x + aw, y + bw), (x - aw, y - bw), + (x + aw - bw, y + bw + aw), (x - aw - bw, y - bw + aw)] + + +def _caps_round(p0, p1, hw, du=1, start=True): + """compute round cap of width 2*hw for [p0,p1].""" + aw, bw = _offset(p0, p1, hw) + n = int(sqrt(hw * du)) + 1 # 1/(du*hw) ~ 1 - cos(da/2) ~ daˆ2/8 at first order + da = pi / (2 * n + 1) + if start: + x, y = p0 + n0 = n + else: + x, y = p1 + n0 = 0 + r = [] + for i in range(n + 1): + a = (n0 - i) * da + c, s = cos(a), sin(a) + r += [(x + c * aw + s * bw, y + c * bw - s * aw), (x - c * aw + s * bw, y - c * bw - s * aw)] + return r + +# join + + +def _join_miter(p0, p1, p2, hw, du, miterlimit): + p0a, p0b, p1a, p1b = _join_bevel(p0, p1, p2, hw, du, miterlimit) + l0, l1 = _line(p0, p1), _line(p1, p2) + try: + pa = _intersection(_parallel(l0, p0a), _parallel(l1, p1a)) + pb = _intersection(_parallel(l0, p0b), _parallel(l1, p1b)) + except ZeroDivisionError: + return [p1a, p1b] + r = miterlimit * hw / _h(p1a, pa) + if r < 1.: + return [_lerp(p0a, pa, r), _lerp(p0b, pb, r), + _lerp(p1a, pa, r), _lerp(p1b, pb, r)] +# return [p0a, p0b, p1a, p1b] + else: + return [pa, pb] + + +def _join_bevel(p0, p1, p2, hw, du, miterlimit): + return _caps_butt(p0, p1, hw, start=False) + \ + _caps_butt(p1, p2, hw) + + +def _join_round(p0, p1, p2, hw, du, miterlimit): + return _caps_butt(p0, p1, hw, du, start=False) + \ + _caps_round(p1, p2, hw, du) + +# stroke + +_caps = { + 'butt': _caps_butt, + 'square': _caps_square, + 'round': _caps_round, +} + +_joins = { + 'miter': _join_miter, + 'bevel': _join_bevel, + 'round': _join_round, +} + + +def _enumerate_unique(path): + previous = None + for i, p in enumerate(path): + if p != previous: + yield i, p + previous = p + + +def _stroke(path, closed, joins, width, du=1., + cap='butt', join='miter', miterlimit=4.): + """compute a stroke from discretized path.""" + hw = width / 2. + _cap = _caps[cap] + _join = _joins[join] + stroke = [] + + path_points = _enumerate_unique(path) + (i0, p0) = next(path_points) + (i1, p1) = next(path_points, (i0, p0)) + p0i, p1i = p0, p1 + + join_indices = iter(joins) + next_join = next(join_indices) + while next_join < i1: + next_join = next(join_indices) + + for i2, p2 in path_points: + if i1 == next_join: + j = _join(p0, p1, p2, hw, du, miterlimit) + next_join = next(join_indices, 0) + else: + j = _join_miter(p0, p1, p2, hw, du, 1.) + stroke += j + i1 = i2 + p0, p1 = p1, p2 + + if closed: + b = e = _join(p0, p1, p1i, hw, du, miterlimit) + else: + b = _cap(p0i, p1i, hw, du) + e = _cap(p0, p1, hw, du, start=False) + + return b + stroke + e + + +# filling #################################################################### + +def _triangle_strip_hits(strip, x, y): + """yields hits and signs in triangles stored as strip.""" + strip_iter = iter(strip) + p0, p1 = next(strip_iter), next(strip_iter) + a0, b0, c0 = _line(p0, p1) + s0, s = a0 * x + b0 * y + c0, 1 + for p2 in strip_iter: + a1, b1, c1 = _line(p1, p2) + s1 = a1 * x + b1 * y + c1 + a2, b2, c2 = _line(p2, p0) + s2 = a2 * x + b2 * y + c2 + yield (s0 * s1 > 0) and (s1 * s2 > 0), s0 * s > 0 + p0, p1 = p1, p2 + s0, s = s1, -s + + +def _evenodd_hit(x, y, fills): + """even/odd hit test on interior of a path.""" + # print( '_evenodd_hit : coucou') + in_count = 0 + for hit, _ in _triangle_strip_hits(fills, x, y): + if hit: + in_count += 1 + # print( '_evenodd_hit : in_count=%d' % in_count ) + return (in_count % 2) == 1 + + +def _nonzero_hit(x, y, fills): + """non-zero hit test on interior of a path.""" + # print( '_nonzero_hit : coucou') + in_count = 0 + for hit, positive in _triangle_strip_hits(fills, x, y): + if hit: + if positive: + in_count += 1 + # print( '_nonzero_hit : positive hit : in_count=%d' % in_count ) + else: + in_count -= 1 + # print( '_nonzero_hit : negative hit : in_count=%d' % in_count ) + # print( '_nonzero_hit : in_count=%d' % in_count ) + return in_count != 0 + + +def _stroke_hit(x, y, strokes): + """hit test on stroke of a path.""" + for hit, _ in _triangle_strip_hits(strokes, x, y): + if hit: + return True + return False + + +def _bbox(paths): + """bounding box of a path.""" + x_min = y_min = +INF + x_max = y_max = -INF + for path in paths: + xs, ys = zip(*path) + x_min, x_max = min(x_min, min(xs)), max(x_max, max(xs)) + y_min, y_max = min(y_min, min(ys)), max(y_max, max(ys)) + return (x_min, y_min), (x_max, y_max) diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/circle.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/circle.py new file mode 100644 index 0000000..ee1ecdc --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/circle.py @@ -0,0 +1,26 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.circle +""" + + +# imports #################################################################### + +from .path import Path + + +# circle ##################################################################### + +class Circle(Path): + tag = "circle" + + cx, cy = 0, 0 + r = 0 + + @property + def d(self): + cx, cy = self.cx, self.cy + r = self.r + return ['M', (cx - r, cy), 'a', (r, r), 0, (0, 0), (2 * r, 0), + 'a', (r, r), 0, (0, 0), (-2 * r, 0), 'Z'] diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/ellipse.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/ellipse.py new file mode 100644 index 0000000..ba96325 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/ellipse.py @@ -0,0 +1,28 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.ellipse +""" + + +# imports #################################################################### + +from .path import Path + + +# ellipse #################################################################### + +class Ellipse(Path): + tag = "ellipse" + + cx, cy = 0, 0 + rx, ry = 0, 0 + + @property + def d(self): + cx, cy = self.cx, self.cy + rx, ry = self.rx, self.ry + if rx <= 0. or ry <= 0.: + return [] + return ['M', (cx - rx, cy), 'a', (rx, ry), 0, (0, 0), (2 * rx, 0), + 'a', (rx, ry), 0, (0, 0), (-2 * rx, 0), 'Z'] diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/group.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/group.py new file mode 100644 index 0000000..f0efbe2 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/group.py @@ -0,0 +1,60 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.group +""" + + +# imports #################################################################### + +from . import Element +from ._path import _bbox + + +# group ###################################################################### + +_empty_bbox = _bbox([]) + + +class Group(Element): + tag = "g" + + _state_attributes = Element._state_attributes + [ + "children", + ] + + def __init__(self, children=None, **attributes): + super(Group, self).__init__(**attributes) + self.children = children if children is not None else [] + + def _aabbox(self, transform, inheriteds): + bboxes = (child.aabbox(transform, inheriteds) for child in self.children) + return _bbox(bbox for bbox in bboxes if bbox != _empty_bbox) + + def _render(self, transform, inheriteds, context): + for child in self.children: + child.render(transform, inheriteds, context) + + def _pick_content(self, x, y, transform): + hits = [] + for child in self.children: + # print('Group._pick_content : child = %s' % str(child) ) + hits += child.pick(x, y, transform) + # print('Group._pick_content : len(hits) = %d' % len(hits) ) + + return hits + + def _xml_content(self, defs): + return "\n".join(child._xml(defs) for child in self.children) + + def add_child(self, child): + """ + :param child: the new child to append to the list of children of this svg group + :type child: a scenegraph.element.Element derived object + """ + self.children.append(child) + child.parent = self + # assert(child.parent == self) + + def remove_child(self, child_to_remove): + self.children = [child for child in self.children if child is not child_to_remove] diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/image.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/image.py new file mode 100644 index 0000000..a02c914 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/image.py @@ -0,0 +1,71 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.image +""" + + +# imports #################################################################### + +from os.path import abspath + +try: + from PIL import Image as _Image +except ImportError: + class _Image(object): + size = (0, 0) + mode = "RGBA" + + @classmethod + def open(klass, href): + return _Image() + + def tobytes(self): + return b"" + + def convert(self, img_format): + raise NotImplementedError + +# from ...opengl.utils import create_texture +from ..paint import Color, _Texture +from .rectangle import Rectangle + + +# image ###################################################################### + +class Image(Rectangle): + tag = "image" + + _state_attributes = Rectangle._state_attributes + [ + "href", + ] + + fill = Color.white + + def __init__(self, href, width=None, height=None, **attributes): + href = abspath(href) + pil_image = _Image.open(href) + if pil_image.mode not in ["RGB", "RGBA"]: + pil_image = pil_image.convert("RGBA") + iw, ih = pil_image.size + if width is None: + width = iw + if height is None: + height = ih + super(Image, self).__init__(width=width, height=height, + **attributes) + self.href = "file://%s" % href + + self._texture_args = (pil_image.size, + pil_image.tobytes(), + pil_image.mode) + + def _render(self, transform, inheriteds, context): + (width, height), data, texture_format = self._texture_args + del self._texture_args + + # self.fill = _Texture(create_texture(width, height, data, texture_format), self.fill) + assert False # call to opengl code removed but there doesn't seem to be a cairo implementation + self._attributes.remove("fill") + + super(Image, self)._render(transform, inheriteds, context) diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/line.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/line.py new file mode 100644 index 0000000..f4649c0 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/line.py @@ -0,0 +1,25 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.line +""" + + +# imports #################################################################### + +from .path import Path + + +# line ####################################################################### + +class Line(Path): + tag = "line" + + fill = None + + x1, y1 = 0, 0 + x2, y2 = 0, 0 + + @property + def d(self): + return ['M', (self.x1, self.y1), 'L', (self.x2, self.y2)] diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/path.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/path.py new file mode 100644 index 0000000..f198e46 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/path.py @@ -0,0 +1,355 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.path +""" + + +# imports #################################################################### + +# from collections import defaultdict +from copy import deepcopy +from math import log, floor, sqrt + +# from ...opengl.utils import create_vbo +from . import Element +from ._path import (_cubic, _quadric, _arc, _stroke, _evenodd_hit, _nonzero_hit, _stroke_hit, _bbox) + + +# flattening ################################################################# + +def _flatten(path_data, du2=1.): + """discretize path into straight segments. + + :param path_data: path description encoded with svg format, as a list of elements, which are either one-letter keywords or numeric arguments. For example, for a circle, this would be 'M', (cx-r, cy), 'a', (r, r), 0, (0, 0), ( 2*r, 0), 'a', (r, r), 0, (0, 0), (-2*r, 0), 'Z'] + """ + paths = [] + path = [] + joins = [] + + path_data_iter = iter(path_data) + + def next_d(): + return next(path_data_iter) + + pn = p0 = (0., 0.) + cn = None + for c in path_data_iter: + x0, y0 = p0 + xn, yn = pn + + if c.islower(): # coordinates are then relative coordinates + def next_p(): + dx, dy = next_d() + return (x0 + dx, y0 + dy) + + def next_x(): + dx = next_d() + return x0 + dx + + def next_y(): + dy = next_d() + return y0 + dy + + c = c.upper() + else: + next_x = next_y = next_p = next_d + + if c == 'M': # Moveto + p1 = next_p() + if path: + paths.append((path, False, joins)) + path = [p1] + joins = [] + + pn, p0 = p0, p1 + + elif c in "LHV": + if c == 'L': # Lineto + p1 = next_p() + elif c == 'H': # Horizontal Lineto + p1 = (next_x(), y0) + elif c == 'V': # Vertical Lineto + p1 = (x0, next_y()) + path.append(p1) + pn, p0 = p0, p1 + + elif c in "CS": # cubic bezier curve + if c == 'C': + p1 = next_p() + else: # 'S' + p1 = (2. * x0 - xn, 2 * y0 - yn) if cn in "CS" else p0 + p2, p3 = next_p(), next_p() + path += _cubic(p0, p1, p2, p3, du2) + pn, p0 = p2, p3 + + elif c in 'QT': # quadratic bezier curve + if c == 'Q': + p1 = next_p() + else: # 'T' + p1 = (2. * x0 - xn, 2 * y0 - yn) if cn in "QT" else p0 + p2 = next_p() + path += _quadric(p0, p1, p2, du2) + pn, p0 = p1, p2 + + elif c == 'A': # Arcto + rs, phi, flags = next_d(), next_d(), next_d() + # rs = (rx, ry) : radius in each direction + # phi = rotation of the axis of the ellipse + # flags = (large-arc-flag, sweep-flag) + # large-arc-flag, indique si on doit afficher l’arc dont la mesure fait plus de la moitié du périmètre de l’ellipse (dans ce cas, la valeur est 1), ou l’arc dont la mesure fait moins de la moitié du périmètre (valeur : 0). + # sweep-flag, indique quant à lui si l’arc doit être dessiné dans la direction négative des angles (dans lequel cas sa valeur est 0) ou dans la direction positive des angles (valeur : 1) + p1 = next_p() + # p1 : end point + path += _arc(p0, rs, phi, flags, p1, du2) + pn, p0 = p0, p1 + + elif c == 'Z': # Closepath + x1, y1 = p1 = path[0] + dx, dy = x1 - x0, y1 - y0 + if (dx * dx + dy * dy) * du2 > 1.: + path.append(p1) + paths.append((path, True, joins)) + path = [] + joins = [] + pn, p0 = p0, p1 + + cn = c + joins.append(len(path) - 1) + + if path: + paths.append((path, False, joins)) + + return paths + + +# utils ###################################################################### + +_WIDTH_LIMIT = 1. +_SCALE_STEP = 1.2 + + +def _du2(transform): + """surface of a pixel in local coordinates.""" + a, b, c, d, _, _ = transform.abcdef + return abs(a * d - b * c) + + +def _scale_index(du2, scale_step=_SCALE_STEP): + """log discretization of the scale suitable as key for hashing cache.""" + try: + return int(floor(log(du2, scale_step) / 2.)) + except: + return None + + +def _strip_range(stop): + """sort verticies in triangle strip order, i.e. 0 -1 1 -2 2 ...""" + i = 0 + while i < stop: + i += 1 + v, s = divmod(i, 2) + yield v * (s * 2 - 1) + + +def _join_strips(strips): + """concatenate strips""" + strips = iter(strips) + strip = next(strips, []) + for s in strips: + if len(strip) % 2 == 1: + strip += [strip[-1], s[0], s[0]] + else: + strip += [strip[-1], s[0]] + strip += s + return strip + + +# cache ###################################################################### + +def _fill_state(path): + return path.d + + +def _stroke_state(path): + return ( + path.d, + path.stroke_width, path.stroke_miterlimit, + path.stroke_linecap, path.stroke_linejoin, + ) + + +def _cache(_state): + """caching decorator + + cache is a dict maintained by path element mapping scale index to data + the cache is cleared if the state characterized by attributes has changed + """ + def decorator(method): + def decorated(path, du2=1.): + state = _state(path) + if state != path._states.get(method, None): + path._caches[method] = cache = {} + path._states[method] = deepcopy(state) + path._bbox_du2 = 0. + else: + cache = path._caches[method] + scale_index = _scale_index(du2) + try: + result = cache[scale_index] + except KeyError: + cache[scale_index] = result = method(path, du2) + return result + return decorated + return decorator + + +# path ####################################################################### + +class Path(Element): + tag = "path" + + _state_attributes = Element._state_attributes + [ + "d", + ] + + _bbox = (0., 0.), (0., 0.) + _bbox_du2 = 0. + + def __init__(self, **attributes): + super(Path, self).__init__(**attributes) + self._caches = {} + self._states = {} + + def _bbox_is_valid(self): + return (self._bbox_du2 != 0.) + + def _update_bbox(self): + """ensures that the bounding box of this Path is available + """ + # print('_update_bbox : self._bbox_du2 = %f' % self._bbox_du2) + if not self._bbox_is_valid(): + # print("_update_bbox : recomputing self._bbox") + # self._paths() # this call recomputes the bounding box with the default precision, but it actually doesn't do anything (I suspect the @_cache decorator does something funny) + du2 = 1.0 + paths = _flatten(self.d, du2) + self._bbox_du2 = du2 + self._bbox = _bbox(path for (path, _, _) in paths) + + @_cache(_fill_state) + def _paths(self, du2=1.): + """returns the polygonal approximation of this Path + + :param du2: precision of the polygonal approximation + :returns: a list of polylines + """ + # print( 'Path._paths : start for %s' % str(self) ) + paths = _flatten(self.d, du2) + if du2 > self._bbox_du2: + self._bbox_du2 = du2 + self._bbox = _bbox(path for (path, _, _) in paths) + return paths + + @_cache(_fill_state) + def _fills(self, du2=1.): + paths = self._paths(du2) + return _join_strips([path[i] for i in _strip_range(len(path))] + for path, _, _ in paths) + + @_cache(_fill_state) + def _fills_data(self, du2): + raise NotImplementedError # only the gl version + fills = self._fills(du2) + return None # create_vbo(fills) + + @_cache(_stroke_state) + def _strokes(self, du2=1.): + # print( 'Path._strokes : start for %s' % str(self) ) + paths = self._paths(du2) + + # better thin stroke rendering + du = sqrt(du2) + adapt_width = self.stroke_width * du + if adapt_width < _WIDTH_LIMIT: + width = 1. / du + opacity_correction = adapt_width + else: + width = self.stroke_width + opacity_correction = 1. + + return _join_strips(_stroke(path, closed, joins, width, du, + self.stroke_linecap, self.stroke_linejoin, + self.stroke_miterlimit) + for path, closed, joins in paths), opacity_correction + + @_cache(_stroke_state) + def _strokes_data(self, du2): + strokes, opacity_correction = self._strokes(du2) + return None, opacity_correction + # return create_vbo(strokes), opacity_correction + + def _aabbox(self, transform, inheriteds): + du2 = _du2(transform) + + points = [] + if self.fill: + fills = self._fills(du2) + if fills: + points.append(transform.project(*p) for p in fills) + if self.stroke and self.stroke_width > 0.: + strokes, _ = self._strokes(du2) + if strokes: + points.append(transform.project(*p) for p in strokes) + + return _bbox(points) + + def _render(self, transform, inheriteds, context): + du2 = _du2(transform) + origin = self.x, self.y + + fill = self._color(self.fill) + if fill: + assert False # doesn't seem to work withoult opengl + fills = self._fills_data(du2) + paint = { + "nonzero": fill.paint_nonzero, + "evenodd": fill.paint_evenodd, + }[self.fill_rule] + paint(self.fill_opacity, fills, transform, context, origin, self._bbox) + + stroke = self._color(self.stroke) + if stroke and self.stroke_width > 0.: + strokes, correction = self._strokes_data(du2) + opacity = self.stroke_opacity * correction + stroke.paint_one(opacity, strokes, transform, context, origin, self._bbox) + + def _hit_test(self, x, y, transform): + """ Tests whether the position (x,y) hits the shape self, when modified with the transformation transform + """ + # print('Path._hit_test : start : x = %f, y=%f' % (x,y)) + x, y = transform.inverse().project(x, y) + # print('Path._hit_test : after transform : x = %f, y=%f' % (x,y)) + du2 = _du2(transform) + hit = False + + if not hit and self.fill: + # print('Path._hit_test : path is filled, self._bbox=%s' % str(self._bbox)) + self._update_bbox() + (x_min, y_min), (x_max, y_max) = self._bbox + # print( '_hit_test : (x_min = %f, y_min = %f), (x_max = %f, y_max = %f)' % (x_min, y_min, x_max, y_max) ) + if (x_min <= x <= x_max) and (y_min <= y <= y_max): + # print('Path._hit_test : in bounding box') + fills = self._fills(du2) + if fills: + fill_hit = { + "nonzero": _nonzero_hit, + "evenodd": _evenodd_hit, + }[self.fill_rule] + hit = fill_hit(x, y, fills) + + if not hit and self.stroke and self.stroke_width > 0.: + strokes, _ = self._strokes(du2) + if strokes: + hit = _stroke_hit(x, y, strokes) + # print( '_hit_test : hit = %d ' % hit ) + return [([self], (x, y))] if hit else [] diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/polygon.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/polygon.py new file mode 100644 index 0000000..669a80b --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/polygon.py @@ -0,0 +1,26 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.polygon +""" + + +# imports #################################################################### + +from .path import Path + + +# polygon #################################################################### + +class Polygon(Path): + tag = "polygon" + + points = [] + + @property + def d(self): + d = ['M'] + for point in self.points: + d += [point, 'L'] + d[-1] = 'Z' + return d diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/polyline.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/polyline.py new file mode 100644 index 0000000..5cdd5c4 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/polyline.py @@ -0,0 +1,26 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.polyline +""" + + +# imports #################################################################### + +from .path import Path + + +# polyline ################################################################### + +class Polyline(Path): + tag = "polyline" + + points = [] + + @property + def d(self): + d = ['M'] + for point in self.points: + d += [point, 'L'] + d.pop() + return d diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/rectangle.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/rectangle.py new file mode 100644 index 0000000..0124be7 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/rectangle.py @@ -0,0 +1,44 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.rectangle +""" + + +# imports #################################################################### + +from .path import Path + + +# rectangle ################################################################## + +class Rectangle(Path): + tag = "rect" + + width, height = 0, 0 + rx, ry = None, None + + @property + def d(self): + w, h = self.width, self.height + if w <= 0. or h <= 0.: + return [] + + rx, ry = self.rx, self.ry + if rx is None and ry is None: + return ['M', (0, 0), 'l', (0, h), + 'l', (w, 0), 'l', (0, -h), 'z'] + + if rx is None: + rx = ry + if ry is None: + ry = rx + + rx, ry = min(rx, w / 2.), min(ry, h / 2.) + + return ['M', (0, ry), + 'L', (0, h - ry), 'A', (rx, ry), 0, (0, 0), (rx, h), + 'L', (w - rx, h), 'A', (rx, ry), 0, (0, 0), (w, h - ry), + 'L', (w, ry), 'A', (rx, ry), 0, (0, 0), (w - rx, 0), + 'L', (rx, 0), 'A', (rx, ry), 0, (0, 0), (0, ry), + 'Z'] diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/text.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/text.py new file mode 100644 index 0000000..e1bc3e3 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/text.py @@ -0,0 +1,212 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.text +""" + + +# imports #################################################################### + +from math import hypot, degrees, atan2, modf, log + +from ...font import Face +# from ...opengl.utils import create_texture + +from .._common import _u +from ..transform import Translate, Rotate, Scale +from ..paint import Color +from .rectangle import Rectangle +from .path import Path +from .group import Group +from .use import Use +from . import Element + + +# text ####################################################################### + + +_ANGLE_STEPS = 360 +_SCALE_DOUBLE_STEPS = 128 +_SUBPIXEL_STEPS = 64 + + +class Text(Element): + tag = "text" + + _state_attributes = Element._state_attributes + [ + "font_family", "font_weight", "font_style", "font_size", "text" + ] + + _VECTOR_L = 30 + _letters_cache = {} + _faces_cache = {} + + def __init__(self, text, + **attributes): + super(Text, self).__init__(**attributes) + + self._text_bbox = Rectangle() + self._width = None + self._text = None + self._ws = [] + + self.text = text + + # TODO: handle list of coordinates + if isinstance(self.x, list): + self.x = self.x[0] + if isinstance(self.y, list): + self.y = self.y[0] + + def _update_text_bbox(self): + (x, y), (width, height) = self.font_face.get_bbox(self.text) + self._width = width + self._text_bbox.x, self._text_bbox.width = x, width + self._text_bbox.y, self._text_bbox.height = y, height + self._text_bbox._paths() # force bbox update + + @property + def font_face(self): + key = (self.font_family, self.font_weight, self.font_style, + int(self.font_size)) + try: + font_face = self._faces_cache[key] + except KeyError: + font_face = self._faces_cache[key] = Face(*key) + return font_face + + def get_text(self): + return _u(self._text) + + def set_text(self, text): + self._text = text.strip() + text = property(get_text, set_text) + + def _anchor(self): + self._update_text_bbox() + return { + 'start': 0., + 'middle': -self._width / 2., # pylint: disable=invalid-unary-operand-type + 'end': -self._width, # pylint: disable=invalid-unary-operand-type + }[self.text_anchor] + + def _aabbox(self, transform, inheriteds): + return self._text_bbox.aabbox(transform * Translate(self._anchor()), inheriteds) + + def _render(self, transform, inheriteds, context): + font_size = self.font_size + font_face = self.font_face + + _, (cosa, sina), _, (sx, sy) = transform.params() + a, b = cosa * sx, sina * sy + c, d = -b, a + scale = hypot(a, b) + angle = degrees(atan2(b, a)) + + vector = font_size * scale > self._VECTOR_L + vector = vector or (self.stroke is not None) or (self.fill is None) + + x_anchor = self._anchor() + X0, Y0 = transform.project(x_anchor) + untransform = transform.inverse() + + if vector: + X, Y = 0., 0. + else: + (X, X0), (Y, Y0) = modf(X0), modf(Y0) + + letters = Group( + transform=[Translate(x_anchor), Rotate(-angle), Scale(1 / scale), Translate(-X, -Y)], + stroke_width=self.stroke_width * scale, + ) + self._ws = [0] + + up = None + for uc in self.text: + X += font_face.get_hkerning(up, uc) + up = uc + + if vector: + (Xf, Xi), (Yf, Yi) = (0., X), (0., Y) + else: + (Xf, Xi), (Yf, Yi) = modf(X), modf(Y) + if Xf < 0: + Xf, Xi = Xf + 1, Xi - 1 + if Yf < 0: + Yf, Yi = Yf + 1, Yi - 1 + key = (font_face, uc, vector, + int(round(angle * _ANGLE_STEPS / 360.)), + int(log(scale, 2.) * _SCALE_DOUBLE_STEPS), + int(Xf * _SUBPIXEL_STEPS), int(Yf * _SUBPIXEL_STEPS)) + try: + letter, (Xc, Yc), (W, H), (dX, dY) = self._letters_cache[key] + except KeyError: + font_face.set_transform(a, b, c, d, Xf, Yf) + if vector: + (Xc, Yc), (W, H), (dX, dY), outline = font_face.outline(uc) + letter = Path(d=outline) + else: + assert False # code requires opengl + # (Xc, Yc), (W, H), (dX, dY), data = font_face.bitmap(uc) + # letter = Rectangle(x=Xc, y=Yc, width=W, height=H, fill=_Texture(create_texture(W, H, data))) + self._letters_cache[key] = letter, (Xc, Yc), (W, H), (dX, dY) + + if W > 0 and H > 0: + letters.add_child(Use(letter, x=Xi, y=Yi)) + + X += dX + Y += dY + x, _ = untransform.project(X + X0, Y + Y0) + self._ws.append(x - x_anchor) + + if all(type(c) in [type(None), Color] for c in [self.fill, self.stroke]): + # single pass rendering + if not vector: + for letter in letters.children: + letter.element.fill.rgb = self.fill.rgb + letters.render(transform, inheriteds, context) + + else: + # multi-pass rendering if a gradient or pattern is used + filler_x, filler_y = self.x, self.y - self._text_bbox.height + bbox_x = self._text_bbox.x - self.stroke_width / 2. + x_anchor + bbox_y = self._text_bbox.y - self.stroke_width / 2. + width = self._text_bbox.width + self.stroke_width, + height = self._text_bbox.height + self.stroke_width + + mask = Use(letters, + transform=[Translate(filler_x - bbox_x, filler_y - bbox_y)], + fill_opacity=1., stroke_opacity=1.,) + + filler = Rectangle( + x=filler_x, y=filler_y, width=width, height=height, + transform=[Translate(bbox_x - filler_x, bbox_y - filler_y)], + stroke=None, + mask=mask,) + + for filler_fill, filler_opacity, masking in [ + (self.fill, self.fill_opacity, (Color.white, None)), + (self.stroke, self.stroke_opacity, (None, Color.white)) + ]: + if filler_fill: + filler.fill, filler.fill_opacity = filler_fill, filler_opacity + mask.fill, mask.stroke = masking + filler.render(transform, inheriteds, context) + + def index(self, x, y=0): + """index of the char at x (local coordinates).""" + for i, w in enumerate(self._ws): + if x < w: + break + return i - 1 + + def _hit_test(self, x, y, transform): + return self._text_bbox.pick(x, y, transform * Translate(self._anchor())) + + def _xml_content(self, defs): + text = self.text + for old, new in [('&', '&'), + ('<', '<'), + ('>', '>')]: + text = text.replace(old, new) + return text diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/element/use.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/use.py new file mode 100644 index 0000000..fd4efdd --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/element/use.py @@ -0,0 +1,38 @@ +# -*- coding: utf-8 -*- + +""" +scenegraph.element.use +""" + + +# imports #################################################################### + +from . import Element + + +# use ######################################################################## + +class Use(Element): + tag = "use" + + _state_attributes = Element._state_attributes + [ + "href", + ] + + def __init__(self, element=None, **attributes): + super(Use, self).__init__(**attributes) + self.element = element + self._attributes.add("href") + + @property + def href(self): + return self.element + + def _aabbox(self, transform, inheriteds): + return self.element.aabbox(transform, inheriteds) + + def _render(self, transform, inheriteds, context): + self.element.render(transform, inheriteds, context) + + def _pick_content(self, x, y, transform): + return self.element.pick(x, y, transform) diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/paint.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/paint.py new file mode 100644 index 0000000..1049288 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/paint.py @@ -0,0 +1,892 @@ +# -*- coding: utf-8 -*- + +""" +paint servers +""" + + +# imports #################################################################### + +# from ..opengl import gl as _gl +# from ..opengl.utils import (get_opengl_version, set_uniform) +# from ..opengl.utils import (create_shader, create_program) +from ._common import _Element + +from .transform import Translate, Matrix, shrink +# from .transform import Ortho, product + + +# shaders #################################################################### + +_ATTRIB_LOCATIONS = { + b"vertex": 0, +} + +_VERT_SHADER = """ + #version %(GLSL_VERSION)s + #if __VERSION__ >= 150 + #define attribute in + #define varying out + #endif + + attribute vec2 vertex; + + uniform vec3 color; + uniform float alpha; + + uniform mat3 projection_transform; + uniform mat3 modelview_transform; + + uniform mat3 paint_transform; + uniform mat3 mask_transform; + + varying vec4 front_color; + varying vec2 paint_coord; + varying vec2 mask_coord; + + void main() { + front_color = vec4(color, alpha); + vec3 pixel_position = modelview_transform * vec3(vertex, 1.); + paint_coord = (paint_transform * vec3(vertex, 1.)).xy; + mask_coord = (mask_transform * pixel_position).xy; + gl_Position = vec4((projection_transform * pixel_position).xy, 0., 1.); + } +""" + +_MAIN_FRAG_SHADER = """ + #version %(GLSL_VERSION)s + #if __VERSION__ >= 150 + #define varying in + #define texture2D texture + #define gl_FragColor fragment_color + out vec4 fragment_color; + #endif + + uniform bool masking; + uniform sampler2D mask; + + const vec4 luminance = vec4(.2125, .7154, .0721, 0.); + + varying vec4 front_color; + varying vec2 mask_coord; + + vec4 color(); // filling color + + vec4 frag_color() { + vec4 color = color(); + if(masking) { + color.a *= dot(luminance, texture2D(mask, mask_coord)); + } + return front_color * color; + } + + void main() { gl_FragColor = frag_color(); } +""" + + +# filling fragment shaders ################################################### + +_SOLID_FRAG_SHADER = """ + #version %(GLSL_VERSION)s + + vec4 color() { + return vec4(1., 1., 1., 1.); + } + +""" + +_TEXTURE_FRAG_SHADER = """ + #version %(GLSL_VERSION)s + #if __VERSION__ >= 150 + #define varying in + #define texture2D texture + #endif + + uniform sampler2D texture; + + varying vec2 paint_coord; + + vec4 color() { + return texture2D(texture, paint_coord); + } + +""" + +MAX_STOPS = 21 + +_GRADIENT_FRAG_SHADER = """ + #version %(GLSL_VERSION)s + #if __VERSION__ >= 150 + #define varying in + #endif + + const int N = %(MAX_STOPS)s; + + uniform int n; + uniform float os[N]; + uniform vec4 colors[N]; + uniform int spread; + + varying vec2 paint_coord; + + float o(vec2 p); // offset at point p in the gradient + + float s(float o) { + // offset according to spread method + float pad = o; + float repeat = fract(o); + float reflect = mod(o, 2.); + if(reflect > 1.) + reflect = 2.-reflect; + return vec3(pad, reflect, repeat)[spread]; + } + + vec4 gradient(float o) { + // color at offset o in the gradient + float oa, oi = os[0]; + vec4 ca, ci = colors[0]; + for(int i = 0; i < n; i++) { + oa = os[i]; ca = colors[i]; + if(o <= oa) break; + oi = oa; ci = ca; + } + float ki = (oi == oa) ? 1. : (oa-o)/(oa-oi); + return ki*ci + (1.-ki)*ca; + } + + vec4 color() { + float o = o(paint_coord); + float s = s(o); + return gradient(s); + } +""" + +_LINEAR_OFFSET_FRAG_SHADER = """ + #version %(GLSL_VERSION)s + + uniform vec2 p1; + uniform vec2 p2; + + float o(vec2 p) { + // offset at point p in the linear gradient + vec2 u = p - p1; + vec2 v = p2 - p1; + return dot(u, v)/dot(v, v); + } +""" + +_RADIAL_OFFSET_FRAG_SHADER = """ + #version %(GLSL_VERSION)s + + uniform vec2 c; + uniform float r; + uniform vec2 f; + + float o(vec2 p) { + // offset at point p in the radial gradient + vec2 u = p - f; + vec2 v = c - f; + float a2 = dot(v, v) - r*r; + float a1 = dot(u, v); + float a0 = dot(u, u); + if(a2 == 0.) { + return .5*a0/a1; // at first order sqrt(1+x) == 1+x/2 + } else { + return (a1-sqrt(a1*a1-a2*a0))/a2; + } + } +""" + +_PATTERN_FRAG_SHADER = """ + #version %(GLSL_VERSION)s + #if __VERSION__ >= 150 + #define varying in + #endif + + uniform vec2 origin; + uniform vec2 period; + + varying vec2 paint_coord; + + vec4 color() { + vec2 uv = mod(paint_coord + origin, period); + if((uv.x-period.x/2.)*(uv.y-period.y/2.) < 0.) { + return vec4(.75, .75, .75, 1.); + } else { + return vec4(1., 1., 1., 1.); + } + } + +""" + + +# _shaders = { +# "solid_color": [ +# (_gl.VERTEX_SHADER, _VERT_SHADER), +# (_gl.FRAGMENT_SHADER, _SOLID_FRAG_SHADER), +# (_gl.FRAGMENT_SHADER, _MAIN_FRAG_SHADER), +# ], +# "texture": [ +# (_gl.VERTEX_SHADER, _VERT_SHADER), +# (_gl.FRAGMENT_SHADER, _TEXTURE_FRAG_SHADER), +# (_gl.FRAGMENT_SHADER, _MAIN_FRAG_SHADER), +# ], +# "linear_gradient": [ +# (_gl.VERTEX_SHADER, _VERT_SHADER), +# (_gl.FRAGMENT_SHADER, _GRADIENT_FRAG_SHADER), +# (_gl.FRAGMENT_SHADER, _LINEAR_OFFSET_FRAG_SHADER), +# (_gl.FRAGMENT_SHADER, _MAIN_FRAG_SHADER), +# ], +# "radial_gradient": [ +# (_gl.VERTEX_SHADER, _VERT_SHADER), +# (_gl.FRAGMENT_SHADER, _GRADIENT_FRAG_SHADER), +# (_gl.FRAGMENT_SHADER, _RADIAL_OFFSET_FRAG_SHADER), +# (_gl.FRAGMENT_SHADER, _MAIN_FRAG_SHADER), +# ], +# "pattern": [ +# (_gl.VERTEX_SHADER, _VERT_SHADER), +# (_gl.FRAGMENT_SHADER, _PATTERN_FRAG_SHADER), +# (_gl.FRAGMENT_SHADER, _MAIN_FRAG_SHADER), +# ] +# } + + +# programs ################################################################### + +# _programs = {} +# +# +# def _program(name): +# global _programs +# try: +# program = _programs[name] +# except KeyError: +# shaders = list(create_shader(*shader, MAX_STOPS=MAX_STOPS) for shader in _shaders[name]) +# program = _programs[name] = create_program(shaders, attrib_locations=_ATTRIB_LOCATIONS) +# return program + + +_current_kwargs = {} +_current_program = None + + +def _create(name, enable_sample_shading=True, **default_uniforms): + # def set_sample_shading(): + # """en/dis-able the sample shading + # + # this function specializes itself on first call to avoid checking opengl + # version at each use. + # """ + # nonlocal set_sample_shading + # if get_opengl_version() >= (4, 0): + # if enable_sample_shading: + # set_sample_shading = lambda: _gl.Enable(_gl.SAMPLE_SHADING) + # else: + # set_sample_shading = lambda: _gl.Disable(_gl.SAMPLE_SHADING) + # else: + # set_sample_shading = lambda: None + # set_sample_shading() + + def _use(**kwargs): + raise NotImplementedError +# global _current_program, _current_uniforms +# program = _program(name) +# if _current_program != program: +# _gl.UseProgram(program) +# _current_program = program +# _current_uniforms = {} +# uniforms = dict(default_uniforms) +# uniforms.update(kwargs) +# uniforms["mask_transform"] = _MaskContext.transforms[-1].uniform() +# uniforms["masking"] = [len(_MaskContext.textures) > 1] +# for k in uniforms: +# v = uniforms[k] +# if v != _current_uniforms.get(k, None): +# set_uniform(program, k, v) +# _current_uniforms = uniforms +# set_sample_shading() + return _use + +_use_solid_color = _create("solid_color", mask=[1]) +_use_texture = _create("texture", texture=[0], mask=[1], enable_sample_shading=False) +_use_linear_gradient = _create("linear_gradient", mask=[1]) +_use_radial_gradient = _create("radial_gradient", mask=[1]) +_use_pattern = _create("pattern", mask=[1]) + + +# painting ################################################################## + +# def _stencil_op(n, op): +# _gl.StencilOp(_gl.KEEP, _gl.KEEP, op) +# _gl.DrawArrays(_gl.TRIANGLE_STRIP, 0, n) +# +# def _make_stencil(op): +# def _stencil(n): +# _stencil_op(n, op) +# return _stencil +# +# _stencil_one = _make_stencil(_gl.INCR) +# _stencil_evenodd = _make_stencil(_gl.INVERT) +# _stencil_replace = _make_stencil(_gl.REPLACE) +# +# def _stencil_nonzero(n): +# _gl.Enable(_gl.CULL_FACE) +# for cull, op in [(_gl.BACK, _gl.INCR_WRAP), +# (_gl.FRONT, _gl.DECR_WRAP)]: +# _gl.CullFace(cull) +# _stencil_op(n, op) +# _gl.Disable(_gl.CULL_FACE) +# +# +# def _make_paint(_stencil): +# def paint(color, alpha, data, transform, context, origin, bbox): +# paint_transform = product(*color.transform).inverse() * \ +# color.units(origin, bbox) +# projection_transform = Ortho(*context.orthos[-1]) +# color._use_program(color=[color.rgb], alpha=[float(alpha)], +# modelview_transform=transform.uniform(), +# paint_transform=paint_transform.uniform(), +# projection_transform=projection_transform.uniform()) +# n, vbo_id = data +# _gl.BindBuffer(_gl.ARRAY_BUFFER, vbo_id) +# _gl.VertexAttribPointer(_ATTRIB_LOCATIONS[b"vertex"], 2, _gl.FLOAT, +# False, 0, None) +# +# for mask, func, stencil in [(_gl.FALSE, _gl.ALWAYS, _stencil), +# (_gl.TRUE, _gl.NOTEQUAL, _stencil_replace)]: +# _gl.ColorMask(mask, mask, mask, mask) +# _gl.StencilFunc(func, 0, -1) +# stencil(n) +# return paint + + +# paint base class ########################################################### + +def _object_bbox(origin, bbox): + (x_min, y_min), (x_max, y_max) = bbox + try: + return shrink(x_min, y_min, x_max - x_min, y_max - y_min) + except ZeroDivisionError: + return Matrix() + + +def _user_space(origin, bbox): + return Translate(*origin) + +_UNITS = { + "objectBoundingBox": _object_bbox, + "userSpaceOnUse": _user_space, +} + + +class _Paint(_Element): + _r, _g, _b = 1., 1., 1. + units = staticmethod(_UNITS["objectBoundingBox"]) + transform = [] + + def get_rgb(self): + return self._r, self._g, self._b + + def set_rgb(self, rgb): + self._r, self._g, self._b = rgb + rgb = property(get_rgb, set_rgb) + +# paint_one = _make_paint(_stencil_one) +# paint_evenodd = _make_paint(_stencil_evenodd) +# paint_nonzero = _make_paint(_stencil_nonzero) + + +# solid color ################################################################ + +_BASE = 255. + + +def _float(i, base=_BASE): + """convert byte color components to float""" + return float(i / base if isinstance(i, int) else i) + + +class Color(_Paint): + tag = "solidColor" + + none = None + current = "currentColor" + + _state_attributes = _Paint._state_attributes + [ + "_r", "_g", "_b", + ] + + def __init__(self, r=0., g=None, b=None, name=""): + self._r = _float(r) + self._g = _float(g) if g is not None else self._r + self._b = _float(b) if b is not None else self._r + self._name = name + + def _use_program(self, **kwargs): + _use_solid_color(**kwargs) + + def _xml_attr(self, defs): + return self._name or \ + "#%02x%02x%02x" % tuple(int(v * _BASE) for v in self.rgb) + + +# texture #################################################################### + +class _Texture(_Paint): + def __init__(self, texture_id=0, color=Color(1., 1., 1.)): + self.texture_id = texture_id + self.get_rgb, self.set_rgb = color.get_rgb, color.set_rgb + + def _use_program(self, **kwargs): + pass + # _gl.BindTexture(_gl.TEXTURE_2D, self.texture_id) + # _use_texture(**kwargs) + + +class _MaskContext: + textures = [0] + transforms = [Matrix()] + + def __init__(self, origin, size, texture_id): + x, y = origin + width, height = size + self.transform = shrink(x, y, width, height) + self.texture_id = texture_id + + def __enter__(self): + self.textures.append(self.texture_id) + self.transforms.append(self.transform) + # _gl.ActiveTexture(_gl.TEXTURE1) + # _gl.BindTexture(_gl.TEXTURE_2D, self.texture_id) + # _gl.ActiveTexture(_gl.TEXTURE0) + + def __exit__(self, *args): + assert self.textures.pop() == self.texture_id + assert self.transforms.pop() == self.transform + # _gl.ActiveTexture(_gl.TEXTURE1) + # _gl.BindTexture(_gl.TEXTURE_2D, self.textures[-1]) + # _gl.ActiveTexture(_gl.TEXTURE0) + + +# pserver #################################################################### + +class _PaintServer(_Paint): + _state_attributes = _Paint._state_attributes + [ + "parent", + ] + + def __init__(self, parent=None): + self.parent = parent + + def __getattr__(self, attribute): + try: + return getattr(self.parent, attribute) + except AttributeError: + pass + if attribute in self._DEFAULTS: + return self._DEFAULTS[attribute] + return super(_PaintServer, self).__getattribute__(attribute) + + @property + def id(self): + return "%X" % id(self) + + @property + def href(self): + return self.parent + + @property + def attributes(self): + attributes = ["id"] + attributes += list(k for k in self._DEFAULTS if k in dir(self)) + if self.parent: + attributes += ["href"] + return attributes + + +# gradients ################################################################## + +_SPREADS = { + "pad": 0, + "reflect": 1, + "repeat": 2, +} + + +def _stop(o, c, a=1.): + """add optional alpha to gradient stop definitions""" + if c is Color.none: + c = Color.black + a = 0. + elif c is Color.current: # TODO: should be fixed + c = Color.black + a = 0. + return (float(o), (c._r, c._g, c._b, a)) + + +class _Gradient(_PaintServer): + _DEFAULTS = { + "stops": [(0., Color.none)], + "gradientTransform": [], + "gradientUnits": "objectBoundingBox", + "spreadMethod": "pad", + } + + _state_attributes = _PaintServer._state_attributes + list(_DEFAULTS) + + def __init__(self, parent=None, stops=None, spreadMethod=None, + gradientUnits=None, gradientTransform=None): + super(_Gradient, self).__init__(parent) + if stops is not None: + self.stops = stops + if spreadMethod is not None: + self.spreadMethod = spreadMethod + if gradientUnits is not None: + self.gradientUnits = gradientUnits + if gradientTransform is not None: + self.gradientTransform = gradientTransform + + @property + def units(self): + return _UNITS[self.gradientUnits] + + @property + def transform(self): + return self.gradientTransform + + def _use_gradient(self, n, os, colors, spread, **kwargs): + raise NotImplementedError + + def _use_program(self, **kwargs): + n = len(self.stops) + assert n <= MAX_STOPS, "too much stops in gradient" + + os, colors = zip(*(_stop(*stop) for stop in self.stops)) + spread = _SPREADS[self.spreadMethod] + self._use_gradient(n, os, colors, spread, **kwargs) + + @property + def attributes(self): + attributes = super(_Gradient, self).attributes + if "stops" in attributes: + attributes.remove("stops") + return attributes + + def _xml_content(self, defs): + if "stops" not in dir(self): + return "" + stops = [] + + def _stop(offset, color, opacity=None): + if color is Color.none: + color = "none" + elif color == Color.current: + pass + else: + color = color._xml_attr(defs) + return offset, color, opacity + for stop in self.stops: + offset, color, opacity = _stop(*stop) + if opacity is None: + stop = "" % (offset, color) + else: + stop = "" % (offset, color, opacity) + stops.append(stop) + return "\n".join(stops) + + +class LinearGradient(_Gradient): + tag = "linearGradient" + + _DEFAULTS = { + "x1": 0., + "y1": 0., + "x2": 1., + "y2": 0., + } + _state_attributes = _Gradient._state_attributes + list(_DEFAULTS) + _DEFAULTS.update(_Gradient._DEFAULTS) + + def __init__(self, parent=None, stops=None, spreadMethod=None, + gradientUnits=None, gradientTransform=None, + x1=None, y1=None, x2=None, y2=None): + super(LinearGradient, self).__init__(parent, stops, spreadMethod, + gradientUnits, gradientTransform) + if x1 is not None: + self.x1 = x1 + if y1 is not None: + self.y1 = y1 + if x2 is not None: + self.x2 = x2 + if y2 is not None: + self.y2 = y2 + + def _use_gradient(self, n, os, colors, spread, **kwargs): + _use_linear_gradient(p1=[(float(self.x1), float(self.y1))], + p2=[(float(self.x2), float(self.y2))], + n=[n], os=list(os), colors=list(colors), + spread=[spread], **kwargs) + + +class RadialGradient(_Gradient): + tag = "radialGradient" + + _DEFAULTS = { + "cx": .5, + "cy": .5, + "r": .5, + "fx": None, + "fy": None, + } + _state_attributes = _Gradient._state_attributes + list(_DEFAULTS) + _DEFAULTS.update(_Gradient._DEFAULTS) + + def __init__(self, parent=None, stops=None, spreadMethod=None, + gradientUnits=None, gradientTransform=None, + cx=None, cy=None, r=None, fx=None, fy=None): + super(RadialGradient, self).__init__(parent, stops, spreadMethod, + gradientUnits, gradientTransform) + if cx is not None: + self.cx = cx + if cy is not None: + self.cy = cy + if r is not None: + self.r = r + if fx is not None: + self.fx = fx + if fy is not None: + self.fy = fy + + def _use_gradient(self, n, os, colors, spread, **kwargs): + fx, fy = self.fx, self.fy + if fx is None: + fx = self.cx + if fy is None: + fy = self.cy + + _use_radial_gradient(c=[(float(self.cx), float(self.cy))], + r=[float(self.r)], + f=[(float(fx), float(fy))], + n=[n], os=list(os), colors=list(colors), + spread=[spread], **kwargs) + + +# pattern #################################################################### + +class Pattern(_PaintServer): + tag = "pattern" + _r, _g, _b = 1., 1., 1. + + _DEFAULTS = { + "patternUnits": "objectBoundingBox", + "patternContentUnits": "userSpaceOnUse", + "patternTransform": [], + "x": 0., + "y": 0., + "width": 0., + "height": 0., + "viewBox": None, + } + _state_attributes = _Paint._state_attributes + list(_DEFAULTS) + [ + "pattern", + ] + _DEFAULTS.update(_Gradient._DEFAULTS) + + def __init__(self, parent=None, pattern=None, + patternUnits=None, patternContentUnits=None, + patternTransform=None, + x=None, y=None, width=None, height=None, + viewBox=None, + **kwargs): + super(Pattern, self).__init__(parent) + self.pattern = pattern + if patternUnits is not None: + self.patternUnits = patternUnits + if patternContentUnits is not None: + self.patternContentUnits = patternContentUnits + if patternTransform is not None: + self.patternTransform = patternTransform + if x is not None: + self.x = x + if y is not None: + self.y = y + if width is not None: + self.width = width + if height is not None: + self.height = height + self.viewBox = viewBox + + @property + def units(self): + return _UNITS[self.patternUnits] + + @property + def transform(self): + return self.patternTransform + + def _use_program(self, **kwargs): + _use_pattern(origin=[(float(self.x), float(self.y))], + period=[(float(self.width), float(self.height))], + **kwargs) + + def _xml_content(self, defs): + return self.pattern._xml_content(defs) + + +# colors by name ############################################################# + +# see + +_color_keywords = { + "aliceblue": (240, 248, 255), + "antiquewhite": (250, 235, 215), + "aqua": ( 0, 255, 255), + "aquamarine": (127, 255, 212), + "azure": (240, 255, 255), + "beige": (245, 245, 220), + "bisque": (255, 228, 196), + "black": ( 0, 0, 0), + "blanchedalmond": (255, 235, 205), + "blue": ( 0, 0, 255), + "blueviolet": (138, 43, 226), + "brown": (165, 42, 42), + "burlywood": (222, 184, 135), + "cadetblue": ( 95, 158, 160), + "chartreuse": (127, 255, 0), + "chocolate": (210, 105, 30), + "coral": (255, 127, 80), + "cornflowerblue": (100, 149, 237), + "cornsilk": (255, 248, 220), + "crimson": (220, 20, 60), + "cyan": ( 0, 255, 255), + "darkblue": ( 0, 0, 139), + "darkcyan": ( 0, 139, 139), + "darkgoldenrod": (184, 134, 11), + "darkgray": (169, 169, 169), + "darkgreen": ( 0, 100, 0), + "darkgrey": (169, 169, 169), + "darkkhaki": (189, 183, 107), + "darkmagenta": (139, 0, 139), + "darkolivegreen": ( 85, 107, 47), + "darkorange": (255, 140, 0), + "darkorchid": (153, 50, 204), + "darkred": (139, 0, 0), + "darksalmon": (233, 150, 122), + "darkseagreen": (143, 188, 143), + "darkslateblue": ( 72, 61, 139), + "darkslategray": ( 47, 79, 79), + "darkslategrey": ( 47, 79, 79), + "darkturquoise": ( 0, 206, 209), + "darkviolet": (148, 0, 211), + "deeppink": (255, 20, 147), + "deepskyblue": ( 0, 191, 255), + "dimgray": (105, 105, 105), + "dimgrey": (105, 105, 105), + "dodgerblue": ( 30, 144, 255), + "firebrick": (178, 34, 34), + "floralwhite": (255, 250, 240), + "forestgreen": ( 34, 139, 34), + "fuchsia": (255, 0, 255), + "gainsboro": (220, 220, 220), + "ghostwhite": (248, 248, 255), + "gold": (255, 215, 0), + "goldenrod": (218, 165, 32), + "gray": (128, 128, 128), + "grey": (128, 128, 128), + "green": ( 0, 128, 0), + "greenyellow": (173, 255, 47), + "honeydew": (240, 255, 240), + "hotpink": (255, 105, 180), + "indianred": (205, 92, 92), + "indigo": ( 75, 0, 130), + "ivory": (255, 255, 240), + "khaki": (240, 230, 140), + "lavender": (230, 230, 250), + "lavenderblush": (255, 240, 245), + "lawngreen": (124, 252, 0), + "lemonchiffon": (255, 250, 205), + "lightblue": (173, 216, 230), + "lightcoral": (240, 128, 128), + "lightcyan": (224, 255, 255), + "lightgoldenrodyellow": (250, 250, 210), + "lightgray": (211, 211, 211), + "lightgreen": (144, 238, 144), + "lightgrey": (211, 211, 211), + "lightpink": (255, 182, 193), + "lightsalmon": (255, 160, 122), + "lightseagreen": ( 32, 178, 170), + "lightskyblue": (135, 206, 250), + "lightslategray": (119, 136, 153), + "lightslategrey": (119, 136, 153), + "lightsteelblue": (176, 196, 222), + "lightyellow": (255, 255, 224), + "lime": ( 0, 255, 0), + "limegreen": ( 50, 205, 50), + "linen": (250, 240, 230), + "magenta": (255, 0, 255), + "maroon": (128, 0, 0), + "mediumaquamarine": (102, 205, 170), + "mediumblue": ( 0, 0, 205), + "mediumorchid": (186, 85, 211), + "mediumpurple": (147, 112, 219), + "mediumseagreen": ( 60, 179, 113), + "mediumslateblue": (123, 104, 238), + "mediumspringgreen": ( 0, 250, 154), + "mediumturquoise": ( 72, 209, 204), + "mediumvioletred": (199, 21, 133), + "midnightblue": ( 25, 25, 112), + "mintcream": (245, 255, 250), + "mistyrose": (255, 228, 225), + "moccasin": (255, 228, 181), + "navajowhite": (255, 222, 173), + "navy": ( 0, 0, 128), + "oldlace": (253, 245, 230), + "olive": (128, 128, 0), + "olivedrab": (107, 142, 35), + "orange": (255, 165, 0), + "orangered": (255, 69, 0), + "orchid": (218, 112, 214), + "palegoldenrod": (238, 232, 170), + "palegreen": (152, 251, 152), + "paleturquoise": (175, 238, 238), + "palevioletred": (219, 112, 147), + "papayawhip": (255, 239, 213), + "peachpuff": (255, 218, 185), + "peru": (205, 133, 63), + "pink": (255, 192, 203), + "plum": (221, 160, 221), + "powderblue": (176, 224, 230), + "purple": (128, 0, 128), + "red": (255, 0, 0), + "rosybrown": (188, 143, 143), + "royalblue": ( 65, 105, 225), + "saddlebrown": (139, 69, 19), + "salmon": (250, 128, 114), + "sandybrown": (244, 164, 96), + "seagreen": ( 46, 139, 87), + "seashell": (255, 245, 238), + "sienna": (160, 82, 45), + "silver": (192, 192, 192), + "skyblue": (135, 206, 235), + "slateblue": (106, 90, 205), + "slategray": (112, 128, 144), + "slategrey": (112, 128, 144), + "snow": (255, 250, 250), + "springgreen": ( 0, 255, 127), + "steelblue": ( 70, 130, 180), + "tan": (210, 180, 140), + "teal": ( 0, 128, 128), + "thistle": (216, 191, 216), + "tomato": (255, 99, 71), + "turquoise": ( 64, 224, 208), + "violet": (238, 130, 238), + "wheat": (245, 222, 179), + "white": (255, 255, 255), + "whitesmoke": (245, 245, 245), + "yellow": (255, 255, 0), + "yellowgreen": (154, 205, 50), +} +for name in _color_keywords: + r, g, b = _color_keywords[name] + color = Color(r=r, g=g, b=b, name=name) + setattr(Color, name, color) diff --git a/src/msspec/msspecgui/scenegraph2d/scenegraph/transform.py b/src/msspec/msspecgui/scenegraph2d/scenegraph/transform.py new file mode 100644 index 0000000..803218a --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/scenegraph/transform.py @@ -0,0 +1,237 @@ +# -*- coding: utf-8 -*- + +""" +transforms +""" + +# imports #################################################################### +from math import radians, cos, sin, hypot, degrees, atan2, tan + +from ._common import _Base + + +# transforms ################################################################# + +class _Transform(_Base): + """represents an affine transformation matrix + + The affine transform that transforms coordinates (x_1, y_1) expressed in space 1 to corrdinates (x2, y2) expressed in space 2, is expressed with 6 floating point values (a, b, c, d, e, f) such that : + x_2 = a * x_1 + c * y_1 + e + y_2 = b * x_1 + d * y_1 + f + + """ + _state_attributes = ["tag"] + attributes = [] + + @property + def tag(self): + """the svg tag that represents this transform + """ + raise NotImplementedError # this tag is suppsed to be defined in derived classes + + def project(self, x=0, y=0): + """transforms a point using this transform + + :returns: the transformed point + """ + a, b, c, d, e, f = self.abcdef + return a * x + c * y + e, b * x + d * y + f + + @property + def abcdef(self): + """ + return the 6 elements a,b,c,d,e,f defining this transformation + """ + return + + def __mul__(self, other): + sa, sb, sc, sd, se, sf = self.abcdef + oa, ob, oc, od, oe, of = other.abcdef + a, c, e = sa * oa + sc * ob, sa * oc + sc * od, sa * oe + sc * of + se + b, d, f = sb * oa + sd * ob, sb * oc + sd * od, sb * oe + sd * of + sf + return Matrix(a, b, c, d, e, f) + + def params(self, error=1e-6): + """separate translation, rotation, shear and scale""" + a, b, c, d, e, f = self.abcdef + tx, ty = e, f + + if abs(b * c) < error: + cosa, sina = 1., 0. + sx, hy = a, b + hx, sy = c, d + else: + sign = 1. if a * d >= b * c else -1. + cosa, sina = a + sign * d, b - sign * c + h = hypot(cosa, sina) + cosa, sina = cosa / h, sina / h + sx, hy = a * cosa + b * sina, b * cosa - a * sina + hx, sy = c * cosa + d * sina, d * cosa - c * sina + sx -= hx * hy / sy + return (tx, ty), (cosa, sina), (hx, hy), (sx, sy) + + def uniform(self): + """returns this matrix in the form of a 3x3 matrix for homogen coordinates + """ + a, b, c, d, e, f = self.abcdef + return [(a, b, 0., c, d, 0., e, f, 1.)] + + def __str__(self): + return "%s(" % self.tag + \ + ",".join(str(getattr(self, a)) for a in self.attributes) + \ + ")" + + +class Translate(_Transform): + tag = "translate" + attributes = ["tx", "ty"] + _state_attributes = _Transform._state_attributes + attributes + + def __init__(self, tx=0, ty=0): + self.tx, self.ty = tx, ty + + def inverse(self): + return Translate(-self.tx, -self.ty) + + @property + def abcdef(self): + return 1., 0., 0., 1., self.tx, self.ty + + +class Scale(_Transform): + tag = "scale" + attributes = ["sx", "sy"] + _state_attributes = _Transform._state_attributes + attributes + + def __init__(self, sx=1., sy=None): + self.sx = sx + self.sy = sy or sx + + def inverse(self): + return Scale(1. / self.sx, 1. / self.sy) + + @property + def abcdef(self): + return self.sx, 0., 0., self.sy, 0., 0. + + +class Rotate(_Transform): + tag = "rotate" + attributes = ["a", "cx", "cy"] + _state_attributes = _Transform._state_attributes + attributes + + def __init__(self, a=0, cx=0, cy=0): + self.a = a + self.cx, self.cy = cx, cy + + def inverse(self): + return Rotate(-self.a, self.cx, self.cy) + + @property + def abcdef(self): + a, cx, cy = radians(self.a), self.cx, self.cy + c, s = cos(a), sin(a) + return c, s, -s, c, cx * (1. - c) + cy * s, cy * (1. - c) - cx * s + + +class SkewX(_Transform): + tag = "skewX" + attributes = ["ax"] + _state_attributes = _Transform._state_attributes + attributes + + def __init__(self, ax=0.): + self.ax = ax + + def inverse(self): + return SkewX(-self.ax) + + @property + def abcdef(self): + t = tan(radians(self.ax)) + return 1., 0., t, 1., 0., 0. + + +class SkewY(_Transform): + tag = "skewY" + attributes = ["ay"] + _state_attributes = _Transform._state_attributes + attributes + + def __init__(self, ay=0.): + self.ay = ay + + def inverse(self): + return SkewY(-self.ay) + + @property + def abcdef(self): + t = tan(radians(self.ay)) + return 1., t, 0., 1., 0., 0. + + +class Matrix(_Transform): + tag = "matrix" + attributes = ["a", "b", "c", "d", "e", "f"] + _state_attributes = _Transform._state_attributes + attributes + + def __init__(self, a=1., b=0., c=0., d=1., e=0., f=0.): + self.a, self.c, self.e = a, c, e + self.b, self.d, self.f = b, d, f + + def get_abcdef(self): + return self.a, self.b, self.c, self.d, self.e, self.f + + def set_abcdef(self, abcdef): + self.a, self.b, self.c, self.d, self.e, self.f = abcdef + abcdef = property(get_abcdef, set_abcdef) + + def inverse(self): + a, b, c, d, e, f = self.abcdef + det = a * d - b * c + return Matrix(*(u / det for u in (d, -b, -c, a, c * f - e * d, b * e - a * f))) + + +def ortho(left, right, bottom, top): + width, height = right - left, top - bottom + a, c, e = 2. / width, 0., -(left + right) / width + b, d, f = 0., 2. / height, -(bottom + top) / height + return Matrix(a, b, c, d, e, f) + + +def stretch(x, y, width, height): + a, c, e = width, 0., x + b, d, f = 0., height, y + return Matrix(a, b, c, d, e, f) + + +def shrink(x, y, width, height): + a, c, e = 1. / width, 0., -x / width + b, d, f = 0., 1. / height, -y / height + return Matrix(a, b, c, d, e, f) + + +# helpers #################################################################### + +def product(p=Matrix(), *qs): + for q in qs: + p = p * q + return p + + +def _list_from_params(t, r, sk, s, error=1e-6): + (tx, ty), (cosa, sina), (hx, hy), (sx, sy) = t, r, sk, s + transforms = [] + if (tx, ty) != (0., 0.): + transforms.append(Translate(tx, ty)) + if abs(sina) > abs(cosa) * error: + transforms.append(Rotate(degrees(atan2(sina, cosa)))) + if abs(hx) > abs(sy) * error: + transforms.append(SkewX(degrees(atan2(hx, sy)))) + if abs(hy) > abs(sx) * error: + transforms.append(SkewY(degrees(atan2(hy, sx)))) + if any(abs(1. - s) > error for s in (sx, sy)): + transforms.append(Scale(sx, sy)) + return transforms + + +def normalized(transform): + return _list_from_params(*product(*transform).params()) diff --git a/src/msspec/msspecgui/scenegraph2d/xml/__init__.py b/src/msspec/msspecgui/scenegraph2d/xml/__init__.py new file mode 100644 index 0000000..51e1333 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/xml/__init__.py @@ -0,0 +1,4 @@ +# -*- coding: utf8 -*- + +from .parser import parse +from .serializer import serialize diff --git a/src/msspec/msspecgui/scenegraph2d/xml/parser.py b/src/msspec/msspecgui/scenegraph2d/xml/parser.py new file mode 100644 index 0000000..ccc2c32 --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/xml/parser.py @@ -0,0 +1,653 @@ +# -*- coding: utf-8 -*- + +""" +svg parser +""" + +# imports #################################################################### + +# import sys +import os +import logging +import xml.parsers.expat +import gzip +from tempfile import mkstemp +from base64 import b64decode +from collections import defaultdict + +from .. import scenegraph as sg + + +# logging #################################################################### + +log = logging.getLogger(__name__) + + +# utils ###################################################################### + +def ascii(v, _=None): + return str(v) + + +def string_to_number(v, _=None): + try: + return int(v) + except ValueError: + scale = 1. + if v.endswith(r"%"): + scale = 100. + v = v[:-len(r"%")] + return float(v) / scale + + +def replace(s, *pairs): + for before, after in pairs: + s = s.replace(before, after) + return s + + +# sublanguages ############################################################### + +def unquote(v): + b, e = v[0], v[-1] + if b == e and b in ["'", '"']: + v = v[1:-1] + return v + + +def attributify(style): + attributes = [p.strip().split(":") for p in style.split(";") if p] + return dict((k.strip(), unquote(v.strip())) for (k, v) in attributes) + + +def styles(cdata): + """ + :param str cdata: + """ + _styles = defaultdict(dict) + cdata = replace(cdata, ("{", " { "), ("}", " } ")) + cdata = iter(cdata.split()) + for token in cdata: + if token == "/*": + while not next(cdata) == "*/": + pass + try: + token = next(cdata) + except StopIteration: + continue + while not token.startswith("{"): + key = token # TODO: properly implement css selectors + token = next(cdata, "{}") + content = token + for token in cdata: + content += token + if content.endswith("}"): + break + _styles[key].update(attributify(content[len("{"):-len("}")])) + return _styles + + +def asciify_key(k): + k = ascii(k) + for c in "-:": + k = k.replace(c, '_') + if k in ["id", "class"]: + k = "_%s" % k + if k == "xlink_href": + k = "href" + return k + + +def asciify_keys(d): + return dict((asciify_key(k), d[k]) for k in d) + + +def switify_values(d, elements): + """ + :param d: a dictionary mapping xml attribute names (string) to their values (as strings) + :return : a dictionary mapping xml attribute names (string) to their parsed values (which type depends on the attribute (eg scenegraph.Color, float, etc.) + """ + return dict((k, svg_attributes_parsers[k](d[k], elements)) for k in d) + +_UNITS = { # http://www.w3.org/TR/SVG/coords.html#Units + "px": 1., + "pt": 1.25, + "pc": 15, + "em": 10, # TODO: this should be dependant on current font-size + "ex": 5, # TODO: this should be dependant on current x-height + "mm": 3.543307, + "cm": 35.43307, + "in": 90., +} + +_SIZE_FACTOR = 1.2 +_MEDIUM = 12 * _UNITS["pt"] + +_ABSOLUTE_SIZES = { + "xx-small": _MEDIUM * _SIZE_FACTOR ** -3, + "x-small": _MEDIUM * _SIZE_FACTOR ** -2, + "small": _MEDIUM * _SIZE_FACTOR ** -1, + "medium": _MEDIUM, + "large": _MEDIUM * _SIZE_FACTOR ** 1, + "x-large": _MEDIUM * _SIZE_FACTOR ** 2, + "xx-large": _MEDIUM * _SIZE_FACTOR ** 3, +} + + +def string_to_length(v, _=None): + v = v.lower() + if v in _ABSOLUTE_SIZES: + return _ABSOLUTE_SIZES[v] + + u = 1. + unit = v[-2:] + if unit in _UNITS: + u = _UNITS[unit] + v = v[:-2] + return u * string_to_number(v) + + +def string_to_length_list(v, _=None): + if v == 'none': + return None + v = replace(v, (",", " ")) + v = list(string_to_length(u) for u in v.split()) + if len(v) == 1: + return v[0] + return v + + +def string_to_color(v, elements=None): + if v == "currentColor": + v = "current" + + if elements is None: + elements = {} + + if hasattr(sg.Color, v): # named color + return getattr(sg.Color, v) + + if v.startswith("rgb(") and v.endswith(")"): # rgb + rgb = v[len("rgb("):-len(")")] + r, g, b = (string_to_number(u) for u in rgb.split(",")) + return sg.Color(r, g, b) + + if v.startswith("#"): # raw color + rrggbb = v[len('#'):] + if len(rrggbb) == 3: + rrggbb = "".join(c * 2 for c in rrggbb) + rr, gg, bb = rrggbb[:2], rrggbb[2:4], rrggbb[4:] + return sg.Color(*(int(u, 16) for u in (rr, gg, bb))) + + if v.startswith("url(#"): # def + url = v[len("url(#"):-len(")")] + if url in elements: + return get_pserver(elements, url) + + log.warning("unknown color %s", v) + return "unknown" + + +def transform(v): + """creates and returns an object representing a 2D transformation, initialized from its svg transform attribute + + :param v: the value of single transform in a svg transform attribute (for example 'rotate(30 20,40)') + :rtype: an object of a class derived from _Transform + """ + _transform, v = v.split("(") + transform_class = { + "translate": sg.Translate, + "rotate": sg.Rotate, + "scale": sg.Scale, + "skewX": sg.SkewX, + "skewY": sg.SkewY, + "matrix": sg.Matrix, + }[_transform] + return transform_class(*(string_to_number(u) for u in v.split())) + + +def string_to_transform_list(v, _=None): + """creates and returns a list of objects (each of them representing a 2D transformation) , initialized from the value of a svg transform attribute + + :param v: the value of a svg transform attribute (for example 'rotate(30 20,40) translate(13,15)') + :rtype: a list of objects of a class derived from scenegraph.transform._Transform (eg [scenegraph.transform.Rotate(), scenegraph.transform.Translate()] ) + """ + v = replace(v, (" (", "("), (",", " ")) + return [transform(t.strip()) for t in v.split(")")[:-1]] + + +def string_to_url(v, elements=None): + if elements is None: + elements = {} + if v == "none": + return None + assert v.startswith("url(#"), v + url = v[len("url(#"):-len(")")] + return elements.get(url, str(url)) + + +def string_to_href(v, _=None): + if v.startswith("file://"): + v = v[len("file://"):] + elif v.startswith("data:image/"): + ext, data = v[len("data:image/"):].split(";", 1) + assert data.startswith("base64,") + data = data[len("base64,"):] + data = data.encode("ascii") + data = b64decode(data) + try: + data = gzip.decompress(data) # @UndefinedVariable + except OSError: + pass + _, v = mkstemp(".%s" % ext) + with open(v, "wb") as _image: + _image.write(data) + return ascii(v) + + +_PATH_COMMANDS = "MLVHCSQTAZmlvhcsqtaz" + + +def pop1(v): + return string_to_number(v.pop()) + + +def pop2(v): + return (pop1(v), pop1(v)) + +_POPPERS = defaultdict(list, { + 'M': [pop2], + 'L': [pop2], + 'V': [pop1], + 'H': [pop1], + 'C': [pop2, pop2, pop2], + 'S': [pop2, pop2], + 'Q': [pop2, pop2], + 'T': [pop2], + 'A': [pop2, pop1, pop2, pop2], +}) + + +def string_to_path_data(v, _=None): + v = replace(v, ("-", " -"), ("e -", "e-"), ("E -", "E-"), (",", " "), + *((c, " %s " % c) for c in _PATH_COMMANDS)) + v = list(reversed(v.split())) + d, last_c = [], 'M' + while v: + c = v.pop() + if c not in _PATH_COMMANDS: + v.append(c) + c = last_c + d.append(c) + last_c = c + if last_c == 'M': + last_c = 'L' + if last_c == 'm': + last_c = 'l' + for popper in _POPPERS[c.upper()]: + d.append(popper(v)) + return d + + +def string_to_point_list(v, _=None): + v = replace(v, ("-", " -"), ("e -", "e-"), ("E -", "E-"), (",", " ")) + v = list(reversed(v.split())) + d = [] + while v: + try: + d.append(pop2(v)) + except IndexError: + break + return d + + +svg_attributes_parsers = defaultdict(lambda: lambda a, _: ascii(a), { + "x": string_to_length_list, + "y": string_to_length_list, + "rx": string_to_length, + "ry": string_to_length, + "x1": string_to_length, + "y1": string_to_length, + "x2": string_to_length, + "y2": string_to_length, + "width": string_to_length, + "height": string_to_length, + "font_size": string_to_length, + "stroke_width": string_to_length, + "stroke_miterlimit": string_to_number, + "stroke_opacity": string_to_number, + "stroke_dasharray": string_to_length_list, + "stroke_dashoffset": string_to_length, + "fill_opacity": string_to_number, + "opacity": string_to_number, + "color": string_to_color, + "fill": string_to_color, + "stroke": string_to_color, + "transform": string_to_transform_list, + "clip_path": string_to_url, + "mask": string_to_url, + "href": string_to_href, + "d": string_to_path_data, + "points": string_to_point_list, + "cx": string_to_length, + "cy": string_to_length, + "r": string_to_length, + "fx": string_to_length, + "fy": string_to_length, + "gradientTransform": string_to_transform_list, + "patternTransform": string_to_transform_list, + "viewBox": string_to_length_list, +}) + + +# gradient ################################################################### + +def stop(offset, stop_color="none", stop_opacity=None, **_): + o, c = string_to_number(offset), string_to_color(stop_color) + if stop_opacity is None: + return o, c + return o, c, string_to_number(stop_opacity) + + +# parser class ############################################################### + +class Parser(object): + def __init__(self): + self.expat_parser = xml.parsers.expat.ParserCreate() + self.expat_parser.StartElementHandler = self.start_element + self.expat_parser.EndElementHandler = self.end_element + self.expat_parser.CharacterDataHandler = self.char_data + self.expat_parser.ProcessingInstructionHandler = self.proc_instruction + self.cdata = None + self.pserver_kwargs = None + self.gradient_stops = None + self.reset() + + def proc_instruction(self, target, data): + if target != 'xml-stylesheet': + return + if not data.startswith('type="text/css"'): + return + b = data.find('href="') + if b < 0: + return + b += len('href="') + e = data.find('"', b) + css_name = data[b:e] + style = styles(open(css_name).read()) + self.styles.update(style) + + def reset(self, **attributes): + self.root = sg.Group(**attributes) + self.group_stack = [self.root] # the group stack representing the current node path during parsing + self.elements = {"__root__": self.root} + self.cdata = [] + self.texts = [] + self.gradient_stops = [] + self.uses = defaultdict(list) + self.clippeds = defaultdict(list) + self.maskeds = defaultdict(list) + self.styles = defaultdict(dict) + + def parse(self, document): + self.expat_parser.Parse(document) + for _id in self.uses: + log.warning("undefined reference #%s replaced by empty group", _id) + for use in self.uses[_id]: + use.element = sg.Group() + for _id in self.clippeds: + log.warning("undefined clipPath #%s replaced by none", _id) + for clipped in self.clippeds[_id]: + clipped.clip_path = None + for _id in self.maskeds: + log.warning("undefined mask #%s replaced by none", _id) + for masked in self.maskeds[_id]: + masked.mask = None + + def char_data(self, data): + self.cdata.append(data) + + def start_element(self, name, attributes): + """expat handler for the start of an xml tag + + :param str name: the xml node's name (eg circle) + :param atttributes: the xml node's attributes, in the form of a dictionary mapping attribute names to their values (eg {'width':'50', 'height':70}) + """ + name = name.split(":")[-1] + if "style" in attributes: + style = attributes.pop("style") + attributes.update(attributify(style)) + if "class" in attributes: + key = ".%s" % attributes["class"] + attributes.update(self.styles[key]) + if "id" in attributes: + key = "#%s" % attributes["id"] + attributes.update(self.styles[key]) + attributes.update(self.styles[name]) + attributes.update(self.styles["*"]) + + attributes = asciify_keys(attributes) + attributes = switify_values(attributes, self.elements) + for k in "color", "fill", "stroke": + if attributes.get(k, None) == "unknown": + del attributes[k] + + try: + handler = getattr(self, "open_%s" % name) + except AttributeError: + try: + handler = { + "svg": sg.Group, + "g": sg.Group, + "symbol": sg.Group, + "a": sg.Group, + "defs": sg.Group, + "clipPath": sg.Group, + "mask": sg.Group, + "path": sg.Path, + "rect": sg.Rectangle, + "circle": sg.Circle, + "ellipse": sg.Ellipse, + "line": sg.Line, + "polyline": sg.Polyline, + "polygon": sg.Polygon, + }[name] + except KeyError: + log.warning("unhandled %s element", name) + return + elem = handler(**attributes) + if elem is None: + return + + if "clip_path" in attributes: + clipPath = attributes["clip_path"] + if isinstance(clipPath, str): + self.clippeds[clipPath].append(elem) + + if "mask" in attributes: + mask = attributes["mask"] + if isinstance(mask, str): + self.maskeds[mask].append(elem) + + if "_id" in attributes: + _id = attributes["_id"] + self.elements[_id] = elem + for use in self.uses.pop(_id, []): + use.element = elem + for clipped in self.clippeds.pop(_id, []): + clipped.clip_path = elem + for masked in self.maskeds.pop(_id, []): + masked.mask = elem + + if name in ["defs", "clipPath", "mask", "pattern"]: + elem.tag = name + else: + # set this element as a child to its parent group + self.group_stack[-1].add_child(elem) + + if isinstance(elem, sg.Group): + self.group_stack.append(elem) + + def end_element(self, name): + name = name.split(":")[-1] + try: + handler = getattr(self, "close_%s" % name) + except AttributeError: + pass + else: + handler() + + def close_g(self): + return self.group_stack.pop() + close_symbol = close_g + close_a = close_g + close_defs = close_g + close_svg = close_g + + def close_clipPath(self): + return fix_clip_attributes(self.close_g()) + + def close_mask(self): + return fix_mask_attributes(self.close_g()) + + def open_style(self, **attributes): + self.cdata = [] + + def close_style(self): + self.styles.update(styles("".join(self.cdata))) + self.cdata = [] + + def open_text(self, **attributes): + text = sg.Text("", **attributes) + self.texts.append(text) + self.cdata = [] + return text + + def close_text(self): + text = self.texts.pop() + text.text = "".join(self.cdata) + + def open_use(self, **attributes): + _href = attributes.pop("href") + try: + external, _id = _href.split("#") + except ValueError: + external, _id = _href, "__root__" + if external: + # TODO: cache parsers if the same external file is reused with != _id + parser = Parser() + cwd = os.getcwd() + path, filename = os.path.split(external) + if path: + os.chdir(path) + if filename.endswith('z'): + f = gzip.open(filename) + else: + f = open(filename, "rb") + try: + parser.parse(f.read()) + finally: + f.close() + os.chdir(cwd) + else: + parser = self + element = parser.elements.get(_id, None) + use = sg.Use(element, **attributes) + if element is None: + self.uses[_id].append(use) + return use + + def open_image(self, **attributes): + href = attributes["href"] + if "svg" in href.rsplit(".")[-1]: + return self.open_use(**attributes) + return sg.Image(**attributes) + + def open_pserver(self, **attributes): + self.pserver_kwargs = attributes + + def close_pserver(self, PaintServer): + kwargs = self.pserver_kwargs + _id = kwargs.pop("_id") + _href = kwargs.pop("href", None) + if _href: + assert _href.startswith("#") + kwargs["parent"] = _href[len("#"):] + if self.gradient_stops: + kwargs["stops"] = [stop(**s) for s in self.gradient_stops] + self.gradient_stops = [] + self.elements[_id] = (PaintServer, kwargs) + + open_linearGradient = open_radialGradient = open_pserver + + def open_pattern(self, **attributes): + self.open_pserver(**attributes) + return sg.Group() + + def close_linearGradient(self): + return self.close_pserver(sg.LinearGradient) + + def close_radialGradient(self): + return self.close_pserver(sg.RadialGradient) + + def close_pattern(self): + self.pserver_kwargs["pattern"] = self.close_g() + return self.close_pserver(sg.Pattern) + + def open_stop(self, **attributes): + self.gradient_stops.append(attributes) + + +def get_pserver(elements, _id): + pserver = elements[_id] + + try: + PaintServer, kwargs = pserver + except TypeError: + pass + else: + if "parent" in kwargs: + parent_id = kwargs["parent"] + parent = get_pserver(elements, parent_id) + else: + parent = None + pserver = elements[_id] = PaintServer(parent, **{k: kwargs[k] for k in kwargs if k in PaintServer._DEFAULTS}) + + return pserver + + +def fix_clip_attributes(clip): + try: + clip.fill_rule = clip.clip_rule + except AttributeError: + pass + if isinstance(clip, sg.Group): + clip.fill = sg.Color.white + clip.fill_opacity = 1. + clip.stroke = None + clip.opacity = 1. + for child_clip in clip.children: + fix_clip_attributes(child_clip) + else: + for attr in ["fill", "fill_opacity", "stroke", "opacity"]: + try: + delattr(clip, attr) + except AttributeError: + pass + return clip + + +def fix_mask_attributes(mask): + for attr in ["x", "y", "width", "height"]: + try: + delattr(mask, attr) + except AttributeError: + pass + return mask + + +def parse(document, logging_level=logging.ERROR): + log.setLevel(logging_level) + parser = Parser() + parser.parse(document) + return parser.root diff --git a/src/msspec/msspecgui/scenegraph2d/xml/serializer.py b/src/msspec/msspecgui/scenegraph2d/xml/serializer.py new file mode 100644 index 0000000..fdb692b --- /dev/null +++ b/src/msspec/msspecgui/scenegraph2d/xml/serializer.py @@ -0,0 +1,58 @@ +# -*- coding: utf8 -*- + +"""svg serialization""" + + +# serialization ############################################################## + +_SVG_HEADER = """\ + + +""" + +_SVG_FOOTER = """\ + +""" + + +def _indent(s, level=1, tab="\t"): + """indent blocks""" + indent = tab * level + return "\n".join("%s%s" % (indent, line) for line in s.split("\n")) + + +def serialize(*elems): + """ + serialization of elems into svg+xml. + + :param elems: the elements that need to be output to svg + :type elems: scenegraph.Element + + """ + defs = [] + xml_elems = [_indent(elem._xml(defs)) for elem in elems] + xml_defs = set() + while defs: + elem = defs.pop() + xml_defs.add(_indent(elem._xml(defs), 2)) + + # compute the bounding box of the elements that need to be serialized + (x_min, y_min), (x_max, y_max) = (float("inf"), ) * 2, (float("-inf"), ) * 2 + for elem in elems: + (ex_min, ey_min), (ex_max, ey_max) = elem.aabbox() + x_min, x_max = min(x_min, ex_min), max(x_max, ex_max) + y_min, y_max = min(y_min, ey_min), max(y_max, ey_max) + + def xml_lines(): + yield _SVG_HEADER % (x_min, y_min, x_max - x_min, y_max - y_min) + if xml_defs: + yield "\t" + for xml_def in xml_defs: + yield xml_def + yield "\t" + for xml_elem in xml_elems: + yield xml_elem + yield _SVG_FOOTER + + return "\n".join(xml_lines()) diff --git a/src/msspec/parameters.py b/src/msspec/parameters.py new file mode 100644 index 0000000..23553f5 --- /dev/null +++ b/src/msspec/parameters.py @@ -0,0 +1,1749 @@ +# coding: utf-8 +""" +Module parameters +================= + +""" +import textwrap +import numpy as np +import re +from terminaltables import AsciiTable +from msspec.misc import LOGGER, UREG, XRaySource, get_level_from_electron_configuration +import ase + +class Parameter(object): + def __init__(self, name, types=None, limits=(None, None), + unit=None, allowed_values=None, default=None, + pattern=None, fmt='s', binding=None, private=False, group="", + doc='Sorry, no more help for this parameter.'): + self.name = name + self.group = group + if isinstance(types, (tuple, list)): + self.allowed_types = types + else: + self.allowed_types = (types,) + self.low_limit, self.high_limit = limits + self.unit = unit + self.allowed_values = allowed_values + self.default = default + self.pattern = pattern + self.fmt = fmt + self.binding = binding + self.private = private + self.docstring = doc + self._value = None + + self.value = default + + def serialize(self): + data = { + 'name': self.name, + 'types': self.allowed_types, + 'limits': (self.low_limit, self.high_limit), + 'unit': self.unit, + 'allowed_values': self.allowed_values, + 'default': self.default, + 'pattern': self.pattern, + 'fmt': self.fmt, + # 'binding': self.binding, + 'private': self.private, + 'group': self.group, + 'doc': self.docstring + } + return data + + def convert(self, value): + if hasattr(value, 'magnitude'): + if self.unit != None: + return value.to(self.unit).magnitude + return value + + def check(self, value): + + def assert_message(msg, *args): + s = '\'{}\': {}'.format(self.name, msg) + s = s.format(*args) + + try: + allowed_types = '\n'.join( + ['- ' + str(_) for _ in self.allowed_types]) + except TypeError: + allowed_types = self.allowed_types + + try: + allowed_values = '\n'.join( + ['- ' + str(_) for _ in self.allowed_values]) + except TypeError: + allowed_values = self.allowed_values + + data = [ + ['PROPERTY', 'VALUE'], + ['Name', '\'{}\''.format(self.name)], + ['Allowed types', '{}'.format(allowed_types)], + ['Limits', '{} <= value <= {}'.format(self.low_limit, + self.high_limit)], + ['Unit', '{}'.format(self.unit)], + ['Allowed values', '{}'.format(allowed_values)], + ['Default', '{}'.format(self.default)] + ] + t = AsciiTable(data) + table = '\n'.join(['\t' * 2 + _ for _ in t.table.split('\n')]) + + s = "{}\n\n{}\n{}".format(s, table, self.docstring) + + return s + + # convert if a unit was given + _value = self.convert(value) + + if self.allowed_types != None: + # val = value + # if hasattr(value, 'magnitude'): + # val = value.magnitude + try: + if isinstance(_value, bool): + assert bool in self.allowed_types + assert isinstance(_value, self.allowed_types) + except AssertionError: + raise AssertionError(assert_message( + 'Type {} is not an allowed type for this option ' + '({} allowed)', + str(type(_value)), str(self.allowed_types))) + # if not isinstance(_value, (list, tuple, np.ndarray)): + # _values = [_value,] + + # if isinstance(_value, tuple): + # _values = list(_value) + + + # for i, val in enumerate(_values): + for val in np.array(_value).flatten(): + if self.low_limit != None: + assert val >= self.low_limit, assert_message( + 'Value must be >= {:s}', + str(self.low_limit)) + if self.high_limit != None: + assert val <= self.high_limit, assert_message( + 'Value must be <= {:s}', + str(self.high_limit)) + if self.allowed_values != None and isinstance(val, tuple(type(x) for x in self.allowed_values)): + assert val in self.allowed_values, assert_message( + 'This value is not allowed. Please choose between ' + 'one of {:s}', + str(self.allowed_values)) + if self.pattern != None: + p = re.compile(self.pattern) + m = p.match(val) + assert m != None, assert_message( + 'Wrong string format') + # _value[i] = val + + return _value + + @property + def value(self): + return self._value + + @value.setter + def value(self, value): + v = self.check(value) + self._value = v + # if hasattr(value, 'magnitude'): + # self._value = value.magnitude + # else: + # self._value = value + if self.binding: + new_value = None + try: + new_value = self.binding(self) + except AttributeError: + pass + if new_value is not None: + self._value = new_value + # LOGGER.debug('{:s} = {:s}'.format(self.name, str(self.value))) + + def get(self, *args): + return self.value + + def set(self, *args): + value = args[-1] + self.value = value + + def __str__(self): + fmt = '{:' + self.fmt + '}' + try: + return fmt.format(self._value) + except ValueError: + return str(self._value) + + def __len__(self): + try: + return len(self._value) + except TypeError: + return 1 + +class BaseParameters(object): + __isfrozen = False + + def __init__(self): + self._parameters = [] + + def add_parameters(self, *parameters): + cls = self.__class__ + + for p in parameters: + p.group = self.__class__.__name__ + try: + p.binding = getattr(self, 'bind_' + p.name) + except AttributeError: + pass + + if not p.private: + setattr(self, 'set_' + p.name, p.set) + setattr(self, 'get_' + p.name, p.get) + setattr(cls, p.name, property(fset=p.set, fget=p.get, + doc=p.docstring)) + self._parameters.append(p) + + def get_parameter(self, name): + retval = None + for p in self._parameters: + if p.name == name: + retval = p + if retval is None: + raise KeyError('No such parameter: {}'.format(name)) + return retval + + def set_parameter(self, name, value, force=False): + found = False + for p in self._parameters: + if p.name == name: + if p.private: + if force: + LOGGER.debug("forcing the value of the private " + "parameter '%s' to the value = %s", + p.name, value) + else: + err_msg = ("Cannot change the value of the private " + "parameter '{}'").format(p.name) + LOGGER.error("Cannot change the value of a private " + "parameter") + raise NameError(err_msg) + p.value = value + found = True + if found is False: + err_msg = 'No such parameter: {}'.format(name) + LOGGER.error("Unknwon parameter's name!") + raise ValueError(err_msg) + + def freeze(self, frozen=True): + self.__isfrozen = frozen + + def __setattr__(self, key, value): + if self.__isfrozen and not hasattr(self, key): + data = '\n'.join( + ["\t\t- '{}'".format(p.name) for p in self._parameters]) + err_msg = """ + '{}' is not an allowed attribute of {} class. + Please use one of:\n{}""".format(key, self.__class__.__name__, + data) + print(key, value) + LOGGER.error('Unknown attribute!') + raise AttributeError(err_msg) + object.__setattr__(self, key, value) + + def __iter__(self): + for x in range(len(self._parameters)): + yield self._parameters[x] + + def __getitem__(self, index): + return self._parameters[index] + + + +class PhagenParameters(BaseParameters): + def __init__(self): + parameters = ( + Parameter('calctype', allowed_values=('xpd', 'xas', 'aed', 'led', + 'rex', 'els', 'e2e'#, 'dos' + ), + types=(str,), default='xpd'), + Parameter('expmode', allowed_values=('cis', 'cfs', 'cel'), + types=(str,), default='cis'), + Parameter('coor', allowed_values=('angs', 'au'), types=(str,), + default='angs'), + Parameter('enunit', allowed_values=('ryd', 'eV'), fmt='3>s', + types=(str,), default='ryd'), + Parameter('einc', types=(int, float), limits=(0, None), fmt='.1f', + default=700.), + Parameter('esct', types=(int, float), limits=(0, None), fmt='.1f', + default=580.), + Parameter('scangl', types=(int, float), limits=(0, 360), fmt='.2f', + default=0.), + Parameter('lambda', types=(int, float), fmt='.2f', default=20.), + Parameter('emin', types=(int, float), limits=(0, None), fmt='.4f', + default=13.5236), + Parameter('emax', types=(int, float), limits=(0, None), fmt='.4f', + default=13.5236), + Parameter('delta', types=(int, float), limits=(0, None), fmt='.4f', + default=0.3), + Parameter('cip', types=(int, float), limits=(0, None), fmt='.4f', + default=0.), + Parameter('potgen', allowed_values=('in', 'ex'), types=(str,), + default='in'), + Parameter('potype', allowed_values=('hdrel', 'hedin', 'xalph', + 'dhrel', 'dhcmp', + #'lmto', 'msf', 'spkkr' + ), + types=(str,), fmt='5>s', default='hedin'), + Parameter('relc', allowed_values=('nr', 'sr', 'so'), types=(str,), + default='nr'), + Parameter('norman', allowed_values=('stdcrm', 'scaled', 'extrad'), + types=(str,), default='stdcrm'), + Parameter('ovlpfac', types=(int, float), limits=(0, None), + fmt='.4f', default=0.), + Parameter('gamma', types=(int, float), limits=(None, None), + fmt='.2f', default=0.03), + Parameter('charelx', allowed_values=('ex', 'gs'), types=(str,), + default='gs'), + Parameter('ionzst', allowed_values=('neutral', 'ionic'), + types=(str,), fmt='7>s', default='neutral'), + Parameter('eikappr', allowed_values=('yes', 'no'), types=(str,), + fmt='3>s', default='no'), + Parameter('db', types=(int, float), fmt='.2f', default=0.01), + Parameter('optrsh', allowed_values=('y', 'n'), types=(str,), + default='n'), + Parameter('rsh', types=(float,), limits=(0., None), fmt='.1f', + default=0.9), + Parameter('lmax_mode', types=(int,), limits=(0, 2), fmt='d', + default=2), + Parameter('lmaxt', types=(int,), limits=(0, None), fmt='d', + default=20), + Parameter('edge', types=(str,), fmt='<2s', default='k'), + Parameter('edge1', types=(str,), fmt='<2s', + default='l1'), + Parameter('edge2', types=(str,), fmt='<2s', default='l1'), + Parameter('l2h', types=(int,), fmt='d', default=4), + + Parameter('ionicity', types=dict, default={}), + #Parameter('absorber', types=(int,), limits=(1, None), fmt='d', default=1), + #Parameter('nosym', types=(str,), allowed_values=('.true.', '.false.'), fmt='s', default='.true.'), + #Parameter('outersph', types=(str,), allowed_values=('.true.', '.false.'), fmt='s', default='.false.'), + Parameter('atoms', types=ase.atoms.Atoms, default=ase.atoms.Atoms())) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.freeze() + +class PhagenMallocParameters(BaseParameters): + def __init__(self): + parameters = ( + Parameter('nat_', types=int, limits=(1, None), default=1550), + Parameter('ua_', types=int, limits=(1, None), default=1550), + Parameter('neq_', types=int, limits=(1, None), default=48), + Parameter('rdx_', types=int, limits=(1, None), default=1500), + Parameter('lmax_', types=int, limits=(1, None), default=60), + Parameter('nef_', types=int, limits=(1, None), default=200), + Parameter('lexp_', types=int, limits=(1, None), default=10), + Parameter('nep_', types=int, limits=(1, None), default=1000), + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.freeze() + +class SpecParameters(BaseParameters): + def __init__(self): + parameters = ( + Parameter('calctype_spectro', types=str, + allowed_values=('PHD', 'AED', 'XAS', 'LED', 'ACS', 'EIG'), + default='PHD'), + Parameter('calctype_ispin', types=int, limits=(0, 1), default=0, + fmt='d'), + Parameter('calctype_idichr', types=int, limits=(0, 2), default=0, + fmt='d'), + Parameter('calctype_ipol', types=int, limits=(-1, 2), default=0, + fmt='d'), + Parameter('calctype_iamp', types=int, limits=(0, 1), default=1, + fmt='d'), + + Parameter('ped_li', types=str, default='1s'), + Parameter('ped_so', types=str, default='1/2'), + Parameter('ped_initl', types=int, limits=(-1, 2), default=2, + fmt='d'), + Parameter('ped_iso', types=int, limits=(-1, 2), default=0, + fmt='d'), + Parameter('ped_iphi', types=int, limits=(-1, 3), default=3, + fmt='d'), + Parameter('ped_itheta', types=int, limits=(-1, 3), default=0, + fmt='d'), + Parameter('ped_ie', types=int, limits=(0, 4), default=0, + fmt='d'), + Parameter('ped_ifthet', types=int, limits=(0, 1), default=0, + fmt='d'), + Parameter('ped_nphi', types=int, limits=(1, None), default=360, + fmt='d'), + Parameter('ped_ntheta', types=int, limits=(1, None), default=45, + fmt='d'), + Parameter('ped_ne', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('ped_nfthet', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('ped_phi0', types=float, limits=(0., 360.), default=0., + fmt='.2f'), + Parameter('ped_theta0', types=float, limits=(-360., 360.), + default=-70., fmt='.2f'), + Parameter('ped_e0', types=float, limits=(0., None), default=316.4, + fmt='.2f'), + Parameter('ped_r0', types=float, default=0.5, + fmt='.3f'), + Parameter('ped_phi1', types=float, limits=(0., 360.), default=0., + fmt='.2f'), + Parameter('ped_theta1', types=float, limits=(-360., 360.), + default=69., fmt='.2f'), + Parameter('ped_e1', types=float, limits=[0., None], default=316.4, + fmt='.2f'), + Parameter('ped_r1', types=float, default=-1.0, + fmt='.3f'), + Parameter('ped_thlum', types=float, default=-55.0, + fmt='.2f'), + Parameter('ped_philum', types=float, default=0., + fmt='.2f'), + Parameter('ped_elum', types=float, default=1253.6, + fmt='.2f'), + Parameter('ped_imod', types=int, default=1, + fmt='d'), + Parameter('ped_imoy', types=int, default=0, + fmt='d'), + Parameter('ped_accept', types=float, default=0., + fmt='.2f'), + Parameter('ped_ichkdir', types=int, default=0, + fmt='d'), + + Parameter('leed_iphi', types=int, limits=(-1, 3), default=-1, + fmt='d'), + Parameter('leed_itheta', types=int, limits=(-1, 3), default=0, + fmt='d'), + Parameter('leed_ie', types=int, limits=(0, 4), default=0, + fmt='d'), + Parameter('leed_ifthet', types=int, limits=(0, 1), default=0, + fmt='d'), + Parameter('leed_nphi', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('leed_ntheta', types=int, limits=(1, None), default=140, + fmt='d'), + Parameter('leed_ne', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('leed_nfthet', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('leed_phi0', types=float, limits=(0., 360.), default=0., + fmt='.2f'), + Parameter('leed_theta0', types=float, limits=(-360., 360.), + default=-70., fmt='.2f'), + Parameter('leed_e0', types=float, limits=(0., None), default=100., + fmt='.2f'), + Parameter('leed_r0', types=float, default=0.5, + fmt='.3f'), + Parameter('leed_phi1', types=float, limits=(0., 360.), default=0., + fmt='.2f'), + Parameter('leed_theta1', types=float, limits=(-360., 360.), + default=69., fmt='.2f'), + Parameter('leed_e1', types=float, limits=[0., None], default=316.4, + fmt='.2f'), + Parameter('leed_r1', types=float, default=-1.0, + fmt='.3f'), + 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=1, + fmt='d'), + Parameter('leed_imoy', types=int, default=0, + fmt='d'), + Parameter('leed_accept', types=float, default=0., + fmt='.2f'), + Parameter('leed_ichkdir', types=int, default=0, + fmt='d'), + + Parameter('exafs_edge', types=str, default='L1', + pattern=r'((K|K1)|[KLMNO][1-9])', fmt='<2s'), + Parameter('exafs_initl', types=int, limits=[-1, 2], + default=1, fmt='d'), + Parameter('exafs_thlum', types=float, default=-55.0, + fmt='.2f'), + Parameter('exafs_philum', types=float, default=0., + fmt='.2f'), + Parameter('exafs_ne', types=int, limits=[1, None], + default=1, fmt='d'), + Parameter('exafs_ekini', types=float, limits=[0, None], + default=200., fmt='.2f'), + Parameter('exafs_ekfin', types=float, limits=[0, None], + default=600., fmt='.2f'), + Parameter('exafs_ephini', types=float, limits=[0, None], + default=1486.7, fmt='.2f'), + + Parameter('aed_edgec', types=str, default='L2', + pattern=r'((K|K1)|[KLMNO][1-9])', fmt='<2s'), + Parameter('aed_edgei', types=str, default='M2', + pattern=r'((K|K1)|[KLMNO][1-9])', fmt='<2s'), + Parameter('aed_edgea', types=str, default='M2', + pattern=r'((K|K1)|[KLMNO][1-9])', fmt='<2s'), + Parameter('aed_imult', types=int, limits=[0, 1], default=1, + fmt='d'), + Parameter('aed_mult', types=str, default='1D2', + pattern=r'\d[SPDFG]\d', fmt='s'), + Parameter('aed_iphi', types=int, limits=(-1, 3), default=0, + fmt='d'), + Parameter('aed_itheta', types=int, limits=(-1, 3), default=1, + fmt='d'), + Parameter('aed_ifthet', types=int, limits=(0, 1), default=0, + fmt='d'), + Parameter('aed_iint', types=int, limits=(0, 3), default=0, + fmt='d'), + Parameter('aed_nphi', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('aed_ntheta', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('aed_nfthet', types=int, limits=(1, None), default=1, + fmt='d'), + Parameter('aed_phi0', types=float, limits=(0., 360.), default=0., + fmt='.2f'), + Parameter('aed_theta0', types=float, limits=(-360., 360.), + default=45., fmt='.2f'), + Parameter('aed_r0', types=float, default=0.5, + fmt='.3f'), + Parameter('aed_phi1', types=float, limits=(0., 360.), default=0., + fmt='.2f'), + Parameter('aed_theta1', types=float, limits=(-360., 360.), + default=70., fmt='.2f'), + Parameter('aed_r1', types=float, default=-1.0, + fmt='.3f'), + Parameter('aed_imod', types=int, default=1, + fmt='d'), + Parameter('aed_imoy', types=int, default=0, + fmt='d'), + Parameter('aed_accept', types=float, default=1., + fmt='.2f'), + Parameter('aed_ichkdir', types=int, default=0, + fmt='d'), + + Parameter('eigval_ne', types=int, limits=[1, None], default=1, + fmt='d'), + Parameter('eigval_ekini', types=float, limits=[0., None], + default=10., fmt='.2f'), + Parameter('eigval_ekfin', types=float, limits=[0., None], + default=10., fmt='.2f'), + Parameter('eigval_idamp', types=int, limits=[0, 3], + default=3, fmt='d'), + Parameter('eigval_ispectrum_ne', types=int, limits=[0, 1], + default=1, fmt='d'), + Parameter('eigval_ipwm', types=int, limits=[-4, 4], default=1, + fmt='d'), + Parameter('eigval_method', types=str, default='EPSI', + allowed_values=['AITK', 'RICH', 'SALZ', 'EPSI', 'EPSG', + 'RHOA', 'THET', 'LEGE', 'CHEB', 'OVER', + 'DURB', 'DLEV', 'TLEV', 'ULEV', 'VLEV', + 'ELEV', 'EULE', 'GBWT', 'VARI', 'ITHE', + 'EALG']), + Parameter('eigval_acc', types=float, limits=[0., None], + default=0.001, fmt='.5f'), + Parameter('eigval_expo', types=float, default=1., fmt='.3f'), + Parameter('eigval_nmax', types=int, limits=[1, None], default=200, + fmt='d'), + Parameter('eigval_niter', types=int, limits=[1, None], default=10, + fmt='d'), + Parameter('eigval_ntable', types=int, limits=[1, None], default=3, + fmt='d'), + Parameter('eigval_shift', types=float, default=0., + fmt='.3f'), + Parameter('eigval_ixn', types=int, limits=[1, 5], default=1, + fmt='d'), + Parameter('eigval_iva', types=int, limits=[1, 5], default=1, + fmt='d'), + Parameter('eigval_ign', types=int, limits=[1, 7], default=1, + fmt='d'), + Parameter('eigval_iwn', types=int, limits=[1, 6], default=1, + fmt='d'), + Parameter('eigval_l', types=int, limits=[0, 1], default=0, + fmt='d'), + Parameter('eigval_alpha', types=float, default=1., fmt='.2f'), + Parameter('eigval_beta', types=float, default=1., fmt='.2f'), + + Parameter('calc_no', types=int, limits=[0, 8], default=1, fmt='d'), + Parameter('calc_ndif', types=int, limits=[1, 10], default=3, + fmt='d'), + Parameter('calc_ispher', types=int, limits=[0, 1], default=1, + fmt='d'), + Parameter('calc_igr', types=int, limits=[0, 2], default=0, fmt='d'), + Parameter('calc_isflip', types=int, limits=[0, 1], default=0, + fmt='d'), + Parameter('calc_irdia', types=int, limits=[0, 1], default=0, + fmt='d'), + Parameter('calc_itrtl', types=int, limits=[1, 9], default=7, + fmt='d'), + Parameter('calc_itest', types=int, limits=[0, 2], default=0, + fmt='d'), + Parameter('calc_isom', types=int, limits=[0, 2], default=0, + fmt='d'), + Parameter('calc_nonvol', types=int, limits=[0, 1], default=1, + fmt='d'), + Parameter('calc_npath', types=int, limits=[0, None], default=100, + fmt='d'), + Parameter('calc_vint', types=float, default=0., fmt='.2f'), + Parameter('calc_ifwd', types=int, limits=[0, 1], default=0, + fmt='d'), + Parameter('calc_nthout', types=int, limits=[0, None], default=1, + fmt='d'), + Parameter('calc_ino', types=int, limits=[0, None], default=0, + fmt='d'), + Parameter('calc_ira', types=int, limits=[0, 1], default=0, fmt='d'), + Parameter('calc_ipw', types=int, limits=[0, 1], default=0, fmt='d'), + Parameter('calc_ncut', types=int, limits=[0, 10], default=2, + fmt='d'), + Parameter('calc_pctint', types=float, limits=[1e-4, 999.9999], + default=0.01, fmt='.4f'), + Parameter('calc_ipp', types=int, limits=[1, 2], default=1, fmt='d'), + Parameter('calc_ilength', types=int, limits=[0, 1], default=0, + fmt='d'), + Parameter('calc_rlength', types=float, limits=[0, None], + default=10., fmt='.2f'), + Parameter('calc_unlength', types=str, allowed_values=['ANG', ], + default='ANG'), + Parameter('calc_idwsph', types=int, limits=[0, 1], default=0, + fmt='d'), + Parameter('calc_ispeed', types=int, limits=[None, 1], default=1, + fmt='d'), + Parameter('calc_iatt', types=int, limits=[0, 1], default=1, + fmt='d'), + Parameter('calc_iprint', types=int, limits=[0, 2], default=1, + fmt='d'), + Parameter('calc_idcm', types=int, limits=[0, 2], default=0, fmt='d'), + Parameter('calc_td', types=float, limits=[0., None], default=420., + fmt='.2f'), + Parameter('calc_t', types=float, limits=[0., None], default=293., + fmt='.2f'), + Parameter('calc_rsj', types=float, limits=[0., None], default=1.2, + fmt='.2f'), + + Parameter('calc_ilpm', types=int, limits=[-1, 2], default=2, + fmt='d'), + Parameter('calc_xlpm0', types=float, limits=[0., None], default=15., + fmt='.2f'), + + Parameter('input_data', types=str, default='../input/spec.dat'), + Parameter('input_unit00', types=int, default=5, fmt='d'), + Parameter('input_tl', types=str, default='../output/tmatrix.tl'), + Parameter('input_unit01', types=int, default=1, fmt='d'), + Parameter('input_rad', types=str, default='../output/tmatrix.rad'), + Parameter('input_unit02', types=int, default=3, fmt='d'), + Parameter('input_cluster', types=str, + default='../output/cluster.clu'), + Parameter('input_unit03', types=int, default=4, fmt='d'), + Parameter('input_adsorbate', types=str, + default='../input/adsorbate.pos'), + Parameter('input_unit04', types=int, default=2, fmt='d'), + Parameter('input_kdirs', types=str, default='../input/kdirs.dat'), + Parameter('input_unit05', types=int, default=11, fmt='d'), + + Parameter('input2_tl', types=str, default='../output/tmatrix.tl'), + Parameter('input2_unit06', types=int, default=12, fmt='d'), + Parameter('input2_rad', types=str, default='../output/tmatrix.rad'), + Parameter('input2_unit07', types=int, default=13, fmt='d'), + Parameter('input2_kdirs', types=str, default='../input/kdirs.dat'), + Parameter('input2_unit08', types=int, default=14, fmt='d'), + + Parameter('output_log', types=str, default='../output/spec.log'), + Parameter('output_unit09', types=int, default=6, fmt='d'), + Parameter('output_res', types=str, default='../output/results.dat'), + Parameter('output_unit10', types=int, default=9, fmt='d'), + Parameter('output_sf', types=str, default='../output/facdif1.dat'), + Parameter('output_unit11', types=int, default=8, fmt='d'), + Parameter('output_augclus', types=str, + default='../output/augclus.clu'), + Parameter('output_unit12', types=int, default=10, fmt='d'), + + Parameter('extra_atoms', types=ase.atoms.Atoms, + default=ase.atoms.Atoms()), + Parameter('extra_nat', types=int, limits=[1, None], default=1, + fmt='d'), + Parameter('extra_energies', types=(list, tuple), default=[0., ]), + Parameter('extra_nlmax', types=int, default=10), + Parameter('extra_level', types=str, default='1s'), + Parameter('extra_parameters', types=dict, default={}) + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.freeze() + +class SpecMallocParameters(BaseParameters): + def __init__(self): + parameters = ( + Parameter('NATP_M', types=int, limits=(1, None), default=20), + Parameter('NATCLU_M', types=int, limits=(1, None), default=300), + Parameter('NAT_EQ_M', types=int, limits=(1, None), default=16), + Parameter('N_CL_L_M', types=int, limits=(1, None), default=1), + Parameter('NE_M', types=int, limits=(1, None), default=100), + Parameter('NL_M', types=int, limits=(1, None), default=50), + Parameter('LI_M', types=int, limits=(1, None), default=7), + Parameter('NEMET_M', types=int, limits=(1, None), default=2), + Parameter('NO_ST_M', types=int, limits=(1, None), default=2), + Parameter('NDIF_M', types=int, limits=(1, None), default=10), + Parameter('NSO_M', types=int, limits=(1, None), default=2), + Parameter('NTEMP_M', types=int, limits=(1, None), default=1), + Parameter('NODES_EX_M', types=int, limits=(1, None), default=3), + Parameter('NSPIN_M', types=int, limits=(1, None), default=1), + Parameter('NTH_M', types=int, limits=(1, None), default=2000), + Parameter('NPH_M', types=int, limits=(1, None), default=2000), + Parameter('NDIM_M', types=int, limits=(1, None), default=100000), + Parameter('N_TILT_M', types=int, limits=(1, None), default=11), + Parameter('N_ORD_M', types=int, limits=(1, None), default=200), + Parameter('NPATH_M', types=int, limits=(1, None), default=500), + Parameter('NGR_M', types=int, limits=(1, None), default=10), + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.freeze() + + + +class GlobalParameters(BaseParameters): + def __init__(self, phagen_parameters=None, spec_parameters=None): + parameters = ( + Parameter('spectroscopy', types=str, allowed_values=( + 'PED', 'AED', 'LEED', 'EXAFS', 'EIG'), default='PED', + doc=textwrap.dedent(""" + There are 4 choices for the spectroscopy option: + + - '**PED**', for Photo Electron Diffraction + - '**AED**', for Auger Electron Diffraction + - '**LEED**', for Low Energy Electron Diffraction + - '**EXAFS**', for the Extended X-ray Absorption Fine Structure + + Additionally, a 5th keyword **EIG** is used to get deeper information + about the convergence of the eigen values of multiple scattering + matrix. + + The value is case insensitive. + """)), + Parameter('algorithm', types=str, allowed_values=('expansion', + 'inversion', + 'correlation', + 'power'), + default='expansion', doc=textwrap.dedent(""" + You can choose the algorithm used for the computation of the scattering path operator. + + - '**inversion**', for the classical matrix inversion method + - '**expansion**', for the Rehr-Albers series expansion + - '**correlation**', for the correlation-expansion algorithm + - '**power**', for the power method approximation scheme (only for spectroscopy='EIG') + + The series expansion algorithm is well suited for high energy since the number of terms + required decreases as the energy increases. The exact solution is obtained by the matrix inversion + method but should be preferably used for lower energy. + """)), + Parameter('polarization', types=(type(None), str), + allowed_values=(None, 'linear_qOz', 'linear_xOy', + 'circular'), default=None, doc=textwrap.dedent(""" + Specify the polarization of the incident light. + + - **None**, for unpolarized light + - '**linear_qOz**' for a polarization vector in the :math:`(\\vec{q}0z)` plane + - '**linear_xOy**' for a polarization vector in the :math:`(x0y)` plane + - '**circular**' for circular dichroism + + """)), + Parameter('dichroism', types=(type(None), str), + allowed_values=(None, 'natural', 'sum_over_spin', + 'spin_resolved'), default=None, doc=textwrap.dedent(""" + Used to perform dichroic calculations. The default (None) is to disable this. + """)), + Parameter('spinpol', types=bool, default=False, doc=textwrap.dedent(""" + Enable or disbale spin-resolved calculations. + """)), + Parameter('folder', types=str, default='./calc', doc=textwrap.dedent(""" + This parameter is the path to the temporary folder used for the calculations. If you do not change this + parameter between calculations, all the content will be overridden. This is usually not a problem, since the + whole bunch of data created during a computation is not meant to be saved. But you may want to anyway by + changing it to another path. + + This folder is not automatically removed after a computation. It is removed when calling the :meth:`shutdown` + calculator method: + + .. code-block:: python + + calc = MSSPEC() # the './calc' folder is created + # do your calculation here + calc.shutdown() # the folder is removed + + + """)) + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.phagen_parameters = phagen_parameters + self.spec_parameters = spec_parameters + self.spec_parameters.extra_parameters['global'] = self + self.freeze() + + def bind_spectroscopy(self, p): + mapping = { + 'PED': ('xpd', 'PHD'), + 'AED': ('aed', 'AED'), + 'LEED': ('led', 'LED'), + 'EXAFS': ('xas', 'XAS'), + 'EIG': ('xpd', 'EIG'), + } + phagen_calctype, spec_calctype = mapping[p.value] + self.phagen_parameters.calctype = phagen_calctype + self.spec_parameters.calctype_spectro = spec_calctype + +class MuffintinParameters(BaseParameters): + def __init__(self, phagen_parameters, spec_parameters): + parameters = ( + Parameter('charge_relaxation', types=bool, default=True, doc=textwrap.dedent(""" + Used to specify wether the charge density of the photoabsorbing atom, which is used + to construct the potential, is allowaed to relax around the core hole or not. + """)), + Parameter('ionicity', types=dict, default={}, doc=textwrap.dedent(""" + A dictionary to specify the ionicity of each kind of atoms. If empty, the atoms are considered to be + neutral. Otherwise, each key must be a chemical symbol and the corresponding value should be the fraction + of electrons added (negative) or substracted (positive) with respect to neutrality. + As an example for a LaFeO\ :sub:`3` cluster:: + + >>> calc.muffintin_parameters.ionicity = {'La': 0.15, 'Fe': 0.15, 'O': -0.1} + + means that 0.15 electrons have been substracted from La, likewise from Fe. Neutrality implies that 0.3 + electrons have to be added to oxygen atoms. + + """)), + Parameter('relativistic_mode', types=str, + allowed_values=('non_relativistic', 'scalar_relativistic', + 'spin_orbit_resolved'), + default='non_relativistic', doc=textwrap.dedent(""" + To tell whether to use the scalar relativistic approximation or not. + """)), + Parameter('radius_overlapping', types=float, limits=(0., 1.), + default=0., doc=textwrap.dedent(""" + to allow atomic spheres to overlapp with each other. The value is a percentage, 1. means 100%. + """)), + Parameter('interstitial_potential', types=(int, float), + unit=UREG.eV, default=0., doc=textwrap.dedent(""" + The average interstitial potential (or inner potential) expressed in eV. It is used to compute + the refraction at the surface. + """)), + Parameter('hydrogen_radius', types=(int, float), default=0.9, + limits=(0., None), unit=UREG.angstroms, doc=textwrap.dedent(""" + The program can have difficulties to find the radius of the hydrogen atom (small atom). You can + specify here a value for the radius. If you set it to 'None', the calculation of the muffin-tin + radius of H atoms will be left to the program. + """)) + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.phagen_parameters = phagen_parameters + self.spec_parameters = spec_parameters + self.freeze() + + def bind_charge_relaxation(self, p): + mapping = {True: 'ex', False: 'gs'} + self.phagen_parameters.charelx = mapping[p.value] + + def bind_ionicity(self, p): + self.phagen_parameters.ionicity = p.value + + def bind_relativistic_mode(self, p): + mapping = {'non_relativistic': 'nr', 'scalar_relativistic': 'sr', + 'spin_orbit_resolved': 'so'} + self.phagen_parameters.relc = mapping[p.value] + + def bind_radius_overlapping(self, p): + self.phagen_parameters.ovlpfac = p.value + + def bind_interstitial_potential(self, p): + self.spec_parameters.calc_vint = p.value + + def bind_hydrogen_radius(self, p): + self.phagen_parameters.rsh = p.value + +class TMatrixParameters(BaseParameters): + def __init__(self, phagen_parameters): + parameters = ( + Parameter('potential', types=str, + allowed_values=('muffin_tin', 'lmto'), + default='muffin_tin', doc=textwrap.dedent(""" + This option allows to choose which kind of potential is used to compute the T-Matrix. For now, + only the internal *Muffin-Tin* potential is supported. + """)), + Parameter('exchange_correlation', types=str, + allowed_values=('hedin_lundqvist_real', + 'hedin_lundqvist_complex', + 'x_alpha_real', + 'dirac_hara_real', 'dirac_hara_complex'), + default='hedin_lundqvist_complex', doc=textwrap.dedent(""" + Set the type of exchange and correlation potential that will be used. + """)), + Parameter('imaginery_part', types=(int, float), default=0., doc=textwrap.dedent(""" + This value is added to complex potentials to account for core-hole lifetime and experimental resolution + broadening effects. + """)), + Parameter('lmax_mode', types=str, + allowed_values=('max_ke', 'true_ke', 'imposed'), + default='true_ke', doc=textwrap.dedent(""" + This allows to control the number of basis functions used to expand the wave function on each + atom. It can be: + + - '**imposed**', and will be equal to the *lmaxt* parameter (see below). It is therefore independent + on both the energy and atom type. + - '**max_ke**', in this case :math:`l_{max}` is computed according to the formula + :math:`l_{max} = kr_{at} + 1` where :math:`k=E^{1/2}_{max}` with :math:`E_{max}` being the + maximum kinetic energy. In this case :math:`l_{max}` is independent of the energy but + depends on the atom number. + - '**true_ke**', in this case :math:`l_{max}` is computed according to the formula + :math:`l_{max} = kr_{at} + 1` where :math:`k=E^{1/2}_k` with :math:`E_k` being the kinetic + energy. In this case :math:`l_{max}` depends both on the energy and the atom number. + + """)), + Parameter('lmaxt', types=int, limits=(1, None), default=19, doc=textwrap.dedent(""" + The value of :math:`l_{max}` if *lmax_mode = 'imposed'* + """)), + Parameter('tl_threshold', types=(type(None), float), default=None, doc=textwrap.dedent(""" + This option allows to control the number of basis function by defining a threshold value for the *tl*. + For example:: + + >>> calc.tmatrix_parameters.tl_threshold = 1e-6 + + will remove all *tl* with a value :math:`< 1.10^{-6}` + + .. note:: + This option is compatible with any modes of the *lmax_mode* option. + + """)), + Parameter('max_tl', types=(type(None), dict), default=None, doc=textwrap.dedent(""" + *max_tl* is used to sepcify a maximum number of basis functions to use for each kind of atoms. For example, + in the case of an MgO cluster, you could write:: + + >>> calc.muffintin_parameters.max_tl = {'Mg': 20, 'O', 15} + + to tell the program to use at most 20 *tl* for Mg and 15 for O. It acts like a filter, meaning that if you + use this option, you are not required to sepcif a value for each kind of atoms in your cluster. You can + restrict the number of *tl* only for one type of atom for example. + + .. note:: + This option is compatible with any modes of the *lmax_mode* option. + + """)) + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.phagen_parameters = phagen_parameters + self.freeze() + + def bind_potential(self, p): + mapping = {'muffin_tin': 'in', 'lmto': 'ex'} + self.phagen_parameters.potgen = mapping[p.value] + + def bind_exchange_correlation(self, p): + potential = self.get_parameter('potential').value + if potential == 'muffin_tin': + mapping = { + 'hedin_lundqvist_real': 'hdrel', + 'hedin_lundqvist_complex': 'hedin', + 'x_alpha_real': 'xalph', + 'dirac_hara_real': 'dhrel', + 'dirac_hara_complex': 'dhcmp' + } + self.phagen_parameters.potype = mapping[p.value] + elif potential == 'lmto': + self.phagen_parameters.potype = 'lmto' + + def bind_imaginery_part(self, p): + self.phagen_parameters.gamma = p.value + + def bind_lmax_mode(self, p): + mapping = { + 'imposed': 0, + 'max_ke': 1, + 'true_ke': 2 + } + self.phagen_parameters.lmax_mode = mapping[p.value] + + def bind_lmaxt(self, p): + self.phagen_parameters.lmaxt = p.value + + def bind_max_tl(self, p): + cluster = self.phagen_parameters.get_parameter('atoms').value + # issue a warning if a chemical symbol entered in max_tl is not + # a chemical symbol in the cluster + if isinstance(p.value, dict): + for symbol in list(p.value.keys()): + if symbol not in np.unique(cluster.get_chemical_symbols()): + LOGGER.warning('You provided a maximum tl value for ' + '\'%s\' atoms, but there is no such ' + 'chemical symbol in your cluster.', symbol) + +class SourceParameters(BaseParameters): + def __init__(self, global_parameters=None, phagen_parameters=None, spec_parameters=None): + parameters = ( + Parameter('energy', types=(list, tuple, int, float), + limits=(0, None), unit=UREG.eV, doc=textwrap.dedent(""" + The photon energy in eV. + + Common laboratories X-ray source Mg |kalpha| and Al |kalpha| lines are + defined in the :py:class:`msspec.misc.XRaySource` class. For example: + + .. highlight:: python + + :: + + >>> from msspec.calculator import MSSPEC + >>> calc = MSSPEC() + >>> calc.source_parameters.energy = XRaySource.MG_KALPHA + >>> print calc.source_parameters.energy + 1253.6 + + + """), + default=XRaySource.MG_KALPHA), + Parameter('theta', types=(int, float), limits=(-180., 180.), + unit=UREG.degree, default=-55., doc=textwrap.dedent(""" + The polar angle of the photon incidence (in degrees). Please refer to + :ref:`this figure ` for questions regarding the proper + orientation. + """)), + Parameter('phi', types=(int, float), limits=(0., 360.), + unit=UREG.degree, default=0., doc=textwrap.dedent(""" + The azimuthal angle of the photon incidence (in degrees). Please refer to + :ref:`this figure ` for questions regarding the proper + orientation. + """)), + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.global_parameters = global_parameters + self.phagen_parameters = phagen_parameters + self.spec_parameters = spec_parameters + self.freeze() + + def bind_energy(self, p): + spectro = self.global_parameters.spectroscopy + if spectro in ('PED',): + assert isinstance(p.value, (int, float)), ( + 'Only a single value for the light is allowed in ' + 'PhotoElectron Diffraction spectroscopy') + self.spec_parameters.ped_elum = float(p.value) + LOGGER.info('Incomming photon energy set to %s', p.value * p.unit) + else: + LOGGER.warning('Setting the source energy is pointless in %s ' + 'spectroscopy. Statement ignored.', spectro) + + def bind_theta(self, p): + spectro = self.global_parameters.spectroscopy + if spectro in ('PED', 'EXAFS', 'LEED'): + self.spec_parameters.ped_thlum = float(p.value) + self.spec_parameters.leed_thini = float(p.value) + self.spec_parameters.exafs_thlum = float(p.value) + LOGGER.info('Incomming photon beam theta angle set to %s', + p.value * p.unit) + else: + LOGGER.warning('Setting the source beam polar (theta) angle is ' + 'pointless in %s spectroscopy. Statement ignored.', + spectro) + + def bind_phi(self, p): + spectro = self.global_parameters.spectroscopy + if spectro in ('PED', 'EXAFS', 'LEED'): + self.spec_parameters.ped_philum = float(p.value) + self.spec_parameters.leed_phiini = float(p.value) + self.spec_parameters.exafs_philum = float(p.value) + LOGGER.info('Incomming photon beam theta angle set to %s', + p.value * p.unit) + else: + LOGGER.warning('Setting the source beam azimutal (phi) angle is ' + 'pointless in %s spectroscopy. Statement ignored.', + spectro) + +class DetectorParameters(BaseParameters): + def __init__(self, global_parameters, phagen_parameters, spec_parameters): + parameters = ( + Parameter('angular_acceptance', types=(int, float), + unit=UREG.degree, limits=(0., None), default=0., + doc=textwrap.dedent(""" + The angular acceptance of the detector in degrees used + when the *average_sampling* option is enabled below. + """)), + Parameter('average_sampling', types=(type(None), str), + allowed_values=(None, 'low', 'medium', 'high'), + default=None, doc=textwrap.dedent(""" + Used to averaged the signal over directions lying in the + cone of half-angle *angular_acceptance*. The number of + directions to take into account depends on the choosen + value: + + - **None**, for no averaging at all + - '**low**', to average over 5 directions + - '**medium**', to average over 13 directions + - '**high**', to average over 49 directions + """)), + Parameter('rotate', types=bool, default=False, doc=textwrap.dedent(""" + When False, the sample is rotated when doing a scan (the + usual way). Otherwise, the detector is rotated. + """)) + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.global_parameters = global_parameters + self.phagen_parameters = phagen_parameters + self.spec_parameters = spec_parameters + self.freeze() + + def bind_angular_acceptance(self, p): + spectro = self.global_parameters.spectroscopy + if spectro in ('PED', 'LEED', 'AED'): + self.spec_parameters.ped_accept = float(p.value) + self.spec_parameters.leed_accept = float(p.value) + self.spec_parameters.aed_accept = float(p.value) + LOGGER.info('Detector angular acceptance set to %s', p.value * p.unit) + else: + LOGGER.warning('Setting the detector angular acceptance is ignored ' + 'in %s spectroscopy.', spectro) + + def bind_average_sampling(self, p): + spectro = self.global_parameters.spectroscopy + if spectro in ('PED', 'LEED', 'AED'): + imoy = p.allowed_values.index(p.value) + self.spec_parameters.ped_imoy = imoy + self.spec_parameters.leed_imoy = imoy + self.spec_parameters.aed_imoy = imoy + LOGGER.info('Detector average sampling set to %s', p.value.upper()) + else: + LOGGER.warning('Setting the average sampling is ignored in %s ' + 'spectroscopy.', spectro) + + def bind_rotate(self, p): + spectro = self.global_parameters.spectroscopy + if spectro in ('PED', 'LEED', 'AED'): + imod = int(not p.value) + self.spec_parameters.ped_imod = imod + self.spec_parameters.leed_imod = imod + self.spec_parameters.aed_imod = imod + if imod == 0: + LOGGER.info('The DETECTOR will rotate') + else: + LOGGER.info('The SAMPLE will rotate') + else: + LOGGER.warning('Setting the detector ratation is ignored in %s ' + 'spectroscopy.', spectro) + +class ScanParameters(BaseParameters): + def __init__(self, global_parameters, phagen_parameters, spec_parameters): + parameters = ( + Parameter('type', allowed_values=('theta', 'phi', 'theta_phi', + 'energy', 'scatf'), + types=str, default='theta'), + Parameter('theta', types=(np.ndarray, list, tuple, int, float), + unit=UREG.degree, limits=(-90., 90.), + default=np.linspace(0., 88., 45)), + Parameter('phi', types=(np.ndarray, list, tuple, int, float), + unit=UREG.degree, limits=(0., 360.), + default=np.array([0.])), + Parameter('kinetic_energy', types=(list, tuple, int, float), + unit=UREG.eV, limits=(0., None), + default=200., doc=textwrap.dedent(""" + if given as a list or tuple: + * with 2 elements, 10 points of energy will be generated + with the first element as the starting energy and the + second element as the stopping energy. + * with 3 elements, the first element is the starting energy + the second one is the stopping energy and the last one is + the number of points. + + if given as a float or integer, there will be one point + for the kinetic energy. + """)), + Parameter('ke_array', types=np.ndarray, unit=UREG.eV, + default=np.array([200., ]), private=True) + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.phagen_parameters = phagen_parameters + self.spec_parameters = spec_parameters + self.global_parameters = global_parameters + + self.spec_parameters.extra_parameters['scan'] = self + self.freeze() + + def bind_type(self, p): + spectro = self.global_parameters.spectroscopy + calculation_parameters = self.spec_parameters.extra_parameters[ + 'calculation'] + + scantype = p.value + if spectro in ('EXAFS',): + LOGGER.warning('No scan type are allowed in %s spectroscopy. This ' + 'will be ignored.', spectro) + return + if spectro in ('AED',) and scantype == 'energy': + LOGGER.error('Energy scan is not compatible with %s ' + 'spectroscopy.', spectro) + raise ValueError + params = { + 'phi': (2, 0, 0, 0), + 'theta': (0, 2, 0, 0), + 'energy': (0, 0, 1, 0), + 'scatf': (0, 1, 0, 1), + 'theta_phi': (-1, 0, 0, 0)} + self.spec_parameters.ped_iphi = params[scantype][0] + self.spec_parameters.ped_itheta = params[scantype][1] + self.spec_parameters.ped_ie = params[scantype][2] + self.spec_parameters.ped_ifthet = params[scantype][3] + + self.spec_parameters.leed_iphi = params[scantype][0] + self.spec_parameters.leed_itheta = params[scantype][1] + self.spec_parameters.leed_ie = params[scantype][2] + self.spec_parameters.leed_ifthet = params[scantype][3] + + self.spec_parameters.aed_iphi = params[scantype][0] + self.spec_parameters.aed_itheta = params[scantype][1] + self.spec_parameters.aed_ifthet = params[scantype][3] + + if scantype == 'scatf': + self.spec_parameters.ped_theta0 = -360. + self.spec_parameters.ped_theta1 = 0. + self.spec_parameters.ped_ntheta = 577 + self.spec_parameters.ped_nfthet = 577 + + self.spec_parameters.leed_theta0 = -360. + self.spec_parameters.leed_theta1 = 0. + self.spec_parameters.leed_ntheta = 577 + self.spec_parameters.leed_nfthet = 577 + + self.spec_parameters.aed_theta0 = -360. + self.spec_parameters.aed_theta1 = 0. + self.spec_parameters.aed_ntheta = 577 + self.spec_parameters.aed_nfthet = 577 + + if scantype == "scatf": + calculation_parameters.set_parameter('basis_functions', + 'plane_wave', force=True) + else: + calculation_parameters.set_parameter('basis_functions', + 'spherical', force=True) + + LOGGER.info('\'%s\' scan type choosen.', p.value) + + def bind_theta(self, p): + spectro = self.global_parameters.spectroscopy + scantype = self.get_parameter('type').value + + if scantype == 'scatf': + comment = 'with the scattering factor scan type.' + if spectro == 'EXAFS': + comment = 'in EXAFS spetroscopy.' + if spectro in ('EXAFS',) or scantype in ('scatf',): + msg = 'Setting the theta angle is not possible %s' % comment + LOGGER.error('Incompatible options!') + raise ValueError(msg) + + # p._value = np.array(p.value, dtype=np.float).flatten() + arr = np.array(p.value, dtype=np.float).flatten() + + theta0 = arr[0] + theta1 = arr[-1] + ntheta = len(arr) + + self.spec_parameters.ped_theta0 = theta0 + self.spec_parameters.ped_theta1 = theta1 + self.spec_parameters.ped_ntheta = ntheta + + self.spec_parameters.leed_theta0 = theta0 + self.spec_parameters.leed_theta1 = theta1 + self.spec_parameters.leed_ntheta = ntheta + + self.spec_parameters.aed_theta0 = theta0 + self.spec_parameters.aed_theta1 = theta1 + self.spec_parameters.aed_ntheta = ntheta + + LOGGER.info('theta = %s (%d points)', arr * p.unit, len(arr)) + return arr + + def bind_phi(self, p): + spectro = self.global_parameters.spectroscopy + scantype = self.get_parameter('type').value + + if scantype == 'scatf': + comment = 'with scattering factor scan type.' + if spectro == 'EXAFS': + comment = 'in EXAFS spetroscopy.' + if spectro in ('EXAFS',) or scantype in ('scatf',): + msg = 'Setting the phi angle is not possible %s' % comment + LOGGER.error('Incompatible options') + raise ValueError(msg) + + arr = np.array(p.value, dtype=np.float).flatten() + + phi0 = arr[0] + phi1 = arr[-1] + nphi = len(arr) + + self.spec_parameters.ped_phi0 = phi0 + self.spec_parameters.ped_phi1 = phi1 + self.spec_parameters.ped_nphi = nphi + + self.spec_parameters.leed_phi0 = phi0 + self.spec_parameters.leed_phi1 = phi1 + self.spec_parameters.leed_nphi = nphi + + self.spec_parameters.aed_phi0 = phi0 + self.spec_parameters.aed_phi1 = phi1 + self.spec_parameters.aed_nphi = nphi + + LOGGER.info('phi = %s (%d points)', arr * p.unit, len(arr)) + return arr + + def bind_kinetic_energy(self, p): + npts = 10 + energies = [0, 0, npts] + if isinstance(p.value, (list, tuple, np.ndarray)): + assert len(p.value) <= 3, ( + 'kinetic_energy -- if given as a list -- must have at most ' + '3 elements, in which case:\n' + '* the first element is the starting energy,\n' + '* the second one is the stopping energy,\n' + '* and the last one is the number of points.\n' + 'If the last element is omitted, %s points are ' + 'assumed' % str(npts)) + energies[0] = float(p.value[0]) + energies[1] = float(p.value[0]) + if len(p.value) > 1: + energies[1] = float(p.value[1]) + if len(p.value) > 2: + energies[-1] = int(p.value[-1]) + else: + energies[0] = float(p.value) + energies[1] = float(p.value) + energies[2] = 1 + + ke_array_eV = np.linspace(*energies) + ke_array_ry = (ke_array_eV * p.unit).to('rydberg') + + emin = np.min(ke_array_ry) + emax = np.max(ke_array_ry) + npts = len(ke_array_ry) + + assert npts > 0, 'The number of energy points must be >= 1' + if npts == 1: + delta = 0.3 * UREG.rydberg + else: + delta = (emax - emin) / (npts - 1) + + self.phagen_parameters.emin = emin.magnitude + self.phagen_parameters.emax = emax.magnitude + self.phagen_parameters.delta = float(delta.magnitude) + + self.spec_parameters.ped_e0 = energies[0] + self.spec_parameters.ped_e1 = energies[1] + self.spec_parameters.ped_ne = energies[2] + + self.spec_parameters.eigval_ekini = energies[0] + self.spec_parameters.eigval_ekfin = energies[1] + self.spec_parameters.eigval_ne = energies[2] + + self.set_parameter('ke_array', ke_array_eV, force=True) + + LOGGER.info('Kinetic energy = %s (%d points)', ke_array_eV, npts) + +class CalculationParameters(BaseParameters): + def __init__(self, global_parameters, phagen_parameters, spec_parameters): + parameters = ( + Parameter('RA_cutoff', types=int, limits=(0, 8), default=1, + doc=textwrap.dedent(""" + The Rehr-Albers cut-off parameter which controls the degree of + sphericity introduced in the description of the basis functions + used to expand the wave function around each atomic center. + It is only meaningful for the series expansion algorithm. + Its value is limited to 8 but it is rarely necessary to go beyond + 2 or 3.""")), + Parameter('scattering_order', types=int, limits=(1, 10), default=3, + doc=textwrap.dedent(""" + The scattering order. Only meaningful for the 'expansion' algorithm. + Its value is limited to 10.""")), + Parameter('RA_cutoff_damping', types=int, limits=(0, None), + default=0, doc=textwrap.dedent(""" + The Rehr-Albers truncation order. If > 0, the *RA_cutoff* is + decreased by 1 every *i*\ :sup:`th` scatterer until 0, where + *i* = *RA_cutoff_damping*.""")), + Parameter('spin_flip', types=bool, default=False, + doc=textwrap.dedent(""" + This parameter tells if spin-flip is authorized or not in the + scattering process. + + :Note: + + This option works only if the spin polarization is + enabled in your calculator object (see spinpol_).""")), + Parameter('integrals', types=str, allowed_values=('all', + 'diagonal'), + default='all', doc=textwrap.dedent(""" + This option allows to take into account all four radial integrals + (R++, R+-, R-+ and R--) in the calculation or only the diagonal + radial integrals (R++ and R--) which are generally much larger. + + .. note:: + + This option works only if the spin polarization is + enabled in your calculator object. + + """)), + Parameter('path_filtering', types=(type(None), str, tuple, list), + allowed_values=(None, + 'forward_scattering', + 'backward_scattering', + 'distance_cutoff', + 'plane_wave_normal', + 'plane_wave_spin_averaged'), + default=None, doc=textwrap.dedent(""" + Used to activate some filters. It is possible to specify several + of them by grouping them in a tuple or a list. For example:: + + >>> my_filters = ('forward_scattering', 'backward_scattering') + >>> calc.calculation_parameters.path_filtering = my_filters + + """)), + Parameter('off_cone_events', types=int, limits=(0, None), default=1, + doc=textwrap.dedent(""" + Used in conjunction with the '*forward_scattering*' filter. + If the number of scattering processes outside the forward (or + backward) scattering cone is greater than this number, then the + path is rejected and its contribution to the scattering path + operator won’t be computed. + """)), + Parameter('scattering_order_cutoff', types=int, limits=(0, 10), + default=2, doc=textwrap.dedent(""" + Used in conjunction with the ‘*plane_wave_normal*’ filter. It states + to activate the plane wave approximation (which is fast but + less accurate) to compute the contribution when the scattering order + is greater than this value.""")), + + Parameter('distance', types=(int, float), limits=(0, None), + unit=UREG.angstroms, default=10., doc=textwrap.dedent(""" + Used with the '*distance_cut_off*' filter. Paths whose length is + larger than this value are simply rejected.""")), + Parameter('vibrational_damping', types=(type(None), str), + allowed_values=(None, 'debye_waller', 'averaged_tl'), + default='debye_waller', doc=textwrap.dedent(""" + Tells how to compute the effect of atomic vibrations. It can be: + + - '**debye_waller**' for using the Debye Waller model. + - '**averaged_tl**' to use the more correct averaging over T-matrix elements.""")), + Parameter('temperature', types=(int, float), limits=(0, None), + unit=UREG.degK, default=293., doc=textwrap.dedent(""" + The temperature of the cluster. Used when *use_debye_model* = True + """)), + Parameter('debye_temperature', types=(int, float), limits=(0, None), + unit=UREG.degK, default=420., doc=textwrap.dedent(""" + The Debye temperature used for the calculation of the mean square + displacements if *use_debye_model* = True""")), + Parameter('use_debye_model', types=bool, default=False, + doc=textwrap.dedent(""" + No matter the way you compute the effect of atomic vibrations, + you need the mean square displacements of atoms. It can be computed + internally following the Debye model if you set this option to True. + """)), + Parameter('vibration_scaling', types=(int, float), + limits=(0., None), default=1.2, doc=textwrap.dedent(""" + Used to simulate the fact that surface atoms vibrate more than + bulk ones. It is a factor applied to the mean square displacements. + """)), + Parameter('basis_functions', types=str, allowed_values=( + 'plane_wave', 'spherical'), default='spherical', private=True), + Parameter('cutoff_factor', types=(int, float), + limits=(1e-4, 999.9999), default=0.01, private=True), + Parameter('mean_free_path', types=(int, float, str), + default='SeahDench', allowed_values=('mono', 'SeahDench'), + doc=textwrap.dedent(""" + The electron mean free path value. You can either: + - Enter a value (in Angströms), in this case any value <=0 will disable the damping + - Enter the keyword 'mono' to use a formula valid only for monoelemental samples + - Enter the keyword 'SeahDench' to use the Seah and Dench formula. + + .. note:: + + The mean free path is only taken into account when the input T-matrix corresponds + to a real potential as, when the potential is complex, this damping is taken care + of by the imaginery part othe potential. + + """)), + + ) + BaseParameters.__init__(self) + self.add_parameters(*parameters) + self.global_parameters = global_parameters + self.phagen_parameters = phagen_parameters + self.spec_parameters = spec_parameters + self.spec_parameters.extra_parameters['calculation'] = self + self.freeze() + + def bind_RA_cutoff(self, p): + self.spec_parameters.calc_no = p.value + LOGGER.info('Rehr-Albers cutoff parameter set to %s', p.value) + + def bind_scattering_order(self, p): + self.spec_parameters.calc_ndif = p.value + LOGGER.info('Scattering order set to %s', p.value) + + def bind_RA_cutoff_damping(self, p): + self.spec_parameters.calc_ino = p.value + LOGGER.info('Rehr-Albers cutoff damping set to %s', p.value) + + def bind_basis_functions(self, p): + if p.value == 'plane_wave': + ispher = 0 + elif p.value == 'spherical': + ispher = 1 + self.spec_parameters.calc_ispher = ispher + LOGGER.info('Type of basis functions: \'%s\'', p.value) + + def bind_spin_flip(self, p): + if self.global_parameters.spinpol is False: + err_msg = ( + "'{}' is ignored since the 'spinpol' global parameter is set " + "to False. Enable spin polarization in the constructor of " + "your Calculator if you want to use this option." + ).format(p.name) + LOGGER.error("Incompatible options!") + raise ValueError(err_msg) + isflip = int(p.value) + self.spec_parameters.calc_isflip = isflip + LOGGER.info('Spin-flip set to %s', p.value) + + def bind_integrals(self, p): + if self.global_parameters.spinpol is False: + err_msg = ( + "'{}' is ignored since the 'spinpol' global parameter is set " + "to False. Enable spin polarization in the constructor of " + "your Calculator if you want to use this option." + ).format(p.name) + LOGGER.error("Incompatible options!") + raise ValueError(err_msg) + irdia = 0 if p.value == 'all' else 1 + self.spec_parameters.calc_irdia = irdia + LOGGER.info('Radial integrals taken into account: %s', p.value) + + def bind_path_filtering(self, p): + ifwd = ipw = ilength = 0 + ipp = 1 + if ('plane_wave_spin_averaged' in p.value and 'plane_wave_normal' in + p.value): + err_msg = ( + "Only one plane wave filter (either 'plane_wave_normal' or " + "'plane_wave_spin_averaged') can be used at a time (along " + "with other filters if needed).") + LOGGER.error('Incompatible options!') + raise ValueError(err_msg) + + if p.value != None: + if 'forward_scattering' in p.value: + ifwd = 1 + if 'backward_scattering' in p.value: + ifwd = 1 + if 'distance_cutoff' in p.value: + ilength = 1 + if 'plane_wave_normal' in p.value: + ipw = 1 + ipp = 1 + if 'plane_wave_spin_averaged' in p.value: + ipw = 1 + ipp = 2 + + self.spec_parameters.calc_ifwd = ifwd + self.spec_parameters.calc_ipw = ipw + self.spec_parameters.calc_ilength = ilength + self.spec_parameters.calc_ipp = ipp + LOGGER.info('Filters activated: %s', p.value) + + def bind_off_cone_events(self, p): + self.spec_parameters.calc_nthout = p.value + LOGGER.info('Off cone events set to %s', p.value) + path_filtering = self.get_parameter('path_filtering').value + f = 'forward_scattering' + if path_filtering is not None and f not in path_filtering: + LOGGER.warning("'%s' option set but ignored since the " + "'%s' filter' is not activated", + p.name, f) + + def bind_scattering_order_cutoff(self, p): + self.spec_parameters.calc_ncut = p.value + LOGGER.info('Scattering order cutoff set to %s', p.value) + path_filtering = self.get_parameter('path_filtering').value + f = 'plane_wave_normal' + if path_filtering is not None and f not in path_filtering: + LOGGER.warning("'%s' option set but ignored since the " + "'%s' filter' is not activated", + p.name, f) + + def bind_cutoff_factor(self, p): + self.spec_parameters.calc_pctint = float(p.value) + LOGGER.info('Cutoff factor set tp %s', p.value) + + def bind_distance(self, p): + self.spec_parameters.calc_rlength = float(p.value) + LOGGER.info('Distance cutoff set to %s', p.value * p.unit) + path_filtering = self.get_parameter('path_filtering').value + f = 'distance_cutoff' + if path_filtering is not None and f not in path_filtering: + LOGGER.warning("'%s' option set but ignored since the " + "'%s' filter' is not activated", + p.name, f) + + def bind_vibrational_damping(self, p): + #self.spec_parameters.calc_ispeed = 1 + if p.value is None: + LOGGER.info('Vibrational damping disabled') + # no spec parameters updated here since it is done + # when writing the data input file by setting the + # sample temperature to 0K and using the debye_model + return + if p.value == 'debye_waller': + self.spec_parameters.calc_idwsph = 0 + elif p.value == 'averaged_tl': + self.spec_parameters.calc_idwsph = 1 + LOGGER.info('Vibrational damping activated with \'%s\' model', p.value) + + def bind_temperature(self, p): + self.spec_parameters.calc_t = float(p.value) + LOGGER.info('Sample temperature set to %s', p.value * p.unit) + if not self.get_parameter('use_debye_model').value: + LOGGER.warning("The sample temperature was set, but will be " + "ignored since 'use_debye_model' parameter is " + "False.") + + def bind_debye_temperature(self, p): + self.spec_parameters.calc_td = float(p.value) + LOGGER.info('Sample Debye temperature set to %s', p.value * p.unit) + if not self.get_parameter('use_debye_model').value: + LOGGER.warning("The sample Debye temperature was set, but will be " + "ignored since 'use_debye_model' parameter is " + "False.") + + def bind_use_debye_model(self, p): + if p.value: + self.spec_parameters.calc_idcm = 1 + else: + self.spec_parameters.calc_idcm = 0 + LOGGER.info('use of the Debye model for mean square displacements: %s', + p.value) + if self.get_parameter('vibrational_damping').value is None: + LOGGER.warning("'use_debye_model' parameter was set but will be " + "ignored as long as vibrational_damping is " + "disbaled.") + + def bind_vibration_scaling(self, p): + self.spec_parameters.calc_rsj = float(p.value) + LOGGER.info('Vibration scaling set to: %s', p.value) + + def bind_mean_free_path(self, p): + if isinstance(p.value, str): + if p.value == 'mono': + self.spec_parameters.calc_ilpm = 1 + elif p.value == 'SeahDench': + self.spec_parameters.calc_ilpm = 2 + else: + if p.value <= 0: + self.spec_parameters.calc_ilpm = -1 + else: + self.spec_parameters.calc_ilpm = 0 + self.spec_parameters.calc_xlpm0 = float(p.value) + LOGGER.info('Mean free path set to: %s', str(p.value)) + + +class PEDParameters(BaseParameters): + def __init__(self, phagen_parameters, spec_parameters): + parameters = ( + Parameter('level', types=str, pattern=r'\d+[spdfgSPDFG](\d/2)?$', + default='1s', doc=textwrap.dedent(""" + 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_so = somap[p.value] + + +class EIGParameters(BaseParameters): + def __init__(self, phagen_parameters, spec_parameters): + parameters = ( + Parameter('level', types=str, pattern=r'\d+[spdfgSPDFG](\d/2)?$', + default='1s', doc=textwrap.dedent(""" + 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), + Parameter('kernel_matrix_spectrum', types=(bool,), default=False, doc=textwrap.dedent(""" + Whether to output the kernel matrix spectrum for each energy point. + """)), + ) + 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 diff --git a/src/msspec/phagen/__init__.py b/src/msspec/phagen/__init__.py new file mode 100644 index 0000000..e69de29 diff --git a/src/msspec/phagen/fortran/Makefile b/src/msspec/phagen/fortran/Makefile new file mode 100644 index 0000000..0af3e19 --- /dev/null +++ b/src/msspec/phagen/fortran/Makefile @@ -0,0 +1,28 @@ +COMP=gfortran +OPTS := -g -Wall -Wextra -Warray-temporaries -Wconversion -fbacktrace -ffree-line-length-0 -fcheck=all -ffpe-trap=zero,overflow,underflow -finit-real=nan +OPTs := + +objects_src := phagen_scf.f +objects := $(patsubst %.f,%.o, $(objects_src)) + + +.PHONY: clean pybinding + +pybinding: libphagen.so + +libphagen.so: $(objects) main.f + @echo "building Python binding..." + @f2py3 -I. $(objects) -c -m libphagen main.f + #f2py3 -I. $(objects) --debug-capi --debug -c -m libphagen main.f + @cp libphagen.cpython*.so ../ + @mv libphagen.cpython*.so libphagen.so + +$(objects): $(objects_src) + @echo "compiling subroutines and functions..." + @$(COMP) $(OPTS) -fPIC -c $^ + +clean: + @echo "cleaning..." + rm -rf *.so *.o *.mod + rm -rf ../*.so + diff --git a/src/msspec/phagen/fortran/main.f b/src/msspec/phagen/fortran/main.f new file mode 100644 index 0000000..efa60f0 --- /dev/null +++ b/src/msspec/phagen/fortran/main.f @@ -0,0 +1,3 @@ + SUBROUTINE MAIN() + CALL PHAGEN() + END SUBROUTINE MAIN diff --git a/src/msspec/phagen/fortran/msxas3.inc b/src/msspec/phagen/fortran/msxas3.inc new file mode 100644 index 0000000..849823d --- /dev/null +++ b/src/msspec/phagen/fortran/msxas3.inc @@ -0,0 +1,69 @@ +c.. dimensions for the program + integer ua_ + parameter ( nat_ = 1550, + $ ua_ = 1550, + $ neq_ = 48 ) +C +C where : +c +c nat_ maximum number of atoms expected in any +c molecule of interest (including an outer +c sphere). +c +c ua_ maximum number of nda's (unique, or +c symmetry-distinct atoms) expected in any +c molecule (including an outer sphere). +c +c neq_ maximum number of atoms expected in +c any symmetry-equivalent set (including +c the nda of the set). +c +c +c +c................................................................... +c cont and cont_sub source program dimensioning +c................................................................... +c +c + integer f_, rdx_, nef_ +c + parameter ( rdx_ = 1500, + $ lmax_ = 60, + $ npss = lmax_ + 2, + $ f_ = 2*npss + 1, + $ nef_ = 200, + $ lexp_ = 10, + $ nep_ = 1000 ) +c +c where : +c +c rdx_ number of points of the linear-log mesh +c +c lmax_ maximum l-value used on any atomic sphere. +c sphere). +c +c nef_ effective number of atoms used in the transition +c matrix elements of eels. Put = 1 if not doing a eels +c calculation +c +c lexp_ lmax in the expansion of coulomb interaction plus one! temporary +c +c nep_ the maximum number of energy points for which phase +c shifts will be computed. +c +c....................................................................... +c multiple scattering paths, xn programs dimensioning +c....................................................................... +c +c + parameter (natoms=nat_) +c +c +c where: +c +c natoms = number of centers in the system +c +c +c......................................................................... +c +c.......................................................................... diff --git a/src/msspec/phagen/fortran/msxasc3.inc b/src/msspec/phagen/fortran/msxasc3.inc new file mode 100644 index 0000000..72dce0b --- /dev/null +++ b/src/msspec/phagen/fortran/msxasc3.inc @@ -0,0 +1,27 @@ + logical vinput + character*5 potype + character*1 optrsh + character*2 edge,charelx,edge1,edge2,potgen,relc + character*3 calctype,expmode,eikappr,enunit + character*4 coor + character*6 norman + character*7 ionzst + integer absorber,hole,l2h,hole1,hole2 + dimension nz(natoms) + dimension c(natoms,3), rad(natoms), redf(natoms) + dimension neqat(natoms) + dimension nk0(0:lmax_) +c.....Warning: when reordering common/options/, reorder also the same common in +c.....subroutine inpot + common/options/rsh,ovlpfac,vc0,rs0,vinput,absorber,hole,mode, + & ionzst,potype,norman,coor,charelx,edge,potgen,lmax_mode, + & lmaxt,relc,eikappr,optrsh + common/atoms/c,rad,redf,charge_ion(100),nat,nz,neqat +c common/azimuth/lin,lmax + common/auger/calctype,expmode,edge1,edge2 + common/auger1/lin1,lin2,hole1,hole2,l2h + common/funit/idat,iwr,iphas,iedl0,iwf + common/constant/antoau,ev,pi,pi4,pif,zero,thresh,nk0 +c.................................................................... +c rpot = if real potential is to be used +c..................................................................... diff --git a/src/msspec/phagen/fortran/phagen_scf.f b/src/msspec/phagen/fortran/phagen_scf.f new file mode 100644 index 0000000..3abcb83 --- /dev/null +++ b/src/msspec/phagen/fortran/phagen_scf.f @@ -0,0 +1,14917 @@ + subroutine phagen() +c program phagen + +c .................................... +C .. .. +c .. Generates atomic phase shifts .. +c .. for inequivalent atoms in a .. +c .. given cluster. Prototypical .. +c .. atoms selected automatically. .. +c .. Muffin-tin radii and type of .. +c .. final state potential selected .. +c .. via input option .. +C .. .. +c .. By C.R. Natoli 15/10/93 .. +C .. .. +c .. This version can handle ES .. +c .. ES = Empty Spheres 28/09/2007 .. +C .. .. +C .. Scalar-relativistic version .. +C .. with spin-orbit selection .. +C .. by C.R. Natoli 9 june 2011 .. +C .. .. +C .................................... +c .................................... +C +c .. INCOMING WAVE BOUNDARY CONDITIONS +c +C .................................... +C +C bug corrected in subroutine +C GET_CORE_STATE +C (FDP 18th May 2006) +C +C bug corrected in subroutine +C ALPHA0 (DS : 7th May 2007) +C 2nd dimension r: 150 ---> UA_ +C +C LEED case (calctype = 'led') +C added (DS : 30th May 2007). +C +C bug corrected in subroutine +C SETEQS (DS+CRN 30th May 2007) : +C z_shift=5.0 and i_z_shift=5 +C instead of 0.0 and 0. +C +C bug corrected in subroutines +C MOLDAT,GRPNEI,WRIDAT : +C NEIMAX set to nat_ instead +C of 350 in PARAMETER statement +C (FDP+DS 4th June 2007) +C +C all error output redirected to +C unit 6 (DS 4th March 2008). +C +C modified to handle high Z elements +C (CRN : september 2008) +C +C cleaned : DS 17th November 2008 +C +C modified to impose lmaxt externally +C (CRN : july 2009) +C +C modified to include quadrupole +C radial matrix elements +C (CRN : june 2012) +C +C File formats for radial integrals +C modified (DS 8th january 2013) +C +C modified to introduce t-matrix +C calculation in the eikonal approximation +C (CRN : march 2013) +C +C bug corrected in routine linlogmesh: rhon ---> r_sub +C (CRN : april 2013) +C +C modified to calculate tmatrix, radial integrals +C and atomic cross sections on linearlog mesh +C (CRN: september 2012 and april 2013) +C +C bug corrected in routine pgenll2: complex*16 dnm. +C v potential converted to complex*16 in routines +C pgenll1m and pgenll2 +C (CRN: april 2013) +C +C bug corrected in the calculation of the total mfp = amfpt +C (CRN: april 2014) +C +C modified to calculate eels regular radial matrix elements +C (CRN: november 2014) +C +C modified to convert energy input data in data3.ms to Ryd +C (CRN: november 2014) +C +C modified to calculate eels and xas/rexs irregular radial matrix elements +C (CRN: juin 2015) +C +C modified to calculate e2e regular radial matrix elements +C (CRN: december 2015) modification in subroutine smtxllm +C statement 13824 +C +C bug corrected in subroutine calc_edge (xion = 0 for ground state) +C (CNR: June 2017) + + implicit real*8 (a-h,o-z) +c + include 'msxas3.inc' + include 'msxasc3.inc' +c +c.. constants +c + antoau = 0.52917715d0 + pi = 3.141592653589793d0 + ev = 13.6058d0 + zero = 0.d0 +c +c.. threshold for linearity +c + thresh = 1.d-4 +c +c.. fortran io units +c + idat = 5 + iwr = 6 + +c iwr = 16 + iwf=32 + iphas = 30 + iedl0 = 31 + iof = 17 +c....................................................... +c open (iwr,file='results.dat',form='formatted',status='unknown') + write(iwr,1000) +c... +c open (idat,file='data/auger.ms',status='old') +c open (iphas,file='phases.dat',status='unknown') +c if (calctype.eq.'xpd') then + call system('mkdir -p div/wf') + call system('mkdir -p plot') + call system('mkdir -p tl') +C!!!! INPUT FILE TO LOAD + open (idat,file='../input/input.ms',status='old') +C!!!! + open (iphas,file='div/phases.dat',form='formatted', + 1 status='unknown') + open (iedl0,file='div/exdl0.dat',form='unformatted', + 1 status='unknown') + open (iof,file='div/inf.xas',form='unformatted',status='unknown') +c open (iwr,file='phagen_3.lis',status='unknown') + + open (unit=21,form='unformatted',status='scratch') + open (60,file='div/file060.dat',form='formatted',status='unknown') + open (50,file='div/filerme.dat',form='formatted', + 1 status='unknown') +c open (56,file='div/eelsrme.dat',form='formatted', +c 1 status='unknown') + open (unit=13,file='div/filepot.dat',form='formatted', + 1 status='unknown') + open (unit=14,file='div/filesym.dat',form='formatted', + 1 status='unknown') + open(unit=11,file='div/fort.11',status='unknown') +c open(unit=56,file='div/nchannels.dat',status='unknown') + open(unit=32,file='div/wf/wf1.dat',status='unknown') + open(unit=33,file='div/wf/wf2.dat',status='unknown') + open(unit=66,file='div/file066',status='unknown') +c open(unit=15,file='div/vrel.dat',status='unknown') !in sub vrel +c open(unit=34,file='wf3.dat',status='unknown') + open(unit=70,file='div/tl-nr.dat',status='unknown') + open(unit=71,file='div/phases-nr.dat',status='unknown') +c + open(unit=80,file='div/tl-sr.dat',status='unknown') + open(unit=81,file='div/phases-sr.dat',status='unknown') +c + open(unit=90,file='div/tl-so.dat',status='unknown') + open(unit=91,file='div/phases-so.dat',status='unknown') +C +C Storage of old t_l calculation (subroutine smtx) for reference +C + open(unit=95,file='div/tl_ref.dat',status='unknown') +c + open(unit=98,file='div/cshsm.dat',status='unknown') +c + open(unit=99,file='div/csllm.dat',status='unknown') +c open(unit=69,file='check.log',status='unknown') +c else + +c open(iphas,file='phasesaed.dat',form='formatted',status='unknown' +c open (iwf,file='wfaed.dat',form='formatted',status='unknown') +c open(iedl0,file='exdl0aed.dat',form='unformatted', +c * status='unknown') +c open (iof,file='infaed.xas',form='unformatted',status='unknown') + + +c open (iwr,file='phagen_12aed.lis',status='unknown') +c write(iwr,*)'ciao' + +c open (unit=21,form='unformatted',status='scratch') +c open (60,file='file060aed.dat',form='formatted',status='unknown') +c open (50,file='fileatcsaed.dat',form='formatted',status='unknown' +c open (unit=13,file='filepotaed.dat',form='formatted', +c 1 status='unknown') +c open (unit=14,file='filesymaed.dat',form='formatted', +c 1 status='unknown') +c open(unit=11,file='fortaed.11',status='unknown') +c open(unit=32,file='wf1aed.dat',status='unknown') +c open(unit=33,file='wf2aed.dat',status='unknown') +c open(unit=66,file='fortaed.66',status='unknown') +c open(unit=34,file='wf3aed.dat',status='unknown') +c open(unit=35,file='tlaedmio3.dat',status='unknown') +c open(unit=55,file='radaedmio3.dat',status='unknown') + +c endif +c + rewind idat + rewind iwf + rewind iphas + rewind iedl0 + rewind iof +c +c read control cards +c + call inctrl +c +c read title cards +c + call intit(iof) +c +c read atomic coordinates cards (internal or cartesian) +c + call incoor +c +c compute atomic phase shifts if required +c + call calphas +c +c normal end +c + write(iwr,1100) +c +c.. +c close(69) + close(70) + close(71) + close(80) + close(81) + close(90) + close(91) + close(21) + close(60) + close(13) + close(14) + close(15) + close(7) + close(50) + close(56) + close(35) + close(iwf) + close(iphas) + close(55) +c + 1000 format(1x,65('_'),//,31x,'PHAGEN',/,1x,65('_'),/) + 1100 format(//,15x,' ** phagen terminated normally ** ',//) +c + end +c + subroutine inctrl + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + real*4 emin,emax,delta,cip,gamma,eftri,db + common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c + common/typot/ ipot +c +c I define the shells and orbitals of the primary core hole, and the +c two holes in the final state: +c + character shell,shell1,shell2,orbital1,orbital,orbital2 +c................................................................ + namelist/job/edge,edge1,edge2,l2h,potype,norman,absorber,coor, + $ emin,emax,delta,gamma,eftri,cip,vc0,rs0,vinput,eikappr,rsh,db, + $ lmaxt,ovlpfac,ionzst,charelx,calctype,potgen,lmax_mode,relc, + $ einc,esct,scangl,optrsh,enunit,lambda,expmode +c +c initialize namelist +c + vinput = .false. + potype='hedin' + potgen='in' + cip=0.0 + relc='nr' + eikappr=' no' + coor='angs' + edge='k' + edge1='k' + edge2='k' + lmaxt=60 + lmax_mode=2 + l2h=0 + absorber = 1 + charelx = 'ex' + norman = 'stdcrm' + ovlpfac=0.d0 + ionzst='neutral' +c mode = 0 + calctype='xpd' + expmode='cis' + optrsh='n' + enunit='Ryd' +c + vc0 = -0.7d0 + rs0 = 3.d0 +c + emin = 0.5 + emax = 40.0 + delta= 0.05 + gamma= 0.0 + eftri= 0.0 + rsh = 0.0d0 !used as a flag; set below to default in au + db = 0.01 +c +c data initialization for calctype='els' or 'e2e' +c if(calctype.eq.'els'.or.calctype.eq.'e2e') then +c + einc= 1200.0 + esct= 1000.0 + scangl= 7.0/180.0*3.1415926 + lambda = 0.0 !used as a flag; set below to default in au +c endif +c +c.....definition of lmax_mode: +c..... lmax_mode = 0: lmaxn(na)=lmax_, independent of energy and atom number +c..... lmax_mode = 1: lmaxn(na)= km*rs(na)+1, where km=(emax)^{1/2} +c..... lmax_mode = 2: lmaxn(na)= ke*rs(na)+1, where ke=(e)^{1/2}, where +c..... e is the running energy +c +c.. read control cards in namelist &job +c + read(idat,job) + read(idat,*) +c +c.....convert lengths in au if coor='angs'. Coordinates will be converted +c in subroutine inoor + if(coor.eq.'angs'.and.lambda.ne.0) then + lambda = lambda/real(antoau) + else + lambda = 20.0 ! in au corresponding to kappa = 0.05 (see subroutine cont) + endif +c + if(coor.eq.'angs'.and.rsh.ne.0) then + rsh = rsh/antoau + else + rsh = 1.0d0 ! in au + endif +c.....convert all energies to Ryd (when they are inputed in eV) +c + if(enunit.eq.' ev') then +c vc0 = vc0/ev +c + cip = cip/real(ev) + emin = emin/real(ev) + emax = emax/real(ev) + delta= delta/real(ev) + gamma= gamma/real(ev) + eftri= eftri/real(ev) + einc= einc/real(ev) + esct= esct/real(ev) + endif +c + if(lmax_mode.gt.2) then + write(iwr,*) 'lmax_mode should be less than 3' + call exit + endif +c + if(calctype.eq.'els') then + lmax_mode = 2 + einl = dble(einc - esct - cip) + if(cip.ne.0.0.and.einl.lt.0.0d0) then + write(6,*)' unable to excite chosen edge:', + & ' einc - esct - cip less than zero =', einl + call exit + endif + endif +c + if(calctype.eq.'led') charelx = 'gs' + if ((calctype.eq.'xpd').or.(calctype.eq.'led').or. + & (calctype.eq.'els')) then +c + write(iwr,1000) calctype + write(iwr,1001) + if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex'.or.calctype.eq.'els') write(iwr,1005)edge + write(iwr,1010)potype,norman,absorber + write(iwr,1015)coor,emin,emax + write(iwr,1020)delta,gamma,eftri +c write(iwr,1025)cip,lmax + write(iwr,1038) ionzst +c if (mode.eq.0) write(iwr,1036) + if (potgen.eq.'in') write(iwr,1036) +c if (mode.eq.1) write(iwr,1037) + if (potgen.eq.'ex') write(iwr,1037) + 1000 format(' parameters for this ',a3,' calculation:') + 1001 format(1x,65('-')) + 1005 format(2x,'edge= ',a2) + 1010 format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2) + 1015 format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ', + $ f7.2,' Ry') + 1020 format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2, + $ 2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry') + 1025 format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2) + 1036 format(2x,'final state potential generated internally') + 1037 format(2x,'final state potential read in from extnl file') + 1038 format(2x,'ionization state : ',a7) +c + else +c + write(iwr,10001) calctype + write(iwr,10011) + write(iwr,10051)edge,edge1,edge2 + write(iwr,10101)potype,norman,absorber + write(iwr,10151)coor,emin,emax + write(iwr,10201)delta,gamma,eftri +c write(iwr,10251)cip,lmax + write(iwr,10381) ionzst +c if (mode.eq.0) write(iwa,10361) +c if (mode.eq.1) write(iwa,10371) +10001 format(' parameters for this 'a3,' calculation:') +10011 format(52('-')) +10051 format(2x,'edge= ',a2,2x,'edge1= ',a2,2x,'edge2= ',a2) +10101 format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2) +10151 format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ', + $ f7.2,' Ry') +10201 format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2, + $ 2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry') +10251 format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2) +10381 format(2x,'ionization state :',a7) +c + end if +c +c......check number of energy points +c + kxe = nint((emax-emin)/delta + 1.) + if(kxe.gt.nep_)then + write(6,731) kxe +731 format(//, + & ' increase the dummy dimensioning variable, nep_. ', + & /,' it should be at least equal to: ', i5,/) + call exit + end if +c +c.. set other options and seek for errors +c + ierror=0 +c +c potgen determines whether the potential is generated internally +c by the present program or read in externally +c potype determines which which kind of exchange-correlation potential +c is used +c mode is 0 if the potential is to be computed and 1 if the +c potential is to be read +c iexcpot is defined after the potential type according to +c the values found below +c + mode = 0 + if (potgen.eq.'ex') mode=1 +c + iexcpot = 0 + ipot = 0 +c + if(potype.eq.'xalph')then + iexcpot=1 + else + if(potype.eq.'hedin')then + ipot = 1 + iexcpot=5 + else + if(potype.eq.'dhrel')then + iexcpot=2 + else + if(potype.eq.'dhcmp')then + ipot = 1 + iexcpot=4 + else + if(potype.eq.'hdrel')then + iexcpot=3 + else + if(potype.eq.' lmto') then + iexcpot=6 + else + ierror=1 + endif + endif + endif + endif + endif + endif +c + shell=edge(1:1) + orbital=edge(2:2) +c + if(shell.eq.'k')then + lin=0 + hole=1 + else + if(shell.eq.'l')then + if(orbital.eq.'1') then + lin=0 + hole=2 + else + if(orbital.eq.'2')then + lin=1 + hole=3 + else + if(orbital.eq.'3')then + lin=1 + hole=4 + else + ierror=1 + endif + endif + endif +c + else + if(shell.eq.'m')then + if(orbital.eq.'1')then + lin=0 + hole=5 + else + if(orbital.eq.'2')then + lin=1 + hole=6 + else + if(orbital.eq.'3')then + lin=1 + hole=7 + else + if(orbital.eq.'4')then + lin= 2 + hole=8 + else + if(orbital.eq.'5')then + lin=2 + hole=9 + else + ierror=1 + endif + endif + endif + endif + endif +c + else +c + if(shell.eq.'n')then + if(orbital.eq.'1')then + lin=0 + hole=10 + else + if(orbital.eq.'2')then + lin=1 + hole=11 + else + if(orbital.eq.'3')then + lin=1 + hole=12 + else + if(orbital.eq.'4')then + lin= 2 + hole=13 + else + if(orbital.eq.'5')then + lin=2 + hole=14 + else + if(orbital.eq.'6')then + lin=3 + hole=15 + else + if(orbital.eq.'7')then + lin=3 + hole=16 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + else +c + if(shell.eq.'o')then + if(orbital.eq.'1')then + lin=0 + hole=17 + else + if(orbital.eq.'2')then + lin=1 + hole=18 + else + if(orbital.eq.'3')then + lin=1 + hole=19 + else + if(orbital.eq.'4')then + lin= 2 + hole=20 + else + if(orbital.eq.'5')then + lin=2 + hole=21 + else + if(orbital.eq.'6')then + lin=3 + hole=22 + else + if(orbital.eq.'7')then + lin=3 + hole=23 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + endif + endif + endif + endif + endif +c + + if (calctype.eq.'aed') then +c +c We take the substrings of the final holes in the Auger decay +c + shell1=edge1(1:1) + orbital1=edge1(2:2) + shell2=edge2(1:1) + orbital2=edge2(2:2) +c + if(shell1.eq.'k')then + lin1=0 + hole1=1 + else + if(shell1.eq.'l')then + if(orbital1.eq.'1') then + lin1=0 + hole1=2 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=3 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=4 + else + ierror=1 + endif + endif + endif +c + else +c + if(shell1.eq.'m')then + if(orbital1.eq.'1')then + lin1=0 + hole1=5 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=6 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=7 + else + if(orbital1.eq.'4')then + lin1= 2 + hole1=8 + else + if(orbital1.eq.'5')then + lin1=2 + hole1=9 + else + ierror=1 + endif + endif + endif + endif + endif +c + else +c + if(shell1.eq.'n')then + if(orbital1.eq.'1')then + lin1=0 + hole1=10 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=11 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=12 + else + if(orbital1.eq.'4')then + lin1= 2 + hole1=13 + else + if(orbital1.eq.'5')then + lin1=2 + hole1=14 + else + if(orbital1.eq.'6')then + lin1=3 + hole1=15 + else + if(orbital1.eq.'7')then + lin1=3 + hole1=16 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + else +c + if(shell1.eq.'o')then + if(orbital1.eq.'1')then + lin1=0 + hole1=17 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=18 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=19 + else + if(orbital1.eq.'4')then + lin1= 2 + hole1=20 + else + if(orbital1.eq.'5')then + lin1=2 + hole1=21 + else + if(orbital1.eq.'6')then + lin1=3 + hole1=22 + else + if(orbital1.eq.'7')then + lin1=3 + hole1=23 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + endif + endif + endif + endif + endif +c + if(shell2.eq.'k')then +c + lin2=0 + hole2=1 +c + else +c + if(shell2.eq.'l')then + if(orbital2.eq.'1') then + lin2=0 + hole2=2 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=3 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=4 + else + ierror=1 + endif + endif + endif +c + else +c + if(shell2.eq.'m')then + if(orbital2.eq.'1')then + lin2=0 + hole2=5 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=6 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=7 + else + if(orbital2.eq.'4')then + lin2= 2 + hole2=8 + else + if(orbital2.eq.'5')then + lin2=2 + hole2=9 + else + ierror=1 + endif + endif + endif + endif + endif +c + else +c + if(shell2.eq.'n')then + if(orbital2.eq.'1')then + lin2=0 + hole2=10 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=11 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=12 + else + if(orbital2.eq.'4')then + lin2= 2 + hole2=13 + else + if(orbital2.eq.'5')then + lin2=2 + hole2=14 + else + if(orbital2.eq.'6')then + lin2=3 + hole2=15 + else + if(orbital2.eq.'7')then + lin2=3 + hole2=16 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + else +c + if(shell2.eq.'o')then + if(orbital2.eq.'1')then + lin2=0 + hole2=17 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=18 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=19 + else + if(orbital2.eq.'4')then + lin2= 2 + hole2=20 + else + if(orbital2.eq.'5')then + lin2=2 + hole2=21 + else + if(orbital2.eq.'6')then + lin2=3 + hole2=22 + else + if(orbital2.eq.'7')then + lin2=3 + hole2=23 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + endif + endif + endif + endif + endif +c + endif +c +c.. stop if errors occurred +c + if(ierror.eq.0)goto 10 +c + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** error in inctrl **' + write(iwr,*)' -> check namelist values' + write(iwr,*) ' ' + write(iwr,*) ' ' +c + stop + 10 continue +c +c.. check dimensions for lmax +c + if(lmaxt.gt.lmax_) then + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** error in inctrl **' + write(iwr,*)' -> check dimensions for lmax_' + write(iwr,*) ' ' + write(iwr,*) ' ' + stop + endif +c + end +c + subroutine intit(iof) +C +c... read title cards until a blank card is encountered +C + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + logical blank + logical line1 + character*1 card(80) +c + write(iwr,1001) + + line1=.true. +c + 1 call incard (idat,card,ierr) + if(ierr.eq.0) goto 3 + if(ierr.eq.1) then + + write(iwr,2000) + + if(ierr.eq.2) then + + write(iwr,2001) + + endif + endif + 2000 format(//,' ** intit : end input -> stop **',//) + 2001 format(//,' ** intit : input error -> stop **',//) + stop + 3 continue +c +c.. write the 1st line of title into iof +c + if (line1) write(iof) (card(j),j=1,79) + line1=.false. + if ( blank(card) ) goto 2 + write(iwr,1000) (card(j),j=1,79) + goto 1 + 2 continue + write(iwr,1001) +1000 format(1x,80a1) +1001 format(/) + end +c + subroutine incard (idat,card,ierr) +c + character*1 card(80) + ierr=0 + do 2 i=1,80 + 2 card(i)=' ' + read(idat,1000,end=9,err=10) (card(i),i=1,80) + return + 9 ierr=1 + return + 10 ierr=2 + return + 1000 format(80a1) + end +c + logical function blank(card) + character*1 card(80) + data iasc/32/ +c +c iasc is the ascii code for ' ' (32) +c here a blank card is a card with ascii codes < 32 +c i.e., control characters are ignored +c + blank=.true. + do 1 i=1,80 + if (ichar(card(i)).gt.iasc) then + blank=.false. + return + endif + 1 continue + end +c + subroutine incoor +c + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + common/lmto/ rdsymbl,tag(nat_) + character*2 tag,tagi + logical rdsymbl +c + if( coor.eq.'au ') write(iwr,2000) + if( coor.eq.'angs') write(iwr,2001) + write(iwr,2002) + i=1 + 1 continue +c + rdsymbl=.false. + read (idat,*,iostat=ios) tagi,nzi + backspace(idat) + if (ios.eq.0) rdsymbl=.true. +c + if (rdsymbl) then +c + if (norman.eq.'stdcrm') then + radi = 0.0d0 + redfi = 0.0d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'stdfac') then + radi = 0.d0 + redfi = 0.8d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'scaled') then + radi = 0.0d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,redfi + endif +c + if (norman.eq.'extrad') then + redfi = 0.0d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,radi + endif +c + else +c + if (norman.eq.'stdcrm') then + radi = 0.0d0 + redfi = 0.0d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'stdfac') then + radi = 0.d0 + redfi = 0.8d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'scaled') then + radi = 0.0d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3,redfi + endif +c + if (norman.eq.'extrad') then + redfi = 0.0d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3,radi + endif +c + endif +c + if (nzi.lt.0) goto 2 +c + if (i.gt.natoms) then + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** error in incoor **' + write(iwr,*)' -> too many atoms, ', + 1 'check dimensions' + write(iwr,*) ' ' + write(iwr,*) ' ' + stop + endif +c + nz(i) = nzi + c(i,1) = ci1 + c(i,2) = ci2 + c(i,3) = ci3 + rad(i) = radi + redf(i) = redfi + tag(i) = tagi + if(rdsymbl) then + write (iwr,101) tag(i),nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i) + else + write (iwr,100) nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i) + endif + 100 format(2x,i3,3f10.4,3x,2f7.4) + 101 format(2x,a2,3x,i3,3f10.4,3x,2f7.4) + i=i+1 + goto 1 + 2 nat = i-1 +C print *, 'nat =', nat + write(iwr,2002) + write(iwr,2003) + if(ionzst.eq.' ionic') then + 10 read(idat,*) nzat + if(nzat.lt.0) goto 20 + backspace(idat) + read(idat,*) ndummy,charge_ion(nzat) + goto 10 + endif + 20 continue +c +c.. default units are angtroms, convert to a.u. if necessary +c + if (coor.eq.'au ') return + if (coor.eq.'angs') then + do 3 i=1,nat + if (norman.eq.'extrad') + & rad(i) = rad(i)/antoau + do 3 iz=1,3 + c(i,iz)= c(i,iz) / antoau + 3 continue + return + endif +c + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** incoor: unit type unknown -> ', + 1 'stop ** ' + write(iwr,*) ' ' + write(iwr,*) ' ' +c + 2000 format(' coordinates in a.u. ',25x,'Radii') + 2001 format(' coordinates in angstroms',25x,'Radii') + 2002 format(1x,65('-')) + 2003 format(/) + stop + end +c + subroutine calphas +c + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c +c + real*4 emin,emax,delta,cip,gamma,eftri,db + common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c + character*8 nsymbl +c +c ######## Modified to introduce the two state wave functions for the +c Auger decay +c ######## let's introduce i_absorber_hole1 and i_absorber_hole2 +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + common/dimens/nats,ndat,nout,lmaxx,irreps +c + common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), + u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), + u lmaxat(natoms), ktau(ua_),natau(neq_,ua_) +c + common/aparms_extra/rs_(natoms),redf_(natoms),ovlf +c +c real*4 emin,emax,delta,cip,gamma,eftri +c + write(iwr,*) ' ** enter calphas **' +c + if(cip.eq.0.0) then +c +c calculate edge ionization potential +c + call calc_edge(cip) + write(6,*) ' calculated ionization potential (ryd) =',cip + else + write(6,*) ' given ionization potential (ryd) =',cip + endif + write(6,*) ' ---' +c +c check consistency of input data in case of calctype = 'els' +c + if(calctype.eq.'els') then + einl = dble(einc - esct - cip) + if(einl.lt.0.0d0) then + write(6,*)' unable to excite chosen edge:', + & ' einc - esct - cip less than zero =', einl + call exit + endif + endif +c +c phase shifts computation +c initializes some variables for symmetry+potential programs +c nat is the total number of physical atoms as read in in +c subroutine incoor and is listed in common/atoms/ +c + nats=nat + i_absorber = absorber + i_absorber_hole = hole +c +c ################## Modified to introduce the two state wave functions +c for the Auger decay +c ################## hole1 is the electron that will go down to fill +c the primary core hole +c + i_absorber_hole1 = hole1 + + + i_absorber_hole2 = hole2 + + + + + + + i_norman = 1 +c if (norman.eq.'extrad') i_norman = 0 + i_mode = mode + do 100 i=2,nat+1 + + nzeq(i) = nz(i-1) + xv(i) = c(i-1,1) + yv(i) = c(i-1,2) + zv(i) = c(i-1,3) + rs_(i)=rad(i-1) + redf_(i)=redf(i-1) + 100 continue + ovlf = ovlpfac +c + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*) ' symmetrizing coordinates... ' + open (7,file='div/sym.out',status='unknown') + + call xasymfn_sub + + +c +c.....Warning: in subroutine xasymfn_sub nats has been assigned +c.....the value (nat+1) to take into account the outer sphere. +c +c create equivalence table neqat +c i=1 is the outer sphere in xasym programs +c + do 200 i=1,nat + if (neq(i+1).eq.0) then + neqat(i)=i + else + neqat(i)=neq(i+1)-1 + endif + 200 continue +c +c.....Write out atomic coordinates in symmetry-program order: +c each prototypical atom is followed by its sym-equivalent atoms +c +c open (10,file='clus/clus.out',status='unknown') + if( coor.eq.'au ') then + ipha=1 + coef=1.d0 + endif + if( coor.eq.'angs') then + ipha=2 + coef=0.529177d0 + endif + write(10,888) ipha + 888 format(30x,i1) + write(7,10) (neqat(i),i=1,nat) + 10 format (/,16i5,//) +c +c write(7,10) nat, ndat-1 +c + x0 = xv(2) + y0 = yv(2) + z0 = zv(2) +c + no = 0 + do na = 1, ndat-1 + do k = 2, nat+1 + if (neqat(k-1).eq.na) then + no = no + 1 + write(7,20) no,nsymbl(k),nzeq(k),xv(k)-x0, + & yv(k)-y0,zv(k)-z0,neqat(k-1) + write(10,20) no,nsymbl(k),nzeq(k),(xv(k)-x0)*coef, + & (yv(k)-y0)*coef,(zv(k)-z0)*coef,neqat(k-1) + endif + continue + enddo + enddo +c + close(10) +c + 20 format (i5,6x,a4,i5,3f10.4,i5) +c + write(iwr,*) + write(iwr,*)' computing muffin tin potential and phase shifts' + call cont_sub(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db) +c +ctn write(iwr,*)'calphas: neq', (neq(i),i=1,nat+1) +ctn write(iwr,*)'calphas: neqat', (neqat(i),i=1,nat) +c tstop=cputim() +c elapsed=tstop-tstart +c write(iwr,2000)elapsed +c 2000 format(' ** end calphas ** elapsed time ',f10.3,' seconds') + return + end +c +c + subroutine exit +c + write(6,*) ' ' + write(6,*) ' ' + write(6,*)' ** stop via call exit **' + write(6,*) ' ' + write(6,*) ' ' + stop + end +c + subroutine xasymfn_sub +c +c*********************************************************************** +c +c xasymfn: xalpha symmetry function program (version 3, 11 feb 1981) +c +c written by m. cook, 1981. +c +c calls: input(at input,outpot),seteqs,symops,closur,ctable,basfns +c +c*********************************************************************** +c + + implicit real*8 (a-h,o-z) +c include 'mscalc.inc' + include 'msxas3.inc' + integer op_,ord_,two_npr_ + parameter (natm2_=nat_-2,npr_=24,op_=48,ntax_=250, + 1 ir_=14,ib_=28,ord_=8,l_=3,lp1_=4, + 2 nms_=7,nfac_=9,nbf_=nat_*4,ncs_=24) + parameter(two_npr_=2*npr_,npr_p1_=npr_+1) +c + common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, + u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +c +c !flag for reformatted output + common/sym_out/isym_format + + +c +c----- define maximum array dimensions --------------------------------- +c warning : natmx est dans le common +cman data natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, +cman u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +cman u /nat_,ua_,neq_,npr_,two_npr_,npr_p1_, +cman u ord_,ir_,ib_,l_,nbf_,ncs_,ntax_/ +c + data natm2m,nopmax,lp1mx,nmsmx,mxfct + u /natm2_,op_,lp1_,nms_,nfac_/ +cman + natmx = nat_ + ndatmx = ua_ + neqsmx = neq_ + nprmx = npr_ + nopmx = two_npr_ + nimp1 = npr_p1_ + nordmx = ord_ + nirpmx = ir_ + nibmx = ib_ + lbasmx = l_ + nbfmx = nbf_ + ncsmx = ncs_ + ntaxmx = ntax_ + +c +c + if (natm2m.lt.natmx-2) go to 10 + if (nopmax.ne.2*nprmx) go to 20 + if (lp1mx.ne.lbasmx+1) go to 30 + if (nmsmx.ne.2*lbasmx+1) go to 40 + if (mxfct.lt.2*lbasmx+1) go to 50 + if (nordmx.lt.3) go to 60 +c +c----- call major calculational subroutines ---------------------------- +c + + call input_xasymfn + + + call seteqs + call outpot_xasymfn +c + return +c +c----- error prints and stops ------------------------------------------ +c + 10 write (6,500) natm2m + stop + 20 write (6,510) nopmax + stop + 30 write (6,520) lp1mx + stop + 40 write (6,530) nmsmx + stop + 50 write (6,540) mxfct + stop + 60 write (6,550) nordmx + stop +c + 500 format (//,' error stop: natm2m =',i6,' is less than', + u ' natmx-2 : redimension',//) + 510 format (//,' error stop: nopmax =',i6,' is not equal to', + u ' 2*nprmx : redimension',//) + 520 format (//,' error stop: lp1mx =',i6,' is not equal to', + u ' lbasmx+1 : redimension',//) + 530 format (//,' error stop: nmsmx =',i6,' is not equal to', + u ' 2*lbasmx+1 : redimension',//) + 540 format (//,' error stop: mxfct =',i6,' is less than', + u ' 2*lbasmx+1 : redimension',//) + 550 format (//,' error stop: nordmx =',i6,' : must be', + u ' redimensioned to 3 or greater',//) + end +c +c + subroutine input_xasymfn +c +c*********************************************************************** +c +c reads in the molecular geometry information, desired +c l-values, and mode control variables. modes of operation: +c +c iprt=0, rot'n matrices not printed +c iprt=1, rot'n matrices will be printed out from ctable +c +c mdin=0, geometry, nz, neq data all read from card input +c mdin=1, non-sym data read from a molec stpot; sym data from cards +c +c mdou=0, only 1st col of degenerate irreps output to ktape +c mdou=1, all columns of degenerate irreps will be written +c +c mdco=0, single-atom core functions will be generated +c mdco=1, symmetry-adapted core functions will be generated +c +c mdeq=0, calc'd symmetry-eq list (neq) overrides any input neq +c mdeq=1, input list of symmetry-equivalences will be used +c +c if mdin=1, mdeq=1 is automatically enforced by this program +c because the form of the stpot depends on the list of sym-eq ats. +c +c called by: main (at input,outpot) +c +c*********************************************************************** +c + implicit real*8(a-h,o-z) +c include 'mscalc.inc' + include 'msxas3.inc' +c + logical cmplxc,frezeq,inpot,nonint,onecol,symcor + character*8 nsymbl,nsymbl2 + common/aparms_extra/rs(nat_),redf(nat_) + common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_), + u nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_), + u ktau(ua_),natau(neq_,ua_) + common/aparms2/xv2(nat_),yv2(nat_),zv2(nat_),rs2(nat_), + u alpha2(nat_),redf2(nat_),z2(nat_),q2(nat_),qspnt2(2), + u qint2(2), + u watfac(nat_),alpha02,volint2,ovout2,rmxout2,nsymbl2(nat_), + u nz2(nat_),neq2(nat_),kmax2(nat_),kplace2(nat_),ktau2(ua_) + common/lparam/lmax2(nat_),l0i + common/coords/s(3,nat_) + dimension s2(3,nat_) + common/dimens/nat,ndat,nout,lmaxx,irreps + common/dimens2/nat2,ndat2 + common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor + common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, + u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +c !flag for reformatted output + common/sym_out/isym_format +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + +c !generate potential file + common/out_ascii/iout_ascii +c + common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc + logical shift_cc +c + common/lmto/ rdsymbl,tag(nat_) + character*2 tag + logical rdsymbl + + character*2 nameat + dimension nameat(100) +c + DATA NAMEAT/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', + 1 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca', + 1 'Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn', + 1 'Ga','Ge','As','Se','Br','Kr','Rb','Sr',' Y','Zr', + 1 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', + 1 'Sb','Te',' I','Xe','Cs','Ba','La','Ce','Pr','Nd', + 1 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', + 1 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg', + 1 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', + 1 'Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm'/ +c + data thr/0.001d0/ + data zero/0.d0/ + data lunout,lunout2/7,60/ + +c + iprt=0 + mdou=0 + mdco=0 + mdeq=0 + isym_format=0 + +c !nout defined + nout=1 +c !same as nout but global + i_outer_sphere=1 +c + frezeq=.false. + symcor=.false. + onecol=.true. + if (mdeq.eq.1) frezeq=.true. + if (mdco.eq.1) symcor=.true. + if (mdou.eq.1) onecol=.false. +c +c----------------------------------------------------------------------- +c mdin = 0 : only geometry & atomic # data, from card input +c----------------------------------------------------------------------- +c + inpot=.false. +c !nout defined + nout=1 +ctn +ctn Values passed through the subroutines parameters +ctn read (lunin,*) nat,i_absorber,i_absorber_hole,i_norman, +ctn &i_mode +c + nat=nat+i_outer_sphere + if (nout.eq.0) write (lunout,570) nat + if (nout.ne.0) write (lunout,580) nat + if (nat.gt.natmx) go to 140 + write (lunout,530) + + +c + r_sphere=0.0d0 + + + + do 10 na=2,nat + + +ctn read (lunin,*) nsymbl(na),nz(na),xv(na),yv(na),zv(na), +ctn u rs(na),redf(na) +ctn modifs : + + +c nsymbl(na)=nameat(nz(na)) +c......modification for Empty Spheres +c + if(rdsymbl) then + nsymbl(na)=tag(na-1) + else + if(nz(na).eq.0) then + nsymbl(na)='ES' + else + nsymbl(na)=nameat(nz(na)) + endif + endif + z(na)=dfloat(nz(na)) + neq(na)=0 +c !needed to determine point group + lmax(na)=3 + ncores(na)=0 + + + write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na), + u neq(na),lmax(na),ncores(na) + 10 continue +c +c define outer sphere parameters (i. e. atomic center) +c + na=1 + nsymbl(na)='osph' + nz(na)=0 + z(na)=0.0d0 + neq(na)=0 + rs(na)=0.0d0 + redf(na)=0.0d0 +c !needed to determine point group + lmax(na)=3 + ncores(na)=0 +c +c define outer sphere coordinates at center of charge +c + xo=zero + yo=zero + zo=zero + wt=zero + do 910 na1=2,nat + xo=xo+z(na1)*xv(na1) + yo=yo+z(na1)*yv(na1) + zo=zo+z(na1)*zv(na1) + wt=wt+z(na1) + 910 continue + xo=xo/wt + yo=yo/wt + zo=zo/wt + if (dabs(xo).lt.thr) xo=zero + if (dabs(yo).lt.thr) yo=zero + if (dabs(zo).lt.thr) zo=zero + xv(na)=xo + yv(na)=yo + zv(na)=zo +c + if(i_norman.ne.1)then + do 15 na1=2,nat + r_sphere_temp=sqrt((xv(na1)-xv(1))**2+ + u (yv(na1)-yv(1))**2+ + u (zv(na1)-zv(1))**2)+rs(na1) + if(r_sphere.lt.r_sphere_temp)then + r_sphere=r_sphere_temp + end if +15 continue + rs(1)=r_sphere + end if + write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na), + u neq(na),lmax(na),ncores(na) + write (lunout,560) +c +c*** check coordinates of atoms +c + do 1150 na1=1,nat + do 1140 na2=1,na1 + dist =dsqrt((xv(na1)-xv(na2))**2 + u +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 ) + if((na2.gt.1).and.(na1.ne.na2)) then + if(dist.lt.thr)then + write(6,562)na1,na2 + call exit + end if + end if + 1140 continue + 1150 continue +c + return +c +c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c entry outpot_xasymfn +c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c +c----- molecule will usually have been rotated: +c print the new atomic coordinates in standard orientation ------ +c + entry outpot_xasymfn + write (lunout,590) + print 595 + write (lunout,530) + print 535 + nashf=1 +c + + nat2=nat + ndat2=ndat + i_absorber_real=i_absorber+i_outer_sphere +c +c set z on absorbing atom back to original value +c + z(i_absorber_real)=z(i_absorber_real)-z_shift + nz(i_absorber_real)=nz(i_absorber_real)-i_z_shift +c !symmetry distinct atoms + do 70 nda=1,ndat + if(shift_cc)then +c !go back to real cente + s2(1,nashf)=s(1,nashf)-cc_dif(1,1) +c !of charge + s2(2,nashf)=s(2,nashf)-cc_dif(2,1) + s2(3,nashf)=s(3,nashf)-cc_dif(3,1) + if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero + if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero + if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero + else + s2(1,nashf)=s(1,nashf) + s2(2,nashf)=s(2,nashf) + s2(3,nashf)=s(3,nashf) + endif + write (lunout,550) nda,nsymbl(nda),nz(nda), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda), + u lmax(nda),ncores(nda) + print 555, nda,nsymbl(nda),nz(nda), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda) + if(nda.ne.1)write (lunout2,552) s2(1,nashf),s2(2,nashf), + u s2(3,nashf),nsymbl(nda) +c + rs2(nda)=rs(nda) + redf2(nda)=redf(nda) + nsymbl2(nda)=nsymbl(nda) + xv2(nda)=s2(1,nashf) + yv2(nda)=s2(2,nashf) + zv2(nda)=s2(3,nashf) + nz2(nda)=nz(nda) + z2(nda)=z(nda) + neq2(nda)=neq(nda) + ktau2(nda)=ktau(nda) + nashf=nashf+ktau(nda) + 70 continue + nashf=0 + do 90 nda=1,ndat + nashf=nashf+1 + neqs=ktau(nda) + if (neqs.eq.1) go to 90 + do 80 ne=2,neqs +c !equivalent sets + nashf=nashf+1 + na=natau(ne,nda) + if(shift_cc)then +c !go back to real cente + s2(1,nashf)=s(1,nashf)-cc_dif(1,1) +c !of charge + s2(2,nashf)=s(2,nashf)-cc_dif(2,1) + s2(3,nashf)=s(3,nashf)-cc_dif(3,1) + if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero + if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero + if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero + else + s2(1,nashf)=s(1,nashf) + s2(2,nashf)=s(2,nashf) + s2(3,nashf)=s(3,nashf) + endif + write (lunout,550) na,nsymbl(na),nz(na), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na),lmax(na),ncores(na) + print 555, na,nsymbl(na),nz(na), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na) + write (lunout2,552) s2(1,nashf),s2(2,nashf),s2(3,nashf), + u nsymbl(na) + rs2(na)=rs(na) + redf2(na)=redf(na) + nsymbl2(na)=nsymbl(na) + xv2(na)=s2(1,nashf) + yv2(na)=s2(2,nashf) + zv2(na)=s2(3,nashf) + nz2(na)=nz(na) + z2(na)=z(na) + neq2(na)=neq(na) + 80 continue + 90 continue + if(nout.eq.1) then + + + z2(1)=1.0d0 + nz2(1)=1 + end if + write (lunout,560) + + return +c +c----- error prints and stops ------------------------------------------ +c + 140 write (6,600) natmx,nat + stop +c + 530 format (t53,'position'/30x,'atom no.',4x,'x',9x,'y',9x,'z',8x, + u 'eq',5x,'lmax',5x,'#cores'/) + 535 format (t35,'position'/12x,'atom no.',4x,'x',9x,'y',9x,'z',8x, + u 'eq'/) + 550 format (26x,i4,2x,a4,i6,3f10.4,i6,i8,i9) + 552 format (3(2x,f10.3),2x,a4) + 555 format (8x,i4,2x,a4,i6,3f10.4,i6) + 560 format (/46x,6('*****')/) + 562 format (//,'error: check coordinates of atoms # ',i4, + & ' and # ',i4,//) + 570 format (//38x,'number of centers=',i5,' no outer sphere'/) + 580 format (//38x,'number of centers=',i5,' outer sphere at ' + u ,'center 1'/) + 590 format (///38x,'molecular orientation for basis fn projection:'/) + 595 format (//14x,' symmetrized atomic coordinates of cluster '/) + 600 format (//' error stop: variable nat is .gt.',i6, + u ' : redimension natmx to',i6,//) + end +c + subroutine seteqs +c +c*********************************************************************** +c +c translates the molecule to the center of nuclear charge +c and tentatively identifies symmetry-equivalent sets of atoms +c on the basis of interatomic distances. +c checks that the atoms are arranged in correct order for +c xascf: nda's first and eq atoms following. if input is from +c a molec starting pot, error stop if order is not correct. if +c input is not from a pot, the atoms will be shuffled into +c the appropriate xascf order at output time. +c note that during the execution of the symmetry program, the +c atoms are not kept in the scf order: they are in sym-program +c order, each nda followed immediately by its sym-eq partners. +c +c called by: main +c +c*********************************************************************** +c + implicit real*8 (a-h,o-z) +c include 'mscalc.inc' + include 'msxas3.inc' + parameter (natm2_=nat_-2) +c + character*8 nsymbl + logical doshuf,equiv,found,match,frezeq + logical cmplxc,inpot,nonint,onecol,symcor + dimension neqt(nat_) + dimension found(natm2_),nbrz(natm2_,nat_),dnbr(natm2_,nat_) + integer trans(nat_) + common/aparms_extra/rs(nat_),redf(nat_) + common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_), + u nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_), + u ktau(ua_),natau(neq_,ua_) + common/coords/s(3,nat_) + common/dimens/nat,ndat,nout,lmaxx,irreps + common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor + common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, + u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + +c + common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc + common/transform/trans + logical shift_cc +c + data zero,thr/0.0d0,0.001d0/ +c + data jtape/21/ + data lunout/7/ +c +c----------------------------------------------------------------------- +c find the center of charge of the nuclear framework and +c translate the molecule to that origin +c----------------------------------------------------------------------- +c !define nuclear charge shift + z_shift=5.0d0 + i_z_shift=5 + shift_cc=.true. +c + xo=zero + yo=zero + zo=zero + wt=zero + nastrt=nout+1 +c !set up to make absorbing atom unique by addin + cc_dif(1,1)=zero +c !z_shift units of charge to its nucleus + cc_dif(2,1)=zero + cc_dif(3,1)=zero + wt_real=zero + + do 5 na=nastrt,nat + cc_dif(1,1)=cc_dif(1,1)+z(na)*xv(na) + cc_dif(2,1)=cc_dif(2,1)+z(na)*yv(na) + cc_dif(3,1)=cc_dif(3,1)+z(na)*zv(na) + wt_real=wt_real+z(na) + 5 continue + cc_dif(1,1)=cc_dif(1,1)/wt_real + cc_dif(2,1)=cc_dif(2,1)/wt_real + cc_dif(3,1)=cc_dif(3,1)/wt_real +c + i_absorber_real=i_absorber+i_outer_sphere +c increase z value of absorbing atom + z(i_absorber_real)=z(i_absorber_real)+z_shift + nz(i_absorber_real)=nz(i_absorber_real)+i_z_shift +c + do 10 na=nastrt,nat + xo=xo+z(na)*xv(na) + yo=yo+z(na)*yv(na) + zo=zo+z(na)*zv(na) + wt=wt+z(na) + 10 continue + xo=xo/wt + yo=yo/wt + zo=zo/wt + if (dabs(xo).lt.thr) xo=zero + if (dabs(yo).lt.thr) yo=zero + if (dabs(zo).lt.thr) zo=zero +c !cc_dif is difference between + cc_dif(1,1)=cc_dif(1,1)-xo +c !real and shifted centers of + cc_dif(2,1)=cc_dif(2,1)-yo +c !charge + cc_dif(3,1)=cc_dif(3,1)-zo + if (dabs(cc_dif(1,1)).lt.thr) cc_dif(1,1)=zero + if (dabs(cc_dif(2,1)).lt.thr) cc_dif(2,1)=zero + if (dabs(cc_dif(3,1)).lt.thr) cc_dif(3,1)=zero + r_dif_cc=sqrt( cc_dif(1,1)*cc_dif(1,1)+cc_dif(2,1)* + u cc_dif(2,1)+cc_dif(3,1)*cc_dif(3,1) )/dsqrt(3.0d0) + if(r_dif_cc.lt.thr)shift_cc=.false. + do 20 na=1,nat + xv(na)=xv(na)-xo + yv(na)=yv(na)-yo + zv(na)=zv(na)-zo + if (dabs(xv(na)).lt.thr) xv(na)=zero + if (dabs(yv(na)).lt.thr) yv(na)=zero + if (dabs(zv(na)).lt.thr) zv(na)=zero + 20 continue +c +c----------------------------------------------------------------------- +c classify sym-eq sets of atoms: two atoms are eqiv +c if they have same number of neighbors of same nz at same distances +c----------------------------------------------------------------------- +c +c----- calculate the distances of each atom from the others ------------ +c + neqt(1)=0 + do 40 na1=nastrt,nat + nabor=0 + neqt(na1)=0 + do 30 na2=nastrt,nat + if (na1.eq.na2) go to 30 + nabor=nabor+1 + nbrz(nabor,na1)=nz(na2) + rab=dsqrt((xv(na1)-xv(na2))**2 + u +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 ) + dnbr(nabor,na1)=rab + 30 continue + 40 continue +c +c----- compare the neighbor charges and distances ---------------------- +c + nabors=nat-(nout+1) + do 90 na1=nastrt,nat + na1p1=na1+1 + if (na1p1.gt.nat) go to 90 + do 80 na2=na1p1,nat + if (nz(na1).ne.nz(na2)) go to 80 + if (neqt(na2).ne.0) go to 80 + do 50 nabor=1,nabors + 50 found(nabor)=.false. + equiv=.true. +c +c----- try to match the neighbors of na1 & na2 one-to-one -------------- +c + do 70 nabor1=1,nabors + nzt= nbrz(nabor1,na1) + rabt=dnbr(nabor1,na1) + match=.false. + do 60 nabor2=1,nabors + if (found(nabor2)) go to 60 + if (nbrz(nabor2,na2).ne.nzt) go to 60 + if (dabs(dnbr(nabor2,na2)-rabt).gt.thr) go to 60 + found(nabor2)=.true. + match=.true. + go to 65 + 60 continue + 65 if (match) go to 70 + equiv=.false. + go to 75 + 70 continue +c +c----- if all nabor2 found and each nabor1 had match=.true., +c na1 and na2 have equivalent sets of neighbors ----------------- +c + 75 if (equiv) neqt(na2)=na1 + 80 continue + 90 continue +c +c----------------------------------------------------------------------- +c compare the calculated and input neq arrays +c----------------------------------------------------------------------- +c + write (lunout,500) + write (lunout,510) (na,neqt(na),na=1,nat) + equiv=.true. + do 100 na=1,nat + if (neqt(na).ne.neq(na)) equiv=.false. + if (.not.frezeq) neq(na)=neqt(na) + 100 continue + if (equiv) write (lunout,520) + if (.not.equiv.and.frezeq) write (lunout,530) + if (.not.equiv.and..not.frezeq) write (lunout,540) +c +c----------------------------------------------------------------------- +c check that the atoms are arranged in the correct scf order: +c all nda's first, then the sym-eq atoms for each nda in same order +c----------------------------------------------------------------------- +c + doshuf=.false. + do 110 na=nastrt,nat + if (neq(na).eq.0.and.neq(na-1).ne.0) doshuf=.true. + if (neq(na).lt.neq(na-1)) doshuf=.true. + 110 continue + if (inpot.and.doshuf) go to 230 +c +c----- if not running from a molecular starting pot, +c shuffle the atoms into xascf order ---------------------------- +c + rewind jtape + nda=0 + do 130 na=1,nat + if (neq(na).gt.0) go to 130 + nda=nda+1 + write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) + write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) + do 120 na2=1,nat + if (neq(na2).eq.na) neq(na2)=nda + 120 continue + 130 continue + ndat=nda + if (ndat.gt.ndatmx) go to 240 + do 150 nda=1,ndat + do 140 na=1,nat + if (neq(na).ne.nda) go to 140 + write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) + write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) + 140 continue + 150 continue + + nda=0 + do 310 i=2,nat + if (neq(i).eq.0) then + nda=nda+1 + trans(i-1)=nda + endif + 310 continue + + + do 320 na=2,ndat + do 325 i=2,nat + if (neq(i).eq.na) then + nda=nda+1 + trans(i-1)=nda + endif + 325 continue + 320 continue + + +c +c----- read the shuffled atomic parameters back in --------------------- +c + rewind jtape + do 160 na=1,nat + read (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) + read (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) + 160 continue + rewind jtape +c +c----------------------------------------------------------------------- +c calculate the final symmetry-equivalence list ( natau ) +c----------------------------------------------------------------------- +c + do 200 nda=1,ndat + neqs=1 + natau(1,nda)=nda + do 190 na=1,nat + if (neq(na).ne.nda) go to 190 + neqs=neqs+1 + if (neqs.gt.neqsmx) go to 250 + natau(neqs,nda)=na + 190 continue + ktau(nda)=neqs + 200 continue + +c +c----------------------------------------------------------------------- +c arrange the atomic x,y,z coords in symmetry-program order: +c each nda is followed immediately by its sym-equivalent atoms +c----------------------------------------------------------------------- +c + nashuf=0 + do 220 nda=1,ndat + neqs=ktau(nda) + do 210 ne=1,neqs + na=natau(ne,nda) + nashuf=nashuf+1 + s(1,nashuf)=xv(na) + s(2,nashuf)=yv(na) + s(3,nashuf)=zv(na) + 210 continue + 220 continue + + return +c +c----- error prints and stops ------------------------------------------ +c + 230 write (6,550) + stop + 240 write (6,560) ndatmx,ndat + stop + 250 write (6,570) neqsmx + stop +c + 500 format (//25x,'calculated atomic symmetry equivalences,'/ + u 30x,'based on interatomic distance matrix:',7x,'na', + u 4x,'neq(na)'/) + 510 format (69x,i7,i8) + 520 format (/t35,'the calculated symmetry-eq sets agree with', + u ' the input'/) + 530 format (/t25,'calculated & input symmetry-eq sets do not', + u ' agree: input sets will be used'/) + 540 format (/t22,'calculated & input symmetry-eq sets do not', + u ' agree: calculated sets will be used'/) + 550 format (//t25,'input molecular pot does not have distinct', + u ' & sym-eq atoms in correct order for input to xascf',//) + 560 format (//' error stop: variable ndat is .gt.',i6, + u ' : redimension ndatmx to',i6,//) + 570 format (//' error stop: variable neqs is .gt.',i6, + u ' : redimension neqsmx',//) + end +c +c + subroutine vgen +c write(6,*) 'check1' + call rhoat +c write(6,*) 'check2' + call molpot +c write(6,*) 'check3' + call inpot +c write(6,*) 'check4' + return + end +c +C*********************************************************************** + SUBROUTINE RHOAT +C*********************************************************************** +C +C MAY-92 +C +C GENERATES ATOMIC CHARGE DENSITY FOR PROTOTYPICAL ATOMS +C +C DICTIONARY : +C NDAT Number of prototypical atoms +C INV Logical unit on which to write the output [8] +C ZAT Atomic number +C MESH Number of radial mesh points [441] +C +C************************************************ + implicit real*8 (a-h,o-z) +c + include 'msxas3.inc' + include 'msxasc3.inc' +c + common/dimens/nats,ndat +c + character*8 nsymbl +c.. + + +c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1 +c *i_absorber_hole2,i_norman,i_alpha, +c 1i_outer_sphere,i_exc_pot,i_mode + + + + COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1, + * I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA, + 1 I_OUTERSPHERE,I_EXC_POT,I_MODE + + + + +C COMMON/APARMS/XV(NATOMS),YV(NATOMS),ZV(NATOMS),Z(NATOMS), +C u NSYMBOL(NATOMS),NZEQ(NATOMS),NEQ(NATOMS),NCORES(NATOMS), +C . LMAXAT(NATOMS) + +C COMMON/APARMS_EXTRA/RS_(NATOMS),REDF_(NATOMS),OVLF + + + common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), + u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), + u lmaxat(natoms),ktau(ua_),natau(neq_,ua_) +C + COMMON/CRHOAT/RO(441,UA_,1) +c + DIMENSION X(441),RMESH(441) +C + REAL*4 XC,YC,ZC + DIMENSION XC(NAT_),YC(NAT_),ZC(NAT_) +C + DIMENSION NPAC(100) +C + LOGICAL OK +C + OK = .TRUE. +C +C* * * Initialize variables for subroutine molpot * * * +C + MESH = 441 +C +C Prepare coordinate vectors to input subroutine moldat +C + DO 10 I=1,NAT + XC(I) = sngl(XV(I+1)) + YC(I) = sngl(YV(I+1)) +10 ZC(I) = sngl(ZV(I+1)) +C Initialize to zero the vector indicating for which atom the density +C has already been calculated + DO N = 1, 100 + NPAC(N) = 0 + ENDDO +C +C compute x and r mesh (441 points) +C + NBLOCK=11 + I=1 + X(I)=0.0D0 + RMESH(I)=0.0D0 + DELTAX=0.0025D0 + DO 120 J=1,NBLOCK + DO 121 K=1,40 + I=I+1 + X(I)=X(I-1)+DELTAX +121 CONTINUE +C +C For each new block, double the increment +C + DELTAX=DELTAX+DELTAX +120 CONTINUE +C +C Loop over prototypical atoms excluding outer sphere +C + NDAT1 = NDAT-1 + + DO 100 M=2,NDAT + DO NR = 1, 441 + RO(NR,M,1) = 0.D0 + ENDDO + IHOLE = 0 + IF (M.EQ.2.AND.CHARELX.EQ.'ex') IHOLE=HOLE + NZAT = NZEQ(M) + IF(NZAT.NE.0) CION=CHARGE_ION(NZAT) + ZAT = Z(M) +C +C.....CHANGE FOR EMPTY SPHERES; CHS=0.88534138D0/ZAT**(1.D0/3.D0) +C + IF(ZAT.NE.0.D0) THEN + CHS=0.88534138D0/ZAT**(1.D0/3.D0) + ELSE + CHS=0.88534138D0 + ENDIF +C +C Factor CHS is to go from X values to R values +C (the latter in atomic units; See Herman-Skillman p.5-3) +C + DO 130 I=2,MESH + RMESH(I)=CHS*X(I) +130 CONTINUE +C + IF(NZAT.EQ.0) GO TO 100 + IF(NPAC(NZAT).EQ.0) THEN + CALL atom_sub(NZAT,IHOLE,RMESH(1),RO(1,M,1),0,0,CION) + IF(M.NE.2) NPAC(NZAT) = M + GO TO 100 + ELSE + DO I = 1, 441 + RO(I,M,1) = RO(I,NPAC(NZAT),1) + ENDDO + ENDIF +C +100 CONTINUE +C +C* * * * Generate input structural parameters for subroutine molpot * * +C +C + CALL MOLDAT(XC,YC,ZC,NZEQ(1),NEQAT(1),NAT,NDAT1,OK) +C + RETURN +C + END +C +C******************************* +C + subroutine atom_sub(iz,ihole,r_hs,rho0_hs,i_mode_atom, + $ i_radial,xion) +c +c i_mode_atom = 1 pass_back P_nK corresponding to neutr +c atom. i_radial designates radial function +c which is passed back in array rho0_hs re +c to mesh r_hs. +c I_radial has same label convention +c as ihole (1 = 1s1/2 ...). +c = all else pass back charge density in rho0_hs. +c +c + implicit real*8(a-h,o-z) +c + parameter ( mp = 251, ms = 30 ) +c + character*40 title +c + common/mesh_param/jlo + common dgc(mp,ms),dpc(mp,ms),bidon(630),IDUMMY +c +c common /pass/ passd, passvt(251), passvc(251), passc(251) +c rho0 not renormalized +c common /rho/rho0(251) +c dgc contains large component radial functions +c common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30) +c passc and rho0 contain 4*pi*r^2*rho(r) +c + dimension r(mp),r_hs(441),rho0_hs(441) +C + dimension dum1(mp), dum2(mp) + dimension vcoul(mp), rho0(mp), enp(ms) +c + title = ' ' +c + ifr=1 + iprint=0 +C + amass=0.0d0 + beta=0.0d0 +c +c There are no nodes in relativistic radial charge density +c + small=1.0d-11 +c !Hence a lower limit on rho(r) can be used. + dpas=0.05d0 + dr1=dexp(-8.8d0) + dex=exp(dpas) + r_max=44.447d0 +c +c compute relativistic Hartree-Fock charge density (on log mesh) +C and core state orbital wave function +c open(unit=543,file='atom_.dat',status='unknown') +c + + call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, + 1 vcoul, rho0, dum1, dum2, enp, eatom) + + +c +c compute radial log mesh (see subroutine phase in J.J. Rehr's progr +c FEFF.FOR) +c + ddex=dr1 + do 10 i=1,251 + r(i)=ddex + ddex=ddex*dex +10 continue +C + DO JMP=1,MP + WRITE(66,*) R(JMP),RHO0(JMP) + ENDDO +c + do 15 i=1,441 + rho0_hs(i)=0.0d0 +15 continue + +c +cman if(i_mode_atom.eq.1)goto 30 +c + if(i_mode_atom.eq.1)goto 31 +c +c using mesh form xainpot (r=0 not included) +c + do 30 i=1,441 + if(r_hs(i).gt.r_max) goto 30 +c +c find nearest points +c initialize hunting parameter (subroututine nearest) +c + jlo=1 + call nearest(r,251,r_hs(i), + 1 i_point_1,i_point_2,i_point_3) + if(abs(rho0(i_point_3)).lt.small) goto 30 +c interpolate charge density + call interp_quad( r(i_point_1),rho0(i_point_1), + 1 r(i_point_2),rho0(i_point_2), + 1 r(i_point_3),rho0(i_point_3), + 1 r_hs(i),rho0_hs(i) ) +c +c branch point +c +30 continue +31 continue +c +c + if(i_mode_atom.ne.1)goto 50 +c +c wave function generation +c using mesh form xainpot (r=0 not included) +c + do 40 i=1,441 + if(r_hs(i).gt.r_max) goto 50 +c +c find nearest points +c initialize hunting parameter (subroututine nearest) +c + jlo=1 + call nearest(r,251,r_hs(i), + 1 i_point_1,i_point_2,i_point_3) +c interpolate wavefunction + call interp_quad( + 1 r(i_point_1),dgc(i_point_1,i_radial), + 1 r(i_point_2),dgc(i_point_2,i_radial), + 1 r(i_point_3),dgc(i_point_3,i_radial), + 1 r_hs(i),rho0_hs(i) + 1 ) +40 continue +c +c branch point +c +50 continue +c + return + end + + SUBROUTINE NEAREST(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3) +C +C FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X +C AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3 +C This subroutine was taken from Numerical Recipes, +C W. H. Press, B. F. Flanney, S. A. Teukolsky and W. T. +C Vetterling, page 91. Originally called HUNT +c + IMPLICIT REAL*8(A-H,O-Z) + COMMON/MESH_PARAM/JLO +C + DIMENSION XX(N) + LOGICAL ASCND + ASCND=XX(N).GT.XX(1) +C +C EXTRAPOLATE BELOW LOWEST POINT +C + IF(X.LE.XX(1))THEN + I_POINT_1=1 + I_POINT_2=2 + I_POINT_3=3 + RETURN + END IF +C +C EXTRAPOLATE BEYOND HIGHEST POINT +C + IF(X.GE.XX(N))THEN + I_POINT_1=N-2 + I_POINT_2=N-1 + I_POINT_3=N + RETURN + END IF + IF(JLO.LE.0.OR.JLO.GT.N)THEN + JLO=0 + JHI=N+1 + GO TO 3 + ENDIF + INC=1 + IF(X.GE.XX(JLO).EQV.ASCND)THEN +1 JHI=JLO+INC + IF(JHI.GT.N)THEN + JHI=N+1 + ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN + JLO=JHI + INC=INC+INC + GO TO 1 + ENDIF + ELSE + JHI=JLO +2 JLO=JHI-INC + IF(JLO.LT.1)THEN + JLO=0 + ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN + JHI=JLO + INC=INC+INC + GO TO 2 + ENDIF + ENDIF +3 IF(JHI-JLO.EQ.1)THEN + IF((JLO+1).EQ.N)THEN + I_POINT_1=JLO-1 + I_POINT_2=JLO + I_POINT_3=JLO+1 + ELSE + I_POINT_1=JLO + I_POINT_2=JLO+1 + I_POINT_3=JLO+2 + END IF + RETURN + END IF + JM=(JHI+JLO)/2 + IF(X.GT.XX(JM).EQV.ASCND)THEN + JLO=JM + ELSE + JHI=JM + ENDIF + GO TO 3 + END +C +C + SUBROUTINE INTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4) +C +C INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2) +C TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT +C PARAMETERS. THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C +C + IMPLICIT REAL*8(A-H,O-Z) +C + TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1) + BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1) + B = TOP/BOTTOM + A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1) + C = Y3 - A*X3*X3 - B*X3 + Y4 = A*X4*X4 + B*X4 + C +C + RETURN + END + +C*********************************************************************** +C + SUBROUTINE MOLDAT(XCOORD,YCOORD,ZCOORD,ZNUMBE,GROUPN,NATOMSM, + 1 NTYPES,OK) +C +C 8-dec-86 C.Brouder +C This subroutine builds the file containing the additional input +C required for MOLPOT once CLEM has been run. +C 15-dec-86 If program CONTINUUM is to be run with complex +C potential, set all alpha parametres to zero. +C If program MOLPOT is to be run with an outer sphere, +C write corresponding parametres. +C +C Arguments description : +C XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms +C ZNUMBE Array of the atomic numbers of the atoms +C GROUPN Array of the number of the group to which the +C atoms belong. (A group is a class of atoms equivalent +C by the symmetry operations of the symmetry group) +C NATOMSM Number of atoms +C NTYPES Number of groups (prototypical atoms) +C +C DATA description (Value of data is [value]) : +C NRUNS Number of cluster for which potential is computed [1] +C INV Logical unit from which output from CLEM is read [8] +C +C NOUT 0 No outer sphere, 1 an outer sphere [0] +C NWR1 Punched output to be punched [PCH] +C NWR2 Print charge densities, charge, potential [PRT] +C 1NSPINS 1 spin restricted potential, 2 spin polarized potential [1] +C EXAFCO Slater alpha parameter for exchange for the interstitial regi +C OVLF Overlap factor of neighbouring spheres [.10] +C CHPERC The charge radius of the atom, is defined as the radius +C for which the integrated density of charge is Z*(1+CHPER +C This is used to compute the muffin-tin radii [0.005] +C NCUT A control number intended to change the mesh size for high +C energy calculations [0] (= no change) +C +C NSYMBL 4 character description of the atom (Symbol + number) +C NEQ 0 for prototypical atoms +C NTYPE of the prototypical atom for atoms equivalent to N +C NGBR The number of neighbours surrounding the atom. +C NTYPE Type of the atom (Group number) +C XV,YV,ZV Coordinates in atomic units +C EXFACT Slater alpha parameter +C +C ALPHAP Alpha Parameter of elements, from Schwarz, (Phys.Rev.B 5(7) +C 2466 (1972)) up to Z=41 (Nb), some possible "interpolation" +C for the other elements. +C NAMEAT Name of atoms +C OUTER Logical. .TRUE. if MOLPOT is to be run with an outer sphere +C BOHRAD Bohr radius in Angstrom +C +C*********************************************************************** +C + INCLUDE 'msxas3.inc' +C + COMMON/CONTINUUM/EMIN,EMAX,DELTA,CIP,GAMMA,EFTRI,IEXCPOT +C + REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM +C + COMMON/MOLINP/ + 1 EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM, + 1 NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_), + 1 NAM(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 + +C + PARAMETER (NEIMAX=nat_) + REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS) + INTEGER ZNUMBE(NATOMS),ZNBRE,GROUPN(NATOMS) + INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX) + LOGICAL OK,OUTER,PROTO,DEUX + CHARACTER*5 NWR1,NWR2 + REAL ALPHAP(100) + DATA NRUNS/1/,INV/8/ + DATA NOUT/0/,NSPINS/1/ + DATA OVLF/0.0/,CHPERC/0.005/,NCUT/1/ +C DATA BOHRAD/.529177/ + DATA BOHRAD/1.0/ +C H-Ne,Na-Ca,Sc-Zn,Ga-Zr,Nb-Sn,Sb-Nd,Pm-Yb + DATA ALPHAP/.978,.773,.781,.768,.765,.759,.752,.744,.737,.731, + 1 .731,.729,.728,.727,.726,.725,.723,.722,.721,.720, + 1 .718,.717,.716,.714,.713,.712,.710,.709,.707,.707, + 1 .707,.707,.707,.706,.706,.706,.706,.705,.705,.704, + 1 .704,.704,.704,.704,.704,.704,.704,.704,.704,.704, + 1 .703,.703,.703,.703,.703,.703,.703,.703,.703,.703, + 1 .702,.702,.702,.702,.702,.702,.702,.702,.702,.702, + 1 30*.702/ + NWR1=' PCH' + NWR2=' PRT' +C +C Check whether complex potential will be used +C + IF (IEXCPOT.EQ.4.OR.IEXCPOT.EQ.5) THEN + DO 100 I=1,100 + ALPHAP(I)=0. +100 CONTINUE + END IF +C +C Ask whether an outer sphere is to be used. +C 13-APR-87 In this new version, the file is always generated with an o +C sphere. +C + OUTER=.TRUE. +C +C* * * * Open file and write header * * * * * * * +C + OPEN(UNIT=2,FILE='div/STRPARM.DAT',STATUS='UNKNOWN', + & FORM='FORMATTED') +C +C Write first line +C + WRITE(2,2000) NRUNS,INV +2000 FORMAT(2I5) +C +C Compute EXAFCO (EXAFCO is taken as the average of all alpha parametr +C and write second line. +C +C Correction for the presence of empty spheres: 27th Sept 2007 +C + NPA = 0 + EXAFCO=0. + DO 200 I=1,NATOMSM + NZAT = ZNUMBE(I) + IF(NZAT.NE.0) THEN + NPA = NPA + 1 + EXAFCO=EXAFCO+ALPHAP(NZAT) + ENDIF +200 CONTINUE + EXAFCO=EXAFCO/NPA + IF (OUTER) THEN + IITYPE=NTYPES+1 + IIATOM=NATOMSM+1 + NOUT=1 + ELSE + IITYPE=NTYPES + IIATOM=NATOMSM + NOUT=0 + END IF + WRITE(2,2010) IITYPE,IIATOM,NOUT,NWR1,NWR2,NSPINS,EXAFCO,OVLF, + 1 CHPERC,NCUT +2010 FORMAT(3I5,2A5,I5,3F10.5,I5) +C + EXAFCOM=DBLE(EXAFCO) + OVLFM=DBLE(OVLF) + CHPERCM=DBLE(CHPERC) +C +C* * * * * * Write outer sphere description if any * * * * +C + IF (OUTER) THEN + XV=0. + YV=0. + ZV=0. + ITYPE=0 + CALL GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) + IF (.NOT.OK) THEN + CLOSE(UNIT=2) + RETURN + END IF + EXFACT=EXAFCO + ZNBRE=0 + PROTO=.TRUE. + N = 1 + CALL WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) + END IF +C +C* * * * * * Write prototypical atom description * * * * * +C + DO 300 NTYPE=1,NTYPES + XV=XCOORD(NTYPE)/BOHRAD + YV=YCOORD(NTYPE)/BOHRAD + ZV=ZCOORD(NTYPE)/BOHRAD +C +C + CALL GRPNEI(NTYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) + IF (.NOT.OK) THEN + CLOSE(UNIT=2) + RETURN + END IF + ZNBRE=ZNUMBE(NTYPE) +C +C.......CHANGE FOR ES +C + IF(ZNBRE.EQ.0.D0) THEN + EXFACT=EXAFCO + ELSE + EXFACT=ALPHAP(ZNBRE) + ENDIF + PROTO=.TRUE. + N=NTYPE+1 + CALL WRIDAT(XV,YV,ZV,NTYPE,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) +300 CONTINUE +C +C* * * * * Write non prototypical atom description * * * * * * +C + IF (NATOMSM.GT.NTYPES) THEN + DO 400 I=NTYPES+1,NATOMSM + XV=XCOORD(I)/BOHRAD + YV=YCOORD(I)/BOHRAD + ZV=ZCOORD(I)/BOHRAD + ZNBRE=ZNUMBE(I) +C +C.......CHANGE FOR ES +C + IF(ZNBRE.EQ.0.D0) THEN + EXFACT=EXAFCO + ELSE + EXFACT=ALPHAP(ZNBRE) + ENDIF + CALL GRPNEI(I,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) + IF (.NOT.OK) THEN +C CLOSE(UNIT=2) + RETURN + END IF + PROTO=.FALSE. + N = I + 1 + CALL WRIDAT(XV,YV,ZV,I,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) +400 CONTINUE + END IF +C CLOSE (UNIT=2) +C +C * * * * * * * Create MOLSYM.COO * * * * * * * * +C +C Now we create a file called MOLSYM.COO which lists the coordinates +C and the number of each atom in the cluster, according to the +C FORMAT required by MOLSYM. This file will be used later on to +C make the input file of MOLSYM. In this file, the atoms must be +C ordered according to their group (all equivalent atoms must follow +C each other), and numbered according to the way their are declared +C in the input of MOLPOT. If an outer sphere is to be used, it must +C be declared to be atom number 1. +C According to the FORMAT required by MOLSYM, the atoms must +C be written in pairs. The logical variable DEUX is here to say +C that two atoms are available and it is time to write them. +C + OPEN(UNIT=2,FILE='div/molsym.coo',STATUS='unknown') +C*************************************************** +C*************************************************** + DEUX=.TRUE. +C**** IF (OUTER) THEN +C**** XX1=0. +C**** YY1=0. +C** ZZ1=0. +C** NN1=1 +C** DEUX=.FALSE. +C** END IF +C + X0 = XCOORD(1) + Y0 = YCOORD(1) + Z0 = ZCOORD(1) +C + DO 500 ITYPE=1,NTYPES + DO 500 I=1,NATOMSM +C +C Order atoms according to their groups +C + IF (GROUPN(I).EQ.ITYPE) THEN + IF (DEUX) THEN + XX1=XCOORD(I)/BOHRAD - X0 + YY1=YCOORD(I)/BOHRAD - Y0 + ZZ1=ZCOORD(I)/BOHRAD - Z0 +C*** IF (OUTER) THEN +C*** NN1=I+1 +C*** ELSE + NN1=I +C*** END IF + DEUX=.FALSE. + ELSE + XX2=XCOORD(I)/BOHRAD - X0 + YY2=YCOORD(I)/BOHRAD - Y0 + ZZ2=ZCOORD(I)/BOHRAD - Z0 +C*** IF (OUTER) THEN +C*** NN2=I+1 +C*** ELSE + NN2=I +C*** END IF + WRITE (2,3000) XX1,YY1,ZZ1,NN1,XX2,YY2,ZZ2,NN2 +3000 FORMAT(2(3F10.6,I5,5X)) + DEUX=.TRUE. + END IF + END IF +500 CONTINUE +C +C If the number of atoms written in the file (including possibly +C the outer sphere) is not even, there is an atom that is left +C to be written, so write it. In any case, close the file. +C + IF (.NOT.DEUX) THEN + WRITE (2,3010) XX1,YY1,ZZ1,NN1 +3010 FORMAT(3F10.6,I5,5X) + END IF + CLOSE (UNIT=2) + RETURN + END +C +C*********************************************************************** +C + SUBROUTINE GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) +C +C 9-dec-86 C.Brouder +C This subroutine finds the groups of neighbours of atom number ITYPE +C A group of neighbours of atom ITYPE is a set of all atoms +C at the same distance from atom ITYPE and belonging to the same group +C (i.e. equivalent to the same prototypical atom, i.e.having the same +C group number GROUPN). +C At the end, the groups of neigbours are sorted according to increasi +C distances. +C +C Arguments description : +C ITYPE # of atom (0 if outer sphere) whose neighbours +C are to be determined. +C XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms. +C GROUPN Array of the number of the group to which the +C atoms belong. (A group is a class of atoms equivalent +C by the symmetry operations of the symmetry group). +C NATOMSM Number of atoms +C NGBR Number of groups of neighbours +C NEIGHB # of an atom in the group of neigbours +C NUMNEI Number of atoms in the group of neighbours +C NEIMAX Maximum number of groups of neighbours. +C +C DISTAN Array of distances of neigbours +C EPSILO If the distances are smaller than EPSILO, they are +C supposed to be identical. +C +C********************************************************************* +C + INCLUDE 'msxas3.inc' +C + PARAMETER (NEIMAX=nat_) + REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS) + REAL DISTAN(NEIMAX) + INTEGER GROUPN(NATOMS),NEIGHB(NEIMAX),NUMNEI(NEIMAX) + LOGICAL OK,NEW + DATA EPSILO/1.E-5/ + NGBR=1 +C +C Initialize arrays +C + DO 100 I=1,NATOMSM + NEIGHB(I)=0 + NUMNEI(I)=0 +100 CONTINUE + IF (ITYPE.EQ.0) THEN + X0=0. + Y0=0. + Z0=0. + ELSE + X0=XCOORD(ITYPE) + Y0=YCOORD(ITYPE) + Z0=ZCOORD(ITYPE) + END IF +C +C Scan all other atoms +C + DO 200 I=1,NATOMSM + IF (I.NE.ITYPE) THEN +C +C Compute distance +C + NEW=.TRUE. + DISTAN(NGBR)=(XCOORD(I)-X0)*(XCOORD(I)-X0) + DISTAN(NGBR)=DISTAN(NGBR)+(YCOORD(I)-Y0)*(YCOORD(I)-Y0) + DISTAN(NGBR)=DISTAN(NGBR)+(ZCOORD(I)-Z0)*(ZCOORD(I)-Z0) + DISTAN(NGBR)=SQRT(DISTAN(NGBR)) + IF (NGBR.NE.1) THEN +C +C Check whether this distance already exists and the corresponding +C atom belongs to the same group. +C + DO 210 I2=1,NGBR-1 + IF ((ABS(DISTAN(I2)-DISTAN(NGBR)).LT.EPSILO).AND. + 1 (GROUPN(NEIGHB(I2)).EQ.GROUPN(I))) THEN + NEW=.FALSE. + NUMNEI(I2)=NUMNEI(I2)+1 + END IF +210 CONTINUE + END IF +C +C If it does not, this is a new group +C + IF (NEW) THEN + NUMNEI(NGBR)=1 + NEIGHB(NGBR)=I + NGBR=NGBR+1 + IF (NGBR.GT.NEIMAX) THEN + PRINT 4000 +4000 FORMAT(' Too many neighbours, increase NEIMAX in', + 1 ' subroutines GRPNEI and MOLDAT') + OK=.FALSE. + RETURN + END IF + END IF + END IF +200 CONTINUE + NGBR=NGBR-1 +C +C Order groups of neighbours according to increasing distances +C + DO 300 I=1,NGBR +C +C Look for the smallest remaining distance +C + DISMIN=1.E20 + IDISMI=I + DO 310 J=I,NGBR + IF (DISTAN(J).LT.DISMIN) THEN + DISMIN=DISTAN(J) + IDISMI=J + END IF +310 CONTINUE +C +C Transpose values +C + IF (IDISMI.NE.I) THEN + N1TEMP=NEIGHB(I) + N2TEMP=NUMNEI(I) + DTEMPO=DISTAN(I) + NEIGHB(I)=NEIGHB(IDISMI) + NUMNEI(I)=NUMNEI(IDISMI) + DISTAN(I)=DISTAN(IDISMI) + NEIGHB(IDISMI)=N1TEMP + NUMNEI(IDISMI)=N2TEMP + DISTAN(IDISMI)=DTEMPO + END IF +300 CONTINUE + RETURN + END +C +C*********************************************************************** +C + SUBROUTINE WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) +C +C This subroutine writes on file 2 the data collected by MOLDAT, +C for each atom. There are many cases to consider : the outer sphere +C (ITYPE=0), prototypical atoms (PROTO=.TRUE.), non prototypical atoms +C (PROTO=.FALSE.) and in the latter cases, the outputs are different +C if there is an outer sphere (OUTER=.TRUE.) or not. +C Variable description +C XV,YV,ZV Position +C ITYPE # of atom whose data are involved +C ZNBRE Z number of atom +C NGBR Number of neighbours +C EXFACT Alpha parametre +C GROUPN Group numbers +C NUMNEI Number of neighbours +C NEIGHB Example of neighbour +C NATOMSM Number of atoms +C OUTER .TRUE. if there is an outer sphere +C PROTO .TRUE. if this is a prototypical atom +C +C NSYMBL Symbol +C +C******************************************************************** +C + INCLUDE 'msxas3.inc' +C + REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM +C + COMMON/MOLINP/ + 1 EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM, + 1 NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_), + 1 NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 +C + PARAMETER (NEIMAX=nat_) + INTEGER GROUPN(NATOMS),ZNBRE + INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX) + LOGICAL PROTO,OUTER + CHARACTER*5 NWR1,NWR2 +C +C* * * * * * Initialize data * * * * * * * +C +C +C NEQ (0 if prototypical atom, NTYPE of prototypical atom otherwise +C + IF (PROTO) THEN + NEQ=0 + ELSE + IF (OUTER) THEN + NEQ=GROUPN(ITYPE)+1 + ELSE + NEQ=GROUPN(ITYPE) + END IF + END IF +C +C NTYPE (if outer sphere, outer sphere is number 1, so add 1 to +C all group numbers) +C + IF (PROTO) THEN + IF (OUTER) THEN + NTYPE=ITYPE+1 + ELSE + NTYPE=ITYPE + END IF + ELSE + NTYPE=NEQ + END IF +C +C* * * Initialize variables for subroutine molpot * * * +C + NGBRM(N)=NGBR + NTYPEM(N)=NTYPE + EXFCTM(N)=DBLE(EXFACT) +C +C* * * Initialize variables for subroutine molpot * * * +C + IF (PROTO) THEN + DO 300 K=1,NGBR + IF (OUTER) THEN + NATAN(K,N) = GROUPN(NEIGHB(K)) + 1 + NAT1(K,N) = NEIGHB(K) + 1 + ELSE + NATAN(K,N) = GROUPN(NEIGHB(K)) + NAT1(K,N) = NEIGHB(K) + ENDIF +300 NA(K,N) = NUMNEI(K) + ENDIF +C + RETURN + END +C +C*********************************************************************** +C + SUBROUTINE MOLPOT +C +C SPIN-RESTRICTED MOLECULAR POTENTIAL PROGRAM +C GENERATES SUPERPOSED-ATOM POTENTIAL USED TO START SCF CALCULATION +C + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + character*8 nsymbl +c.. +c common/dimens/nats,ndat,nout,lmaxx,irreps + common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), + u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), + u lmaxat(natoms) + common/aparms_extra/rs_(natoms),redf_(natoms),ovlf +c + integer trans + common/transform/trans(natoms) +C + COMMON/MOLINP/ + * EXFAC0,EXFACT(NAT_),OVLFM,CHPERC,NTYPES,NATOMSM, + * NGBR(NAT_),NTYPE(NAT_),NATAN(NAT_,UA_), + * NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 +C + COMMON/CRHOAT/ RO(441,UA_,1) +C + COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT +C + COMMON/MTRAD/ RS(NAT_) +C + COMMON/STRUCT/NTNABS(NAT_),NGBRABS +C + DIMENSION R(441,UA_),V(441,1),RV(441,UA_),Q(441),ALPHA(441), + 1 BETA(441),GAMMA(441,1),SNLO(441),XI(441),XJ(441), + 2 ZPALPH(441),ROTOTL(441,1),ROT(441) +C + DIMENSION ZM(NAT_),NZM(NAT_),NIMAX(NAT_),AN(NAT_,NAT_), + * FAC2(NAT_),RSC(NAT_) +C + CHARACTER*5 NWR1,NWR2 +C +c DATA PI/3.14159265358979/ +c DATA PI4/12.56637061435916/,THIRD/.333333333333333/ +C + LOGICAL SKIP + PI=3.14159265358979D0 + PI4=12.56637061435916D0 + THIRD=.333333333333333D0 + NRUNS = 1 + DO 999 IRUNS=1,NRUNS +1002 FORMAT(15I5) + SKIP=.FALSE. +C +C.....MOUT: CONTROLS THE OUTPUT OF PROGRAM INPOT. IF MOUT=1 THIS +C..... OUTPUT WILL CONTAIN THE OUTER SPHERE. IF MOUT=0 IT +C..... WILL NOT. THIS VERSION INITIALIZED TO MOUT=0 +C.....0VLF: THIS IS THE OVERLAP FACTOR FOR THE MUFFIN-TIN RADII +C..... DEFAULT=0.1 IN SUBROUTINE MOLDAT +C.....CHPERC: THIS IS THE PERCENTAGE OF ATOMIC CHARGE INSIDE THE +C..... ATOMIC SPHERES WHEN APPLYING NORMAN CRITERIUM +C..... DEFAULT=0.005 IN SUBROUTINE MOLDAT +C + MOUT=0 + NOUT=1 + NSPINS=1 + NSAT=1 + NCUT=1 + FAC1=NSPINS + NDAT=NATOMSM + OPEN (UNIT=7,FILE='div/molinpot3.out',STATUS='unknown') + DO 43 N=1,NATOMSM +C READ(5,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N), +C 1 EXFACT(N) + 1001 FORMAT(1X,A8,3I5,4F10.6) + WRITE(7,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N), + 1 EXFACT(N) + FAC2(N)=6.D0*EXFACT(N)*(FAC1*3.D0/(32.D0*PI*PI))**THIRD + IF(NEQ(N).NE.0) GO TO 443 + NGBRS=NGBR(N) +C READ(5,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS) +C NATAN=TYPE OF NEIGHBOR NA=NUMBER OF ATOMS IN GROUP NAT1=LABEL OF +C ONE OF THE NEIGHBORS +C + WRITE(7,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS) + IF(SKIP) GO TO 4511 + GO TO 43 + 4511 WRITE(7,1045) + 1045 FORMAT(' DIFFERENT ATOMS MUST COME FIRST') + SKIP=.FALSE. + GO TO 43 + 443 IF(SKIP) GO TO 43 + SKIP=.TRUE. + NDAT=N-1 + 43 CONTINUE +C +C AN(I,N): DISTANCE OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I +C + WRITE(7,*) + WRITE(7,*) 'DIST. OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I' + ANMAX = 0.0D0 + DO 44 N=1,NDAT + ANPR=0.0D0 + NGBRS=NGBR(N) + IF(N.EQ.2) NGBRABS=NGBRS + DO 44 I=1,NGBRS + NT = NATAN(I,N) + IF(N.EQ.2) NTNABS(I)=NT-1 +C write(6,*) i,nt,ntnabs(i),ngbrabs + NB=NAT1(I,N) + AN(I,N)=DSQRT((XV(NB)-XV(N))**2+(YV(NB)-YV(N))**2+(ZV(NB)-ZV(N))** + 1 2) + WRITE(7,*) N, NT, AN(I,N) + IF(I.EQ.1) THEN + ANPR=AN(I,N) + GO TO 440 + ENDIF + IF(AN(I,N).LT.ANPR) THEN + WRITE(7,30) I,N + 30 FORMAT(' **WARNING** : NEIGHBOR OF TYPE',I3,' TO ATOM',I3, + * ' NOT ARRANGED IN ASCENDING ORDER OF DISTANCE') +C +C CALL EXIT +C + ENDIF + 440 IF(N.NE.1) GO TO 44 + IF(AN(I,N).GT.ANMAX) ANMAX = AN(I,N) + 44 CONTINUE + SKIP=NOUT.NE.0 + WRITE(7,104) NATOMSM,NDAT,FAC1 + 104 FORMAT(30X,I3,7H ATOMS,,I3,17H DIFFERENT, FAC1=,F11.7) + WRITE(7,105) (NSYMBL(N),NEQ(N),XV(N),YV(N),ZV(N),EXFACT(N),N=1, + 1 NATOMSM) + 105 FORMAT(//28X,6HSYMBOL,4X,2HEQ,5X,1HX,11X,1HY,11X,1HZ,7X,6HEXFACT + 1 /(30X,A5,I6,4F11.7)) + DO 1 N=1,NTYPES + IF(SKIP) GO TO 89 + WRITE(7,2002) NZEQ(N),NSAT + 2002 FORMAT(6I4) + KMAX=441 + ZM(N)=NZEQ(N) + NZM(N)=NZEQ(N) + TZ=2.D0*ZM(N) + GO TO 90 + 89 DELTAR=.88534138D0*.0025D0 + NZM(1)=1 + GO TO 91 + 90 IF(ZM(N).EQ.0.D0) THEN + DELTAR=.88534138D0*.0025D0 + ELSE + DELTAR=.88534138D0*.0025D0/ZM(N)**THIRD + ENDIF + 91 I=1 + R(1,N)=0.D0 + DO 87 J=1,11 + DO 88 K=1,40 + I=I+1 + 88 R(I,N)=R(I-1,N)+DELTAR + 87 DELTAR=2.0D0*DELTAR + IF(SKIP) GO TO 49 + DO 52 K=1,441 + 52 ROT(K)=RO(K,N,1) + CALL MINTEGR(ROT,XI,R(1,N),441) + Q(1)=0.D0 + DO 10 I=2,441 + 10 Q(I)=ROT(I)/R(I,N) + CALL MINTEGR(Q,XJ,R(1,N),441) +C +C RV=R*( COULOMB POTENTIAL ) +C + DO 12 I=1,441 + 12 RV(I,N)=-TZ+2.D0*(XI(I)+R(I,N)*(XJ(441)-XJ(I))) + IF(NSPINS.EQ.1.AND.ZM(N).NE.0) + 1 WRITE(7,101) N,(I,R(I,N),RV(I,N),ROT(I),XI(I),I=1,KMAX) + 101 FORMAT(1H1,40X,22HATOMIC DATA FOR CENTER,I3,4X,/, + & 2(9X,1HR,15X,2HRV, + 1 14X,3HRHO,11X,6HCHARGE,3X),/,2(I4,1P4E15.6)) + GO TO 1 + 49 DO 50 J=1,441 + 50 RV(J,N)=0.D0 + 1 SKIP=.FALSE. + IF(NWR1.NE.' PCH') GO TO 1041 + OPEN (UNIT=4,FORM='UNFORMATTED',STATUS='unknown') + REWIND(4) + WRITE(4) NATOMSM,NDAT,NOUT,EXFAC0,NSPINS + KC=2 + 1041 DO 1000 M=1,NDAT + N=NTYPE(M) + NZM(M)=NZM(N) + NIMAX(M)=441 + IF(M.EQ.1.AND.NOUT.NE.0) GO TO 450 + DO 1043 J=1,441 + IF(R(J,N).LT.AN(1,M)) GO TO 1043 + NIMAX(M)=J + GO TO 450 + 1043 CONTINUE + 450 NBRS=NGBR(M) + IMAX=NIMAX(M) + DO 600 I=1,441 + ZPALPH(I)=0.D0 + BETA(I)=0.D0 + DO 600 ISPIN=1,NSPINS + ROTOTL(I,ISPIN)=0.D0 + 600 GAMMA(I,ISPIN)=0.D0 + DO 45 I=1,NBRS + MVAL=NATAN(I,M) + IF(NOUT.NE.0.AND.MVAL.EQ.1) GO TO 45 +C +C ITH SET OF NEIGHBORS TO CENTER M +C N IS TYPE OF CENTER M +C MVAL IS THE TYPE OF ITH SET OF NEIGHBORS TO CENTER M +C + IF(AN(I,M).GT..00001D0) GO TO 650 +C +C FOR A CENTER COINCIDING WITH THE MOLECULAR CENTER +C AVERAGE VALUES ARE EQUAL TO THE VALUES AT THE POINT +C + DO 652 J=2,IMAX + CALL MINTERP(R(J,N),RV(1,MVAL),XVAL,R(1,MVAL)) + ZPALPH(J)=ZPALPH(J)+NA(I,M)*XVAL + BETA(J)=BETA(J)-0.5D0*XVAL*NA(I,M)*R(J,N)**2 + DO 652 ISPIN=1,NSPINS + CALL MINTERP(R(J,N),RO(1,MVAL,ISPIN),XVAL,R(1,MVAL)) + ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*XVAL/R(J,N) + 652 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)-0.5D0*XVAL*NA(I,M)*R(J,N) + DO 451 ISPIN=1,NSPINS + CALL MINTEGR(RO(1,MVAL,ISPIN),SNLO,R(1,MVAL),441) + DO 451 J=1,441 + CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL)) + XJ(J)=R(J,MVAL)*RV(J,MVAL) + 451 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*XVAL + CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) + DO 452 J=1,441 + CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL)) + 452 BETA(J)=BETA(J)+NA(I,M)*XVAL + GO TO 45 +C +C FOR SEPARATED CENTERS CALCULATE SPHERICAL AVERAGES AROUND CENTER M +C + 650 CALL MINTEGR(RV(1,MVAL),SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL) + DO 65 J=2,IMAX + 65 ZPALPH(J)=NA(I,M)*ALPHA(J)+ZPALPH(J) + Q(1)=0.D0 +C +C SPHERICAL AVERAGE CHARGE DENSITY +C + DO 95 ISPIN=1,NSPINS + DO 901 J=2,441 + 901 Q(J)=RO(J,MVAL,ISPIN)/R(J,MVAL) + CALL MINTEGR(Q,SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL) + DO 95 J=2,IMAX + 95 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*ALPHA(J) + IF(N.NE.1.OR.NOUT.EQ.0) GO TO 45 + XJ(1)=0.D0 +C +C TOTAL CHARGE FOR OUTER SPHERE +C + DO 37 ISPIN=1,NSPINS + DO 36 J=2,441 + 36 XJ(J)=-RO(J,MVAL,ISPIN)*(R(J,MVAL)-AN(I,M))**2/R(J,MVAL) + CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,Q,R,441,N,MVAL) + CALL MINTEGR(RO(1,MVAL,ISPIN),XJ,R(1,MVAL),441) + DO 37 J=2,441 + CALL MINTERP(R(J,N)-AN(I,M),XJ,XVAL,R(1,MVAL)) + 37 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*(XVAL+0.5D0*Q(J)) +C +C INTEGRATED POTENTIAL FOR OUTER SPHERE +C + XI(1)=0.D0 + XJ(1)=-RV(1,MVAL)*AN(I,M)**2 + DO 46 J=2,441 + XI(J)=RV(J,MVAL)*R(J,MVAL) + 46 XJ(J)=-RV(J,MVAL)*(R(J,MVAL)-AN(I,M))**2 + CALL MINTEGR(XI,Q,R(1,MVAL),441) + CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,441,N,MVAL) + DO 47 J=2,441 + CALL MINTERP(R(J,N)-AN(I,M),Q,XVAL,R(1,MVAL)) + 47 BETA(J)=BETA(J)+NA(I,M)*(XVAL+0.5D0*ALPHA(J)) + 45 CONTINUE + IF(N.NE.1.OR.NOUT.EQ.0) GO TO 2003 + DO 2005 J=1,IMAX + BETA(J)=(BETA(J)+0.5D0*ZPALPH(J)*R(J,N)**2)*PI4 + DO 2005 ISPIN=1,NSPINS + ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N) + 2005 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+0.5D0*ROTOTL(J,ISPIN)*R(J,N) + GO TO 112 +C +C INTEGRATED POTENTIAL AND TOTAL CHARGE FOR MUFFIN-TIN SPHERE +C GAMMA(I,ISPIN) IS TOTAL INTEGRATED CHARGE, BETA(I) IS INTEGRATED +C POTENTIAL, ZPALPH(I) IS R*VCOULOMB CALCULATED WITH PROJECTED +C DENSITY +C + 2003 DO 2001 J=1,IMAX + ZPALPH(J)=ZPALPH(J)+RV(J,N) + Q(J)=PI4*R(J,N)*ZPALPH(J) + DO 2001 ISPIN=1,NSPINS + 2001 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N)+RO(J,N,ISPIN) + DO 2004 ISPIN=1,NSPINS + 2004 CALL MINTEGR(ROTOTL(1,ISPIN),GAMMA(1,ISPIN),R(1,N),IMAX) + CALL MINTEGR(Q,BETA,R(1,N),IMAX) + 112 DO 111 ISPIN=1,NSPINS + V(1,ISPIN)=0 + DO 111 J=2,IMAX +C +C VC(J) = ZPALPH(J)/R(J,N) +C + 111 V(J,ISPIN)=(ZPALPH(J)-FAC2(M)*(R(J,N)*DABS(ROTOTL(J,ISPIN)))**THIR + 1D)/R(J,N) +C +C...FIND RADIUS CONTAINING THE ATOMIC NUMBER OF ELECTRONS WITHIN CHPERC +C + RSC(M) = AN(1,M)/2.D0 + IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 14 + IF(NZM(M).EQ.0) GO TO 14 + DO 13 I=1,IMAX +C IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 13 + CHPCI=(ZM(M)-GAMMA(I,1))/ZM(M) + IF(CHPCI.GT.CHPERC)GO TO 13 + RSC(M) = R(I,M) + GO TO 14 + 13 CONTINUE + 14 IF(NWR2.NE.' PRT') GO TO 1032 + WRITE(7,6)M + 6 FORMAT(1H1,35X,11HATOM NUMBER,I6) + WRITE(7,7) (NA(I,M),NATAN(I,M),AN(I,M),I=1,NBRS) + 7 FORMAT(/ 23H NO. OF CENTERS TYPE,7X,8HDISTANCE/(5X,I4,10X,I + 1 4,F17.8)) + IF(NSPINS.EQ.1) WRITE(7,9)(J,R(J,N),ZPALPH(J),BETA(J),GAMMA(J,1),V + 1 (J,1),ROTOTL(J,1),J=1,IMAX) + 9 FORMAT(16X,1HR,16X,6HZPALPH,5X,20HINTEGRATED POTENTIAL,7X,12HTOTAL + 1 CHARGE,13X,1HV,18X,3HRHO/(I4,6E20.8)) + 1032 IF(NWR1.NE.' PCH') GO TO 1000 + NIMAX(M)=NIMAX(M)-1 + WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M), + 1 ZV(M),EXFACT(M),KC + KC=KC+1 + DO 1014 ISPIN=1,NSPINS + DO 1014 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,( V(I,ISPIN),I=K,KCARD) + 1014 KC=KC+1 +C DO 1020 K=2,IMAX,5 +C KCARD=MIN0(IMAX,K+4) +C WRITE(4,1015) KC,( VC(I),I=K,KCARD) +C 1020 KC=KC+1 + DO 2214 ISPIN=1,NSPINS + DO 2214 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,(ROTOTL(I,ISPIN) ,I=K,KCARD) + 2214 KC=KC+1 + DO 1016 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,(BETA(I),I=K,KCARD) + 1016 KC=KC+1 + DO 1019 ISPIN=1,NSPINS + DO 1019 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,(GAMMA(I,ISPIN) ,I=K,KCARD) + 1019 KC=KC+1 + 1000 CONTINUE +C + WRITE(7,*) 'CHECKING MUFFIN-TIN RADII' + IF(OPTRSH.EQ.'y') THEN + WRITE(6,*) ' MT radii for Hydrogen atoms set to rsh' + WRITE(7,*) ' MT radii for Hydrogen atoms set to rsh =', RSH + ELSE + WRITE(6,*) ' MT radii for Hydrogen atoms determined by stdcrm', + & ' unless other options are specified' + WRITE(7,*) ' MT radii for Hydrogen atoms determined by stdcrm', + & ' unless other options are specified' + ENDIF + WRITE(7,*) ' M, Z(M), MN, Z(MN), AN(MN,M),', + & ' RSC(M), RSC(MN), RS(M), RS(MN)' +C +C FIND MUFFIN-TIN RADIUS FOR PAIR IJ ACCORDING TO NORMAN CRITERIUM (STDCRM) +C + DO 18 M=1,NDAT + IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 18 + NBRS=NGBR(M) + IF(NZM(M).NE.0) THEN + DO NG = 1, NBRS + MN=NATAN(NG,M) + IF(NZM(MN).NE.0) GO TO 191 + ENDDO +191 RS(M)=AN(NG,M)*(1.D0+OVLF)/(1.D0+RSC(MN)/RSC(M)) +C +C IF OPTRSH='y' MT RADIUS FOR H ATOMs SET TO RSH IN INPUT ! Added 16 Jul 2013 +C + IF(NZM(M).EQ.1.AND.OPTRSH.EQ.'y') THEN + WRITE(6,*) ' MT radius', RS(M),' for H atom', M, + & ' set to', RSH + RS(M) = RSH + ENDIF + WRITE(7,190) M, NZM(M), MN, NZM(MN), AN(NG,M), + & RSC(M), RSC(MN), RS(M), RS(MN) + GO TO 18 + ENDIF + MN = NATAN(1,M) + IF (NZM(MN).EQ.0.D0) THEN + RS(M) = AN(1,M)*(1.D0+OVLF)/2.D0 + ELSE + RS(M) = (AN(1,M)-RS(MN))*(1.D0+OVLF) + ENDIF + WRITE(7,190) M, NZM(M), MN, NZM(MN), AN(1,M), + & RSC(M), RSC(MN), RS(M), RS(MN) +190 FORMAT(4I5, 5F10.5) + IF(NORMAN.EQ.'stdfac'.OR.NORMAN.EQ.'scaled') + *RS(M)=REDF_(M)*RSC(M) + 18 CONTINUE + IF(NOUT.EQ.1) RS(1) = ANMAX + RS(NDAT) + IF(NDAT.EQ.NATOMSM) GO TO 5001 + NDAT1=NDAT+1 + DO 221 M=NDAT1,NATOMSM + NZM(M)= NZM(NEQ(M)) + RS(M)= RS(NEQ(M)) + NIMAX(M)=0 + WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M), + 1 ZV(M),EXFACT(M),KC + 221 KC=KC+1 + 5001 CONTINUE + IF (NORMAN.EQ.'extrad') THEN + RS(1) = ANMAX + RS_(NDAT) + DO 5002 M=2,NATOMSM + 5002 RS(M)=RS_(M) + END IF + IF (NORMAN.NE.'extrad') THEN + WRITE(6,*) + WRITE(6,5003) + 5003 FORMAT(1X,65('-')) + WRITE(6,*) ' i rs(i) i=1,natoms ' + WRITE(6,5004) (I, RS(I), I=1,NATOMSM) + WRITE(6,*) ' N.B.: Order of atoms as reshuffled by', + * ' symmetry routines ' + 5004 FORMAT(8(I5,1X,F7.2)) + WRITE(6,5003) + WRITE(6,*) + END IF + IF(NWR1.NE.' PCH') GO TO 999 + WRITE(7,*) + WRITE(7,*) ' Radion, qion, ncut, rs(i), i=1,nat' + WRITE(7,19) RADION,QION,NCUT,(RS(M),M=1,NATOMSM) + 19 FORMAT(/,1X,2F10.5,I5/(8F10.5),//) + 999 CONTINUE +C + REWIND(4) +C + RETURN + END +C +CLAGRNG + SUBROUTINE LAGRNG(F,LPLACE,B,RES) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION F(4),B(4) + RES=0.D0 + DO 5 N=1,4 + M=LPLACE-2+N + 5 RES=RES+B(N)*F(M) + RETURN + END +CBSET + SUBROUTINE BSET(PINTRP,B) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION B(4) + PM=PINTRP*(PINTRP**2-1.D0)*(PINTRP-2.D0) + B(1)=-PM/(6.D0*(PINTRP+1.D0)) + B(2)= PM/(2.D0*PINTRP) + B(3)=-PM/(2.D0*(PINTRP-1.D0)) + B(4)= PM/(6.D0*(PINTRP-2.D0)) + RETURN + END +CINTERP +C L.F. MATTHEISS SUBROUTINE INTERP(B,X1,M2,D,R) +C B IS THE RADIAL DISTANCE +C X1 IS THE INTEGRATED FUNCTION +C D IS THE INTERPOLATED VALUE OF THE INTEGRAL FROM 0 TO B. +C R IS THE RADIAL MESH +C + SUBROUTINE MINTERP(B,X1,D,R) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION X1(441),R(441),B1(4),C(4) + IF(B-R(2 ))10,11,12 + 10 D=0.0D0 + GOTO 100 + 11 D=X1(2) + GOTO 100 + 12 IF(B-R(440 ))15,14,13 + 13 D=X1(441) + GOTO 100 + 14 D=X1(440) + GOTO 100 + 15 DO 22 I=1,441 + L=441+1-I + IF(R(L)-B) 23,24,22 + 22 CONTINUE + 23 LPLACE=L + DO 29 N=1,11 + ISCALE=41+40*(N-1)-LPLACE + IF(ISCALE)25,46,25 + 25 IF(ISCALE-1)29,48,29 + 29 CONTINUE + B1(1)=X1(LPLACE-1) + B1(2)=X1(LPLACE) + B1(3)=X1(LPLACE+1) + B1(4)=X1(LPLACE+2) + H=R(LPLACE+1 )-R(LPLACE ) + 50 PINTRP=(B-R(LPLACE ))/H + 51 CALL BSET(PINTRP,C) + CALL LAGRNG(B1,2,C,D) + 100 RETURN + 24 D=X1(L) + RETURN + 46 B1(1)=X1(LPLACE-2) + B1(2)=X1(LPLACE) + B1(3)=X1(LPLACE+1) + B1(4)=X1(LPLACE+2) + H=R(LPLACE+1 )-R(LPLACE ) + GOTO 50 + 48 B1(1)=X1(LPLACE-3) + B1(2)=X1(LPLACE-1) + B1(3)=X1(LPLACE+1) + B1(4)=X1(LPLACE+2) + H=R(LPLACE+2 )-R(LPLACE+1 ) + PINTRP=(B-R(LPLACE-1 ))/H + GO TO 51 + END +CINTEGR +C SIMPSON'S RULE INTEGRATION +C + SUBROUTINE MINTEGR(X,Y,R,M2) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION X(441),Y(441),R(441) + H=R(2) + Y(1)=0.D0 + Y(2)=H*(5.D0*X(1 )+8.D0*X(2 )-X(3 ))/12.D0 + DO 20 J=1,11 + DO 10 K=1,40 + I=40*(J-1)+K + IF(I.GT.M2) RETURN + IF(I-440) 5,10,10 + 5 Y(I+2)=Y(I)+H*(X(I )+4.D0*X(I+1 )+X(I+2 ))/3.D0 + 10 CONTINUE + H=H+H + IF (I-440) 15,20,15 + 15 Y(I+2)=Y(I+1)+H*(5.D0*X(I+1 )+8.D0*X(I+2 )-X(I+3 ))/12.D0 + 20 CONTINUE + RETURN + END +CALPHAO +C L.F. MATTHEISS SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2) +C AP IS THE DISTANCE OF THE NEIGHBORING ATOM +C ZINT IS THE INDEFINITE INTEGRAL +C ALPHA IS A TABLE OF THE DESIRED ALPHA FUNCTIONS +C R IS THE RADIAL DISTANCE +C IMAX IS THE NUMBER OF ALPHA FUNCTIONS TO BE COMPUTED +C M1 IS THE ATOM NO. AT THE ORIGIN +C M2 IS THE ATOM NO. AT AP +C + SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2) +C + IMPLICIT REAL*8(A-H,O-Z) +C + include 'msxas3.inc' +C + DIMENSION ZINT(441),ALPHA(441),R(441,UA_) + DO 100 I=2,IMAX + APLUSR=AP+R(I,M1) + AMINSR=DABS(AP-R(I,M1)) + CALL MINTERP(APLUSR,ZINT,XVAL1,R(1,M2)) + CALL MINTERP(AMINSR,ZINT,XVAL2,R(1,M2)) + ALPHA(I)=(XVAL1-XVAL2)/(2.0D0*AP) + 100 CONTINUE + RETURN + END +C + SUBROUTINE INPOT +C + IMPLICIT REAL*8 (A-H,O-Z) +C + INCLUDE 'msxas3.inc' +C + character*2 potgen + character*4 coor + character*5 potype + character*7 ionzst + character*2 edge,charelx + character*6 norman + integer absorber,hole + logical*4 vinput + + + common/options/rsh,ovlpfac,vc0,rs0,vinput,absorber,hole,mode, + & ionzst,potype,norman,coor,charelx,edge,potgen + +C +C**** CONT_SUB DIMENSIONING VARIABLES +C + INTEGER AT_,D_,RD_,SD_ + PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) +C +C**** +C + COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT +C + COMMON/MTRAD/ RS(NAT_) +C + DIMENSION XV(NAT_),YV(NAT_),ZV(NAT_),Z(NAT_),NEQ1(NAT_), + 1EXFACT(NAT_),NZ(NAT_),NSYMBL(NAT_),NEQ(NAT_),H(NAT_), + 2VCONS(2),R(441,UA_),V(441,UA_),ICHG(10,UA_),KPLACE(NAT_), + 3KMAX(NAT_),VINT(UA_),CHARGE(UA_,2),ROCON(2),RHO(441,UA_) +C 4,VC(441,UA_) +C + DIMENSION RTEMP(440),VTEMP(441,2),GAMMA(440,2),DENSTEMP(441,2) + EQUIVALENCE (VTEMP(1,1),BETA(1)),(ROTEMP(1,1),GAMMA(1,1)) + DIMENSION BETA(440),ROTEMP(440,2) +C DIMENSION VCTEMP(441) +C +C +CC**** CONT_SUB COMMON BLOCKS +C + COMMON /DENS/ IRHO2,RHOTOT2(RD_,SD_),RHOINT2(2), + $ vcoul(rd_,sd_),vcoulint(2) + REAL*4 RHOTOT2,RHOINT2,vcoul,vcoulint +C + COMMON /FCNR/KXE2, H2(D_),VCONS2(2),R2(RD_,D_),V2(2,RD_,SD_), + $ ICHG2(10,D_),KPLACE2(AT_),KMAX2(AT_) + REAL*4 H2,R2,V2 + COMPLEX VCONS2 +C + COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, + 1 IMVHL,NEDHLP +C + CHARACTER*8 NAME0 ,NSYMBL2 +C + REAL*4 EFTR2,GAMMA2,E2,RS2,XV2,YV2,ZV2 + REAL*4 EXFACT2,Z2,CIP,EMAX,EMIN,DE + COMPLEX VCON2,XE2,EV2 + COMMON/PARAM/EFTR2,GAMMA2,VCON2,XE2,EV2,E2,IOUT2,NAT2, + 1 NDAT2,NSPINS2,NAS2,RS2(AT_),XV2(AT_),YV2(AT_),ZV2(AT_), + 2 EXFACT2(AT_),Z2(AT_),LMAXX2(AT_),NZ2(AT_),NSYMBL2(AT_), + 4 NEQ2(AT_),NAME0,CIP,EMAX,EMIN,DE +C +C ############MODIFIED TO INCLUDE THE TWO CORE STATE WAVE FUNCTIONS +c ############FOR THE AUGER CALCULATION +c + common/pot_type/i_absorber,i_absorber_hole, + 1 i_absorber_hole1,i_absorber_hole2, + 2 i_norman,i_alpha,i_outer_sphere, + 3 i_exc_pot,i_mode + + + + + + +C +C***** +C +C + CHARACTER*8 NSYMBL +C + DATA PI/3.14159265358979D0/,THIRD/.333333333333333D0/ +C +C FORMAT FOR ALL FUNCTIONS OF RADIAL MESH POINTS +C FORMAT FOR ERROR MESSAGE IF INPUT CARD IS OUT OF ORDER +C + 400 FORMAT(' CARD',I5,' OUT OF SEQUENCE') + LOGICAL OUTER + READ(4) NAT,NDAT,NOUT,EXFAC0,NSPINS +C READ(10,8853)RADION,QION,NCUT,MOUT + + + IF(NCUT.EQ.0) NCUT=2 +C READ(10,8854)(RS(I),I=1,NAT) + IF (NAT.EQ.0) STOP 4602 + FAC1=NSPINS + IF(NOUT.EQ.0) WRITE(7,110) NAT + ROCON(2)=0 + ROCON(1)=0 + VCON=0.0D0 + IN = 0 +C +C IN=1 SECTION. INPUT DATA FROM MOLECULAR POTENTIAL PROGRAM +C + IF (IN.GT.1) GO TO 4300 + NC0=1 + 113 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,26H OUTER SPHERE AT CENTE + *R 1 ) + 110 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,17H NO OUTER SPHERE) + IF(NOUT.NE.0) WRITE(7,113)NAT + WRITE(7,8852)NCUT,RADION,QION +8852 FORMAT(30X,'NCUT=',I3,' RADION=',F7.3,' QION=', F7.1) + VOLUME=0.0D0 + DO 422 N=1,NAT + OUTER=NOUT.NE.0.AND.N.EQ.1 + READ(4) NSYMBL(N),NEQ(N),NZ(N),KMAX(N),XV(N),YV(N), + U ZV(N),EXFACT(N),NC + IF(NC.EQ.NC0+1) GO TO 423 + WRITE(7,400) NC + 423 NC0=NC + Z(N)=NZ(N) + IF(NEQ(N).NE.0) GO TO 439 + KMAXN=KMAX(N) + KMAXL=KMAXN +C +C CALCULATE RADIAL MESH FOR INPUT DATA +C + ZINO=Z(N) + IF(NZ(N) .EQ. 0) ZINO=1.D0 + HH=.0025D0*.88534138D0/ZINO**THIRD + RTEMP(1)=HH + KK=1 + K0=2 + DO 4285 I=1,11 + DO 4286 K=K0,40 + KK=KK+1 + IF(KK.GT.KMAXN) GO TO 1014 + 4286 RTEMP(KK)=RTEMP(KK-1)+HH + K0=1 + 4285 HH=2.0D0*HH + 1014 DO 1020 ISPIN=1,NSPINS +C +C READ STARTING POTENTIAL +C + DO 1019 K=1,KMAXN,5 + KCARD=MIN0(K+4,KMAXN) + READ(4) NC,( VTEMP(I,ISPIN),I=K,KCARD) + IF(NC.EQ.NC0+1) GO TO 1019 + WRITE(7,400) NC + 1019 NC0=NC + 1020 CONTINUE +C DO 1200 K=1,KMAXN,5 +C KCARD=MIN0(K+4,KMAXN) +C READ(4,1015) NC,( VCTEMP(I),I=K,KCARD) +C IF(NC.EQ.NC0+1) GO TO 1200 +C WRITE(7,400) NC +C ERROR=.TRUE. +C 1200 NC0=NC + DO 2720 ISPIN=1,NSPINS +C +C READ STARTING CH[AARGE DENSITY +C + DO 2723 K=1,KMAXN,5 + KCARD=MIN0(K+4,KMAXN) + READ(4) NC,(DENSTEMP(I,ISPIN),I=K,KCARD) + IF(NC.EQ.NC0+1) GO TO 2723 + WRITE(7,400) NC + 2723 NC0=NC + 2720 CONTINUE +C +C CONVERT INPUT DATA TO FORM FOR MOLECULAR CALCULATION +C + KMIN=1 + 428 KPL=(KMAXN+KMIN)/2 + IF(RTEMP(KPL)-RS(N)) 424,434,426 + 424 KMIN=KPL + IF(KMAXN-KMIN-1) 427,427,428 + 426 KMAXN=KPL + IF(KMAXN-KMIN-1) 427,427,428 + 427 KPL=KMIN + 434 KPL0=KPL + N40=40/NCUT + KPL=KPL/NCUT + IF(RTEMP(KPL*NCUT+NCUT)+RTEMP(KPL*NCUT)-2.D0*RS(N)) 429,430,430 + 429 KPL=KPL+1 + 430 IF(OUTER) GO TO 433 + KMAX(N)=KPL+3 + KMAXN=KMAX(N) + NMOD=MOD(KMAXN,N40) + IF(NMOD.GE.5.OR.NMOD.EQ.0) GO TO 431 + KMAXN=KMAXN-NMOD + 431 ICHGN=KMAXN + DO 432 K=1,KMAXN + KN=NCUT*K + R(K,N)=RTEMP(KN) + NS=N + DO 4320 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 4320 NS=NS+NDAT + 432 CONTINUE + IF(KMAXN.EQ.KMAX(N)) GO TO 441 + KX1=KMAXN+1 + KMAXN=KMAX(N)+1 + IF(NCUT.EQ.1) GO TO 435 + DO 436 K=KX1,KMAXN + KN=(KX1+K-1)*NCUT/2 + R(K,N)=RTEMP(KN) + NS=N + DO 4360 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 4360 NS=NS+NDAT + 436 CONTINUE + GO TO 440 + 435 DO 437 K=KX1,KMAXN + KN=(KX1+K-1)/2 + IF(2*((K-KX1+1)/2).EQ.(K-KX1+1)) GO TO 438 + R(K,N)=.5D0*(RTEMP(KN)+RTEMP(KN+1)) + NS=N + DO 4310 IS=1,NSPINS + CALL DINTERP(RTEMP(KN-3),VTEMP(KN-3 ,IS),7,R(K,N),V(K,NS),DUMMY, + 1 .FALSE.) +C CALL DINTERP(RTEMP(KN-3),VCTEMP(KN-3 ),7,R(K,N),VC(K,NS),DUMMY, +C 1 .FALSE.) + CALL DINTERP(RTEMP(KN-3),DENSTEMP(KN-3 ,IS),7,R(K,N), + 1 RHO(K,NS),DUMMY,.FALSE.) + 4310 NS=NS+NDAT + GO TO 437 + 438 R(K,N)=RTEMP(KN) + NS=N + DO 4311 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 4311 NS=NS+NDAT + 437 CONTINUE + 440 IF( ABS(R(KPL,N)-RS(N)).LE. ABS(R(KPL+1,N)-RS(N))) GO TO 441 + KPL=KPL+1 + KMAX(N)=KMAX(N)+1 + 441 KPLACE(N)=KPL + ICHG(1,N)=N40 + DO 443 K=2,10 + ICHG(K,N)=ICHG(K-1,N)+N40 + IF(ICHG(K,N).GE.ICHGN) ICHG(K,N)=400/NCUT + 443 CONTINUE + GO TO 448 +C +C.....FOR OUTER REGION +C + 433 KMIN=(KPL-3)*NCUT + KMAX(N)=MIN0((440/NCUT-KPL+4),200) + ICHG(1,N)=(40-MOD(KMIN,40))/NCUT+1 + ICHGN=1 + IF(ICHG(1,N).GT.4) GO TO 444 + ICHGN=ICHG(1,N)-1 + DO 445 K=1,ICHGN + KN=KMIN+NCUT*(2*K-ICHG(1,N)-1) + R(K,N)=RTEMP(KN) + NS=N + DO 445 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 445 NS=NS+NDAT + ICHG(1,N)=ICHG(1,N)+N40 + ICHGN=ICHGN+1 + 444 KMAXN=KMAX(N) + DO 446 K=ICHGN,KMAXN + KN=KMIN+(K-1)*NCUT + R(K,N)=RTEMP(KN) + NS=N + DO 446 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 446 NS=NS+NDAT + DO 447 K=2,10 + 447 ICHG(K,N)=ICHG(K-1,N)+N40 + KPLACE(N)=4 +C +C.....FOR ATOMIC SPHERES +C + 448 NQ=N + K=KPL0 + IF(RTEMP(K+1)+RTEMP(K)-2.D0*RS(N).LT.0.0D0 ) K=KPL0+1 +C +C READ INTEGRATED POTENTIAL AND INTERPOLATE FOR VALUE ON BOUNDARY +C + DO 1016 KK=1,KMAXL,5 + KCARD=MIN0(KK+4,KMAXL) + READ(4) NC,(BETA(I),I=KK,KCARD) + IF(NC.EQ.NC0+1) GO TO 1016 + WRITE(7,400) NC + 1016 NC0=NC + CALL DINTERP(RTEMP(K-3), BETA(K-3),7,RS(N), VINT(N),DUMMY,.FALSE.) +C +C READ TOTAL CHARGE AND INTERPOLATE FOR VALUE ON BOUNDARY +C + DO 1022 ISPIN=1,NSPINS + DO 1021 KK=1,KMAXL,5 + KCARD=MIN0(KK+4,KMAXL) + READ(4) NC, (GAMMA(I,ISPIN),I=KK,KCARD) + IF(NC.EQ.NC0+1) GO TO 1021 + WRITE(7,400) NC + 1021 NC0=NC + 1022 CALL DINTERP(RTEMP(K-3),GAMMA(K-3,ISPIN),7,RS(N),CHARGE(N,ISPIN), + 1 DUMMY,.FALSE.) + GO TO 4281 +C +C.....FOR EQUIVALENT ATOMS +C + 439 NQ=NEQ(N) + KPLACE(N)=KPLACE(NQ) + 4281 IF(OUTER) GO TO 4280 + VOLUME=VOLUME-RS(N)**3 + VCON=VCON-VINT(NQ) + DO 455 IS=1,NSPINS + 455 ROCON(IS)=ROCON(IS)-CHARGE(NQ,IS) + IF(NEQ(N).NE.0) GO TO 422 + GO TO 4221 + 4280 VCON=VCON+VINT(NQ) + VOLUME=VOLUME+RS(N)**3 + DO 456 IS=1,NSPINS + 456 ROCON(IS)=ROCON(IS)+CHARGE(NQ,IS) + 4221 H(N)=R(2,N)-R(1,N) + 422 CONTINUE + VOLUME=1.3333333333333D0*PI*VOLUME + VCON=VCON/VOLUME + VCONC=VCON + IF (RADION.NE.0) THEN + DVSPH = -2.D0*QION/RADION + VCONC = VCONC + DVSPH + ENDIF + NS=1 + RH0 = 3.D0 / (NSPINS*4.D0*PI*RS0**3) +c write (*,*) ' vc0 =', vc0, ' rs0 =',rs0 + DO 453 IS=1,NSPINS + ROCON(IS)=ROCON(IS)/VOLUME + VCONS(IS)=VCON-6*EXFAC0*(3*FAC1*ROCON(IS)/(8*PI))**THIRD + VC0X = VC0 - 6*EXFAC0*(3*FAC1*RH0/(8*PI))**THIRD + IF(RADION.EQ.0) GO TO 453 + VCONS(IS)=VCONS(IS)+DVSPH + KX=KMAX(1) + DO 451 K=1,KX + IF(R(K,1).LT.RADION) GO TO 452 + V(K,NS)=V(K,NS)-2.D0*QION/R(K,1) +C VC(K,NS)=VC(K,NS)-2.*QION/R(K,1) + GO TO 451 + 452 V(K,NS)=V(K,NS)+DVSPH +C VC(K,NS)=VC(K,NS)+DVSPH + 451 CONTINUE + NS=NS+1 + DO 454 N=2,NDAT + KX=KMAX(N) + DO 450 K=1,KX +C VC(K,NS)=VC(K,NS)+DVSPH + 450 V(K,NS)=V(K,NS)+DVSPH + 454 NS=NS+1 + 453 CONTINUE + GO TO 4220 + 4300 WRITE(7,105) + 105 FORMAT(' IN IS EQUAL 2') +C +C OUTPUT AND CHECK FOR CONSISTENCY OF INPUT DATA +C + 4220 WRITE(7,111) + 111 FORMAT(30X,10HATOM NO.,12X,8HPOSITION,14X,13HRADIUS EQ ) + WRITE(7,112) (I,NSYMBL(I),NZ(I),XV(I),YV(I),ZV(I),RS(I),NEQ(I), + 1 I=1,NAT) + 112 FORMAT(26X,I3,A6,I6,4F10.4,I6) +C IF(NOUT.NE.0.AND.NOUT.NE.1) GO TO 205 +C GO TO 1130 +C 205 WRITE(7,200) I,J +C ERROR=.TRUE. + DO 211 I=1,NAT + IF(RS(I).LT.0.0D0) GO TO 213 + IF(NEQ(I).EQ.0)GO TO 210 + IF(NEQ(I).GE.I) GO TO 213 + 210 I1=I+1 + IF(NOUT.EQ.0) GO TO 212 + IF(NEQ(I).EQ.1) GO TO 213 + 212 IF(I1.GT.NAT) GO TO 216 + GO TO 2135 + 213 CONTINUE +C WRITE(6,200) I,J + 2135 DO 211 J=I1,NAT + RIJ = SQRT((XV(J)-XV(I))**2+(YV(J)-YV(I))**2+(ZV(J)-ZV(I))**2) + IF(NOUT.EQ.1.AND.I.EQ.1) GO TO 214 + RSUM = RS(I)+RS(J) + IF (RSUM.GT.RIJ) GO TO 215 + GO TO 211 + 214 RSUM = RIJ+RS(J) + IF (RSUM.GT.RS(1)) GO TO 215 + GO TO 211 + 215 CONTINUE +C WRITE (6,200) I,J,RSUM,RIJ,RDIF + 211 CONTINUE + 216 IF(RADION.EQ.0.0D0) GO TO 217 + IF(RADION.EQ.RS(1)) GO TO 217 + KX=KMAX(1) + DO 219 K=1,KX + IF(RADION.GT.R(K,1)) GO TO 219 + 219 CONTINUE + 217 CONTINUE + NDUMMY = 0 +C +C SHIFT BACK ORIGIN TO PHOTOABSORBER +C + X0=XV(2) + Y0=YV(2) + Z0=ZV(2) +C + DO 150 N=1,NAT + XV(N)=XV(N)-X0 + YV(N)=YV(N)-Y0 + ZV(N)=ZV(N)-Z0 + NEQ1(N)=0 + IF(NEQ(N).NE.0) NEQ1(N)=NEQ(N)-1 + 150 CONTINUE +C +C WRITE OUT POTENTIAL AND DENSITY FILES +C + IF (potype.EQ.'xalph') THEN + OPEN (19, FILE = 'div/XALPHA.POT', STATUS = 'unknown') + ELSE + OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown') + OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown') + ENDIF +C + INV = 20 + IF (potype.EQ.'xalph') INV = 19 + INRHO= 9 + NST=2 + NC=2 + DO 4401 N=NST,NAT + WRITE(INV,311) NSYMBL(N),NEQ1(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N), + 1 XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC + 311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5) + NC=NC+1 + IF(NEQ(N).NE.0) GO TO 4401 + WRITE(INV,308) (ICHG(I,N),I= 1,10),NC + 308 FORMAT(10I5,T76,I5) + NC=NC+1 + WRITE(INV,319) NC,(R(I,N),I=1,5) + 319 FORMAT(T76,I5,T2,1P5E14.7) + NS=N + NC=NC+1 + KX=KMAX(N) + NS = N + DO 142 ISPIN=1,NSPINS + DO 141 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INV,319) NC,(V(I,NS),I=K,KCARD) + 141 NC=NC+1 + 142 NS=NS+NDAT + NS=N + IF (potype.NE.'xalph') THEN + DO 555 ISPIN=1,NSPINS + DO 551 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INRHO,319) NC,(RHO(I,NS),I=K,KCARD) + 551 NC=NC+1 + 555 NS=NS+NDAT + ENDIF + 4401 CONTINUE +C + IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS) +C + IF (INV.EQ.20) THEN + WRITE(INV,319) NC, VCONC + + WRITE( INRHO,319) NC,(ROCON(IS),IS=1,NSPINS) + ENDIF +C +c CLOSE (4) + IF(potype.EQ.'xalph') THEN + CLOSE (UNIT=19) + ELSE + CLOSE (UNIT=20) + CLOSE (UNIT=9) + ENDIF +C +C CLOSE (UNIT=7) +C +C----------------------------------------------------------------------- +C +C PASS POTENTIAL AND/OR CHARGE DENSITY TO CONT_SUB. +C +C990 IF(IOUT_ASCII.NE.2) GO TO 999 +C +C----------------------------------------------------------------------- + NAT2=NAT-NOUT + NDAT2=NDAT-NOUT + NSPINS2=NSPINS +c +c A.Kuzmin 10.06.93 +c Correction of the atomic coordinates due to the outer +c sphere non central position +c + xv0=0.D0 + yv0=0.D0 + zv0=0.D0 +c if(nout.eq.1)then +c xv0=xv(1) +c yv0=yv(1) +c zv0=zv(1) +c endif +c +c End of correction +c + DO 780 I=1,NAT2 +C +C SKIP OUTER SPHERE +C + J=I+NOUT + NSYMBL2(I)=NSYMBL(J) + NZ2(I)=NZ(J) + + + IF(NEQ(J).EQ.0)THEN + NEQ2(I)=0 + ELSE + NEQ2(I)=NEQ(J)-NOUT + END IF + XV2(I)=SNGL(XV(J)-xv0) + YV2(I)=SNGL(YV(J)-yv0) + ZV2(I)=SNGL(ZV(J)-zv0) + Z2(I)=SNGL(Z(J)) + RS2(I)=SNGL(RS(J)) + EXFACT2(I)=SNGL(EXFACT(J)) + KMAX2(I)=KMAX(J) + KPLACE2(I)=KPLACE(J) + IF(NEQ(J).NE.0)GOTO 780 + DO 735 K=1,10 + ICHG2(K,I)=ICHG(K,J) +735 CONTINUE + H2(I)=SNGL(R(2,J)-R(1,J)) + ISDA=I + JSDA=J + DO 745 IS=1,NSPINS + DO 740 K=1,KMAX(J) + IF(IS.EQ.1)R2(K,ISDA)=SNGL(R(K,JSDA)) + RHOTOT2(K,ISDA)=SNGL(RHO(K,JSDA)) + V2(1,K,ISDA)=SNGL(V(K,JSDA)) + V2(2,K,ISDA)=0.0 +740 CONTINUE + ISDA=ISDA+NDAT2 + JSDA=JSDA+NDAT +745 CONTINUE +780 CONTINUE +C + RHKM1 = DBLE(RHOTOT2(KMAX2(1),1))/ + 1 (4.D0*PI*DBLE(R2(KMAX2(1),1))**2) + RHKM2 = DBLE(RHOTOT2(KMAX2(2),2))/ + 1 (4.D0*PI*DBLE(R2(KMAX2(2),2))**2) + RHKM = ( RHKM1 + RHKM2 ) / 2.D0 + RSKM = (3.D0 / ( 4.D0 * PI * RHKM * NSPINS ) ) ** THIRD + VCKM = DBLE((V2(1,KMAX2(1),1)+V2(1,KMAX2(2),2)))/2.D0 + + WRITE(*,*) ' input value for coulomb interst. potential =', + 1 real(vc0) + WRITE(*,*) ' and interstitial rs =', real(rs0) + WRITE(*,*) ' lower bound for coulomb interst. potential =', + 1 real(vckm) + WRITE(*,*) ' and for interst. rs =',real(rskm) + + DO 790 M=1,NSPINS + IF (VINPUT) THEN + VCONS2(M) = CMPLX(VC0X) + RHOINT2(M) = REAL(RH0) + ELSE + VCONS2(M)=CMPLX(SNGL(VCONS(M))) + RHOINT2(M)=SNGL(ROCON(M)) + ENDIF + 790 CONTINUE +C +C +C BRANCH POINT +C + RETURN + END +C + SUBROUTINE DINTERP(R,P,N,RS,PS,DPS,DERIV) + IMPLICIT REAL*8 (A-H,O-Z) + LOGICAL DERIV,NODRIV + DIMENSION R(N),P(N) + NODRIV=.NOT.DERIV + DPS=0.0D0 + PS=0.0D0 + DO 1 J=1,N + TERM=1.0D0 + DENOM=1.0D0 + DTERM=0.0D0 + DO 2 I=1,N + IF(I.EQ.J) GO TO 2 + DENOM=DENOM*(R(J)-R(I)) + TERM=TERM*(RS-R(I)) + IF(NODRIV) GO TO 2 + DTERM1=1.0D0 + DO 3 K=1,N + IF(K.EQ.J.OR.K.EQ.I) GO TO 3 + DTERM1=DTERM1*(RS-R(K)) + 3 CONTINUE + DTERM=DTERM+DTERM1 + 2 CONTINUE + IF(NODRIV) GO TO 1 + DPS=DPS+DTERM*P(J)/DENOM + 1 PS=PS+TERM*P(J)/DENOM + RETURN + END +c----------------------------------------------------------------------- +C + SUBROUTINE CSBF(X0,Y0,MAX,SBF,DSBF) + IMPLICIT REAL*8(A-H,O-Z) + REAL*8 XF1 + COMPLEX*8 X0,Y0 + COMPLEX*16 X,Y,RAT,DSBF1,Z,SBFJ,B,A + COMPLEX*16 SBFK,SBF1,SBF2 + COMPLEX*16 SBF,DSBF + INTEGER MAX,K,JMIN,KMAX + DIMENSION SBF(MAX), DSBF(MAX) +C +C +C GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR +C FIRST DERIVATIVES WITH RESPECT TO R. X=ARGUMENT= Y*R. +C IF Y=0, NO DERIVATIVES ARE CALCULATED. MAX MUST BE AT LEAST 3. +C OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS. MSBF - MODI- +C FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS; +C MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS +C +C +C + X=DCMPLX(X0) + Y=DCMPLX(Y0) + + IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 + IF(ABS(X).LT.0.50D0 ) GO TO 18 +C +C BESSEL FUNCTIONS BY DOWNWARD RECURSION +C + SBF2=(0.0D0,0.0D0) + SBF1=1.0D-25*(0.5D0,0.5D0) + IF(ABS(X).LT.2.0D0) SBF1=1.0D-38*(0.5D0,0.5D0) + JMIN=10+INT(ABS(X)) + KMAX=MAX+JMIN-1 + K=MAX + XF1=2*KMAX+1 + DO 10 J=1,KMAX + SBFK=XF1*SBF1/X-SBF2 + SBF2=SBF1 + SBF1=SBFK + XF1=XF1-2.0D0 + IF (J.LT.JMIN) GO TO 10 + SBF(K)=SBFK + K=K-1 +10 CONTINUE + RAT=SIN(X)/(X*SBF(1)) + DO 17 K=1,MAX + 17 SBF(K)=RAT*SBF(K) + DSBF1=-SBF(2) + GO TO 26 +C +C SMALL ARGUMENTS +C + 18 Z=-(X*X*0.50D0) + A=(1.0D0,0.0D0) + MMX=MAX + IF (MAX.EQ.1.AND.Y.NE.(0.0D0,0.0D0)) MMX=2 + DO 30 J=1,MMX + SBFJ=A + B=A + DO 31 I=1,20 + B=B*Z/(I*(2*(J+I)-1)) + SBFJ=SBFJ+B + IF (ABS(B).LE.1.0D-07*ABS(SBFJ)) GO TO 29 + 31 CONTINUE +29 IF (J.EQ.2) DSBF1=-SBFJ + IF (J.LE.MAX) SBF(J)=SBFJ + 30 A=A*X/DCMPLX(FLOAT(2*J+1)) +C +C +26 IF (Y.EQ.(0.0D0,0.0D0)) RETURN + DSBF(1)=Y*DSBF1 + IF (MAX.EQ.1) RETURN + DO 9 I=2,MAX + 9 DSBF(I)=Y*(SBF(I-1)- DCMPLX(FLOAT(I))*SBF(I)/X) + RETURN +99 WRITE(6,100) MAX +100 FORMAT (' SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8) + STOP + END +C +c + subroutine cshf2(x0,y0,max,sbf,dsbf) + implicit real*8(a-h,o-z) + real*8 xf1 + complex*8 x0,y0 + complex*16 x,y,rat,z,sbfj,b,a + complex*16 sbfk,sbf1,sbf2,cplu + complex*16 sbf,dsbf + integer max,k,jmin,kmax + dimension sbf(max), dsbf(max) +c +c cshf2 - May 1992 +c generates spherical hankel functions of type 2 of order 0 - max-1. +c max must be at least 3. cshf2 is calculated as csbf - i*csnf, wher +c csbf(csnf) are spherical Bessel(Neuman) functions. csbf(csnf) are +c calculated using downward(upward) recurrence realations. +c ***** This subroutine returns i*cshf2 = csnf + i*csbf and its +c derivative if y0 ne. 0. In this case dsbf = i*y0*(cshf")'*** +c +c + cplu = (0.d0,1.d0) +c + x=dcmplx(x0) + y=dcmplx(y0) + + if (max.lt.1.or.max.gt.2000) go to 99 + if(abs(x).lt.0.50D0 ) go to 18 +c +c bessel functions sbf by downward recursion +c + sbf2=(0.0D0,0.0D0) + sbf1=1.0D-25*(0.5D0,0.5D0) + if(abs(x).lt.2.0D0) sbf1=1.0d-38*(0.5D0,0.5D0) + jmin=10+int(abs(x)) + kmax=max+jmin-1 + k=max + xf1=2*kmax+1 + do 10 j=1,kmax + sbfk=xf1*sbf1/x-sbf2 + sbf2=sbf1 + sbf1=sbfk + xf1=xf1-2.0d0 + if (j.lt.jmin) go to 10 + sbf(k)=sbfk + k=k-1 +10 continue + rat=sin(x)/(x*sbf(1)) + do 17 k=1,max + 17 sbf(k)=rat*sbf(k) + go to 2 +c +c sbf for small arguments +c + 18 z=-(x*x*0.50D0) + a=(1.0D0,0.0D0) + mmx=max + if (max.eq.1.and.y.ne.(0.0D0,0.0D0)) mmx=2 + do 30 j=1,mmx + sbfj=a + b=a + do 31 i=1,20 + b=b*z/(i*(2*(j+i)-1)) + sbfj=sbfj+b + if (abs(b).le.1.0d-07*abs(sbfj)) go to 29 + 31 continue + 29 if (j.le.max) sbf(j)=sbfj + 30 a=a*x/ dcmplx(float(2*j+1)) +c +c spherical neumann functions snf by upward recursion +c damped in dsbf +c + 2 sbf2=-cos(x)/x + sbf1=(sbf2-sin(x))/x + dsbf(1)=sbf2 + if (max.eq.1) go to 26 + dsbf(2)=sbf1 + if (max.eq.2) go to 26 + xf1=3.0d0 + do 22 i=3,max + sbfk=xf1*sbf1/x-sbf2 + dsbf(i)=sbfk + sbf2=sbf1 + sbf1=sbfk +22 xf1=xf1+2.0d0 +c +c hankel functions as sbf + i*snf +c + do 3 i=1,max + 3 sbf(i) = cplu*sbf(i) + dsbf(i) + +26 if (y.eq.(0.0D0,0.0D0)) return +c +c calculate derivative of shf +c + dsbf(1) = -y*sbf(2) + if (max.eq.1) return + do 9 i=2,max + 9 dsbf(i)=y*(sbf(i-1)- dcmplx(float(i))*sbf(i)/x) + return +99 write(6,100) max +100 format (' spherical bessel function routine - max=',i8) + stop + end +c + SUBROUTINE DEFINT(F,R,KMAX,ICHG,A,ID) + DIMENSION F(KMAX),R(KMAX),ICHG(10) + COMPLEX F,A,F0 +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=R(2)-R(1) + A0=0.0 + K0=0 + IF (ID.NE.1) GO TO 11 + F0=(0.0,0.0) + GO TO 12 + 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) +12 KX=KMAX + N=1 + A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* + 1 F(K0+4))/S720 + A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* + 1 F(K0+4))/S720 + A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* + 1 F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + KICH=K-ICHG(N) + IF (KICH.EQ.1) GO TO 30 + IF (KICH.EQ.2) GO TO 40 + A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 + GO TO 50 +30 H=H+H + A=A+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 + GO TO 50 +40 N=N+1 + A=A+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 +50 CONTINUE + RETURN + END +C +C +C + SUBROUTINE defint0(F,DX,KMAX,A,ID) + COMPLEX F, A, A0, F0 + DIMENSION F(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=DX + A0=0.0 + K0=0 + IF (ID.NE.1) GO TO 11 + F0=(0.0,0.0) + GO TO 12 + 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) +c 11 F0 = F(1) +c K0 = 1 +c write(6,*) 'defint', f0 +12 KX=KMAX + N=1 + A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* + 1 F(K0+4))/S720 + A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* + 1 F(K0+4))/S720 + A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* + 1 F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 +50 CONTINUE + RETURN +C + END +C +C + SUBROUTINE defint1(F,DX,KMAX,A,ID) + COMPLEX F, A, A0, F0 + DIMENSION F(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=DX + A0=0.0 + K0=0 + IF (ID.NE.1) GO TO 11 + F0=(0.0,0.0) + GO TO 12 +c 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) + 11 F0 = F(1) + K0 = 1 +12 KX=KMAX + N=1 + A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* + 1 F(K0+4))/S720 + A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* + 1 F(K0+4))/S720 + A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* + 1 F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 +50 CONTINUE + RETURN +C + END +C +C + SUBROUTINE INTEGR(F,R,KMAX,ICHG,A,ID) + DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=R(2)-R(1) + A0=0.0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=0.0 + GO TO 12 + 11 K0=1 + A(1)=0.0 + F0=F(1) +12 KX=KMAX + N=1 + A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F + 1 (K0+4))/S720 + A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S + 1 11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 + 1 9*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + KICH=K-ICHG(N) + IF (KICH.EQ.1) GO TO 30 + IF (KICH.EQ.2) GO TO 40 + A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 + GO TO 50 +30 H=H+H + A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 + GO TO 50 +40 N=N+1 + A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C + SUBROUTINE CINTEGR(F,R,KMAX,ICHG,A,ID) + COMPLEX F,A,F0 + DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=R(2)-R(1) + A0=0.0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=(0.0,0.0) + GO TO 12 + 11 K0=1 + A(1)=(0.0,0.0) + F0=F(1) +12 KX=KMAX + N=1 + A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F + 1 (K0+4))/S720 + A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S + 1 11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 + 1 9*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + KICH=K-ICHG(N) + IF (KICH.EQ.1) GO TO 30 + IF (KICH.EQ.2) GO TO 40 + A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 + GO TO 50 +30 H=H+H + A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 + GO TO 50 +40 N=N+1 + A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C +C + SUBROUTINE INTEGRCM(F,DX,KMAX,A,ID) + COMPLEX F,A,F0 + DIMENSION F(KMAX),A(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=DX + A0=0.0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=(0.0,0.0) + GO TO 12 + 11 K0=1 + A(1)=(0.0,0.0) + F0=F(1) +12 KX=KMAX + A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F + 1 (K0+4))/S720 + A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S + 1 11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 + 1 9*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C +C + SUBROUTINE INTEGRCMDP(F,DX,KMAX,A,ID) + COMPLEX*16 F,A,F0 + REAL*8 S106,S19,S346,S456,S74,S11,S720,S251,S646,S264,A0 + DIMENSION F(KMAX),A(KMAX) +C + DATA S720,S251,S646,S264 /720.D0,251.D0,646.,264.D0/ +C + DATA S106,S19,S346,S456,S74,S11 /106.0D0,19.0D0,346.0D0,456.0D0, + 1 74.0D0,11.0D0/ +C + H=DX + A0=0.0D0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=(0.0D0,0.0D0) + GO TO 12 + 11 K0=1 + A(1)=(0.0D0,0.0D0) + F0=F(1) +12 KX=KMAX + A(K0+1)=A0+DBLE(H)*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+ + 1 S106*F(K0+3)-S19*F(K0+4))/S720 + A(K0+2)=A(K0+1)+DBLE(H)*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)- + 1 S74*F(K0+3)+S11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+DBLE(H)*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+ + 1 S346*F(K0+3)-S19*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A(K)=A(K-1)+DBLE(H)*( 9.0D0*F(K)+19.0D0*F(K-1)-5.0D0*F(K-2)+ + 1 F(K-3))/24.0D0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C +C + SUBROUTINE INTERP(R,P,N,RS,PS,DPS,DERIV) + LOGICAL DERIV,NODRIV + DIMENSION R(N),P(N) + COMPLEX P,PS,DPS + NODRIV=.NOT.DERIV + DPS=(0.0,0.0) + PS=(0.0,0.0) + DO 1 J=1,N + TERM=1.0 + DENOM=1.0 + DTERM=0.0 + DO 2 I=1,N + IF(I.EQ.J) GO TO 2 + DENOM=DENOM*(R(J)-R(I)) + TERM=TERM*(RS-R(I)) + IF(NODRIV) GO TO 2 + DTERM1=1.0 + DO 3 K=1,N + IF(K.EQ.J.OR.K.EQ.I) GO TO 3 + DTERM1=DTERM1*(RS-R(K)) + 3 CONTINUE + DTERM=DTERM+DTERM1 + 2 CONTINUE + IF(NODRIV) GO TO 1 + DPS=DPS+DTERM*P(J)/DENOM + 1 PS=PS+TERM *P(J)/DENOM + RETURN +C + END +C + SUBROUTINE INTERPR(R,P,N,RS,PS,DPS,DERIV) + LOGICAL DERIV,NODRIV + DIMENSION R(N),P(N) + NODRIV=.NOT.DERIV + DPS=0.0 + PS=0.0 + DO 1 J=1,N + TERM=1.0 + DENOM=1.0 + DTERM=0.0 + DO 2 I=1,N + IF(I.EQ.J) GO TO 2 + DENOM=DENOM*(R(J)-R(I)) + TERM=TERM*(RS-R(I)) + IF(NODRIV) GO TO 2 + DTERM1=1.0 + DO 3 K=1,N + IF(K.EQ.J.OR.K.EQ.I) GO TO 3 + DTERM1=DTERM1*(RS-R(K)) + 3 CONTINUE + DTERM=DTERM+DTERM1 + 2 CONTINUE + IF(NODRIV) GO TO 1 + DPS=DPS+DTERM*P(J)/DENOM + 1 PS=PS+TERM *P(J)/DENOM + RETURN +C + END +C +C +C + SUBROUTINE SORT(NINI,VALIN,NFIN,VALFIN) +C +C Given a set of **real** numbers VALINI, this routine orders them and +C suppresses the values appearing more than once. The remaining +C values are stored in VALFIN. +C +C VALINI(K+1).GT.VALINI(K) : decreasing order +C VALINI(K+1).LT.VALINI(K) : increasing order +C +C + DIMENSION VALIN(NINI),VALINI(NINI),VALFIN(NINI) +C + LOGICAL BUBBLE +C + DATA SMALL /0.00001/ +C +C.....STORE INPUT ARRAY +C + DO I=1,NINI + VALINI(I)=VALIN(I) + ENDDO +C + DO J=1,NINI-1 + K=J + BUBBLE=.TRUE. +150 IF(K.GE.1.AND.BUBBLE) THEN + IF(VALINI(K+1).LT.VALINI(K)) THEN + R1=VALINI(K) + VALINI(K)=VALINI(K+1) + VALINI(K+1)=R1 + ELSE + BUBBLE=.FALSE. + END IF + K=K-1 + GOTO 150 + ENDIF + ENDDO +C + JFIN=1 + VALFIN(1)=VALINI(1) + DO J=1,NINI-1 + IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN + JFIN=JFIN+1 + VALFIN(JFIN)=VALINI(J+1) + ENDIF + ENDDO + NFIN=JFIN +C + RETURN +C + END +C +C + SUBROUTINE STARTP(ZZ0,L,E,R,V,KMAX,KI,P) +C + IMPLICIT COMPLEX*16 (A-B) + REAL*4 ZZ0,R + REAL*8 XL,Z0,H,RC +C + COMPLEX*8 V + COMPLEX*16 P,Z +C + DIMENSION R(KMAX),V(KMAX),Z(300),P(KMAX) +C 1,ZA(150) +C + Z0=DBLE(ZZ0) + RC = 1.0D0 +C IF(L.GT.10) RC = 0.01/R(1) + KM=KI/4 + IF(KI.EQ.1) KM=1 + KI1=KI+2 + DO 1 K=1,KI1 + 1 Z(K)=DCMPLX(R(K)*V(K)) + XL=DFLOAT(L) + H=DBLE(KM*R(1)) + B1=-2.0D0*Z0 + B2=(22.D0*Z0+18.D0*Z(KM)-9.D0*Z(2*KM)+2.D0*Z(3*KM))/(6.D0*H)- + 1 DBLE(E) + B3=(-12.D0*Z0-15.D0*Z(KM)+12.D0*Z(2*KM)-3.D0*Z(3*KM))/(6.D0*H*H) + B4=(2.D0*Z0+3.D0*Z(KM)-3.D0*Z(2*KM)+Z(3*KM))/(6.D0*H**3) + A1=-Z0/(XL+1.0D0) + A2=(B1*A1+B2)/(4.0D0*XL+6.0D0) + A3=(B1*A2+B2*A1+B3)/(6.0D0*XL+12.0D0) + A4=(B1*A3+B2*A2+B3*A1+B4)/(8.0D0*XL+20.0D0) + A5=(B1*A4+B2*A3+B3*A2+B4*A1)/(10.D0*XL+30.D0) + A6=(B1*A5+B2*A4+B3*A3+B4*A2)/(12.D0*XL+42.D0) + A7=(B1*A6+B2*A5+B3*A4+B4*A3)/(14.D0*XL+56.D0) + DO 4 K=1,KI1 + 4 P(K)=DCMPLX((1.0D0+DBLE(R(K))*(A1+DBLE(R(K))*(A2+DBLE(R(K))* + 1 (A3+DBLE(R(K))*(A4+DBLE(R(K))*(A5+DBLE(R(K))* + 2 (A6+DBLE(R(K))*A7)))))))*(DBLE(R(K))*RC)**(L+1)) +C DO 2 K=1,KI1 +C 2 ZA(K)=B1+R(K)*(B2+(R(K)*(B3+R(K)*B4))) +C WRITE(6,3) (I,(R(I+J-1),Z(I+J-1),ZA(I+J-1),J=1,2),I=1,KI1,2) + RETURN + END +C + subroutine rhl(erl,eim,pi) +c +c +c this is a new hl subroutine, using interpolation for the +c real part while calculating the imaginary part is calculated +c analitically. +c it uses hl to calculate values at the mesh points for the inter +c polation of the real part. the imaginary part is calculated +c using subroutine imhl. +c +c written by jose mustre +c polynomial in rs has a 3/2 power term. j.m. +c + implicit double precision (a-h,o-z) + common /corr/ rs,blt,xk1,vii,index2 + common /hlin/ xk + common /cusp/ icusp +c +c for the right branch the interpolation has the form: +c hl(rs,x) = e/x + f/x**2 + g/x**3 +c where e is known and +c f = sum (i=1,3) ff(i) rs**(i+1)/2 +c g = sum (i=1,3) gg(i) rs**(i+1)/2 +c +c +c lrs=number of rs panels, in this case one has 4 panels +c nrs=number of standard rs values, also order of rs expansion +c if you change nrs you need to change the expansion of hl +c in powers of rs that only has 3 terms! +c nleft=number of coefficients for xx0 +c + parameter (lrs=4,nrs=3,nleft=4,nright=2) + dimension rcfl(lrs,nrs,nleft),rcfr(lrs,nrs,nright) + dimension cleft(nleft),cright(nright) + data conv /1.9191583/ + data rcfr/-0.173963d+00,-0.173678d+00,-0.142040d+00,-0.101030d+00, + 1 -0.838843d-01,-0.807046d-01,-0.135577d+00,-0.177556d+00, + 2 -0.645803d-01,-0.731172d-01,-0.498823d-01,-0.393108d-01, + 3 -0.116431d+00,-0.909300d-01,-0.886979d-01,-0.702319d-01, + 4 0.791051d-01,-0.359401d-01,-0.379584d-01,-0.419807d-01, + 5 -0.628162d-01, 0.669257d-01, 0.667119d-01, 0.648175d-01/ + data rcfl/ 0.590195d+02, 0.478860d+01, 0.812813d+00, 0.191145d+00, + 1 -0.291180d+03,-0.926539d+01,-0.858348d+00,-0.246947d+00, + 2 0.363830d+03, 0.460433d+01, 0.173067d+00, 0.239738d-01, + 3 -0.181726d+03,-0.169709d+02,-0.409425d+01,-0.173077d+01, + 4 0.886023d+03, 0.301808d+02, 0.305836d+01, 0.743167d+00, + 5 -0.110486d+04,-0.149086d+02,-0.662794d+00,-0.100106d+00, + 6 0.184417d+03, 0.180204d+02, 0.450425d+01, 0.184349d+01, + 7 -0.895807d+03,-0.318696d+02,-0.345827d+01,-0.855367d+00, + 8 0.111549d+04, 0.156448d+02, 0.749582d+00, 0.117680d+00, + 9 -0.620411d+02,-0.616427d+01,-0.153874d+01,-0.609114d+00, + 1 0.300946d+03, 0.109158d+02, 0.120028d+01, 0.290985d+00, + 2 -0.374494d+03,-0.535127d+01,-0.261260d+00,-0.405337d-01/ + +c +c calcualte hl using interplation coefficients +c + rkf=conv/rs + ef=rkf*rkf*0.5D0 + wp=sqrt(3.0D0/rs**3) + call imhl (erl,eim,pi) + eim=eim +c +c eim already has a factor of ef in it j.m. +c eim also gives the position of the cusp +c + xx=xk1/rkf +c +c calculate right hand side coefficients +c + if (rs .lt. 0.2D0) then + mrs=1 + go to 209 + endif + if (rs .ge. 0.2D0 .and. rs .lt. 1.0D0) then + mrs=2 + go to 209 + endif + if (rs .ge. 1.0D0 .and. rs .lt. 5.0D0) then + mrs=3 + go to 209 + endif + if (rs .ge. 5.0D0) mrs=4 + 209 do 210 j=1,nright + cright(j)=rcfr(mrs,1,j)*rs+rcfr(mrs,2,j)*rs*sqrt(rs) + 1 +rcfr(mrs,3,j)*rs*rs +c +c jm written this way to calculate powers of rs quicker. +c cright(j)=0.0 +c do 205 k=1,nrs +c 205 cright(j)=cright(j)+rcfr(mrs,k,j)*rs**((k+1.)/2.) + 210 continue + eee=-pi*wp/(4.0D0*rkf*ef) +c + if (icusp .ne. 1) then + do 230 j=1,nleft + cleft(j)=rcfl(mrs,1,j)*rs+rcfl(mrs,2,j)*rs*sqrt(rs) + 1 +rcfl(mrs,3,j)*rs*rs +c cleft(j)=0.0 +c do 225 k=1,nrs +c 225 cleft(j)=cleft(j)+rcfl(mrs,k,j)*rs**((k+1.)/2.) + 230 continue +c + erl=cleft(1) + do 250 j=2,nleft + 250 erl=erl+cleft(j)*xx**(j-1) +c + else +c +c right branch +c + erl=eee/xx + do 280 j=1,nright + 280 erl=erl+cright(j)/xx**(j+1) + endif +c + erl=erl*ef + return + end +c +c +c + subroutine imhl(erl,eim,pi) +C +c********************************************************************** +c********************************************************************** +C +c writen by j. mustre march 1988 based on analytical expression derived +c by john rehr. +c it leaves the real part unchanged. +C +c********************************************************************** +c********************************************************************** + implicit double precision (a-h,o-z) + common /corr/rs,blt,xk1,vii,index2 + common/hlin/xk + common /cusp/ icusp + common/inter/wp,alph,ef,xf + common/cube/a0,a1,a2 + external ffq + icusp=0 + fa=1.9191583D0 + xf=fa/rs + ef=xf*xf/2.0D0 + xk=xk1 + xk=xk/xf +c +c wp is given in units of the fermi energy in the formula below. +c + wp=sqrt(3.0D0/(rs*rs*rs))/ef + alph=4.0D0/3.0D0 +c write(*,225) +c 225 format(1x'xk,wp') +c write(*,*)xk,wp + xs=wp*wp-(xk*xk-1.0D0)**2 +c write (*,*)xs + if (xs .ge. 0.D0) go to 10 + q2=sqrt((sqrt(alph*alph-4.0D0*xs)-alph)/2.0D0) + qu=min(q2,(1.0D0+xk)) + d1=qu-(xk-1.0D0) + if(d1.gt.0.D0) goto 11 + 10 eim=0.0D0 + go to 20 + 11 eim=ffq(qu)-ffq((xk-1.0D0)) + +c write(*,223) +c 223 format(1x'xk,eim,d1') +c write(*,*)xk,eim,d1 + 20 call cubic (rad,qplus,qminus) +c write(*,224) +c 224 format(1x'xk,rad,qplus,qminus') +c write(*,*)xk,rad,qplus,qminus + if (rad.gt. 0.0D0) goto 32 + d2=qplus-(xk+1.0D0) + if(d2.gt.0.D0)go to 21 + eim=eim + go to 30 + 21 eim=eim+ffq(qplus)-ffq((xk+1.0D0)) +c write(*,221) +c 221 format(1x'xk,eim,d2') +c write (*,*)xk,eim,d2 + 30 d3=(xk-1.0D0)-qminus + if(d3.gt.0.D0)go to 31 + return + 31 eim=eim+ffq((xk-1.0D0))-ffq(qminus) +c +c beginning of the imaginary part and position of the cusp x0 +c + icusp=1 +c write(*,222) +c 222 format(1x'xk,eim,d3') +c write (*,*)xk,eim,d3 + 32 return + end +c +c +c + subroutine cubic ( rad,qplus,qminus) + implicit double precision (a-h, o-z) + complex*16 s1,s13 + common/hlin/xk + common/inter/wp,alph,ef,xf + common/cube/a0,a1,a2 +c +c this subroutine finds the roots of the equation +c 4xk*q^3+(alph-4xk^2)q^2+wp^2=0. +c see abramowitz and stegun for formulae. + + a2=(alph/(4.0D0*xk*xk)-1.0D0)*xk + a0=wp*wp/(4.0D0*xk) + a1=0.0D0 + q=a1/3.0D0-a2**2/9.0D0 + r=(a1*a2-3.0D0*a0)/6.0D0-a2**3/27.0D0 + rad=q**3+r**2 + if (rad .gt. 0.0D0) then + qplus=0.0D0 + qminus=0.0D0 + return + endif + s13=dcmplx(r,sqrt(-rad)) + s1=s13**(1.0D0/3.0D0) + qz1=2.0D0*dreal(s1)-a2/3.0D0 + qz3=-(dreal(s1)-dsqrt(3.0D0)*dimag(s1)+a2/3.0D0) + qplus=qz1 + qminus=qz3 + return + end +c +c +c + double precision function ffq(q) + implicit double precision (a-h,o-z) + common /corr/rs,blt,xk1,vii,index2 + common /hlin/xk + common /inter/wp,alph,ef,xf + wq=sqrt(wp*wp+alph*q*q+q*q*q*q) + ffq=(wp+wq)/(q*q)+alph/(2.0D0*wp) +c +c check prefactor (wp/4xk) to see if units are correct. +c + ffq=(ef*wp/(4.0D0*xk1))*log(ffq) + return + end + + subroutine cont_sub(potype,potgen,lmax_mode,lmaxt,relc, + & eikappr,db) +c +c.... continuum program version for phase shift calculation: +c.... february 1990 +c + include 'msxas3.inc' +c include 'msxasc3.inc' + + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $ n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common /dens/ irho,rhotot(rd_,sd_),rhoint(2), + $ vcoul(rd_,sd_),vcoulint(2) +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex v,vcons +c + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + + character*8 name0 ,nsymbl +c + common /param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + + complex vcon,xe,ev +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_), + * ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c +c ##############common /pdqi/ modified to include the two wavefuncti +c ############### for the final two holes state in the Auger decay r +c + common /pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_) +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + character*2 potgen,relc + character*3 eikappr + character*5 potype +c + logical do_r_in +c +c write(6,11) jat,jd,jf,jlmax,jn,jrd,jsd,j1d +c +c 11 format('0 final state parameters:' +c $ /'0 jat =',i6,2x,'number of centers (tb)' +c $ /'0 jd =',i6,2x,'number of inequivalent centers (nun)' +c $ /'0 jf =',i6,2x,'storage location for radial functions:=10' +c $ /'0jlmax =',i6,2x,'maximum l-value on any atomic sphere' +c $ /'0 jn =',i6,2x,'number of basis functions on all atoms' +c $ /'0 jrd =',i6,2x,'maximum number of radial mesh points (npt)' +c $ /'0 jsd =',i6,2x,'nspins*jd (for spin restriction)' +c $ /'0 j1d =',i6,2x,'is jd+1') +c +c +c +ctn write(30,13) +ctn 13 format(2x,' e xe natom l ' +ctn $ ' atmat ') +c +C WARNING: COMMONS /FCNR/ AND /PARAM/ ARE AVAILABLE ONLY AFTER SUBROUTINE +C INPUT_CONT IS CALLED +c +c do not change in this version! + nns=1 +c*********************************************************************** +c get initial state radial function +c*********************************************************************** +c + print 660 +660 format( 1x,' generating core state wavefunction ') +c + call get_core_state +c +c*********************************************************************** +c compute parameters for final state and call subroutine cont +c*********************************************************************** +c + id=1 +c + + call input_cont(id,potype,potgen,lmax_mode,lmaxt) + + call output_cont(id) +c + call setup +c + vcon=vcons(nns) +c + write(6,10) eftr + 10 format(/,1x,' fermi level =', f10.5,/) +c + emmef=emin-eftr + if(emmef.lt.0.0) write(6,556) emin,eftr + 556 format(/,' ***warning***: emin=',f10.5,' less than the fermi ', + * 'level eftr=',f10.5, 'a stop is caused in the case ', + * 'of hedin-lundqvist potential') + if(emmef.lt.0.0.and.irho.ne.0) then + print 780 +780 format (//,1x, 'emin less than the Fermi level; see file: ', + * ' results.dat',//) + stop + endif +c + print 770 +770 format( 1x,' generating t_l (for030) and', + &' atomic cross section (for050)') +c +c construct log-linear x mesh +c + call llmesh +c +c and generate core state wavefunction on log-linear x-mesh +c + call corewf(nas,nz(nas),i_absorber_hole) +c + call cont(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db) +c + + return + end +c +c + subroutine cont(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db) +c +c include 'mscalc.inc' + include 'msxas3.inc' + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +c + common/bessel/sbf(ltot_),dsbf(ltot_),snf(ltot_),dsnf(ltot_) + complex*16 sbf,dsbf,snf,dsnf +c + common /dens/ irho,rhotot(rd_,sd_),rhoint(2), + $ vcoul(rd_,sd_),vcoulint(2) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +c + COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), + & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), + & RAMFSOA(N_) + COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA +c + common /seculrx/ atmnr(n_), atmsr(n_), atmsop(n_), atmsoa(n_) + complex atmnr, atmsr, atmsop, atmsoa +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c + common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), + & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), + & dxxdir,dxxexc + complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, + & dxxdir,dxxexc +c + character*8 name0 ,nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,argc,yc,p3irreg, + & p2irreg + real*4 einc,esct,scangl,qt,lambda +c + common/msbhf/ il(rdx_,lexp_,d_), kl(rdx_,lexp_,d_), kappa + dimension msbfi(lexp_), mshfk(lexp_), ylc(lexp_*(lexp_+1)) + dimension dmsbfi(lexp_), dmshfk(lexp_) + real*8 kappa, arg, y, msbfi, mshfk, il, kl, dmsbfi, dmshfk +c + common/struct/ntnabs(nat_),ngbrabs +c +c ############# I include the common auger to take into account also the +c ############# to make the auger calculation +c + + common/auger/calctype,expmode,edge1,edge2 + + character*3 calctype, expmode + character*2 edge1,edge2 + + common /pdq/ p(rd_,f_),ps(n_),dps(n_), + * ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss + +c ###################common /pdqi/ modified to include the two core hole +c ##################of the electrons which interacts and give rise +c + common /pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_) +c + common /seculr/ atm(n_) + complex*16 atm +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/lparam/lmax2(nat_),l0i +c + common/typot/ ipot +c + complex amem,amem1,pamel,pamel0,cofct,vrr,qcofct,rexsrme,rexssme +c + dimension es(nep_),xkrn(rd_),xkri(rd_),xkrs(d_),cofct(nep_,2) + dimension qcofct(nep_,3) +c + logical*4 doit, do_r_in + logical*4 xasxpd +c +c fortran units +c + common/funit/idat,iwr,iphas,iedl0,iwf + +c + complex atmd +c + dimension distin(d_), distor(d_), ntnabs1(nat_) + character*20 correction + character*9 reg_type,irr_type + character*5 potype + character*4 spectro + character*2 potgen,relc + character*8 filename + character*3 eikappr +c + data facts/8.067/,ot/.3333333/,pai/3.1415927/ + data fsc,fscs4 /7.29735e-3,1.331283e-5/ +c +c.....facts=4.*(pi)**2/137*(0.529)**2*100.0 if cross section is expresse +c..... in megabarns = 10.e-18 cm**2 +c +c +c start energy do loop: +c +c 67 if( irho .eq. 0 ) write(6,40) vcon +c 40 format(//,' interstitial potential vcon = (',E12.6,E12.6,')',//) +c + reg_type='regular ' + irr_type='irregular' +c + if(relc.eq.'nr') then + correction='non relativistic ' + elseif(relc.eq.'sr') then + correction='scalar relativistic ' + elseif(relc.eq.'so') then + correction='spin-orbit ' + else + correction=' ' + endif +c + if (calctype.eq.'xpd') then + spectro='PED ' + elseif (calctype.eq.'xas') then + spectro='XAS ' + elseif (calctype.eq.'aed') then + spectro='AED ' + elseif (calctype.eq.'led') then + spectro='LEED' + elseif (calctype.eq.'rex') then + spectro='REXS' + elseif (calctype.eq.'els') then + spectro='EELS' + elseif (calctype.eq.'e2e') then + spectro='E,2E' + endif +c + if (emin.lt.real(vcon)) then + write(6,45) + stop + endif +c + 45 format(//,' emin less than the interstitial potential vcon',//) +c + xasxpd = (calctype.eq.'xpd'.or.calctype.eq.'xas') +c + if(irho.eq.0) go to 68 + ot = 1./3. + rsint = (3./(4.*pai*rhoint(1)))**ot + write(6,41) gamma,rsint + 41 format(/,1x,' gamma =',f10.6,' rsint =',f10.6,/) + 68 doit = .true. + if(calctype.eq.'xas') then + write(50,803) + elseif(calctype.eq.'rex') then + write(50,804) + elseif(calctype.eq.'xpd') then + write(50,807) + endif +c + 803 format(2x,' e vcon mfp ', + $ ' sigma0 regrme singrme ') +c + 804 format(2x,' e vcon mfp ', + $ ' rexsrme rexssme ') +c + 807 format(2x,' e vcon mfp ', + $ ' sigma0 regrme ') +c +c +c de = alog(emax - emin + 1.)/(kxe - 1.) +c con = 27.2116/7.62 +c wvb = sqrt(con*emin) +c wve = sqrt(con*emax) +c kxe = nint((wve-wvb)/0.05 + 1.) + kxe = nint((emax-emin)/de + 1.) +c + nval=1 + do jat=1,nuatom + nval=max0(nval,nterms(jat)) + enddo + write(35,111) nuatom,kxe,1,ipot,lmax_mode + write(95,111) nuatom,kxe,1,ipot,lmax_mode + write(70,111) nuatom,kxe,1,ipot,lmax_mode + write(80,111) nuatom,kxe,1,ipot,lmax_mode + write(90,111) nuatom,kxe,1,ipot,lmax_mode + 111 format(5(5x,i4)) +c + if(potgen.eq.'in') then + write(6,*) ' check in subroutine cont' +c + write(6,*) ' order of neighb. -- symb. -- dist. from absorber' + write(6,*) ' ' +c +c.....check with molpot data: ok (14/12/2007) +c + do i=1,ngbrabs + nb=ntnabs(i) + dist=sqrt((xv(nb)-xv(1))**2+(yv(nb)-yv(1))**2+(zv(nb)-zv(1))**2) + write(6,*) nb, nsymbl(nb), dist + enddo +c + endif +c + write(6,*) ' ---------------------------------------------------', + 1 '--------------' +c + do nb=1,ndat + dist=sqrt((xv(nb)-xv(1))**2+(yv(nb)-yv(1))**2+(zv(nb)-zv(1))**2) + distin(nb) = dist + enddo +c +c endif +c +c.....Order prototypical atoms in order of increased distance from absor +c + call sort(ndat,distin,ndiff,distor) + small=0.00001 +c nbrs=ngbrabs + nbrs = ndiff +c nbrs=8 +c + do i=1,nbrs + do j=1,ndat + if(abs(distin(j)-distor(i)).lt.small) then + ntnabs1(i)=j + write(6,12) j, nsymbl(j), distin(j) + endif + enddo + enddo + 12 format(5X,I4,12X,A2,10X,F10.6) +c +c do i=2,nbrs +c write(6,*) ntnabs1(i), ntnabs(i-1) +c enddo +c + +c +c write(6,*) 'irho =', irho +c write(6,*) '----------------------------------' + nunit=40 + nunit1=nunit+1 +c +c.....write out potential and density file for first neighbors to absorb +c +100 format(1x,a5,a5,a6,f10.5,a10,3f10.5) +c + if(irho.ne.0) then +c + open(unit=nunit,file='plot/plot_vc.dat',status='unknown') + open(unit=nunit1,file='plot/plot_dens.dat',status='unknown') +c + do i=1,nbrs +c + j = ntnabs1(i) + write(6,12) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), vcoul(k,j) +c +c do ith=0,nthe +c theta = dthe*float(ith) +c do iph=0,nphi +c phi = dphi*float(iph) +c write(nunit1,*) r(k,j), theta, phi, rhotot(k,j) + write(nunit1,*) r(k,j), rhotot(k,j) +c enddo +c enddo +c + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c + else +c + open(unit=nunit,file='plot/plot_v.dat',status='unknown') + open(unit=nunit1,file='plot/plot_dens.dat',status='unknown') + do i=1,nbrs +c + j = ntnabs1(i) + write(6,12) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), real(v(k,j)) +c +c do ith=0,nthe +c theta = dthe*float(ith) +c do iph=0,nphi +c phi = dphi*float(iph) +c write(nunit1,*) r(k,j), theta, phi, rhotot(k,j) + write(nunit1,*) r(k,j), rhotot(k,j) +c enddo +c enddo +c + + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c +c + endif +c + close(nunit) + close(nunit1) +c +c endif +c write(6,*) '----------------------------------' +c do i=1,ndat +c write(6,*) i, nsymbl(i),distin(i),distor(i) +c enddo +C +c +c + cl = (l0i + 1.5)**2 + nid = 1 + write(6,*) ' ' +c +c nels = 1 + if(calctype.eq.'els'.or.calctype.eq.'e2e') then +c nels = 3 +c +c calculate cluster size for effective integration of eels tme +c + kappa = 1.d0/dble(lambda) ! to account for thomas-fermi screening + ! length = 2.9*0.529/(r_s)^(1/2) + ! default = 1/20 = 0.05 (au)^{-1} +c + do i = 1, ndat + rcut = distor(i) + scrcoul = exp(-real(kappa)*rcut)/rcut + if(scrcoul.le.0.05) go to 11 + enddo + 11 neff = i - 1 +c + ltc = lexp_ + y = 0.0d0 + do na = 1, ndat + do k = 1, kmx(na) + arg = kappa*dble(rx(k,na)) + call msbf(arg,y,ltc,msbfi,dmsbfi) + call mshf(arg,y,ltc,mshfk,dmshfk) + do l = 1, ltc + il(k,l,na) = msbfi(l) + kl(k,l,na) = mshfk(l)*(-1)**(l-1)*kappa !correction 15 march 2014 + enddo + enddo + enddo +c + scangl = scangl/180.0*pai + qt2 = einc + esct - 2.0*sqrt(einc*esct)*cos(scangl) + qt = sqrt(qt2) + write(6,*) ' ' + write(6,*)' Calculating eels in DWBA. einc =',einc, + & ' esct =', esct,' einl =', einc - esct - cip + write(6,*)' Momentum transfer qt =', qt, ' au^{-1}' + write(6,*)' Scattering angle', scangl, 'radians' + write(6,*)' Scattering angle', scangl*180.0/pai, 'degrees' + write(6,*) ' ' + write(6,*) ' Coulomb screening inverse length kappa =', kappa + write(6,*) ' ' +c + endif +c +c.....Calculation of tl and rme for xpd, xas and rexs +c +c + if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + 1 calctype.eq.'rex' .or. calctype.eq.'aed'.or. + 2 calctype.eq.'led') then +c + nks = 1 !ficticious: in this section only for writing purposes +c +c writing the headers of the rme file +c + write(55,821) + write(55,822) spectro,correction + write(55,821) +c + if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + 1 calctype.eq.'rex') then + write(55,830) + write(55,840) + write(55,850) + write(55,840) + endif +c + do 9 ne=1,kxe + es(ne) = emin + float(ne-1)*de + e=es(ne) + ev=e-vcon +c +c calculate energy dependent potential: +c + if( irho .ne. 0 ) then + if(ne.eq.1) write(6,*) ' irho =', irho, + & ' entering vxc to calculate energy', + & ' dependent exchange' + call vxc ( doit ) + else + if(ne.eq.1.and.nks.eq.1) then + write(6,*) ' irho =', irho, ' energy independent potential' + write(6,*)' constant interstitial potential vcon =', vcon + endif + endif + ev=e-vcon + write(6,*) ' energy dependent vcon = ', vcon,' at energy', e +C +C CONSTRUCT RELATIVISTIC POTENTIAL ON LINEAR-LOG MESH +C + CALL VREL +C + xe=csqrt(ev) +c +c.....write out potential ans rs files for first neighbors to +c.....absorber for the first energy point +c + nunit=40 + nunit1=nunit+1 + open(unit=nunit,file='plot/plot_v(e).dat',status='unknown') + open(unit=nunit1,file='plot/plot_rs.dat',status='unknown') +c + if(ne.eq.1) then +c + do i=1,nbrs +c + j = ntnabs1(i) + +c write(6,*) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), real(v(k,j)) + write(nunit1,*) r(k,j), rhotot(k,j) + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c + endif +c + close(nunit) + close(nunit1) +c +c calculate maximum l-value lmxne(n,ne) for each prototipical atom +c at the energy e=es(ne) +c +c if(lmax_mode.eq.2.or.calctype.eq.'els'.or.calctype.eq.'e2e') then + if(lmax_mode.eq.2) then + do n=1,nuatom + lmxne(n,ne) = nint(sqrt(e)*rs(n))+2 + if(lmxne(n,ne).lt.l0i+1) lmxne(n,ne)=l0i+2 +c lmxels(nks,n) = lmxne(n,ne) +c write(6,*) nks, n, e, rs(n), lmxne(n,ne) + enddo + endif +c + NBL1=NUATOM/4 + XNBL1=FLOAT(NBL1)+0.0001 + XNBL2=FLOAT(NUATOM)/4. + IF(XNBL1.LT.XNBL2) NBL1=NBL1+1 + 112 FORMAT(4(7X,I2)) + if (lmax_mode.eq.2) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(95,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(70,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(80,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(90,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + ENDDO + else if (lmax_mode.eq.1) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(95,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(70,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(80,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(90,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + ENDDO + else + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmaxt,lmaxt,lmaxt,lmaxt + write(95,112) lmaxt,lmaxt,lmaxt,lmaxt + write(70,112) lmaxt,lmaxt,lmaxt,lmaxt + write(80,112) lmaxt,lmaxt,lmaxt,lmaxt + write(90,112) lmaxt,lmaxt,lmaxt,lmaxt + ENDDO + endif +c +c calculate atomic t-matrix elements atm(n) +C +c if(ne.eq.1.and.nks.eq.1) write(6,*) + if(ne.eq.1) write(6,*) + & ' calculating atomic t-matrix elements atm(n)' +c + call smtx(ne,lmax_mode) +c +c calculate the radial integrals of transition matrix elements: +c + if(calctype.ne.'led') then + call radial(doit,imvhl) + endif + +c +c calculate atomic t-matrix with relativistic corrections +c + call smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax, + & ramfnr,ramfsr,ramfsop,ramfsoa) +c +c and corresponding radial integrals of transition matrix elements: +c + call radialx(ne,relc,eikappr) +c +c modified to write the continuum radial wavefunction for eels +c + lxp = lmxne(nas,ne) + if(lxp.gt.f_) lxp=f_ - 1 + call writewf(lxp) +c +c energy dependent factors for dipole and quadrupole absoprtion; +c factor 1/3 for unpolarized absorption +c + if(ne.eq.1) + & write(6,*) ' check ionization potential:', cip + edfct= facts*(cip+e)*2./3.0 + edfctq = 2.0/5.0*3.0/16.0*edfct*((cip+e)*fsc)**2 + dafsfct = (cip+e)**4 * pai**2 +c + write(6,*) ' ' + write(6,*) ' ' + write(6,*) ' value of the mean free path:' + write(6,44) + 44 format(' --------------------------------------------------', + 1 '---------------') + if(gamma.ne.0.0.and.ne.eq.1.and.nks.eq.1) then + amfph = 0.529/gamma/2 + write(6,43) amfph,e + 43 format(' average mean free path due to finite gamma: mfp =' + * ,f10.5,' angstrom at energy ', f10.5 ,/) + endif +c + if(irho.eq.0.and.imvhl.eq.0.and.nks.eq.1) then + write(6,*)' infinite cluster mfp for real potential' + go to 802 + endif +ctn write(6,40) vcon,eftr + xeim = -aimag(xe) +c +c calculate average mean free path (= amfp). define r-dependent +c wave vector xkr and its indefinite integral xkri +c + + + amfpi = 0.0 + do 20 n = 1,ndat + kxn = kmax(n) + do 30 k = 1,kxn + vrr = v(k,n) + cl/r(k,n)**2 + if ((e-real(vrr)).lt.0.0) then + xkrn(k) = 0.0 + go to 30 + endif + xkrn(k) = -aimag(csqrt(e-vrr)) + 30 continue +c +c calculate integral of xkr +c + call integr (xkrn(1),r(1,n),kxn,ichg(1,n),xkri,nid) + call interpr (r(kplace(n)-3,n),xkri(kplace(n)-3),7,rs(n), + * xkrs(n),dummy,.false.) + xkrs(n) = xkrs(n)/rs(n) + 20 amfpi = amfpi + xkrs(n) +c +c it is assumed that the average interstitial path is 2/3 of the total +c + amfpi = 1./3.*amfpi/ndat + 2.0*xeim/3. + if (amfpi.ne.0.0) then + amfp = 0.529/amfpi/2. + write(6,42) amfp, e + 42 format(' average mean free path in the cluster : mfp =' + * ,f10.5,' angstrom at energy ', f10.5 ,/) + endif + 802 continue + if(gamma.ne.0.0.and.ne.eq.1) then + amfpt = 0.529/(amfpi + gamma)/2.0 + write(6,46) amfpt, e + endif + 46 format(' total mean free path due to Im V and gamma: mfp =' + * ,f10.5,' angstrom at energy ', f10.5) + if(ne.eq.1.and.amfpt.eq.0.0.and.nks.eq.1) write(6,*) + & ' infinite mean free path for gamma: mfp = 0.0 and Im V = 0.0 ' + write(6,44) + write(6,*) ' ' +c +c.....calculate dipole cross section and atomic matrix elements +c + write(50,*)' ------------------------- ' + write(50,*)' &&&&&&&&&&&&&&&&&&&&&&&&& ' + write(50,*)' ------------------------- ' +c + if (xasxpd) then + write(50,*) ' dipole atomic cross section' + else + write(50,*) ' dipole rexs matrix elements' + endif +c + sigmasum = 0.0 +c + do 800 i=1,2 + if((l0i.eq.0).and.(i.eq.1)) goto 800 + np= l0i + (-1)**i + amem = dmx(i) + amem1 = dmx1(i) + pamel = amem1*cmplx(atm(nstart+np))*edfct +c write(50,*)'nr ', amem1*xe/pai/(l0i - 1 + i) + cofct(ne,i) = amem*cmplx(atm(nstart+np))**2*edfct*xe/pai + pamel0 = cofct(ne,i)/cmplx(atm(nstart+np)) + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = dmx(i)*xe/pai/(l0i-1+i) + rexssme = dmx1(i)/(l0i-1+i) +c cofct(ne,i) = cofct(ne,i)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + if(i.eq.2) write(98,*) e*13.6, sigma0 + 800 continue +c + do i=1,2 + cofct(ne,i) = cofct(ne,i)/sigmasum + enddo +c +c.....calculate quadrupole atomic matrix elements for cross section (temp) +c + if (xasxpd) then + write(50,*) ' quadrupole atomic cross section ' + else + write(50,*) ' quadrupole rexs matrix elements ' + endif +c + n = 0 + sigmasum = 0.0 + do 900 i=-2,2,2 + n = n + 1 + lf = l0i + i + if(lf.le.0) go to 900 + np = l0i + i + amem = qmx(n) + amem1 = qmx1(n) + pamel = amem1*cmplx(atm(nstart+np))*edfctq + qcofct(ne,n) = amem*cmplx(atm(nstart+np))**2*edfctq*xe/pai + pamel0 = qcofct(ne,n)/cmplx(atm(nstart+np)) + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = qmx(n)*xe/pai + rexssme = qmx1(n) +c qcofct(ne,i) = qcofct(ne,n)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif + 900 continue +c + if (xasxpd) then + write(50,*)' ------------------------- ' + write(50,*) ' dipole and quadrupole cross section with ', + & 'relativistic corrections of type: ', relc + write(50,*)' ------------------------- ' + else + write(50,*)' ------------------------- ' + write(50,*) ' dipole and quadrupole rexs matrix elements', + & ' with relativistic corrections of type: ', relc + write(50,*)' ------------------------- ' + endif +c +c + if (xasxpd) then + write(50,*) ' dipole atomic cross section with rel. corr.s' + else + write(50,*) ' dipole rexs matrix elements with rel. corr.s' + endif +c + sigmasum = 0.0 +c + do 910 i=1,2 + if((l0i.eq.0).and.(i.eq.1)) goto 910 + np= l0i + (-1)**i + amem = dmxx(i) + amem1 = dmxx1(i) + if(relc.eq.'nr') then + atmd = atmnr(nstart+np) + else if (relc.eq.'sr') then + atmd = atmsr(nstart+np) + else + atmd = atmsop(nstart+np) + endif + pamel = amem1*atmd*edfct +c write(50,*)'nr-rc ', amem1*xe/pai/(l0i - 1 + i) + cofct(ne,i) = amem*atmd**2*edfct*xe/pai + pamel0 = cofct(ne,i)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = dmxx(i)*xe/pai/(l0i-1+i) + rexssme = dmxx1(i)/(l0i-1+i) +c cofct(ne,i) = cofct(ne,i)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + if(i.eq.2) write(99,*) e*13.6, sigma0 + 910 continue +c + do i=1,2 + cofct(ne,i) = cofct(ne,i)/sigmasum + enddo +c +c.....calculate quadrupole atomic matrix elements for cross section (temp) +c + if (xasxpd) then + write(50,*) ' quadrupole atomic cross section with rel. corr.s' + else + write(50,*) ' quadrupole rexs matrix elements with rel. corr.s' + endif +c + n = 0 + sigmasum = 0.0 + do 920 i=-2,2,2 + n = n + 1 + lf = l0i + i + if(lf.le.0) go to 920 + np = l0i + i + amem = qmxx(n) + amem1 = qmxx1(n) + if(relc.eq.'nr') then + atmd = atmnr(nstart+np) + else if (relc.eq.'sr') then + atmd = atmsr(nstart+np) + else + atmd = atmsop(nstart+np) + endif + pamel = amem1*atmd*edfctq + qcofct(ne,n) = amem*atmd**2*edfctq*xe/pai + pamel0 = qcofct(ne,n)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = qmxx(n)*xe/pai + rexssme = qmxx1(n) +c qcofct(ne,i) = qcofct(ne,n)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + 920 continue +c + if(relc.eq.'so') then +c + if (xasxpd) then + write(50,*)' dipole atomic cross section for second so component' + else + write(50,*)' dipole rexs matrix elements for second so component' + endif +c + do 930 i=1,2 + if((l0i.eq.0).and.(i.eq.1)) goto 930 + np= l0i + (-1)**i + amem = dmxxa(i) + amem1 = dmxxa1(i) + atmd = atmsoa(nstart+np) + pamel = amem1*atmd*edfct + cofct(ne,i) = amem*atmd**2*edfct*xe/pai + pamel0 = cofct(ne,i)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = dmxxa(i)*xe/pai/(l0i-1+i) + rexssme = dmxxa1(i)/(l0i-1+i) +c cofct(ne,i) = cofct(ne,i)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + 930 continue +c + do i=1,2 + cofct(ne,i) = cofct(ne,i)/sigmasum + enddo +c +c.....calculate quadrupole atomic matrix elements for cross section (temp) +c + if (xasxpd) then + write(50,*)'quadrupole atomic cross section for second so ', + & 'component' + else + write(50,*)'quadrupole rexs matrix elements for second so ', + & 'component' + endif +c + n = 0 + sigmasum = 0.0 + do 940 i=-2,2,2 + n = n + 1 + lf = l0i + i + if(lf.le.0) go to 940 + np = l0i + i + amem = qmxxa(n) + amem1 = qmxxa1(n) + atmd = atmsoa(nstart+np) + pamel = amem1*atmd*edfctq + qcofct(ne,n) = amem*atmd**2*edfctq*xe/pai + pamel0 = qcofct(ne,n)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = qmxxa(n)*xe/pai + rexssme = qmxxa1(n) +c qcofct(ne,i) = qcofct(ne,n)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + 940 continue +c + endif +C +C Writing the radial integrals in unit 55 +C eliminated division of dmx (qmx) by nfis: 29-3-2013 due to reorganization +C of normalization of initial core state +C + if(l0i.eq.0) then +C +c write(55,860) 0.0,0.0, +c 1 csqrt(dmx(2)*xe/pai), +c 2 0.0,0.0, +c 3 0.0,0.0, +c 4 csqrt(qmx(3)*xe/pai) +C + elseif(l0i.eq.1) then +C +c write(55,860) csqrt(dmx(1)*xe/pai/l0i), +c 1 csqrt(dmx(2)*xe/pai/(l0i+1)), +c 2 0.0,0.0, +c 3 csqrt(qmx(2)*xe/pai), +c 4 csqrt(qmx(3)*xe/pai) +C + else +C +c write(55,860) csqrt(dmx(1)*xe/pai/l0i), +c 1 csqrt(dmx(2)*xe/pai/(l0i+1)), +c 2 csqrt(qmx(1)*xe/pai), +c 3 csqrt(qmx(2)*xe/pai), +c 4 csqrt(qmx(3)*xe/pai) +C + endif +C + if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + 1 calctype.eq.'rex') then + if(l0i.eq.0) then +C + write(55,860) 0.0,0.0, + 1 csqrt(dmxx(2)*xe/pai), + 2 0.0,0.0, + 3 0.0,0.0, + 4 csqrt(qmxx(3)*xe/pai),reg_type +C + elseif(l0i.eq.1) then +C + write(55,860) csqrt(dmxx(1)*xe/pai/l0i), + 1 csqrt(dmxx(2)*xe/pai/(l0i+1)), + 2 0.0,0.0, + 3 csqrt(qmxx(2)*xe/pai), + 4 csqrt(qmxx(3)*xe/pai),reg_type +C + else +C + write(55,860) csqrt(dmxx(1)*xe/pai/l0i), + 1 csqrt(dmxx(2)*xe/pai/(l0i+1)), + 2 csqrt(qmxx(1)*xe/pai), + 3 csqrt(qmxx(2)*xe/pai), + 4 csqrt(qmxx(3)*xe/pai),reg_type +C + endif +c + if(relc.eq.'so') then + write(55,*) ' second component of so matrix element ' +C + if(l0i.eq.0) then +C + write(55,860) 0.0,0.0, + 1 csqrt(dmxxa(2)*xe/pai), + 2 0.0,0.0, + 3 0.0,0.0, + 4 csqrt(qmxxa(3)*xe/pai) +C + elseif(l0i.eq.1) then +C + write(55,860) csqrt(dmxxa(1)*xe/pai/l0i), + 1 csqrt(dmxxa(2)*xe/pai/(l0i+1)), + 2 0.0,0.0, + 3 csqrt(qmxxa(2)*xe/pai), + 4 csqrt(qmxxa(3)*xe/pai) +C + else +C + write(55,860) csqrt(dmxxa(1)*xe/pai/l0i), + 1 csqrt(dmxxa(2)*xe/pai/(l0i+1)), + 2 csqrt(qmxxa(1)*xe/pai), + 3 csqrt(qmxxa(2)*xe/pai), + 4 csqrt(qmxxa(3)*xe/pai) +C + endif +c + endif +c + if(calctype.ne.'xpd') then + if(l0i.eq.0) then +c write(55,*) '========dq irregular me: hs mesh===============' +C +c write(55,860) 0.0,0.0, +c 1 dmx1(2)/(l0i+1), +c 2 qmx1(1), +c 3 qmx1(2), +c 4 qmx1(3) +C +c write(55,*) '========dq irregular me: ll mesh===============' +C + write(55,860) 0.0,0.0, + 1 dmxx1(2)/(l0i+1), + 2 qmxx1(1), + 3 qmxx1(2), + 4 qmxx1(3),irr_type + else +c write(55,*) '========dq irregular me: hs mesh===============' +C +c write(55,860) dmx1(1)/l0i, +c 1 dmx1(2)/(l0i+1), +c 2 qmx1(1), +c 3 qmx1(2), +c 4 qmx1(3) +C +c write(55,*) '========dq irregular me: ll mesh===============' +C + write(55,860) dmxx1(1)/l0i, + 1 dmxx1(2)/(l0i+1), + 2 qmxx1(1), + 3 qmxx1(2), + 4 qmxx1(3),irr_type + endif + endif + endif +C +c +c 810 format(29x,2f8.5,4x,2f8.5) +c + doit = .false. +c + 9 continue !end energy loop +c + write(iedl0) ((cofct(ne,i),ne=1,kxe),i=1,2) +c + else !perform eels or e2e calculation +c + write(6,*)' calculating eels radial matrix elements' + write(6,*)' n. of prototypical atoms in the effective cluster', + & ' chosen for eels (e2e) radial matrix elements',neff + write(6,*) ' ' + write(6,*) ' ' +c +c + write(55,821) + write(55,822) spectro,correction + write(55,821) +c +c +c write(55,815) +c +c 815 format(2x,'single and two-site eels (e2e) radial matrix elements') +c + do ne = 1, kxe + deltae = float(ne-1)*de + write(6,*) ' ---> start of calculation of eels (e2e) rme at', + 1 ' energy point ',ne +c +c nks: loop on the 3 electrons involved: +c = 1 : incoming electron +c = 2 : scattered electron +c = 3 : excited electron +c + do 10 nks = 1, 3 + if(expmode.eq.'cis') then + if(nks.eq.1) e = einc + if(nks.eq.2) e = einc - cip - emin - deltae + if(nks.eq.3) e = emin + deltae + elseif(expmode.eq.'cfs') then + if(nks.eq.1) e = esct + cip + emin + deltae + if(nks.eq.2) e = esct + if(nks.eq.3) e = emin + deltae + elseif(expmode.eq.'cel') then + if(nks.eq.1) e = einc + deltae + if(nks.eq.2) e = einc - cip - emin + deltae + if(nks.eq.3) e = emin + endif +c + ev=e-vcon +c + if(nks.eq.1) write(6,*)' einc =',e,' Ryd' + if(nks.eq.2) write(6,*)' esct =',e,' Ryd' + if(nks.eq.3) write(6,*)' eloss =',e,' Ryd', + 1 ' (excluding the ion. pot.)' +c +c calculate energy dependent potential: +c + if( irho .ne. 0 ) then + if(ne.eq.1) write(6,*) ' irho =', irho, + & ' entering vxc to calculate energy', + & ' dependent exchange' + call vxc ( doit ) + else + if(ne.eq.1.and.nks.eq.1) then + write(6,*) ' irho =', irho, ' energy independent', + 1 ' potential' + write(6,*)' constant interstitial potential vcon =', + 1 vcon + endif + endif + ev=e-vcon + if( irho .ne. 0 ) + & write(6,*) ' energy dependent vcon = ', vcon, + 1 ' at energy', e,' Ryd' + +C +C CONSTRUCT RELATIVISTIC POTENTIAL ON LINEAR-LOG MESH +C + CALL VREL +C + xe=csqrt(ev) +c +c.....write out potential ans rs files for first neighbors to +c.....absorber for the first energy point +c + nunit=40 + nunit1=nunit+1 + open(unit=nunit,file='plot/plot_v(e).dat',status='unknown') + open(unit=nunit1,file='plot/plot_rs.dat',status='unknown') +c + if(ne.eq.1) then +c + do i=1,nbrs +c + j = ntnabs1(i) + +c write(6,*) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), real(v(k,j)) + write(nunit1,*) r(k,j), rhotot(k,j) + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c + endif +c + close(nunit) + close(nunit1) +c +c calculate maximum l-value lmxne(n,ne) for each prototipical atom +c at the energy e=es(ne) +c + if(lmax_mode.eq.2) then + do n=1,nuatom + lmxne(n,ne) = nint(sqrt(e)*rs(n))+2 + lmxels(nks,n) = lmxne(n,ne) + if(lmxne(n,ne).lt.l0i+1) lmxne(n,ne)=l0i+2 + write(6,*) nks, n, e, rs(n), lmxne(n,ne) + enddo + endif +c + NBL1=NUATOM/4 + XNBL1=FLOAT(NBL1)+0.0001 + XNBL2=FLOAT(NUATOM)/4. + IF(XNBL1.LT.XNBL2) NBL1=NBL1+1 +c 112 FORMAT(4(7X,I2)) + if (lmax_mode.eq.2) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(95,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(70,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(80,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(90,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + ENDDO + else if (lmax_mode.eq.1) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(95,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(70,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(80,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(90,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + ENDDO + else + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmaxt,lmaxt,lmaxt,lmaxt + write(95,112) lmaxt,lmaxt,lmaxt,lmaxt + write(70,112) lmaxt,lmaxt,lmaxt,lmaxt + write(80,112) lmaxt,lmaxt,lmaxt,lmaxt + write(90,112) lmaxt,lmaxt,lmaxt,lmaxt + ENDDO + endif +c +c +c calculate atomic t-matrix with relativistic corrections +c + call smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax, + & ramfnr,ramfsr,ramfsop,ramfsoa) +c + if(eikappr.eq.'yes') then + write(6,*) ' ' + write(6,*) ' calculating phases in the eikonal approximation' + call eikonal(nuatom,xe,z,rs,db) + endif +c +c and corresponding radial integrals of transition matrix elements: +c + if(nks.eq.3) then + write(55,823) ne ! energy point + call radialx_eels(neff) + call writeelswf + endif +c +c + doit = .false. +c + 10 continue !end loop for eels +c + write(6,*) ' ---> end of calculation of eels (e2e) rme', + 1 ' at energy point ',ne + write(6,*) ' ' +c + enddo !end energy do loop +c +c + endif !end of if clause beginning at line 5606 +c +c + 801 format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,f10.5,2x,2f10.5) + 805 format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,f10.5,2x,2e15.6,2x,2e15.6) + 806 format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,2e15.6,2x,2e15.6) + 810 FORMAT(29X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 820 FORMAT(29X,f8.5,1X,f8.5,4X,f8.5,1X,f8.5,4X,f8.5,1X,f8.5) + 821 FORMAT(138('-')) + 822 FORMAT(35x,'matrix elements of ',a4,' with corrections of type: ', + 1 a20) + 823 FORMAT(50x,'---> energy point number ',i5,' <---') + 830 FORMAT(' electric dipole radial integrals +', + 1 ' electric quadrupole radial ', + 2 'integrals') + 840 FORMAT('------------------------------------------------------', + 1 '-+----------------------------------------------------', + 2 '------------------------------') + 850 FORMAT(' R(li --> li - 1) R(li --> li + 1) +', + 1 ' R(li --> li - 2) R(li --> li) ', + 2 ' R(li --> li + 2)') + 860 FORMAT(1X,e12.5,1X,e12.5,2X,e12.5,1X,e12.5,4X,e12.5,1X,e12.5, + 1 2X,e12.5,1X,e12.5,2X,e12.5,1X,e12.5,4x,a9) +c +c ######### the auger matrix elements are written in the output file +c radaed.dat directly from the subroutine radial, since they m +c for each interaction momentum lk + + +c + return +c + end +c +c +c + subroutine output_cont(iq) +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,d_,rd_,sd_ + parameter (at_=nat_-1,d_=ua_-1,rd_=440,sd_=ua_-1) +c +c modified output subroutine for complex potentials +c + common /dens/ irho,rhotot(rd_,sd_),rhoint(2), + $ vcoul(rd_,sd_),vcoulint(2) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + character*8 name0 ,nsymbl + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex ev,xe,vcon +c +c + character*4 label(2) + logical pott,rhoo + data label/'down',' up '/ +c + pott=(irho .ne. 1) + rhoo=(irho .ne. 0) +c + write (6,5) iovrho + 5 format(1x,' starting potentials and/or charge densities', + x ' written to file',i3) +ctn if(radion.ne.0.0. and . nout.eq.1) write(6,10) radion,qion + 15 format(7x,'constant potential=(',1pe14.6,' , ',1pe14.6,')') + 20 format(7x,'interstitial charge=',1pe14.6) +c +c + do 300 ispin=1,nspins + if(nspins.eq.2) write(6,25) label(ispin) + 25 format(///40x,'spin ',a4,' potential') + if( pott ) write (iovrho,15) vcons(ispin) + if( rhoo ) write (iovrho,20) rhoint(ispin) + do 200 n=1,nat + if(neq(n).eq.0) goto 35 + write(iovrho,30) n,neq(n) + 30 format(' mesh and potential for',i4,' same as for',i4) + goto 200 + 35 write(iovrho,40) n,h(n),(ichg(i,n),i=1,10),kplace(n),exfact(n) + 40 format(///i8,' h=',f10.4,' change points:',10i4,' kplace=' + 1 ,i4,' exchange=',f8.6) + kmaxn=kmax(n) + m=n+(ispin-1)*ndat + if( rhoo ) goto 55 + write(iovrho,45) + 45 format(72x/12x,4('r',11x,'real(v)',11x)) + write(iovrho,50) (i,(r(i+j-1,n),v(1,i+j-1,m),j=1,4),i=1,kmaxn,4) + 50 format(1x,i3,8e15.7) + goto 200 + 55 if( pott ) goto 65 + write(iovrho,60) + 60 format(72x/12x,4('r',13x,'rho',13x)) + write(iovrho,50) (i,(r(i+j-1,n),rhotot(i+j-1,m),j=1,4), + x i=1,kmaxn,4) + goto 200 + 65 write(iovrho,70) + 70 format(72x/27x,2('r',11x,'real(v)',10x,'rho',13x)) + write(iovrho,75) (i,(r(i+j-1,n),v(1,i+j-1,m),rhotot(i+j-1,m), + x j=1,2),i=1,kmaxn,2) + 75 format(16x,i3,6e15.7) + goto 200 +c 80 if( rhoo ) goto 90 +c write(iovrho,85) +c 85 format(72x/27x,2('r',11x,'real(v)',9x,'lcore',12x)) +c write(iovrho,75) (i,(r(i+j-1,n),v(1,i+j-1,m), +c x j=1,2),i=1,kmaxn,2) +c goto 200 +c 90 if( pott ) goto 100 +c write(iovrho,95) +c 95 format(72x/27x,2('r',13x,'rho',11x,'lcore',12x)) +c write(iovrho,75) (i,(r(i+j-1,n),rhotot(i+j-1,m), +c x j=1,2),i=1,kmaxn,2) +c goto 200 +c 100 write(iovrho,105) +c 105 format(72x/27x,2('r',11x,'real(v)',10x,'rho', +c x 10x)) +c write(iovrho,50) (i,(r(i+j-1,n),v(1,i+j-1,m), +c x rhotot(i+j-1,m),j=1,2),i=1,kmaxn,2) + 200 continue + 300 continue +c +c + return +c + end +c +c + subroutine radial(doit,imvhl) +c +c include 'mscalc.inc' + include 'msxas3.inc' + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +c +c.....this subroutine calculates the radial matrix elements d(i) +c.....(i=1,2) for lfin=l0i-1 (i=1) and lfin=l0i+1 (i=2) both for +c.....the regular (dmx) and irregular solution (dmx1) +c + common /fcnr/kxe, h(d_),vcons(2,2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) +c + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c +c ######### I introduce a new common with the orbital momentum of +c ######### the two electrons which interacts and give rise to +c ######### to the auger decay; these two momentum are necessary +c ######### to do the loop over the interaction momentum when I perf +c the integrals +c + common/l2holes/l01i,l02i + integer l01i,l02i + + character*8 name0 ,nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_),ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c +c ########## common pdqi modified to include also the Auger two +c wavefunctions + common/pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_) +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) + +c +c ######### common pottype modified to consider also the Auger calcu +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + + + + + + common/auger/calctype,expmode,edge1,edge2 + + character*3 calctype, expmode + character*2 edge1,edge2 + integer nct,l2hmin,l2hmax + + data pai/3.1415927/ +c + common /lparam/lmax2(nat_),l0i +c +c +c + dimension rid(rd_),rid0(rd_),riq0(rd_),cri(rd_),cri1(rd_) + dimension rid2(rd_),cri2(rd_) + complex rid,cri,cri1,dx,qx,dx1,dx2,dx3,dx4 + + + +c + logical*4 doit +c + integer nchannel,lkmaxdir1,lkmaxdir2,lkminexc2 + integer lkmindir1,lkmindir2,lkmaxexc1,lkmaxexc2,lkminexc1 + integer lamin,lamax,lkmin,lkmin1,lkmax,lkmax1,lkm,lkmn + + + +c +c iout = 5 + + + id=1 + n = nas +c +c kx = kmax(n) ! value used in older versions (contains the 3 points +C outside the muffin-tin radius that were used for interpolation) +c + kx = kmax(n) - 3 +c +c ################# Modified the subsequent "if" to take into account +c also the possibility to make an auger calcula +c + if(.not.doit) go to 21 + +c go to 20 + +c +c*********************************************************************** +c find normalization factor for initial state: nfis +c*********************************************************************** +c +c + +c if (calctype.eq.'xpd') then + if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex') then +c n=nas +c kx=kmax(n) + do 156 k=1,kx + 156 rid(k)=rpi(k)**2 + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) + nfis=sqrt(real(dx)) + if(iout .eq. 5) write(6,*) (i, r(i,n), rpi(i)/nfis, i=1,kx) + + + + + WRITE(33,*) CIP + write(33,*) l0i + do i=1,kx + write(33,*) r(i,n), rpi(i)/(nfis*r(i,n)) + enddo + nfis = nfis**2 + + + else +c +c ######## normalization of primary core hole wave function +c +c n=nas +c kx=kmax(n) + do 1560 k=1,kx + 1560 rid(k)=rpi(k)**2 + +c + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) +c + nfis=sqrt(real(dx)) + if(iout .eq. 5) write(6,*) (i, r(i,n), rpi(i)/nfis, i=1,kx) + + + + +c WRITE(33,*) CIP +c write(33,*) l0i + do i=1,kx + write(33,*) r(i,n), rpi(i)/(nfis*r(i,n)) + enddo + + + + +c +c ######### Auger normalization +c + rid(k)=rpi1(k)**2 + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + rid(k)=rpi2(k)**2 + call defint(rid,r(1,n),kx,ichg(1,n),dx2,id) +c + nfis1=sqrt(real(dx1)) + nfis2=sqrt(real(dx2)) + + end if + + +c +c*********************************************************************** +c note that for the initial state rpi(k) = r*pi(k) +c*********************************************************************** +c +c ################ I introduce an if condition to take into account +c ################ also the possibility to make an Auger calculation +c +c 21 if(calctype.eq.'xpd') then + 21 if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex') then +C + do 30 k=1,kx + rid0(k) = r(k,n)**2*rpi(k) + 30 riq0(k) = r(k,n)*rid0(k) +c +c.....calculate regular and irregular dipole matrix elements +c + do 100 i=1,2 + dmx(i)=(0.,0.) + dmx1(i)=(0.,0.) + if((l0i.eq.0).and.(i.eq.1))goto 100 + np = l0i + (-1)**i + do 110 k=1,kx + 110 rid(k) = rid0(k)*p(k,np+1) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri,id) + dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i)/nfis + do 120 k=1,kx + 120 rid(k) = rid0(k)*p(k,np+1+npss) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri1,id) + do 130 k=1,kx + 130 rid(k) = rid(k)*cri(k) + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) + do 140 k=1,kx + 140 rid(k) = rid0(k)*p(k,np+1)*(cri1(kx)-cri1(k)) + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np)/nfis + 100 continue +C +c write(6,*) 'radial matrix elements from shell li = ', l0i +c write(6,*) (real(dmx(l)),aimag(dmx(l)),l=1,2) +c write(6,*) (real(dmx1(l)),aimag(dmx1(l)),l=1,2) +c.....calculate regular and irregular quadrupole matrix elements +c + m = 0 + do 10 i=-2,2,2 + m = m + 1 + qmx(m)=(0.,0.) + qmx1(m)=(0.,0.) + lf = l0i + i + if(lf.le.0) go to 10 + np = l0i + i + do 11 k=1,kx + 11 rid(k) = riq0(k)*p(k,np+1) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri,id) + qmx(m) = (cri(kx)/ramf(nstart+np))**2/nfis + do 12 k=1,kx + 12 rid(k) = riq0(k)*p(k,np+1+npss) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri1,id) + do 13 k=1,kx + 13 rid(k) = rid(k)*cri(k) + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) + do 14 k=1,kx + 14 rid(k) = riq0(k)*p(k,np+1)*(cri1(kx)-cri1(k)) + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + qmx1(m) = (dx+dx1)/ramf(nstart+np)/nfis + 10 continue +C + else +c +c ######## start the auger part; first write +c ######## the orbital momentum of the electrons involved +c + write(55,8110)l0i,l01i,l02i +8110 format(5x,i2,5x,i2,5x,i2) + +c +c ######### Start calculation of auger matrix elements +C ######### rpi is the wavefunction of the primary core hole +C ######### rpi1 and rpi2 are the wavefunction for the two holes in t +c ######### nchannel is the number of channels allowed for +c ######### the Auger continuum electron; +c ######### l2h is the orbital angular momentum given by the coupling +c ######### two orbital momentum of the two final holes +c ######### lk is the 'angular momentum' of the interaction-transferr +c ######### here we count the u_er and lower bound for l of the cont +c + + + l2hmin=abs(l01i-l02i) + l2hmax=l01i+l02i + lamin=abs(l0i-l2hmin) + lamax=l0i+l2hmax +c +c here we count the number of the channels for the continuum auger e +c + nchannel=0 + do 101 np=lamin,lamax + nchannel=nchannel+1 +101 continue + + write(55,8120) lamin,nchannel + 8120 format(12x,i2,5x,i2) +c +c loop over the number of continuum channels +c + nct=0 + do 1 i=1,nchannel + np=lamin+(i-1) + + +c +c ###### establish the range for the interaction momentum for +c ###### the direct integral +c ###### from the selection rules we have: +c ###### abs(np-l01i)r +c + do 1040 k=1,kx +1040 rid2(k)=rpi(k)*rpi2(k)*(r(k,n)**lk) + call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id) + + + do 1050 k=1,kx +1050 rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1)) + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + dxdir=(dx+dx1)*2* + * sqrt(xe/pai)/(nfis*nfis1*nfis2*ramf(nstart+np)) + + + end if +c +c ###### now the exchange integral +c + + lsum3=np+lk+l02i + lsum4=l0i+lk+l01i + + if((lk.lt.lkmin1).or.(lk.gt.lkmax1).or. + * (((lsum3/2)*2).ne.lsum3).or.(((lsum4/2)*2).ne.lsum4)) then + dxexc=(0.,0.) + + else + + do 1060 k=1,kx +1060 rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*(r(k,n)**lk) + call cintegr (rid,r(1,n),kx,ichg(1,n),cri,id) + + + do 1070 k=1,kx + +1070 rid(k)=rpi(k)*rpi1(k)*cri(k)/(r(k,n)**(lk+1)) + + call defint(rid,r(1,n),kx,ichg(1,n),dx3,id) + +c +c ####### now the other region where r'>r +c + do 1788 k=1,kx +1788 rid2(k)=rpi(k)*rpi1(k)*(r(k,n)**lk) + call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id) + + + + do 1799 k=1,kx +1799 rid(k)=r(k,n)*rpi2(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1)) + + call defint(rid,r(1,n),kx,ichg(1,n),dx4,id) + + + dxexc=(dx3+dx4)*2* + * sqrt(xe/pai)/(nfis1*nfis2*nfis*ramf(nstart+np)) + + end if +c +c ############## Write the auger matrix elements +c + +c write(55,8111) 'L =',np,'LB =',lk,dxdir,dxexc +c8111 format(2x,a3,i2,4x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5) + write(55,8111) 'LB =',lk,dxdir,dxexc +8111 format(12x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5) + + + + +2 continue + +1 continue + +c write(55,*) 'nct=',nct + + end if + + return + end +c + subroutine radialx_eels(neff) +c + include 'msxas3.inc' +c + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +c.....this subroutine calculates the radial matrix elements +c.....necessary for eels cross-section +c.....using a linear-log mesh +c + common/mtxele/ nstart,nlast +c + common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), + & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), + & dxxdir,dxxexc + complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, + & dxxdir,dxxexc +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe + character*8 nsymbl,name0 +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf +C + COMMON /LLM/ ALPHA, BETA +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +C COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_) +C COMPLEX PX,DPX,PSX,DPSX,RAMFX +c + COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), + & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), + & RAMFSOA(N_) + COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA +c +C + COMMON/PDQIX/RPIX(RDX_), FNISX + COMPLEX RPIX +C + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +C +c ######### common pottype modified to consider also the Auger calcu +c + + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode +c + common/auger/calctype,expmode,edge1,edge2 +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,ramfprd,ramfprx, + & p3irreg,p2irreg,trop1(rdx_) + complex*16 trop(rdx_) + real*4 einc,esct,scangl,qt,lambda + complex qtc, arg, ydf, scprod +c + common/msbhf/ il(rdx_,lexp_,d_), kl(rdx_,lexp_,d_), kappa + double precision kappa, il, kl +c + character*3 calctype, expmode, eikappr + character*2 edge1,edge2 +C + common /lparam/lmax2(nat_),l0i +c + DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_) + DIMENSION RID1(RDX_),RID2(RDX_),RID3(RDX_),RID4(RDX_) + COMPLEX RID,RID1,RID2,RID3,RID4 + COMPLEX VC,VCX,VCD,VCDX,VCDR,VCDXR +C + CHARACTER*2 RELC +C +C +c*************************************************************************** +c note that here rpix(k) = r**3*pi(k). +c wf rpix(k) is already normalized +c (see subroutine corewf) +c*************************************************************************** +c + pi = 3.1415926 +c + id = 1 + na = nas +c +c.....calculate direct and exchange Coulomb integral on absorber and different +c.....spheres +c + nt0a=n0(na) + ntxa=nt0a+nterms(na)-1 + dxa = hx(na) + nstart = nt0a + nlast = ntxa +c write(6,*) 'in radialx_eels', nt0a, ntxa +c + write(6,*) ' ' + write(6,*)' writing eels (e2e) regular direct terms' + write(55,100) + write(55,821) +c + do 20 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(3,na)) goto 20 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 30 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 40 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 40 + do 50 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(2,nb)) goto 50 + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call coulss(rid1,rid2,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,vc) + write(55,10) na, l, lp, ls, lc, vc/ramfprd !, vc + enddo + endif +c + 50 continue +c + 40 continue +c + 30 continue + + 20 continue +c + write(55,821) + write(55,104) + write(55,821) +c + do 120 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(3,na)) goto 120 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 130 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 140 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 140 + do 150 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(2,nb)) goto 150 + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.ne.nb) then + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call coulds(rid1,rid2,dxa,dxb,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,vcd) + vcdr = vcd/ramfprd + if(abs(vcdr).lt.1.e-9) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr + enddo + enddo + endif +c + 150 continue +c + 140 continue +c + 130 continue + + 120 continue +c + write(6,*)' writing eels (e2e) regular exchange terms' + write(55,821) + write(55,102) + write(55,821) +c + do 21 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(2,na)) goto 21 + do k = 1, kmx(na) + rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 31 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 41 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 41 + do 51 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(3,nb)) goto 51 + do k = 1, kmx(nb) + rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call coulss(rid3,rid4,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,vcx) + write(55,10) na, l, lp, ls, lc, vcx/ramfprx + enddo + endif +c + 51 continue +c + 41 continue +c + 31 continue + + 21 continue +c + write(55,821) + write(55,106) + write(55,821) +C + do 121 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(2,na)) goto 121 + do k = 1, kmx(na) + rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 131 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 141 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 141 + do 151 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(3,nb)) goto 151 + do k = 1, kmx(nb) + rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.ne.nb) then + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call coulds(rid3,rid4,dxa,dxb,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,vcdx) + vcdxr = vcdx/ramfprx + if(abs(vcdxr).lt.1.e-9) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdxr + enddo + enddo + endif +c + 151 continue +c + 141 continue +c + 131 continue + + 121 continue +c + 10 format(5i5,4e15.7) + 11 format(7i5,4e15.7) +c +c write(6,*) alpha, beta +c + if(calctype.eq.'els') then + write(6,*) ' ' + write(6,*)' writing eels irregular direct terms' + write(55,821) + write(55,101) + write(55,821) +c + do 22 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(3,na)) goto 22 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) + if(l.le.5) then + rid(k) = rpix(k)*p3irreg(k,l+1)/(alpha*rx(k,na) + beta) + else + rid(k) = (0.0,0.0) + endif + enddo +c + do 32 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 42 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 42 + do 52 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(2,nb)) goto 52 +c + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + & /ramfsr1(lp+1,nb)/ramfsr2(ls+1,nb) + enddo +c +c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) +c + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call sstrop(rid2,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,trop) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop(k) + rid3(k) = rid(k)*trop(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vc) + if(abs(vc/ramfsr3(l+1,na)).lt.1.e-10) cycle + write(55,10) na, l, lp, ls, lc, vc/ramfsr3(l+1,na) + enddo + else + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call dstrop(rid2,dx2,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop1(k) + rid3(k) = rid(k)*trop1(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vcd) + vcdr = vcd/ramfsr3(l+1,na) + if(abs(vcdr).lt.1.e-10) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr + enddo + enddo + endif +c + 52 continue +c + 42 continue +c + 32 continue + + 22 continue +c +c + write(6,*)' writing eels irregular exchange terms' + write(55,821) + write(55,103) + write(55,821) +c + do 23 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(2,na)) goto 23 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) + if(l.le.5) then + rid(k) = rpix(k)*p2irreg(k,l+1)/(alpha*rx(k,na) + beta) + else + rid(k) = (0.0,0.0) + endif + enddo +c + do 33 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 43 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 43 + do 53 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(3,nb)) goto 53 +c + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + & /ramfsr1(lp+1,nb)/ramfsr3(ls+1,nb) + enddo +c +c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) +c + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call sstrop(rid2,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,trop) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop(k) + rid3(k) = rid(k)*trop(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vc) + if(abs(vc/ramfsr2(l+1,na)).lt.1.e-10) cycle + write(55,10) na, l, lp, ls, lc, vc/ramfsr2(l+1,na) + enddo + else + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call dstrop(rid2,dx2,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop1(k) + rid3(k) = rid(k)*trop1(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vcd) + vcdr = vcd/ramfsr2(l+1,na) + if(abs(vcdr).lt.1.e-10) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr + enddo + enddo + endif +c + 53 continue +c + 43 continue +c + 33 continue + + 23 continue +c + endif !end of if clause to write irregular terms in case of calctype = els +c + write(55,821) +c + 100 format(10x,'single site regular direct terms:') + 101 format(10x,'irregular direct terms:') + 102 format(10x,'single site regular exchange terms:') + 103 format(10x,'irregular exchange terms') + 104 format(10x,'two-site regular direct terms:') + 106 format(10x,'two-site regular exchange terms:') + 821 FORMAT(138('-')) +c + return + end +c +c + subroutine coulss(rho1,rho2,il,kl,kmx,dx,pi,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho1, rho2, vc, vc1, vc2 + complex*16 rid, a, p + real*8 il, kl +c + id = 1 + do k = 1, kmx + rid(k) = il(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = kl(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*il(k)*dcmplx(rho1(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + vc1 = cmplx(p(kmx)) +c write(6,*) 'vc1 = ',vc1 + do k = 1, kmx + rid(k) = a(k)*kl(k)*dcmplx(rho1(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + vc2 = cmplx(p(kmx)) +c write(6,*) 'vc2 = ',vc2 + vc = (vc1 + vc2)*8.0*pi +c + return + end +c +c + subroutine coulds(rho1,rho2,dx1,dx2,ila,ilb, + & kmx1,kmx2,pi,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx1), rho2(kmx2), ila(kmx1), ilb(kmx2) + dimension a1(rdx_), a2(rdx_), rid(rdx_) + complex rho1, rho2, a1, a2, rid, vc1, vc2, vc + real*8 ila, ilb +c + id = 1 + do k = 1, kmx1 + rid(k) = rho1(k)*real(ila(k)) + enddo + call integrcm(rid,dx1,kmx1,a1,id) +c call interp(r1(kpl1-3),a1(kpl1-3),7,rs1,vc1,dummy,.false.) + vc1 = a1(kmx1) +c + id = 1 + do k = 1, kmx2 + rid(k) = rho2(k)*real(ilb(k)) + enddo + call integrcm(rid,dx2,kmx2,a2,id) +c call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.) + vc2 = a2(kmx2) +c + vc = vc1*vc2*8.0*pi + return + end +c +c + subroutine sstrop(rho2,il,kl,kmx,dx,pi,trop) +c + include 'msxas3.inc' +c + dimension rho2(kmx), il(kmx), kl(kmx), trop(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho2 + complex*16 rid, a, p, trop + real*8 il, kl +c + id = 1 + do k = 1, kmx + rid(k) = il(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = kl(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*il(k) + enddo +c + do k = 1, kmx + trop(k) = (rid(k) + a(k)*kl(k))*8.0*pi + enddo +c +c + return + end +c +c + subroutine dstrop(rho2,dx2,ila,ilb,kmx1,kmx2,pi,rid) +c + include 'msxas3.inc' +c + dimension rho2(kmx2), ila(kmx1), ilb(kmx2) + dimension a2(rdx_), rid(rdx_) + complex rho2, a2, rid + real*8 ila, ilb +c + id = 1 + do k = 1, kmx2 + rid(k) = rho2(k)*real(ilb(k)) + enddo + call integrcm(rid,dx2,kmx2,a2,id) +c call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.) + do k = 1, kmx1 + rid(k) = ila(k)*a2(kmx2)*8.0*pi + enddo +c + return + end +c +c + subroutine irregint(rho1,rho2,rl,hl,kmx,dx,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho1, rho2, vc, vc1, vc2 + complex rid, a, p, rl, hl +c + id = 1 + do k = 1, kmx + rid(k) = rl(k)*dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = hl(k)*dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*rl(k)*dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc1 = cmplx(p(kmx)) +c write(6,*) 'vc1 = ',vc1 + do k = 1, kmx + rid(k) = a(k)*hl(k)*dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc2 = cmplx(p(kmx)) +c write(6,*) 'vc2 = ',vc2 + vc = (vc1 + vc2) +c + return + end +c +c + subroutine irregint1(rho1,rho2,kmx,dx,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx), rho2(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho1, rho2, vc, vc1, vc2 + complex rid, a, p +c + id = 1 + do k = 1, kmx + rid(k) = dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc1 = cmplx(p(kmx)) +c write(6,*) 'vc1 = ',vc1 + do k = 1, kmx + rid(k) = a(k)*dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc2 = cmplx(p(kmx)) +c + vc = (vc1 + vc2) +c + return + end +c +c + subroutine setup +c +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,ltot_ + parameter ( at_=nat_-1,ltot_=lmax_+1,n_=ltot_*ua_) +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common/funit/idat,iwr,iphas,iedl0,iwf +c + character*8 name0, name0i, nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + + + + common/auger/calctype,expmode,edge1,edge2 + + + character*3 calctype, expmode + character*2 edge1,edge2 + + common/lparam/lmax2(nat_),l0i +c +c ########## I introduce a common/l2holes to take into account the +c ########## the orbital momentum of the two electrons which interac +c ########## and give rise to the Auger decay; the two orbital momen +c ########## are necessary in subroutine radial to do the loop over +c ########## the interaction momentum +c + common/l2holes/l01i,l02i + + integer l01i,l02i +c + character*8 core_basis_name(25) + integer core_basis_l(25) + character*8 exc_basis_name + integer exc_basis_l(lmax_+1),exc_basis_dim + integer exc_basis_ndg +c + data core_basis_name/'1s1/2','2s1/2','2p1/2','2p3/2', + 1'3s1/2','3p1/2','3p3/2','3d3/2','3d5/2','4s1/2','4p1/2', + 2 '4p3/2','4d3/2','4d5/2','4f5/2','4f7/2','5s1/2','5p1/2', + 3 '5p3/2','5d3/2','5d5/2','5f5/2','5f7/2','5g7/2','5g9/2'/ +c + data core_basis_l/0,0,1,1,0,1,1,2,2,0,1,1,2,2,3,3,0, + 1 1,1,2,2,3,3,4,4/ +c + data exc_basis_name/'no sym'/ + data lmaximum/lmax_/ + + data exc_basis_ndg/1/ +c + do 7001 i=1,lmaximum+1 + exc_basis_l(i)=i-1 +7001 continue + exc_basis_dim=0 + do 7002 i=1,ndat + exc_basis_dim=exc_basis_dim+lmax2(i)+1 +7002 continue +c + + do 59 n=1,nat + lmaxx(n)=0 + n0(n)=0 + n0l(n)=0 + lmaxn(n)=0 + nterms(n)=0 + 59 nls(n)=0 + nuatom=0 + write (6,327)iosym + 327 format(1x,' symmetry information generated internally'/, + x 1x,' symmetry information written to file',i3) +c + name0i=core_basis_name(i_absorber_hole) + write(iwr,120) name0i + write(iosym,120) name0i + + + 120 format(1x,//,' core initial state of type: ',a5) +c + ndim=exc_basis_dim + ndg=exc_basis_ndg + name0=exc_basis_name +c + write (iosym,103) ndim,ndg,name0 + 103 format(' # basis function including o.s. =',i4,' degeneracy=', + 1 i3,5x,a6) + i_l=1 + i_atom=1 + + + + + l0i = core_basis_l(i_absorber_hole) +c +c ############## Modified to consider also the Auger part +c + if (calctype.eq.'aed') then + l01i = core_basis_l(i_absorber_hole1) + l02i = core_basis_l(i_absorber_hole2) + end if +c +c + do 125 n=1,ndim + + ln(n)=exc_basis_l(i_l) + write (iosym,104) n, ln(n) +104 format ( 1x,'basis function no.',i5,' l=',i3) + natom(n)=i_atom + i_l=i_l+1 + if(i_l.gt.(lmax2(i_atom)+1))then + i_l=1 + i_atom=i_atom+1 + endif +c + write(iosym,106) natom(n) + 106 format (30x, ' atom no.=',i3) +c + na=natom(n) + lmaxn(na)=max0(lmaxn(na),ln(n)) + nuatom=max0(nuatom,na) + nterms(na)=nterms(na)+1 + nls(na)=nls(na)+1 + 125 continue +ctn write(6,1099) ndim + write(iosym,112) nuatom, name0 + 112 format(' number of inequivalent atoms =',i4, + * ' for representation:',a6) + if (nuatom.ne.ndat) then + write(6,122) nuatom, ndat + stop + endif + 122 format(//,' fatal error: nuatom not equal ndat',2i5,//) +c + n0(1)=1 + n0l(1)=1 + lmaxx(1)=max0(lmaxx(1),lmaxn(1)) + if(nuatom.eq.1) go to 127 + do 124 na=2,nuatom + n0(na)=n0(na-1)+nterms(na-1) + n0l(na)=n0l(na-1)+nls(na-1) + 124 lmaxx(na)=max0(lmaxn(na),lmaxx(na)) +c branch point + 127 continue + return +c + end +c +c + subroutine smtx(ne,lmax_mode) +c +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf + complex*16 sbfrs(ltot_),dsbfrs(ltot_) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_),ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c + character*8 name0 ,nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe +c + common /seculr/ atm(n_) + complex*16 atm,stmat +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c + complex csqrt,arg,ramf0 +c + common/auger/calctype,expmode,edge1,edge2 + character*3 calctype, expmode + character*2 edge1,edge2 +c + + xe= csqrt(ev) + ns=(nns-1)*ndat +c + do 5 j=1,ndim + 5 atm(j)=(0.0D0,0.0D0) +c +c calculate t-matrix elements: +c stmat: inverse t-m elements (atomic spheres) +c ramf: for normalization of ps(k) functions +c + do 60 na=1,nuatom + WRITE(95,77) NA + ns=ns+1 + mout=1 + nt0a=n0(na) + ntxa=nt0a+nterms(na)-1 + if (na.eq.nas) then + nstart=nt0a + nlast=ntxa + endif + l=-1 + nlat=-1 + arg=xe*rs(na) + ml=lmaxn(na)+1 + call csbf(arg,xe,ml,sbf,dsbf) + call cshf2(arg,xe,ml,shf,dshf) + npabs=0 + do 45 nn=nt0a,ntxa + l=ln(nn) + nlat=nlat+1 + npabs=npabs+1 + if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss + if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45 + call tmat(l,rs(na),kmax(na),z(na),h(na),r(1,na),v(1,ns), + 1 ichg(1,na),mout,kplace(na),p(1,npabs),stmat,ps(nn), + 2 dps(nn),ramf0) +c + atm(nn)=stmat + ramf(nn)=ramf0 + IF(LMAX_MODE.EQ.0) THEN + write(95,1001)xe/0.52917715,stmat + ELSE + write(95,1002)xe/0.52917715,stmat + ENDIF +c +C definition of stmat as exp(-i*delta)*sin(delta) +c + fasi=sign(-1.,real(cmplx(stmat)))* + 1 real(asin(sqrt(abs(dimag(stmat))))) + if(fasi.lt.0.0) fasi=fasi+3.1415926 + write(30,1000)e,xe,na,nlat,stmat,fasi +c write(30)e,xe,na,nlat,stmat +c write(*,*)e,xe,na,nlat,stmat + 1000 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3,2x,2e16.6,f10.5) + 1001 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6) + 1002 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9) + 45 continue + 60 continue +C + 77 FORMAT('-------------------------- ATOM ',I3, + 1 ' -----------------------') +c +c calculate singular solution inside muffin tin sphere for the absorbing +c atom, matching to sbf in interstitial region +c + nl=0 + lmsing=5 + mout=4 + kp=kplace(nas) + kpx=kmax(nas) + do 92 k=kp-3,kpx + if(r(k,nas)-rs(nas)) 92,93,93 + 92 continue +c +c define points (first) kp1 and kp2 outside the absorbing sphere +c and use them to start computation of singular solution (s_l) +c + 93 kp1=k+1 + kpl=kp1-3 + nst=n0(nas) + nlst=n0(nas)+nterms(nas)-1 + l=-1 + ml=lmaxn(nas)+1 + arg=xe*r(kp1,nas) + call cshf2(arg,xe,ml,sbf,dsbf) + arg=xe*r(kp1-1,nas) + call cshf2(arg,xe,ml,shf,dshf) + arg=xe*rs(nas) + call cshf2(arg,xe,ml,sbfrs,dsbfrs) + do 95 n=nst,nlst + l=ln(n) +c +c skip high and divergent l-values of +c singular solution h_l +c + if(l.gt.lmsing)go to 95 + nl=nl+1 + np=npss+nl + np1=nl +c + call tmat(l,rs(nas),kp1,z(nas),h(nas),r(1,nas),v(1,nas), + $ichg(1,nas),mout,kpl,p(1,np),stmat,pss(np1),dpss(np1),ramf0) +c +c shfp = shf(l+1)*xepi +c dshfp = dshf(l+1)*xepi +c print *, ps(np),dps(np),shfp,dshfp +c do 96 k=1,kpx +c if(k.lt.kp2)then +c p(k,np)=p(k,np)*(sbfrs(l+1)/pss(np1))*xepi !rescale h_l +c else ! to match h_l at rs +c p(k,np)=(0.,0.) +c end if +c 96 continue + 95 continue +c + return + end +c + subroutine tmat(l,rs,kmax,z,delh,r,v,ichg,mout,kplace,p,stmat, + 1 ps,dps,ramf) +c +c include 'mscalc.inc' + include 'msxas3.inc' + integer ltot_, rd_ + parameter (ltot_=lmax_+1, rd_=440) +c +c +c +c t-matrix calculation - integrates radial schrodinger equation +c using numerov procedure - does outward and inward integration +c for atomic spheres - gives inverse of t-matrix and log deriva- +c tive at sphere surface. +c +c modified for complex potentials +c +c calculates : +c +c mout=4 solution matching to (0.,1.)*hf2 at r=rs +c +c +c mout=1 atomic spheres t-matrix elements +c returns: +c stmat=[sbfc,ps]/[shfc,ps] (@rs atomic sphere +c ramf=[sbfc,ps]*xe*rs**2 (@rc atomic sphere +c +c +c + common/bessel/sbfc(ltot_),dsbfc(ltot_),shfc(ltot_), + 1 dshfc(ltot_) + complex*16 sbfc,shfc,dsbfc,dshfc +c + common/param/eftr,gamma,vcon,xe,ev,e,iout + complex vcon,xe,ev +c +c + dimension v(kmax),p(kmax),r(kmax),ichg(10) + complex v,p,ps,dps,ramf + complex*16 stmat,x,ramff + complex*16 pk,pk1,pkm,dkm,dk1,dk,gk,gk1,gkm + complex*16 pn(rd_) + data pi/3.141592653589793d0/ +c +c +c + kstop=1 + a=l*(l+1) + if(mout.eq.4) go to 60 +c +c outward integration for atomic spheres +c + ki=1 + if(l.ge.5) ki=ichg(1) + call startp(z,l,e,r,v,kmax,ki,pn) + h=r(ki+1)-r(ki) + hsq=h**2 + pkm=pn(ki) + pk1=pn(ki+1) + dkm=-dcmplx((e-v(ki)-a/r(ki)**2)*hsq)*pn(ki)/12.d0 + dk1=-dcmplx((e-v(ki+1)-a/r(ki+1)**2)*hsq)*pn(ki+1)/12.d0 + kis=ki+2 + n=1 + if(ki.eq.ichg(1)) n=2 + do 34 k=kis,kmax + gk=dcmplx((e-v(k)-a/r(k)**2)*hsq)/12.d0 + pk=dcmplx((2.d0*(pk1+5.d0*dk1)-(pkm-dkm))/(1.d0+gk)) + pn(k)=pk + if(k.lt.ichg(n)) go to 30 + n=n+1 + hsq=4.*hsq + dkm=4.d0*dkm + dk1=-4.d0*gk*pk + pk1=pk + go to 34 + 30 pkm=pk1 + dkm=dk1 + dk1=-gk*pk + pk1=pk + 34 continue +c + go to 78 +c +c inward integration to find solution matching to (0.,1.)*hf2 at r=rs +c + 60 n=11 + 61 n=n-1 + if(n.eq.0) go to 66 + kn=ichg(n) + if(kn.ge.kmax) go to 61 +c + 66 kn=kmax + pkm=sbfc(l+1)*dcmplx(xe/pi*r(kn)) + pk1=shfc(l+1)*dcmplx(xe/pi*r(kn-1)) + hsq=delh**2*4**n + pn(kn)=pkm + pn(kn-1)=pk1 + dkm=-dcmplx((e-a/r(kn)**2-vcon))*pkm*dble(hsq)/12.d0 + dk1=-dcmplx((e-a/r(kn-1)**2-vcon))*pk1*dble(hsq)/12.d0 + k=kn+1 + if(k.gt.kmax) go to 79 + do 76 i=k,kmax + 76 pn(i)=(0.0d0,0.0d0) + 79 k=kn-1 + 73 k=k-1 + 74 gk=dcmplx((e-v(k)-a/r(k)**2))*dble(hsq)/12.d0 + pk=dcmplx((2.d0*(pk1+5.d0*dk1)-pkm+dkm)/(1.d0+gk)) + pn(k)=pk + if(k.eq.kstop) go to 78 + if(n.eq.0) go to 69 + if(k.gt.ichg(n)) go to 69 + if(k.le.2) go to 75 + n=n-1 + dk=-pk*gk + gk1=dcmplx((e-v(k-2)-a/r(k-2)**2))*dble(hsq)/12.d0 + pk1=dcmplx((2.d0*(pk+5.d0*dk)-pk1+dk1)/(1.d0+gk1)) + dk1=-pk1*gk1/4.d0 + hsq=hsq/4. + gkm=dcmplx((e-v(k-1)-a/r(k-1)**2))*dble(hsq)/12.d0 + dk=dk/4.d0 + pkm=0.5d0*((pk-dk)+(pk1-dk1))/(1.d0-5.d0*gkm) + dkm=-pkm*gkm + k=k-3 +c +c keller modification subroutine tmat +c + pn(k+2)=pkm + if(k+1.lt.kstop) go to 78 + pn(k+1) = pk1 + if(k+1.eq.kstop) go to 78 + go to 74 + 69 pkm=pk1 + dkm=dk1 + dk1=-pk*gk + pk1=pk + go to 73 + 75 write(6,103) + stop + 103 format(//,18h error stop - tmat,//) +c +c + 78 continue + do 77 k=1,kmax + 77 p(k)=cmplx(pn(k)/dble(r(k))) + call interp(r(kplace-3),p(kplace-3),7,rs,ps,dps,.true.) + if(mout.eq.4) return + x=dcmplx(dps/ps) + ramff=sbfc(l+1)*x-dsbfc(l+1) + + stmat=ramff/(shfc(l+1)*x-dshfc(l+1)) + ramf=cmplx(ramff)*ps*rs*rs*xe + return +c + end +c +c + subroutine eikonal(nuatom,xe,z,rs,db) +c + include 'msxas3.inc' +c + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + dimension z(at_), rs(at_) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + complex xe +c + open(unit=45, file='tl/tbmat.dat',status='unknown') +c + write(45,*) 'impinging electron wave vector kappa =', real(xe) + write(35,*) 'impinging electron wave vector kappa =', real(xe) + write(6,*) ' impinging electron wave vector kappa =', real(xe) +c + do na=1,nuatom + write(45,*)'atom number ', na,'(z =', z(na),')' + write(35,*)'atom number ', na,'(z =', z(na),')' +c write(6,*)' atom number ', na,'(z =', z(na),')' + z0 = z(na) + call tbmat(db,rs(na),kplace(na),z0,r(1,na),v(1,na),real(xe)) + enddo +c + close(45) +c +c write(6,*) ' normal exit in subroutine eikonal ' +c stop +c + return + end +c +c + subroutine tbmat(db,rs,kmax,z0,r,v,xer) +c + integer rd_ + parameter (rd_=440, nt_=1500) +c + dimension v(kmax),r(kmax), z(rd_) + complex v, z +c + dimension x(nt_), rx(nt_), rid(nt_), rid1(nt_) +c + complex cu, tb, zb, z1, zx, dzx, d2zx, rid, rid1, dbf, dbs +c + data pi/3.1415926/ +c + + do i = 1, kmax + z(i) = r(i)*v(i) +c write(45,*) r(i), z(i) + enddo +c + id = 1 !for subroutine defint + idr = 0 !for subroutine defint + cu = (0.0,1.0) +c write(6,*) + twz = -2.0*z0 +c write(6,*) ' twz =', twz +c +c db = 0.01 +c b0 = -5.3 +c nb = (-b0 + log(rs))/db +c do ib = 1, nb +c b = exp((ib-1)*db + b0) + nb = nint(rs/db) +c write(6,*) 'nb =', nb + do ib = 1, nb - 1 + b = (ib-1)*db + db +c + dx = 0.005 + nx = nint(rs/dx) + rmx = nx*dx + t = rmx/b + rt = log(t + sqrt(t**2-1.0)) +c + nt = nint(rt/dx) +c write(6,*) 'nt =', nt,' for ib =', ib + if(nt.gt.nt_) then + write(6,*) ' ' + write(6,*) ' ' + write(6,*) ' stop in subroutine tbmat ' + write(6,*) ' increase dimension nt_; ', + & ' it should be greater than nt =', nt + write(6,*) ' ' + write(6,*) ' ' + call exit + endif + if(nt.le.4) cycle + x(1) = dx + rx(1) = b*(exp(dx) + exp(-dx))/2.0 +c write(2,*) x(1), rx(1) + do i = 2, nt + x(i) = x(i-1) + dx + rx(i) = b*(exp(x(i)) + exp(-x(i)))/2.0 +c write(2,*) x(i), rx(i) + enddo +c + do i = 1, nt + jlo = 1 + call nearest1(r, kmax, rx(i), ip1, ip2, ip3, jlo) +c + call cinterp_quad( r(ip1), z(ip1), r(ip2), z(ip2), + & r(ip3),z(ip3),rx(i),zx,dzx,d2zx) + rid(i) = zx - twz + rid1(i) = zx + enddo +c + call defint0(rid,dx,nt,zb,id) + call defint0(rid1,dx,nt,z1,idr) +c + zbc = twz*rt + dbf = zb + zbc +c write(6,*) ' coulomb eikonal phase zbc =', zbc +c write(6,*) ' eikonal phase zb =', zb +c write(6,*) ' total eikonal phase dbf =', dbf +c +c write(6,*) ' integrated zx =', z1 +c + dbs = -dbf/xer/2.0 + tb = cu/pi*(cexp(2.0*cu*dbs) - 1.0) +c +c write(6,*) ' eikonal t(b) =', tb,' at b =', b +c + write(45,'(3e15.7)') b, tb + write(35,'(3e15.7)') b, tb +c + enddo +c +c + return + end +c +c + subroutine vxc ( doit ) +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,d_,rd_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,rd_=440,sd_=ua_-1) +c +c calculation of ex-correlation h-l potential +c +c +c + common /dens/ irho,rs(rd_,sd_),rsint(2), + $ vcoul(rd_,sd_),vcoulint(2) + + common /fcnr/kxe, h(d_),vcons(2,2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common /hedin/ wp2,xk,e,eta2,pi,ot,kdens +c +c x_k_0 not divided by k_f +c + common/corr/r_s,blt,x_k_0 +c + character*8 name0 ,nsymbl + common/param/eftr,gamma,vcon(2),xe,ev,ekn,iout,nat,ndat, + 1 nspins,nas,rmuftin(at_),xv(at_),yv(at_),zv(at_),exfact(at_), + 3 z(at_),lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + + complex xe,ev + external f1,f2,f3 + + real*8 r_s,blt,x_k_0,im_vxc,re_vxc,pi_8 + real*4 re_vxc_4,im_vxc_4 + + logical doit, iskip + + nout = 0 + anns=float(nspins) + eps=1.e-3 + eta=1.e-3 + eta2=eta*eta + ot=1./3. + ts2=27.*27. + t2=32. + sqr3=sqrt(3.) + pi=3.1415926 + pi_8 = dble(pi) + a=(4./(9.*pi))**ot + eken=ekn-eftr + +c +c do na = 1, ndat +c print *, ' atom number =', na +c do k = 1 , kmax(na) +c print *, k, r(k,na), rs(k,na) +c enddo +c enddo +c +c calculate rs from charge density first time through subroutine: +c remember that rhotot read in input is actually 4*pi*rho*r**2 +c +c print *, nspins, ndat, kmax(1), 'check point' + if( .not. doit ) goto 100 + do 50 isp=1,nspins + do 40 nb=1,ndat + ns=nb+(isp-1)*ndat + do 30 k=1,kmax(nb) + rs(k,ns)=((3.*(r(k,nb)**2))/(rs(k,ns)*anns))**ot +c if(ns.eq.1) +c & print *, 'r, rs(k,1) =', r(k,1), rs(k,1) + 30 continue + 40 continue + rsint(isp)=(3./(pi*4.*rsint(isp)*anns))**ot + 50 continue +c +c +c calculate self-energy +c + 100 do 300 isp=1,nspins + iskip=.false. + do 280 nb=1,ndat+1 + ns=nb+(isp-1)*ndat + if(.not.iskip)then +c +c compute vxc for atomic and outer spheres +c + km=kmax(nb) + else +c +c compute vxc for interstitial region +c + km=1 + endif + do 260 k=1,km + if(.not.iskip)then + rsp=rs(k,ns) + else + rsp=rsint(isp) + endif + ef=1./(a*rsp)**2 + xk=sqrt(1.0+eken/ef) + if(eken.lt.0.0) xk=1.0 + wp2=4.*a*rsp/(3.*pi) + wp=sqrt(wp2) + xk2=xk*xk + e=.5*xk2 + xkp=xk+1. + xkm=xk-1. + xkpi=1./xkp + if(nedhlp.eq.2)then +c +c define variables used by rehr's subroutine rhl +c + x_k_0=dble(xk/(a*rsp)) + r_s=dble(rsp) + call rhl(re_vxc,im_vxc,pi_8) +c +c conversion to single precision and ryd +c + re_vxc_4 = 2.0*sngl(re_vxc) +c +c conversion to single precision and ryd +c + im_vxc_4 = 2.0*sngl(im_vxc) + if (iskip) goto 1200 + v(1,k,ns)=vcoul(k,ns) + re_vxc_4 + if(imvhl.ne.0)v(2,k,ns)=-im_vxc_4 + gamma + goto 1210 +1200 vcons(1,isp)=vcoulint(isp) + re_vxc_4 + if(imvhl.ne.0)vcons(2,isp)=-im_vxc_4 + gamma +1210 continue + if(imvhl.ne.0)goto 260 + goto 210 + end if +c + flg=alog((xkp+eta2)/(xkm+eta2)) + edxc=(1.-xk2)/xk*.5*flg + vedx=1.5*wp2*(1.+edxc) + vsex = 0.0 + vch = 0.0 + if(nedhlp.ne.0) go to 199 + if(nb.eq.1.and.nout.eq.1) go to 199 + vsex=.75*wp2**2/xk*gauss(f2,xkm,xkp,eps) + vch1=gauss(f3,0.,xkp,eps) + vch2=gauss(f1,0.,xkpi,eps) + vch=.75*wp2**2/xk*(vch1+vch2) + 199 continue + if (iskip) goto 200 + v(1,k,ns)=vcoul(k,ns) - ef*(vedx+vsex+vch) + goto 210 + 200 vcons(1,isp)=vcoulint(isp) - ef*(vedx+vsex+vch) + 210 continue +c +c calculate vim, imaginary part of self energy: +c + if(imvhl.eq.0) goto 260 + rfct = 1.0 ! renormalizes the imaginary part +c if((icplxv.eq.1).and.(.not.iskip)) go to 260 + if(wp2.ge.t2/ts2) go to 215 + c1=ts2*wp2/16. + phi=acos(1.-c1) + phit=phi*ot + xkl=1.+2./9.*(-1.+cos(phit)+sqr3*sin(phit)) + goto 216 + 215 q=(16.-ts2*wp2)/54. + del=(ts2*wp2-t2)*wp2/4. + srdel=sqrt(del) + v2=-q-srdel + v2m=abs(-q-srdel) + xkl=7./9.+ot*((-q+srdel)**ot+sign(1.,v2)*v2m**ot) + 216 xkl2m=xkl**2-1. + xkmm=1.+sqrt(-2./3.+sqrt(4./9.-4.*wp2+xkl2m**2)) + if(abs(xkl-xkmm).gt.1.e-4) + x write(iovrho,221) xkl,xkmm,nb,k,rsp + 221 format(' xkl(=',e14.6,') not equal to xkmm(=',e14.6,') for ', + x ' nb,k,rs=',2i10,e20.6) + xmm=sqrt(1.+2.*wp) + if(xkl.lt.xmm) write(iovrho,222) xkl,xmm,nb,k,rsp + 222 format(' xkl(=',e14.6,') less than xmm(=',e14.6,') for ', + x 'nb,k,rs=',2i10,e20.6) + if(.not.iskip) v(2,k,ns)=gamma + if(iskip) vcons(2,isp)=gamma + if(xk.le.xkl) go to 260 + del1=27.*xk2*wp2-4.*(xk2-ot)**3 + if(del1.ge.0.) write(iovrho,223) nb,k,rsp + 223 format(' discriminant del1 positive for nb,k,rs=',2i10,e20.6) + xm2=-2*ot+sqrt(4./9.-4.*wp2+(xk2-1.)**2) + c1=27.*xk2*wp2/(2.*(xk2-ot)**3) + if(c1.gt.2.) write(iovrho,224) c1,nb,k,rsp + 224 format(' c1(=',e14.6,') gt 2. for nb,k,rs=',2i10,e20.6) + phi=acos(1.-c1) + phit=ot*phi + xk1=(1.-cos(phit)+sqr3*sin(phit))*(xk2-ot)/(3.*xk) + xk12=xk1*xk1 + an=xm2*(xk12*(1.-3.*wp)+6.*wp*(wp+xk*xk1)) + ad=xk12*(xm2+3.*wp*(xk2-1.+2.*wp)) + if (iskip) goto 258 + v(2,k,ns)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma + goto 260 + 258 vcons(2,isp)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma + 260 continue + if(nb.eq.ndat)iskip=.true. + 280 continue + 300 continue +c +c transfer constant for interstitial potential +c + vcon(1)=vcons(1,1) + vcon(2)=vcons(2,1) +c + return + end +c + FUNCTION F1(X) + COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT + YI=1./X + YI2=YI*YI + WQ=SQRT(WP2+OT*YI2+(.5*YI2)**2) + T1=.5*(XK+YI)**2-E+WQ + T2=.5*(XK-YI)**2-E+WQ + R=(T1*T1+ETA2)/(T2*T2+ETA2) + F1=.5*ALOG(R)*YI/WQ + RETURN + END + FUNCTION F2(X) + COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT + X2=X*X + WQ=SQRT(WP2+OT*X2+(.5*X2)**2) + T1=.5-E-WQ + T2=.5*(XK-X)**2-E-WQ + T3=T2+2.*WQ + T4=.5-E+WQ + R=(T1*T1+ETA2)*(T3*T3+ETA2)/((T2*T2+ETA2)*(T4*T4+ETA2)) + F2=.5*ALOG(R)/(WQ*X) + RETURN + END + FUNCTION F3(X) + COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT + X2=X*X + WQ=SQRT(WP2+OT*X2+(.5*X2)**2) + T1=.5*(XK+X)**2-E+WQ + T2=.5*(XK-X)**2-E+WQ + R=(T1*T1+ETA2)/(T2*T2+ETA2) + F3=.5*ALOG(R)/(WQ*X) + RETURN + END + FUNCTION GAUSS(F,A,B,EPS) + LOGICAL MFLAG,RFLAG + EXTERNAL F + DIMENSION W(12),X(12) +C +C ****************************************************************** +C +C ADAPTIVE GAUSSIAN QUADRATURE. +C +C GAUSS IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF +C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER +C EPS. +C +C ****************************************************************** +C + DATA W + */1.01228536E-01, 2.22381034E-01, 3.13706646E-01, + * 3.62683783E-01, 2.71524594E-02, 6.22535239E-02, + * 9.51585117E-02, 1.24628971E-01, 1.49595989E-01, + * 1.69156519E-01, 1.82603415E-01, 1.89450610E-01/ + + DATA X + */9.60289856E-01, 7.96666477E-01, 5.25532410E-01, + * 1.83434642E-01, 9.89400935E-01, 9.44575023E-01, + * 8.65631202E-01, 7.55404408E-01, 6.17876244E-01, + * 4.58016778E-01, 2.81603551E-01, 9.50125098E-02/ +C +C ****************************************************************** +C +C START. +C + GAUSS=0. + IF(B.EQ.A) RETURN + CONST=0.005/(B-A) + BB=A +C +C COMPUTATIONAL LOOP. +C + 1 AA=BB + BB=B + 2 C1=0.5*(BB+AA) + C2=0.5*(BB-AA) + S8=0. + DO 3 I=1,4 + U=C2*X(I) + S8=S8+W(I)*(F(C1+U)+F(C1-U)) + 3 CONTINUE + S8=C2*S8 + S16=0. + DO 4 I=5,12 + U=C2*X(I) + S16=S16+W(I)*(F(C1+U)+F(C1-U)) + 4 CONTINUE + S16=C2*S16 + IF( ABS(S16-S8) .LE. EPS*(1.+ABS(S16)) ) GO TO 5 + BB=C1 + IF( 1.+ABS(CONST*C2) .NE. 1. ) GO TO 2 + GAUSS=0. + CALL KERMTR('D103.1',LGFILE,MFLAG,RFLAG) + IF(MFLAG) THEN + IF(LGFILE.EQ.0) THEN + WRITE(*,6) + ELSE + WRITE(LGFILE,6) + ENDIF + ENDIF + IF(.NOT. RFLAG) CALL ABEND + RETURN + 5 GAUSS=GAUSS+S16 + IF(BB.NE.B) GO TO 1 + RETURN +C + 6 FORMAT( 4X, 'FUNCTION GAUSS ... TOO HIGH ACCURACY REQUIRED') + END +C + SUBROUTINE KERSET(ERCODE,LGFILE,LIMITM,LIMITR) + PARAMETER(KOUNTE = 28) + CHARACTER*6 ERCODE, CODE(KOUNTE) + LOGICAL MFLAG, RFLAG + INTEGER KNTM(KOUNTE), KNTR(KOUNTE) + DATA LOGF / 0 / + DATA CODE(1), KNTM(1), KNTR(1) / 'C204.1', 100, 100 / + DATA CODE(2), KNTM(2), KNTR(2) / 'C204.2', 100, 100 / + DATA CODE(3), KNTM(3), KNTR(3) / 'C204.3', 100, 100 / + DATA CODE(4), KNTM(4), KNTR(4) / 'C205.1', 100, 100 / + DATA CODE(5), KNTM(5), KNTR(5) / 'C205.2', 100, 100 / + DATA CODE(6), KNTM(6), KNTR(6) / 'C205.3', 100, 100 / + DATA CODE(7), KNTM(7), KNTR(7) / 'C305.1', 100, 100 / + DATA CODE(8), KNTM(8), KNTR(8) / 'C308.1', 100, 100 / + DATA CODE(9), KNTM(9), KNTR(9) / 'C312.1', 100, 100 / + DATA CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 / + DATA CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 / + DATA CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 / + DATA CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 / + DATA CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 / + DATA CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 / + DATA CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 / + DATA CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 / + DATA CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 / + DATA CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 / + DATA CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 / + DATA CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 / + DATA CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 / + DATA CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100, 0 / + DATA CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100, 0 / + DATA CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100, 0 / + DATA CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100, 0 / + DATA CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 / + DATA CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 / + LOGF = LGFILE + IF(ERCODE .EQ. ' ') THEN + L = 0 + ELSE + DO 10 L = 1, 6 + IF(ERCODE(1:L) .EQ. ERCODE) GOTO 12 + 10 CONTINUE + 12 CONTINUE + ENDIF + DO 14 I = 1, KOUNTE + IF(L .EQ. 0) GOTO 13 + IF(CODE(I)(1:L) .NE. ERCODE(1:L)) GOTO 14 + 13 KNTM(I) = LIMITM + KNTR(I) = LIMITR + 14 CONTINUE + RETURN + ENTRY KERMTR(ERCODE,LOG,MFLAG,RFLAG) + LOG = LOGF + DO 20 I = 1, KOUNTE + IF(ERCODE .EQ. CODE(I)) GOTO 21 + 20 CONTINUE + WRITE(*,1000) ERCODE + CALL ABEND + RETURN + 21 RFLAG = KNTR(I) .GE. 1 + IF(RFLAG .AND. (KNTR(I) .LT. 100)) KNTR(I) = KNTR(I) - 1 + MFLAG = KNTM(I) .GE. 1 + IF(MFLAG .AND. (KNTM(I) .LT. 100)) KNTM(I) = KNTM(I) - 1 + IF(.NOT. RFLAG) THEN + IF(LOGF .LT. 1) THEN + WRITE(*,1001) CODE(I) + ELSE + WRITE(LOGF,1001) CODE(I) + ENDIF + ENDIF + IF(MFLAG .AND. RFLAG) THEN + IF(LOGF .LT. 1) THEN + WRITE(*,1002) CODE(I) + ELSE + WRITE(LOGF,1002) CODE(I) + ENDIF + ENDIF + RETURN +1000 FORMAT(' KERNLIB LIBRARY ERROR. ' / + + ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR', + + ' ERROR MONITOR. RUN ABORTED.') +1001 FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ', + + 'CONDITION ',A6) +1002 FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6) + END +C + SUBROUTINE ABEND +C +C CERN PROGLIB# Z035 ABEND .VERSION KERNVAX 1.10 811126 + + STOP '*** ABEND ***' + END +C==================================================================== +C + SUBROUTINE GET_CORE_STATE +C + IMPLICIT REAL*8(A-H,O-Z) +C +c INCLUDE 'mscalc.inc' + include 'msxas3.inc' +c +c ############ I include the file msxasc3.inc +c + include 'msxasc3.inc' + +cman + integer rd_ + PARAMETER(RD_=440) +C + + + + + + COMMON/APARMS2/XV2(NAT_),YV2(NAT_),ZV2(NAT_),RS2(NAT_), + U ALPHA2(NAT_),REDF2(NAT_),Z2(NAT_),Q2(NAT_),QSPNT2(2), + U QINT2(2), + U WATFAC(NAT_),ALPHA02,VOLINT2,OVOUT2,RMXOUT2,NSYMBL2(NAT_), + U NZ2(NAT_) + + CHARACTER*8 NSYMBL2 + +C + +c #############common/pot_type modified to include the core states +c #############to the two hole in the final state of Auger decay i_ +c ##############common /pdqi modified to consider also the two auger wav +C +C common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, +C * i_absorber_hole2,i_norman,i_alpha, +C 1 i_outer_sphere,i_exc_pot,i_mode +C + + COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1, + * I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA, + 1 I_OUTER_SPHERE,I_EXC_POT,I_MODE + + + + +C + + COMMON/PDQI/RPI(RD_),RPI1(RD_),RPI2(RD_) + REAL*4 RPI,RPI1,RPI2 + INTEGER I_HOLE +c INTEGER HOLE +C + DIMENSION R(440),P_NK(440),P_NK1(440),P_NK2(440),ICHG(12) +C + DATA THIRD,XINCR,CTFD + &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/ +C + DATA KMX,MESH/RD_,440/ +C + IZ=NZ2(I_ABSORBER+I_OUTER_SPHERE) +c open(unit=697,file='get1.dat',status='unknown') + if(iz.eq.0) then + iz=1 ! in case an empty sphere is the first atom + write(6,*) ' warning check! empty sphere is the first atom ' + endif + + I_RADIAL=I_ABSORBER_HOLE +C +C ######### Modified to consider also the Auger calculation +C + I_RADIAL1=I_ABSORBER_HOLE1 + I_RADIAL2=I_ABSORBER_HOLE2 + I_HOLE=0 + NCUT=1 +C +C SET-UP HERMAN-SKILLMAN MESH FOR Z OF ABSORBING ATOM +C + MESH=MESH/NCUT + H=XINCR*CTFD/(DFLOAT(IZ)**THIRD)*NCUT + R(1)=H + DO 10 N=1,12 +10 ICHG(N)=(40/NCUT)*N + N=1 + DO 20 K=2,MESH + R(K)=R(K-1)+H + IF (K.LT.ICHG(N)) GO TO 20 + H=H+H + N=N+1 +20 CONTINUE +C +C*** COMPUTE FUNCTION P_NK ON RADIAL MESH R +C + CALL ATOM_SUB(IZ,I_HOLE,R,P_NK,1,I_RADIAL,0.d0) +C + + +C +C*** PASS VIA COMMON BLOCK THE FIRST KMX POINTS. NOTE THAT +C P_NK IS NOT NORMALIZED SINCE Q_NK MUST ALSO BE CONSIDERED. +C ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION +C R*R_L = P_NK. THIS RELATION HOLDS IN THE LIMIT C --> INFINITY. +C + DO 30 I=1,KMX + RPI(I)=SNGL(P_NK(I)) + + +30 CONTINUE + + +c +c ############# modified to make the calculations also for the two +c ############# wave functions necessary for the auger decay calcula +c ############# these two wavefunction are calculated with Z+1 appro +c ############# with one hole=to the deeper first core hole (hole) +c + IF (calctype.EQ.'aed') THEN + + + I_HOLE=HOLE2 + + + CALL ATOM_SUB(IZ,I_HOLE,R,P_NK1,1,I_RADIAL1,0.d0) + CALL ATOM_SUB(IZ,I_HOLE,R,P_NK2,1,I_RADIAL2,0.d0) + DO 3011 I=1,KMX + RPI1(I)=SNGL(P_NK1(I)) + RPI2(I)=SNGL(P_NK2(I)) + + + + +3011 CONTINUE + + + + + + END IF +C + + RETURN + END +c +C + SUBROUTINE COREWF(NAS,IZC,HOLE) +C + INCLUDE 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +C + COMMON/PDQIX/RPIX(RDX_), FNISX + COMPLEX RPIX +C + DOUBLE PRECISION CWFX(RDX_),RXD(RDX_),XION + COMPLEX RIDX(RDX_),DX +C + INTEGER HOLE +C + DATA THIRD,XINCR,CTFD + &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/ +C +C + IZ=IZC + ITYRADIAL=HOLE +C + XION=0 + ITYHOLE=0 +C + KMXN = KMX(NAS) + DO I = 1, KMXN + RXD(I) = DBLE(RX(I,NAS)) + ENDDO +c write(6,*) ' corewf: kmx = ', kmxn +C +C*** COMPUTE FUNCTION P_NK ON RADIAL MESH RD AND LL MESH RX +C + XION = 0.D0 + CALL GET_INTRP_CORE(IZ,ITYHOLE,ITYRADIAL,XION,CWFX,RXD,KMXN) +C +C*** NOTE THAT CWFX=P_NK (UPPER COMPONENT OF DIRAC EQU.) IS NOT NORMALIZED +C SINCE ALSO Q_NK (LOWER COMPONENT) MUST ALSO BE CONSIDERED. +C ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION R*R_L = P_NK. +C THIS RELATION HOLDS IN THE LIMIT C --> INFINITY. +c +c.....Find normalization constant in ll-mesh. +c + do i = 1, kmxn + xi = sngl(cwfx(i)) + rpix(i)=cmplx(xi) +c write(6,*) rx(i,nas), xi + enddo + +c dh = x(2,n) - x(1,n) +c write(6,*) ' dh ', dh, hx(n), alpha, beta + n = nas + id = 1 + do k = 1,kmxn + ridx(k)=rpix(k)**2*rx(k,n)/(alpha*rx(k,n) + beta) + enddo + call defint0(ridx,hx(n),kmxn,dx,id) + fnisx=sqrt(real(dx)) +c +c write(6,*) 'corewf: fnisx = ', fnisx +c + do k=1,kmxn + rpix(k)=rx(k,n)**2*rpix(k)/fnisx + enddo +c + RETURN + END +C +C +C*********************************************************************** +C + subroutine get_intrp_core(iz,ihole,i_radial,xion,cwfx,rx,kmxn) +c +c + implicit real*8(a-h,o-z) +c +c + parameter ( mp = 251, ms = 30 ) +c + character*40 title +c + common/mesh_param/jlo + common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy +c +c For interpolation on rx mesh +c + dimension rx(kmxn), cwfx(kmxn) + dimension p(0:mp), rat(0:mp), r(mp) +c +c + dimension dum1(mp), dum2(mp) + dimension vcoul(mp), rho0(mp), enp(ms) +c + title = ' ' +c + ifr=1 + iprint=0 +C + amass=0.0d0 + beta=0.0d0 +c +c There are no nodes in relativistic radial charge density +c + small=1.0d-11 +c !Hence a lower limit on rho(r) can be used. + dpas=0.05d0 + dr1=dexp(-8.8d0) + dex=exp(dpas) + r_max=44.447d0 +c + radius=10.0d0 +c + xion=0.d0 +c +c compute relativistic Hartrer-Fock-Slater charge density (on log mesh) +c + call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, + 1 vcoul, rho0, dum1, dum2, enp, eatom) +c +c compute radial log mesh (see subroutine phase in J.J. Rehr's program +c FEFF.FOR) +c + ddex=dr1 + do 10 i=1,251 + r(i)=ddex + ddex=ddex*dex +10 continue +c +c write(6,*) ' interpolating on rx mesh ' +c Dump upper componen of Dirac wf into p +c + p(0) = 0.d-8 + rat(0) = 0.d-8 + do i = 1, 251 + p(i) = dgc(i,i_radial) + rat(i) = r(i) +c write(6,*) rat(i), p(i) + enddo +c + do i=1,kmxn + if(rx(i).gt.r_max) goto 60 +c find nearest points +c initialize hunting parameter (subroututine nearest) +c + jlo=1 + call nearest(rat,252,rx(i), + 1 i_point_1,i_point_2,i_point_3) +c + i_point_1 = i_point_1 -1 + i_point_2 = i_point_2 -1 + i_point_3 = i_point_3 -1 +c +c interpolate wavefunction +c + call interp_quad( rat(i_point_1),p(i_point_1), + 1 rat(i_point_2),p(i_point_2), + 1 rat(i_point_3),p(i_point_3), + 1 rx(i),cwfx(i) ) + enddo +c +60 continue +c + return + end +C +C +C*********************************************************************** +c + subroutine input_cont(id,potype,potgen,lmax_mode,lmaxt) +c + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +c modified input subroutine for (optionally) complex potentials +c + common /dens/ irho,rhotot(rd_,sd_),rhoconi(2), + $ vcoul(rd_,sd_),vcoulint(2) + + common/auger/calctype,expmode,edge1,edge2 +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + character*8 name0 ,nsymbl + character*3 calctype, expmode + character*5 potype + character*2 potgen + character*2 edge1,edge2 +c +ctn common block from msxas3.inc +c .... redundant variables with param.... +c + common/continuum/xemin,xemax,xdelta,xcip,xgamma,xeftri,iexcpot +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode +c !pass pots and rhos to this sub + common/out_ascii/iout_ascii +c + common/lparam/lmax2(nat_),l0i +c + logical check +c + character*65 exc_pot_label(5) + character*65 exc_pot_label_extnl(6) + data exc_pot_label/ + &'generating final potential (x_alpha exchange)', + &'generating final potential (real dirac-hara exchange)', + &'generating final potential (real hedin-lundqvist exchange)', + &'generating final potential (complex dirac-hara exchange)', + &'generating final potential (complex hedin-lundqvist exchange)' + &/ + data exc_pot_label_extnl/ + &'potential from extnl file (x_alpha exchange)', + &'potential from extnl file (real dirac-hara exchange)', + &'potential from extnl file (real hedin-lundqvist exchange)', + &'potential form extnl file (complex dirac-hara exchange)', + &'potential form extnl file (complex hedin-lundqvist exchange)', + &'potential form extnl file (potential from lmto calculation)' + &/ +c + data lunout/7/, ot/.333333/, pi/3.1415926/ +c +c**** definitions for this version of continuum +c + iout=2 + nspins=1 + iout_ascii=2 +c !output check files + iovrho=13 + iosym=14 +c +c*** define state dependent parameters +c read cip (core ionization potential),emin,emax and deltae +c in order to check array sizes. +ctn read(5,*) cip,emin_exc,emax_exc,de_exc +ctn read(5,*) i_exc_pot,gamma,eftri +ctn initializes from common continuum +c + emin_exc=xemin + emax_exc=xemax + de_exc=xdelta + cip=xcip + gamma=xgamma + eftri=xeftri + i_exc_pot=iexcpot +ctn write(*,*)'dans inpot_cont:' +ctn write(*,*) cip,emin_exc,emax_exc,de_exc +ctn write(*,*) i_exc_pot,gamma,eftri +c +c de_exc = 0.05 +c con = 27.2116/7.62 +c wvb = sqrt(con*emin_exc) +c wve = sqrt(con*emax_exc) +c kxe = nint((wve-wvb)/0.05 + 1.) +c kxe = nint(alog(emax_exc - emin_exc + 1.)/de_exc + 1.) + kxe = nint((xemax-xemin)/xdelta + 1.) + if(kxe.gt.nep_)then +c write(lunout,730) kxe + write(6,730) kxe +730 format(//, + & ' increase the dummy dimensioning variable, nep_. ', + & /,'it should be at least equal to: ', i5,/) + write(6,'(3f10.5)') xemax, xemin, xdelta + call exit + end if +c !define absorbing atom + nas=i_absorber +c + emin=emin_exc + emax=emax_exc + de=de_exc + if(i_exc_pot.eq.1)then +c !define exchange potential types + nedhlp=0 + irho=0 + imvhl=0 + if(i_mode.eq.1)then + + print 745,exc_pot_label_extnl(1) + else + print 745,exc_pot_label(1) + end if +745 format(2x,a65) + else if(i_exc_pot.eq.2)then + nedhlp=1 + irho=2 + imvhl=0 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(2) + else + print 745,exc_pot_label(2) + end if + else if(i_exc_pot.eq.3)then +c +c nedhlp=2 !use rehr's approximation to re(vxc) +c + nedhlp=0 !use exact integral expression for re(vxc) + irho=2 + imvhl=0 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(3) + else + print 745,exc_pot_label(3) + end if + else if(i_exc_pot.eq.4)then + nedhlp=1 + irho=2 + imvhl=1 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(4) + else + print 745,exc_pot_label(4) + end if + else if(i_exc_pot.eq.5) then +c +c nedhlp=2 !use rehr's approximation to re(vxc) and im(vxc) +c + nedhlp=0 !use exact integral expression for vxc +c + irho=2 + imvhl=1 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(5) + else + print 745,exc_pot_label(5) + end if + else if(i_exc_pot.eq.6) then + irho = 0 + print 745, exc_pot_label_extnl(6) +c + end if +c + + if(irho.ne.0)then + i_alpha=0 + else + i_alpha=1 + end if + if (i_mode.eq.1)then +c call get_external_pot + if(potype.eq.' lmto') print 745, exc_pot_label_extnl(6) + call get_ext_pot_lmto(potype) + else + call vgen + end if +c +c... calculate fermi level eftr = vcint + kf**2 - .72*3./2.*kf/pi*2. +c + if (irho.eq.0) then + eftr = real(vcons(1))/2. + else + fmkf = (3.*pi**2*rhoconi(1))**ot + eftr = real(vcons(1)) + fmkf*(fmkf - 2.16/pi) + endif +c + if (eftri.ne.0.0) eftr = eftri +c + if (lmax_mode.eq.0) then +c write(lunout,741) + write(6,741) lmaxt +741 format(/,1x,' lmax constant on each atom equal to: ', i5) +c + else if (lmax_mode.eq.1) then +c write(lunout,741) + write(6,742) emax +742 format(/,1x,' lmax assignment based on', + & ' lmax = r_mt * k_max + 2',/, + & ' at energy emax =',f12.6) +c + else +c write(lunout,741) + write(6,743) +743 format(/,1x,' lmax assignment based on', + & ' l_max = r_mt * k_e + 2',/, + & ' where e is the running energy') +c + endif + +c ###### problem: for low energy continuum auger electron it can happen +c that lmax2 is less than the higher value of the orbital mom +c allowed for the continuum auger electron; thus I set the lm +c value equal to the lmax_ value given in the include file +c msxas3.inc +c + l_max = 0 +c + if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or. + & (calctype.eq.'rex').or.(calctype.eq.'led')) then +c +c !assign lmax values and check max(lm) +c + if (lmax_mode.eq.0) then + do i=1,ndat + lmax2(i) = lmaxt +c write(lunout,842) lmax2(i),i + write(6,842) lmax2(i),i +842 format(10x,' lmax =', i3, ' on center =', i3) + enddo +c + else if (lmax_mode.eq.1) then + do i=1,ndat + lmax2(i) = nint(rs(i)*sqrt(emax)) + 2 + if(l_max.lt.lmax2(i)) l_max=lmax2(i) +c write(lunout,843) lmax2(i),i + write(6,843) lmax2(i),i +843 format(10x,' optimal lmax =', i3, ' on center =', i3) + enddo +c + else + do i=1,ndat + lmax2(i) = nint(rs(i)*sqrt(emax)) + 2 + if(l_max.lt.lmax2(i)) l_max=lmax2(i) + if(i.eq.ndat) then +c write(lunout,844) + write(6,844) + endif +844 format(1x,' optimal lmax chosen according to the running', + & ' energy e for each atom') + enddo +c + endif +c +c...give warning for insufficient lmax dimensions +c + check = .false. + if(lmax_mode.ne.0) then + if(l_max.gt.lmax_) then +c manolo + check=.true. +c write(lunout,746)l_max + write(6,746)l_max +746 format(///, + & ' increase the dummy dimensioning variable, lmax_. ', + & /,' it should be at least equal to: ', i5) + call exit + endif + else + if(lmaxt.gt.lmax_) then +c manolo + check=.true. +c write(lunout,746)lmaxt + write(6,746)lmaxt + call exit + endif + endif +c +c + else +c +c ##### auger part: +c + do i=1,ndat + lmax2(i)=lmax_ + l_max=lmax_ + enddo + + end if +c +c...set lmax equal on any atom if check='true' +c + if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or. + & (calctype.eq.'rex').or.(calctype.eq.'led')) then + if(check) then + do i=1,ndat + lmax2(i) = l_max + write(6,7422)lmax2(i),i +7422 format(10x,' lmax =', i3, ' on center =', i3) + enddo +c + write(6,*) ' ' + write(6,*)' ** input_cont warning **' + write(6,*)' -> estimated l_max is greater than lmax_' + write(6,*)' computation proceeds with l_max=lmax_' + write(6,*)' but convergence is not guaranteed' +c + endif +c + else +c do i=1,ndat +c lmax2(i) = l_max +c write(6,7422)lmax2(i),i +c enddo + endif +c + write(6,*) + +c +c + write (iovrho,408) nedhlp,irho,imvhl,eftr,gamma + 408 format(' nedhlp=',i5,' irho=',i5,' imvhl=',i5, + x /,' eftr = ',f10.6,' gamma =',f10.6) + write (iovrho,409) nat,ndat,nspins, + 1 inmsh,inv,inrho,insym,iovrho,iosym + 409 format(9i5) +c + write(iovrho,110) nat + if (iovrho .ne. 6 ) write(6,110) nat + 110 format(/,2x,18hnumber of centers=,i5,/) +c +c store coulomb potential if energy dependent exchange is to be used +c + if(irho.ne.0)then + do 4304 isp=1,nspins + do 4303 nb=1,ndat + ns=nb+(isp-1)*ndat + do 4302 k=1,kmax(nb) + vcoul(k,ns)=v(1,k,ns) +4302 continue +4303 continue + vcoulint(isp)=real(vcons(isp)) +4304 continue + end if +c +c check for consistency of input data: +c + write(iovrho,111) + 111 format(30x,10hatom no.,12x,8hposition,14x,13hradius eq ) + write(iovrho,112) (i,nsymbl(i),nz(i),xv(i),yv(i),zv(i),rs(i), + 1 neq(i),i=1,nat) + write (iovrho,112) + 112 format(26x,i3,2x,a4,i6,4f10.4,i6) + do 211 i=1,nat + if(rs(i).lt.0.0) then + write(iovrho,201) i, rs(i) + write(6,201) i, rs(i) + call exit + endif + if(neq(i).eq.0)go to 210 + if(neq(i).ge.i) go to 213 + 210 i1=i+1 + if(i1.gt.nat) go to 5000 + go to 2135 + 213 write(iovrho,202) neq(i), i + write(6,202) neq(i), i + call exit + 2135 do 211 j=i1,nat + rij = sqrt((xv(j)-xv(i))**2+(yv(j)-yv(i))**2+(zv(j)-zv(i))**2) + rsum = rs(i)+rs(j) + rdif = rsum-rij + if (rsum.gt.rij) go to 215 + go to 211 + 215 write (iovrho,200) i,j,rsum,rij,rdif + 200 format(' spheres',2i5,' overlap ',3f12.6) + 201 format(' sphere',i5,' has negative rs', f12.6) + 202 format(' neq(i)',i5,' for atom i=', i5,' is inconsistent' ) + 211 continue +c + 5000 return + end +c +C + SUBROUTINE GET_EXTERNAL_POT +C +c INCLUDE 'mscalc.inc' + include 'msxas3.inc' + INTEGER AT_,D_,RD_,SD_ + PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) + + COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2), + $ VCOUL(RD_,SD_),VCOULINT(2) +C + COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_), + $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS +C + COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, + 1 IMVHL,NEDHLP +C + CHARACTER*8 NAME0 ,NSYMBL +C + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV +C + COMMON/DIMENS2/NAT2,NDAT2 +C +cman DATA INV,INRHO/2,3/ + inv=2 + inrho=3 +C + NAT = NAT2 - 1 + NDAT = NDAT2 - 1 +C + OPEN(INV, status='unknown') + DO 4444 N=1,NAT + READ (INV,311) NSYMBL(N),NEQ(N), NZ(N),IDUMMY,KMAX(N), + 1 KPLACE(N),XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC +311 FORMAT (1X,A4,3I2,2I4,5F11.6,T76,I5) + Z(N)=NZ(N) + IF(NEQ(N).NE.0) GO TO 4444 +C +C RECONSTRUCT RADIAL MESH +C + READ (INV,308) (ICHG(I,N),I=1,10),NC + 308 FORMAT(10I5,T76,I5) + KX=KMAX(N) + READ (INV,319) NC,(R(I,N),I=1,5) + H(N)=R(2,N)-R(1,N) + HH=H(N) + ICH=1 + KICH=ICHG(ICH,N) + DO 133 K=3,KX + R(K,N)=R(K-1,N)+HH + IF (K.LT.KICH) GO TO 133 + ICH=ICH+1 + KICH=ICHG(ICH,N) + HH=HH+HH +133 CONTINUE + 319 FORMAT(T76,I5,T2,1P5E14.7) + H(N)=R(2,N)-R(1,N) + NS=N +C + DO 142 ISPIN=1,NSPINS + DO 141 K=1,KX,5 + KCARD=MIN0(KX,K+4) + READ (INV,319) NC,(V(1,I,NS),I=K,KCARD) + DO 7474 KKK=K,KCARD + 7474 V(2,KKK,NS) = 0.000 + 141 CONTINUE + 142 NS=NS+NDAT +C + IF(IRHO.EQ.0) GOTO 4444 + OPEN(INRHO, status='unknown') + DO 423 ISPIN=1,NSPINS + NS=N+(ISPIN-1)*NDAT + DO 424 K=1,KX,5 + KCARD=MIN0(KX,K+4) + READ(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD) + 424 CONTINUE + 423 CONTINUE + 4444 CONTINUE +C +C READ INTERSTITIAL V AND RHO +C + READ (INV,319) NC,(VCONS(ISPIN),ISPIN=1,NSPINS) + IF(IRHO.NE.0)READ (INRHO,319) NC,(RHOCONI(ISPIN),ISPIN=1,NSPINS) +C + WRITE(6,120) INV + 120 FORMAT (' STARTING POTENTIAL READ IN FROM FILE',I4) + IF( IRHO .NE. 0) WRITE(6,121) INRHO + 121 FORMAT (' STARTING CHARGE DENSITY READ IN FROM FILE',I4) +C + REWIND(INV) + REWIND(INRHO) +C + RETURN + END +C + SUBROUTINE GET_EXT_POT_LMTO(potype) +C + include 'msxas3.inc' +C + INTEGER AT_,D_,RD_,SD_ + PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) +C + PARAMETER (MRP = 500) +C + COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2), + $ VCOUL(RD_,SD_),VCOULINT(2) +C + COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_), + $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS +C + COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, + 1 IMVHL,NEDHLP +C + CHARACTER*8 NAME0 ,NSYMBL +C + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV +C + COMMON/DIMENS2/NAT2,NDAT2 +C + common/aparms/xa(natoms),ya(natoms),za(natoms),zat(natoms), + & nsymbla(natoms),nzeq(natoms),neqa(natoms),ncores(natoms), + & lmaxat(natoms) +C + REAL*8 xa,ya,za,zat + CHARACTER*8 nsymbla +C + DIMENSION RL(MRP,D_), VCL(MRP,SD_), RHOL(MRP,SD_), HL(D_), + & VLMTO(MRP,SD_), KMXP(SD_), KPLP(SD_), RSL(SD_), + & NPAC(-10:100), NZL(D_), KMX(SD_), ICHGL(SD_,D_) +C + DIMENSION RHS(MRP,D_), VHS(MRP,SD_), RHOHS(MRP,SD_) +C + REAL*8 RL, VCL, RHOL, HL, VLMTO, RSL, RHS, VHS, RHOHS, + & HR, VINT, RHOINT, DVT, DVTRHOINT +C + EXTERNAL NEAREST +C + CHARACTER*5 POTYPE + CHARACTER*5 CHECK +C + DATA THIRD,XINCR,CTFD + &/0.33333333,0.0025E0,0.88534137E0/ +C + INP=2 +C + NDUMMY = 0 + NSPINS = 1 + NAT = NAT2 - 1 + NDAT = NDAT2 - 1 +C + OPEN(INP, file='data/inpot.ext',status='unknown') +C +C Initialize to zero the vector indicating for which atomic species +C the lmto data have been already interpolated. Positions from 1 to +C 100 indicates physical atoms, from 0 to -1010 empty inequivalent +C spheres +C + DO N = -10, 100 + NPAC(N) = 0 + ENDDO +C +C VCOULINT : interstitial Coulomb potential in Ry +C RHOCONI : interstitial charge density in Ry +C VCLMTO : intsrstitial LMTO potential in Ry +C + READ(INP,*) VCOULINT(1), RHOCONI(1), VCLMTO +C + NES=1 +C + DO N=1,NDAT +C + READ(INP,*,END=50) NZL(N), KMX(N), RSL(N) + WRITE(6,*) 'N=',N,'ZATL(N)=', NZL(N),'KMX(N)=',KMX(N), + & 'RS(N)=',RSL(N) + IF (KMX(N).GT.MRP) THEN + WRITE(6,*) ' ' + WRITE(6,*) ' ' + WRITE(6,*)' MRP =', MRP,' TOO SMALL, INCREASE UP TO ', KMX(N) + WRITE(6,*) ' ' + WRITE(6,*) ' ' + CALL EXIT + ENDIF +C + IF(NZL(N).NE.0) THEN + NPAC(NZL(N)) = N +C WRITE(6,*) 'N, NZL(N), NPAC(NZL(N))', N, NZL(N) , NPAC(NZL(N)) + ELSE + NES=NES-1 + NPAC(NES)=N +C WRITE(6,*) 'N, NZL(N), NES, NPAC(NES)', N,NZL(N),NES,NPAC(NES) + ENDIF +C +C NOTE: COULOMB AND LMTO POTENTIALS ARE MULTIPLIED BY RL +C + DO K = 1, KMX(N) + READ(INP,*) RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N) +C WRITE(6,*) K, RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N) + ENDDO + +C +C SET-UP HERMAN-SKILLMAN MESH FOR ATOM OF ATOMIC NUMBER Z +C + MESH=400 + NCUT=1 + MESH=MESH/NCUT + IF(NZL(N).EQ.0) THEN + HL(N)=DBLE(XINCR*CTFD*NCUT) + ELSE + HL(N)=DBLE(XINCR*CTFD/(FLOAT(NZL(N))**THIRD)*NCUT) + ENDIF + HR = HL(N) + RHS(1,N)=HR + DO 10 K=1,12 +10 ICHGL(K,N)=(40/NCUT)*K + I=1 + DO 20 K=2,MESH + RHS(K,N)=RHS(K-1,N)+HR + IF (K.LT.ICHGL(I,N)) GO TO 20 + HR=HR+HR + I=I+1 +20 CONTINUE +C +C FIND KMAX(N) IN THE H-S MESH ACCORDING TO RS(N) +C + KMXP(N) = 0 + KPLP(N) = 0 + DO K = 1, MESH + IF (RHS(K,N).GT.RSL(N)) GO TO 40 + ENDDO + 40 KPLP(N) = K - 1 + KMXP(N) = K + 2 +C + WRITE(6,*) 'ATOMIC SPECIES, HS KPLACE AND KMAX' + WRITE(6,*) 'N=',N, 'KPLP(N)= ',KPLP(N), ' KMXP(N)= ', KMXP(N) +C WRITE(6,*) 'RHSMAX=', RHS(400,N), 'RSL(N) =', RSL(N) +C + DO I=1,KMXP(N) +C FIND NEAREST POINTS +C INITIALIZE HUNTING PARAMETER (SUBROUTUTINE NEAREST) +C + CALL NEAREST(RL(1,N), KMX(N), RHS(I,N), IP1, IP2, IP3) +C + IF(IRHO.NE.0) THEN +C +C INTERPOLATE COULOMB POTENTIAL +C + CALL INTERP_QUAD( RL(IP1,N),VCL(IP1,N),RL(IP2,N),VCL(IP2,N), + & RL(IP3,N),VCL(IP3,N),RHS(I,N),VHS(I,N)) +C +C INTERPOLATE CHARGE DENSITY +C + CALL INTERP_QUAD( RL(IP1,N),RHOL(IP1,N),RL(IP2,N), + & RHOL(IP2,N),RL(IP3,N),RHOL(IP3,N), + & RHS(I,N),RHOHS(I,N)) + ELSE +C +C INTERPOLATE LMTO POTENTIAL +C + CALL INTERP_QUAD( RL(IP1,N),VLMTO(IP1,N), + & RL(IP2,N),VLMTO(IP2,N), + & RL(IP3,N),VLMTO(IP3,N),RHS(I,N),VHS(I,N)) + ENDIF + ENDDO +C + WRITE(6,*) 'INTERPOLATED VALUES ON HS MESH' +C + DO I = 1, KMXP(N) +C WRITE(6,*) I, RHS(I,N), VHS(I,N), RHOHS(I,N) + IF(RHOHS(I,N).LT.0.D0) THEN + WRITE(6,*) ' WARNING: DENSITY INTERPOLATED TO NEGATIVE', + & ' VALUES AT RHS =', RHS(I,N),' FOR ATOM', + & ' NUMBER N =', N + CALL EXIT + ENDIF + ENDDO +C +C......TEST LAST THREE INTERPOLATED VALUES +C + SMALL=0.005 +C + DO I = KPLP(N) + 1, KMXP(N) + KP = KMX(N) +C + IF(IRHO.NE.0) THEN + CALL DINTERP(RL(KP-5,N),VCL(KP-5,N),5,RHS(I,N),VINT,DVT, + & .TRUE.) + CALL DINTERP(RL(KP-5,N),RHOL(KP-5,N),5,RHS(I,N),RHOINT, + & DVTRHOINT,.TRUE.) + IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN + CHECK='OK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VC ', CHECK + ELSE + CHECK='NOTOK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VC ', CHECK + WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N) + ENDIF +C + IF(DABS(RHOHS(I,N)-RHOINT).LT.DBLE(SMALL)) THEN + CHECK='OK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR RHO ', CHECK + ELSE + CHECK='NOTOK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR DENSITY RHO ', CHECK + WRITE(6,*) I, RHS(I,N), RHOINT, RHOHS(I,N) + ENDIF +C + ELSE +C + CALL DINTERP(RL(KP-5,N),VLMTO(KP-5,N),5,RHS(I,N),VINT,DVT, + & .TRUE.) + IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN + CHECK='OK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VLMTO ', CHECK + ELSE + CHECK='NOTOK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VLMTO ', CHECK + WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N) + ENDIF +C + ENDIF +C + ENDDO +C +C + ENDDO +C + 50 CONTINUE +C + CLOSE(2) +C +C write(6,*) npac(22), npac(8), npac(0), npac(-1) + DO 60 I=1,NAT + XV(I) = SNGL(XA(I+1)) - SNGL(XA(2)) + YV(I) = SNGL(YA(I+1)) - SNGL(YA(2)) + ZV(I) = SNGL(ZA(I+1)) - SNGL(ZA(2)) + NSYMBL(I) = NSYMBLA(I+1) + NEQ(I) = NEQA(I+1) +c write(6,*) NEQ(I), NSYMBL(I) + IF(NEQ(I).NE.0) NEQ(I) = NEQ(I) - 1 + NZ(I) = NZEQ(I+1) +C N = NPAC(NZ(I)) + IF(NZ(I).NE.0) THEN +C + N = NPAC(NZ(I)) +C WRITE(6,*) 'N, NZ(I), NPAC(NZ(I))', N, NZ(I), NPAC(NZ(I)) +C + ELSE +C + IF(NSYMBL(I).EQ.'ES') THEN + N=NPAC(0) + ELSE + NES=ICHAR('0')-ICHAR(NSYMBL(I)(2:2)) + N=NPAC(NES) +C WRITE(6,*) ICHAR('0'),ICHAR(NSYMBL(I)(2:2)) +C WRITE(6,*) ' NES = ',NES, ' N = ', N + ENDIF +C + ENDIF + KPLACE(I) = KPLP(N) + KMAX(I) = KMXP(N) + RS(I) = REAL(RSL(N)) + EXFACT(I) = 0.0 +C + IF(NEQ(I).NE.0) GO TO 60 +C + H(I) = REAL(HL(N)) + DO K = 1,10 + ICHG(K,I) = ICHGL(K,N) + ENDDO + DO K = 1, KMAX(I) + R(K,I) = SNGL(RHS(K,N)) + V(2,K,I) = 0.0 + IF(IRHO.NE.0) THEN + V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N)) + RHOTOT(K,I) = SNGL(RHOHS(K,N)) + ELSE + V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N)) + ENDIF + ENDDO + IF(IRHO.NE.0) THEN + VCONS(1) = CMPLX(VCOULINT(1)) + ELSE + VCONS(1) = CMPLX(VCLMTO) + ENDIF + 60 CONTINUE +C +C.....WRITE OUT POTENTIAL AND DENSITY FILES +C + IF (potype.EQ.' lmto') THEN + OPEN (19, FILE = 'div/LMTO.POT', STATUS = 'unknown') + ELSE + OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown') + OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown') + ENDIF +C + INV = 20 + IF (potype.EQ.' lmto') INV = 19 + INRHO= 9 + NST=1 + NC=2 + DO 4401 N=NST,NAT + WRITE(INV,311) NSYMBL(N),NEQ(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N), + 1 XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC + 311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5) + NC=NC+1 + IF(NEQ(N).NE.0) GO TO 4401 + WRITE(INV,308) (ICHG(I,N),I= 1,10),NC + 308 FORMAT(10I5,T76,I5) + NC=NC+1 + WRITE(INV,319) NC,(R(I,N),I=1,5) + 319 FORMAT(T76,I5,T2,1P5E14.7) + NS=N + NC=NC+1 + KX=KMAX(N) + NS = N + DO 142 ISPIN=1,NSPINS + DO 141 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INV,319) NC,(V(1,I,NS),I=K,KCARD) + 141 NC=NC+1 + 142 NS=NS+NDAT + NS=N + IF (potype.NE.' lmto') THEN + DO 555 ISPIN=1,NSPINS + DO 551 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD) + 551 NC=NC+1 + 555 NS=NS+NDAT + ENDIF + 4401 CONTINUE +C + IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS) +C + IF (INV.EQ.20) THEN + WRITE(INV,319) NC, REAL(VCONS(1)) + + WRITE( INRHO,319) NC,(RHOCONI(IS),IS=1,NSPINS) + ENDIF +C + IF(potype.EQ.' lmto') THEN + CLOSE (UNIT=19) + ELSE + CLOSE (UNIT=20) + CLOSE (UNIT=9) + ENDIF +C +C STOP + RETURN + END +C +C +C-------------------------------------------------------------- + + subroutine writewf(lxp) + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV + CHARACTER*8 NSYMBL,NAME0 +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_), + * ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + common/funit/idat,iwr,iphas,iedl0,iwf + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c + nlastl = nstart + lxp +c +c write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf + write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)' + write(iwf,*) e, xe, real(vcon) +c +c write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10) +c + write(iwf,*) + write(iwf,*) ' -- absorber excited regular wf for all l -- ' + write(iwf,*) +c + do 1 i=nstart,nlastl + write(iwf,*) ' l= ', i-1 + do 2 j=1,kmax(nas) + write(iwf,*) r(j,1),p(j,i)/ramf(i) +2 continue +1 continue +c + write(iwf,*) + write(iwf,*) ' -- absorber irregular wf for l less than 6 -- ' + write(iwf,*) ' radial coor --- wf ' + write(iwf,*) +c + do 3 i= 1, 6 + write(iwf,*) ' l= ', i-1 + do 4 j=1,kmax(nas) + write(iwf,*) r(j,1),p(j,i+npss) + 4 continue + 3 continue +c + return + end +c +c +C-------------------------------------------------------------- + + subroutine writeelswf + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV + CHARACTER*8 NSYMBL,NAME0 +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c +c + common/funit/idat,iwr,iphas,iedl0,iwf +c +c write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf + write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)' + write(iwf,*) e, xe, real(vcon) +c +c write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10) +c + write(iwf,*) + write(iwf,*) ' -- absorber excited regular wf for all l -- ' + write(iwf,*) +c + do i=1,lmxels(1,nas) + write(iwf,*) ' inc l= ', i-1 + do j=1,kmx(nas) + write(iwf,10) rx(j,1),p1(j,i,nas)/ramfsr1(i,nas) + enddo + enddo +c +c + do i=1,lmxels(2,nas) + write(iwf,*) ' sct l= ', i-1 + do j=1,kmx(nas) + write(iwf,10) rx(j,1),p2(j,i,nas)/ramfsr2(i,nas) + enddo + enddo +c +c + do i=1,lmxels(3,nas) + write(iwf,*) ' exc l= ', i-1 + do j=1,kmx(nas) + write(iwf,10) rx(j,1),p3(j,i,nas)/ramfsr3(i,nas) + enddo + enddo +c +c + 10 format(7e15.7) +c + write(iwf,*) + write(iwf,*) ' -- absorber irregular wf for l less than 6 -- ' + write(iwf,*) ' radial coor --- wf ' + write(iwf,*) +c + do 3 i= 1, 6 + write(iwf,*) ' l= ', i-1 + do 4 j=1,kmx(nas) + write(iwf,10) rx(j,1),p3irreg(j,i) + 4 continue + 3 continue +c + return + end +c +c +c********************************************************************** +c + subroutine scfdat (title, ifr, iz, ihole, xion,amass, beta,iprint, + 1 vcoul, srho, dgc0, dpc0, enp, eatom) +c +c single configuration dirac-fock atom code +c +c input: +c title - any name that will be written into output files. +c ifr - specify aadditional output file atom(ifr).dat +c iz - atomic number +c ihole - remove one electron from orbital #ihole. +c complete list is in subroutine getorb. +c xion - ionicity (iz-number of electrons) +c amass - mass of nucleus; 0. - for point nucleus. +c beta - thickness parameter for nuclear charge distribution +c beta=0. for uniform distribution +c iprint - if iprint>0 additional output is written into atom(ifr).dat +c output: +c vcoul - total coulomb potential (hartrees) +c srho - total charge density (bohr**-3) +c dgc0 - upper components of dirac spinors +c dpc0 - lower components of dirac spinors +c enp - energy eigenvalues (hartrees) +c eatom - total atomic energy (hartrees) + +c written by a. ankudinov, univ. of washington +c +c programming language fortran 77 +c +c based on modifications of the code ACRV of J.P. Desclaux +c [Comp Phys Comm. 9, 31 (1975)] and some subroutines from +c the FEFF code, J.J. Rehr, J. Mustre de Leon, S.I. Zabinsky +c and R.C. Albers, [J. Am. Chem. Soc 113,5135(1991) +c +c version 1 (5-22-96) +c +c********************************************************************** + + implicit double precision (a-h,o-z) + parameter ( mp = 251, ms = 30 ) +c +c save central atom dirac components, see comments below. +c + dimension dgc0(mp), dpc0(mp) + dimension vcoul(mp), srho(mp), enp(ms) + + character*(*) title + character*40 ttl + character*512 slog + common /charact/ ttl + + character*30 fname +c +c this programm uses cofcon cofdat dsordf ictime iowrdf +c lagdat messer nucdev ortdat potrdf soldir + common cg(mp,ms),cp(mp,ms),bg(10,ms),bp(10,ms),fl(ms),ibgp +c cg (cp) large (small) components +c bg (bp) development coefficients at the origin of large +c (small) component +c fl power of the first term of development limits. +c ibgp first dimension of the arrays bg and bp +c +c gg,gp are the output from soldir +c + common/comdir/cl,dz,gg(mp),ag(10),gp(mp),ap(10),bid(3*mp+30) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/mulabk/afgk + common/inelma/nem + dimension afgk( 30, 30, 0:3) + common/messag/dlabpr,numerr + character*8 dprlab, dlabpr + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/scrhf1/eps(435),nre(30),ipl + common/snoyau/dvn(251),anoy(10),nuc + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + data dprlab/' scfdat'/ + + +c +c *** copy input parameters to common blocks +c + ttl = title + lttl = istrln(title) + if (lttl.le.0) ttl='atomic data' + nz=iz + dz=nz +c +c *** desclaux standard opinion. be careful when changing. +c + nuc=11 +c +c nuc - number of points inside nucleus (suggested value 11) +c + nes=50 +c +c nes number of attempts in program soldir +c differ from desclaux nes=40 +c + niter=30 +c +c equivalent to desclaux niter=1130 +c niter =1000*n1+100*n2+n3 +c n3 is the number of iterations per orbital +c + testy=1.d-5 +c +c testy precision for the wave functions +c + hx=5.d-2 + dr(1)=exp(-8.8D0)*iz +c +c dr(1)=exp(-8.8) +c hx exponential step +c dr1 first tabulation point multiplied by nz +c desclaux dr1=0.01 correspond to iz=66 +c + teste=5.d-6 + rap(1)=1.d2 + rap(2)=1.d1 +c +c teste precision for the one-electron energies +c rap tests of precision for soldir +c + ido=1 +c +c equivalent to ido=ndep=1 +c calculate initial orbitals using thomas-fermi model ido=1 +c option to read from cards(ido=2) destroyed +c nmax=251 - set in subroutine inmuat +c scc=0.3 - set in subroutine inmuat +c *** end of desclaux standard opinion on parameters +c + if (iprint .ge. 1) then +c +c prepare file for atom output +c + write(fname,14) ifr + 14 format('atom', i2.2, '.dat') + open (unit=16, file=fname, status='unknown') +c call chopen (ios, fname, 'atom') +c call head (16) + write(16,*) ' free atom ', ifr + lttl = istrln(ttl) + if (iprint .ge. 1) write(16,40) ttl(1:lttl) + 40 format (1h1,40x,a) + endif +c +c initialize the rest of the data and calculate initial w.f. +c + jfail = 0 + ibgp = 10 + numerr = 0 + nz = iz + call inmuat (ihole, xion) +c +c iholep is the index for core hole orbital in all arrays +c for 90% of atoms iholep=ihole +c + a = - xion - 1 + call wfirdf ( en, a, nq, kap, nmax, ido, amass, beta) + + j = 1 + ind = 1 + nter = 0 + do 41 i=1, norb + 41 scw(i) = 0.D0 + test1 = testy / rap(1) + test2 = testy / rap(2) + netir = abs(niter) * norb + if (iprint .ge. 1) then + write(16,210) niter, teste, testy + 210 format (5x,'number of iterations',i4,//, + 1 5x,'precision of the energies',1pe9.2,//, + 2 23x,'wave functions ',1pe9.2,/) + write(16,220) idim, dr(1), hx + 220 format (' the integration is made on ', i3, + 1 ' points-the first is equal to ' ,f7.4,/, + 2 ' and the step-size pas = ',f7.4,/) + write(16,230) test1, nes + 230 format ('matching of w.f. with precision', 1pe9.2, + 2 ' in ',i3,' attempts ',/) + if (nuc.gt.1) write(16,250) + 250 format (1h0,30x,'finite nucleus case used'/) + endif +c +c muatco - programm to calculate angular coefficients +c + call muatco + if (numerr .ne. 0) go to 711 +c +c iteration over the number of cycles +c + 101 iort = 0 + nter = nter + 1 + if (niter .ge. 0) go to 105 +c +c orthogonalization by schmidt procedure +c + 104 call ortdat (j) + 105 method = 1 +c +c calculate lagrange parameters +c + if (nre(j).gt.0 .and. ipl.ne.0) call lagdat (j,1) +c +c calculate electron potential +c + call potrdf (j) + e = en(j) + np = idim +c +c resolution of the dirac equation +c + ifail = 0 + ainf = cg(nmax(j),j) + call soldir (en(j), fl(j), bg(1,j), bp(1,j), ainf, + 1 nq(j), kap(j), nmax(j), ifail) + if (ifail .ne. 0 .and. jfail .eq. 0) jfail = j + if (jfail .eq. j .and. ifail .eq.0 ) jfail = 0 + if (numerr.eq.0) go to 111 + if (iort.ne.0 .or. niter.lt.0) go to 711 + iort = 1 + go to 104 + + 111 sce(j) = abs((e-en(j)) / en(j)) +c +c variation of the wave function using two iterations +c + k = nmax(j) + pr = 0.D0 + do 121 i = 1, k + w = cg(i,j) - gg(i) + if (abs(w).le.abs(pr)) go to 115 + pr = w + a = cg(i,j) + b = gg(i) + 115 w = cp(i,j) - gp(i) + if (abs(w).le.abs(pr)) go to 121 + pr = w + a = cp(i,j) + b = gp(i) + 121 continue + write(slog,'(i4,i3,2(1pe11.2),2(1pd16.6),4x,a,i2)') + 1 nter, j, sce(j), pr, a, b, 'method', method + call wlog(slog,0) +c +c acceleration of the convergence +c + b = scc(j) + call cofcon (a, b, pr, scw(j)) + scc(j) = b + do 151 i = 1,k + gg(i) = b*gg(i) + a*cg(i,j) + 151 gp(i) = b*gp(i) + a*cp(i,j) + do 155 i=1,ndor + ag(i) = b*ag(i) + a*bg(i,j) + 155 ap(i) = b*ap(i) + a*bp(i,j) +c +c normalization of the wave function +c + a = dsordf (j,k,0,4,fl(j)) + a = sqrt(a) + do 171 i=1, np + cg(i,j) = gg(i) / a + 171 cp(i,j) = gp(i) / a + do 175 i=1, ndor + bg(i,j) = ag(i) / a + 175 bp(i,j) = ap(i) / a +c +c determination of the next orbital to calculate +c + if (nter.lt.norbsc .or. (ind.lt.0 .and. j.lt.norbsc) ) then + j = j+1 + go to 451 + endif + j = j+1 + pr=0.D0 + do 301 i=1, norbsc + w = abs(scw(i)) + if (w.gt.pr) then + pr = w + j = i + endif + 301 continue + if (j.gt.norbsc) j = 1 + if (pr.gt.testy) go to 421 + pr = 0.D0 + do 321 i=1, norbsc + w = abs(sce(i)) + if (w.gt.pr) then + pr = w + j = i + endif + 321 continue + if (pr.ge.teste) go to 421 + if (ind.lt.0) go to 999 + ind = -1 + j = 1 + go to 451 + + 421 ind = 1 + 451 if (nter.le.netir) go to 101 + numerr = 192011 +c +c **** number of iterations exceeded the limit +c + dlabpr = dprlab + 711 call messer + stop + 999 if (numerr .eq. 0) then + if (jfail.ne.0) then + call wlog( + 1 'failed to match lower component, results are meaningless',1) + stop + endif +c +c tabulation of the results +c + if (iprint .ge. 1) call tabrat + call etotal( kap, xnel, en, iprint, eatom) +c +c return coulomb potential +c + do 800 i=1, idim + 800 srho(i) = 0.0D0 + do 830 j=1, norb + do 830 i=1, nmax(j) + 830 srho(i) = srho(i) + xnel(j) * (cg(i,j)**2 + cp(i,j)**2) + call potslw( vcoul, srho, dr, hx, idim) + do 810 i=1, 251 + 810 vcoul(i) = vcoul(i) - nz/dr(i) +c +c return srho as density instead of 4*pi*density*r**2 +c do 860 i = 1, 251 +c srho(i) = srho(i) / (dr(i)**2) / 4. / pi +c srho(i) = srho(i) / 4. / pi +c 860 continue +c + do 870 ispinr = 1, 30 + do 852 i = 1, 251 + dgc0(i) = cg( i, ispinr) + dpc0(i) = cp( i, ispinr) + 852 continue + enp(ispinr) = en(ispinr) + 870 continue + endif + if (iprint .ge. 1) close(unit=16) + + return + end + double precision function akeato (i,j,k) +c angular coefficient by the direct coulomb integral fk +c for orbitals i and j + + implicit double precision (a-h,o-z) + common/mulabk/afgk + dimension afgk(30,30,0:3) +c +c afgk angular coefficients by integrales fk and gk +c coefficient of integral fk(i;j) is in afgk(min,max) +c and that of integral gk(i;j) is in afgk(max,min) +c max=max(i,j) min=min(i,j) +c + if (i .le. j) then + akeato=afgk(i,j,k/2) + else + akeato=afgk(j,i,k/2) + endif + return + + entry bkeato (i,j,k) +c +c angular coefficient at the exchange coulomb integral gk +c + bkeato=0.0d 00 + if (i .lt. j) then + bkeato=afgk(j,i,k/2) + elseif (i.gt.j) then + bkeato=afgk(i,j,k/2) + endif + return + end + double precision function aprdev (a,b,l) +c +c the result of this function is the coefficient of the term of +c power for the product of two polynomes, whose coefficients are +c in rows a and b +c + implicit double precision (a-h,o-z) + dimension a(10),b(10) + + aprdev=0.0d 00 + do 11 m=1,l + 11 aprdev=aprdev+a(m)*b(l+1-m) + return + end + subroutine bkmrdf (i,j,k) +c +c angular coefficients for the breit term +c i and j are the numbers of orbitals +c k is the value of k in uk(1,2) +c this programm uses cwig3j +c coefficients for magnetic interaction are in cmag +c and those for retarded term are in cret +c the order correspond to -1 0 and +1 +c + implicit double precision (a-h,o-z) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabre/cmag(3),cret(3) + + do 12 l=1,3 + cmag(l)=0.0d 00 + 12 cret(l)=0.0d 00 + ji=2* abs(kap(i))-1 + jj=2* abs(kap(j))-1 + kam=kap(j)-kap(i) + l=k-1 + do 51 m=1,3 + if (l.lt.0) go to 51 + a=cwig3j(ji,jj,l+l,-1,1,2)**2 + if (a.eq.0.0d 00) go to 51 + c=l+l+1 + if (m-2) 14,16,17 + 14 cm=(kam+k)**2 + cz=kam*kam-k*k + cp=(k-kam)**2 + n=k + 15 l1=l+1 + am=(kam-l)*(kam+l1)/c + az=(kam*kam+l*l1)/c + ap=(l+kam)*(kam-l1)/c + d=n*(k+k+1) + go to 31 + + 16 d=k*(k+1) + cm=(kap(i)+kap(j))**2 + cz=cm + cp=cm + go to 41 + + 17 cm=(kam-l)**2 + cz=kam*kam-l*l + cp=(kam+l)**2 + n=l + c=-c + go to 15 + + 31 c= abs(c)*d + if (c.ne.0.0d 00) c=n/c + cret(1)=cret(1)+a*(am-c*cm) + cret(2)=cret(2)+(a+a)*(az-c*cz) + cret(3)=cret(3)+a*(ap-c*cp) + 41 if (d.eq.0.0d 00) go to 51 + a=a/d + cmag(1)=cmag(1)+cm*a + cmag(2)=cmag(2)+cz*(a+a) + cmag(3)=cmag(3)+cp*a + 51 l=l+1 + return + end + subroutine cofcon (a,b,p,q) +c +c acceleration of the convergence in the iterative process +c b is the part of final iteration n is a function of the error (p) +c (p) at iteration n and the error (q) at the iteration n-1. +c if the product p*q is positive b is increased by 0.1 +c zero b is unchanged +c negative b is decreased by 0.1 +c b is between 0.1 and 0.9 +c a = 1. - b +c ** at the end makes q=p +c + implicit double precision (a-h,o-z) + + if (p*q) 11,31,21 + 11 if (b .ge. 0.2D0) b = b - 0.1D0 + go to 31 + + 21 if (b .le. 0.8D0) b = b + 0.1D0 + + 31 a = 1.0D0 - b + q=p + return + end + double precision function cwig3j (j1,j2,j3,m1,m2,ient) +c +c wigner 3j coefficient for integers (ient=1) +c or semiintegers (ient=2) +c other arguments should be multiplied by ient +c + implicit double precision (a-h,o-z) + save + character*512 slog + dimension al(32),m(12) + data ini/1/,idim/31/ +c +c idim-1 is the largest argument of factorial in calculations +c + m3=-m1-m2 + if (ini) 1,21,1 +c +c initialisation of the log's of the factorials +c + 1 ini=0 + al(1)=0.0d 00 + do 11 i=1,idim + b=i + 11 al(i+1)=al(i)+ log(b) + 21 cwig3j=0.0d 00 + if (((ient-1)*(ient-2)).ne.0) go to 101 + ii=ient+ient +c +c test triangular inequalities, parity and maximum values of m +c + if (( abs(m1)+ abs(m2)).eq.0.and.mod(j1+j2+j3,ii).ne.0) go to 99 + m(1)=j1+j2-j3 + m(2)=j2+j3-j1 + m(3)=j3+j1-j2 + m(4)=j1+m1 + m(5)=j1-m1 + m(6)=j2+m2 + m(7)=j2-m2 + m(8)=j3+m3 + m(9)=j3-m3 + m(10)=j1+j2+j3+ient + m(11)=j2-j3-m1 + m(12)=j1-j3+m2 + do 41 i=1,12 + if (i.gt.10) go to 31 + if (m(i).lt.0) go to 99 + 31 if (mod(m(i),ient).ne.0) go to 101 + m(i)=m(i)/ient + if (m(i).gt.idim) go to 101 + 41 continue +c +c calculate 3j coefficient +c + max0= max(m(11),m(12),0)+1 + min0= min(m(1),m(5),m(6))+1 + isig=1 + if (mod(max0-1,2).ne.0) isig=-isig + c=-al(m(10)+1) + do 61 i=1,9 + 61 c=c+al(m(i)+1) + c=c/2.0d 00 + do 71 i=max0,min0 + j=2-i + b=al(i)+al(j+m(1))+al(j+m(5))+al(j+m(6))+al(i-m(11))+al(i-m(12)) + cwig3j=cwig3j+isig* exp(c-b) + 71 isig=-isig + if (mod(j1-j2-m3,ii).ne.0) cwig3j=-cwig3j + 99 return + 101 write(slog,'(a,6i5)') 'error in cwig3j ',j1,j2,j3,m1,m2,ient + call wlog(slog,1) + stop + end + double precision function dentfa (dr,dz,ch) +c +c analitical approximation of potential is created for electrons in +c thomas-fermi model for atom or free ion. dr distance from nucleus +c with charge dz +c ch=ionicity = number of electrons-dz-1 +c + implicit double precision (a-h,o-z) + + dentfa=0.0d 00 + if ((dz+ch).lt.1.0d-04) return + w=dr*(dz+ch)**(1.D0/3.D0) + w=sqrt(w/0.8853D0) + t=w*(0.60112D0*w+1.81061D0)+1.D0 + w=w*(w*(w*(w*(0.04793D0*w+0.21465D0)+0.77112D0)+1.39515D0)+ + 1 1.81061D0)+1D0 + dentfa=(dz+ch)*(1.0d 00-(t/w)**2)/dr + return + end + double precision function dsordf (i,j,n,jnd,a) +c +c * calculation of diff. integrals* +c integration by simpson method of the hg*(r**n) +c hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) if jnd=1 +c hg=expression above multiplied by dg if jnd=-1 +c hg(l)=cg(l,i)*cp(l,j) if jnd=2 +c hg=expression above multiplied by dg if jnd=-2 +c hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j) if jnd=3 +c hg(l)=dg(l)*dg(l)+dp(l)*dp(l) if jnd=4 +c hg is constructed by calling program if jnd>=5 +c cg(l,i) large component of the orbital i +c cp(l,j) small component of the orbital j +c a is such that dg,dp or hg following the case +c behave at the origin as cte*r**a +c the integration is made as far as dr(j) for jnd>3 +c +c the development limits at the origin (used for calculation +c of integral form 0 to dr(1) ) of functions dg,dp and hg are +c supposed to be in blocks ag,ap and chg respectively +c this program utilises aprdev +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) + dimension hg(251),chg(10) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + dimension bgi(10),bgj(10),bpi(10),bpj(10) +c +c construction of the array hg +c + if (jnd.le.3) go to 11 + max0=j + b=a + go to 101 + + 11 max0= min(nmax(i),nmax(j)) + do 15 l= 1,ibgp + bgi(l) = bg(l,i) + bgj(l) = bg(l,j) + bpi(l) = bp(l,i) + 15 bpj(l) = bp(l,j) + if ( abs(jnd)-2) 21,55,101 + 21 do 31 l=1,max0 + 31 hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) + do 45 l=1,ndor + 45 chg(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l) + go to 81 + + 55 do 61 l=1,max0 + 61 hg(l)=cg(l,i)*cp(l,j) + do 71 l=1,ndor + 71 chg(l)=aprdev(bgi,bpj,l) + 81 b=fl(i)+fl(j) + if (jnd.gt.0) go to 301 + + do 85 l=1,max0 + 85 hg(l)=hg(l)*dg(l) + do 87 l=1,ndor + 87 ap(l)=chg(l) + b=b+a + do 95 l=1,ndor + 95 chg(l)=aprdev(ap,ag,l) + go to 301 + + 101 if (jnd-4) 201,111,301 + 111 do 121 l=1,max0 + 121 hg(l)=dg(l)*dg(l)+dp(l)*dp(l) + b=b+b + do 131 l=1,ndor + 131 chg(l)=aprdev(ag,ag,l)+aprdev(ap,ap,l) + go to 301 + + 201 do 221 l=1,max0 + 221 hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j) + b=a+fl(i) + do 241 l=1,ndor + 241 chg(l)=aprdev(bgi,ag,l)+aprdev(bpj,ap,l) +c +c integration of the hg +c + 301 dsordf=0.0d 00 + io=n+1 + do 305 l=1,max0 + 305 hg(l)=hg(l)*(dr(l)**io) + do 311 l=2,max0,2 + 311 dsordf=dsordf+hg(l)+hg(l)+hg(l+1) + dsordf=hx*(dsordf+dsordf+hg(1)-hg(max0))/3.0d 00 +c +c integral from 0 to dr(1) +c + b=b+n + do 331 l=1,ndor + b=b+1.0d 00 + 331 dsordf=dsordf+chg(l)*(dr(1)**b)/b + return + end + subroutine etotal (kap,xnel,en,iprint,eatom) +c +c combined from original subroutines tabfgk,tabbre,tabrat. +c kap quantique number "kappa" +c xnel occupation of orbitales (can be fractional) +c en one-electron energies +c fdrirk function calculating radial integrals rk +c akeato angular coefficient for integrals fk, for the +c integrals fk(i;i) gives angular coefficients multiplied by 2 +c bkeato angular coefficient for integrals gk +c coul ener(1) direct coulomb interaction +c ech ener(2) exchange coulomb interaction +c * average value of the breit hamiltonian * +c fdrocc function of the orbitals' occupations. +c bkmrdf is a programm to calculate angular coefficients +c ema ener(3) magnetic energy +c ere ener(4) retardation term +c sous programmes utilises akeato,bkeato +c fdrocc fdrirk bkmrdf +c + implicit double precision (a-h,o-z) + dimension kap(30),xnel(30),en(30) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + dimension ener(4) + dimension cer(17) + common/tabre/cmag(3),cret(3) + common/inelma/nem + character*4 iner(4) + character*512 slog + data iner/'coul','ech.','mag.','ret.'/ + + do 10 i = 1,4 + 10 ener(i)=0.0d 00 + iv=0 +c +c fk integrales +c + do 40 i=1,norb + l= abs(kap(i))-1 + do 40 j=1,i + a=1.0d 00 + if (j.eq.i) a=a+a + m= abs(kap(j))-1 + kmi=2* min(l,m) + k=0 + 20 iv=iv+1 + cer(iv)=fdrirk(i,i,j,j,k) + ener(1)=ener(1)+cer(iv)*akeato(i,j,k)/a + if (iv.lt.3) go to 30 + iv=0 + 30 k=k+2 + if (k.le.kmi) go to 20 + 40 continue + iv=0 + if (norb.gt.1) then +c +c gk integrales +c + do 70 i=2,norb + i1=i-1 + do 70 j=1,i1 + l= abs(kap(i)) + m= abs(kap(j)) + k= abs(l-m) + if ((kap(i)*kap(j)).lt.0) k=k+1 + kmi=l+m-1 + 50 iv=iv+1 + cer(iv)=fdrirk(i,j,i,j,k) + ener(2) = ener(2) -cer(iv)*bkeato(i,j,k) + if (iv.lt.3) go to 60 + iv=0 + 60 k=k+2 + if (k.le.kmi) go to 50 + 70 continue + endif +c + nem=1 +c +c direct integrales +c + ik=0 + do 140 j=1,norb + jj=2* abs(kap(j))-1 + do 140 i=1,j + ji=2* abs(kap(i))-1 + k=1 + kma= min(ji,jj) + 110 ik=ik+1 + cer(ik)=fdrirk(j,j,i,i,k) + if (i.ne.j) go to 120 + call bkmrdf (j,j,k) + ener(3)=ener(3)+(cmag(1)+cmag(2)+cmag(3))*cer(ik)* + 1 fdmocc(j,j)/2.0d 00 + 120 if (ik.lt.3) go to 130 + ik=0 + 130 k=k+2 + if (k.le.kma) go to 110 + 140 continue + if (norb.gt.1) then +c +c exchange integrales +c + do 201 j=2,norb + lj= abs(kap(j)) + na=-1 + if (kap(j).gt.0) go to 121 + na=-na + lj=lj-1 + 121 jp=j-1 + do 201 l=1,jp + ll= abs(kap(l)) + nb=-1 + if (kap(l).gt.0) go to 131 + nb=-nb + ll=ll-1 + 131 b=fdmocc(j,l) + nm1= abs(lj+na-ll) + nmp1=ll+lj+nb + nmm1=ll+lj+na + np1= abs(ll+nb-lj) + k= min(nm1,np1) + kma=max(nmp1,nmm1) + if (mod(k+ll+lj,2).eq.0) k=k+1 + nb= abs(kap(j))+ abs(kap(l)) + 141 call bkmrdf (j,l,k) + do 151 i=1,3 + 151 cer(i)=0.0d 00 + if (nb.le.k.and.kap(l).lt.0.and.kap(j).gt.0) go to 161 + cer(1)=fdrirk(l,j,l,j,k) + cer(2)=fdrirk(0,0,j,l,k) + 161 if (nb.le.k.and.kap(l).gt.0.and.kap(j).lt.0) go to 171 + cer(3)=fdrirk(j,l,j,l,k) + if (cer(2).ne.0.0d 00) go to 171 + cer(2)=fdrirk(0,0,l,j,k) + 171 do 185 i=1,3 + ener(3) =ener(3) +cmag(i)*cer(i)*b + 185 ener(4) =ener(4) +cret(i)*cer(i)*b + k=k+2 + if (k.le.kma) go to 141 + 201 continue + endif +c +c total energy +c + eatom = -(ener(1)+ener(2))+ener(3)+ener(4) + do 212 j=1,norb + 212 eatom = eatom + en(j)*xnel(j) + if (iprint .ge. 1) write(16,'(a,1pd18.7)') 'etot',eatom + write(slog,'(a,1pd18.7)') 'etot',eatom + call wlog(slog,0) + do 215 i=1,4 + if (iprint .ge. 1) write(16,'(a4,1pd18.7)') iner(i),ener(i) + write(slog,'(a4,1pd18.7)') iner(i),ener(i) + 215 call wlog(slog,0) + return + end +c + double precision function fdmocc (i,j) +c +c product of the occupation numbers of the orbitals i and j +c + implicit double precision (a-h,o-z) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + + if (j.eq.i) then + fdmocc=xnel(i)*(xnel(j)-1) + a=2* abs(kap(i)) + fdmocc=fdmocc*a/(a-1.0D0) + else + fdmocc=xnel(i)*xnel(j) + endif + return + end +c + double precision function fdrirk (i,j,l,m,k) +c +c * calculate radial integrales rk * +c rk = integral of f(r) * uk(r,s) * g(s) +c uk(r,s) = rinf**k / rsup**(k+1) rinf=min(r,s) rsup=max(r,s) +c if nem=0 f(.)=cg(.,i)*cg(.,j)+cp(.,i)*cp(.,j) +c g(.)=cg(.,l)*cg(.,m)+cp(.,l)*cp(.,m) +c if nem non zero f(.)=cg(.,i)*cp(.,j) +c g(.)=cg(.,l)*cp(.,m) +c cg (cp) large (small) componenents of the orbitales +c moreover if nem > or =0 the integration is made from 0 to infinity, +c and otherwise from 0 to r. +c this programm uses yzkrdf and dsordf +c + implicit double precision (a-h,o-z) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) +c +c comdir is used just to exchange variables between dsordf,yzkrdf,fdrirk +c + dimension hg(251) + common/inelma/nem + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + save + + fdrirk=0.0d 00 + if (i.le.0.or.j.le.0) go to 201 + call yzkrdf (i,j,k) + nn= abs(kap(i))+ abs(kap(j)) + nn=max(nn-k,1) + a=k+1 + do 21 n=1,ndor + 21 hg(n)=0.0d 00 + do 31 n=1,ndor + if (nn.gt.ndor) go to 31 + hg(nn)=-ag(n) + 31 nn=nn+1 + do 41 n=1,ndor + 41 ag(n)=hg(n) + ag(1)=ag(1)+ap(1) + + 201 if (l.le.0.or.m.le.0) return + n=-1 + if (nem.ne.0) n=-2 + fdrirk=dsordf(l,m,-1,n,a) + return + end +c + subroutine getorb (iz, ihole, xion, norb, norbco, + 1 iholep, den, nqn, nk, xnel, xnval) +c +c Gets orbital data for chosen element. Input is iz, atomic number +c of desired element, other arguments are output. +c Feel free to change occupation numbers for element of interest. +c ival(i) is necessary only for partly nonlocal exchange model. +c iocc(i) and ival(i) can be fractional +c But you have to keep the sum of iocc(i) equal to nuclear charge. +c Also ival(i) should be equal to iocc(i) or zero. +c Otherwise you have to change this subroutine or contact authors +c for help. +c + implicit double precision (a-h, o-z) +c +c Written by Steven Zabinsky, July 1989 +c modified (20 aug 1989) table increased to at no 97 +c Recipe for final state configuration is changed. Valence +c electron occupations are added. ala 17.1.1996 + +c Table for each element has occupation of the various levels. +c The order of the levels in each array is: + +c element level principal qn (nqn), kappa qn (nk) +c 1 1s 1 -1 +c 2 2s 2 -1 +c 3 2p1/2 2 1 +c 4 2p3/2 2 -2 +c 5 3s 3 -1 +c 6 3p1/2 3 1 +c 7 3p3/2 3 -2 +c 8 3d3/2 3 2 +c 9 3d5/2 3 -3 +c 10 4s 4 -1 +c 11 4p1/2 4 1 +c 12 4p3/2 4 -2 +c 13 4d3/2 4 2 +c 14 4d5/2 4 -3 +c 15 4f5/2 4 3 +c 16 4f7/2 4 -4 +c 17 5s 5 -1 +c 18 5p1/2 5 1 +c 19 5p3/2 5 -2 +c 20 5d3/2 5 2 +c 21 5d5/2 5 -3 +c 22 5f5/2 5 3 +c 23 5f7/2 5 -4 +c 24 6s 6 -1 +c 25 6p1/2 6 1 +c 26 6p3/2 6 -2 +c 27 6d3/2 6 2 +c 28 6d5/2 6 -3 +c 29 7s 7 -1 +c + dimension den(30), nqn(30), nk(30), xnel(30), xnval(30) + dimension kappa (29) + real iocc, ival + dimension iocc (97, 29), ival (97, 29) + dimension nnum (29) + character*512 slog +c +c kappa quantum number for each orbital +c k = - (j + 1/2) if l = j - 1/2 +c k = + (j + 1/2) if l = j + 1/2 +c + data kappa /-1,-1, 1,-2,-1, 1,-2, 2,-3,-1, 1,-2, 2,-3, 3, + 1 -4,-1, 1,-2, 2, -3, 3,-4,-1, 1, -2, 2,-3,-1/ +c +c principal quantum number (energy eigenvalue) +c + data nnum /1,2,2,2,3, 3,3,3,3,4, 4,4,4,4,4, + 1 4,5,5,5,5, 5,5,5,6,6, 6,6,6,7/ +c +c occupation of each level for z = 1, 97 +c + data (iocc( 1,i),i=1,29) /1,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 1,i),i=1,29) /1,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 2,i),i=1,29) /2,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 2,i),i=1,29) /2,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 3,i),i=1,29) /2,1,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 3,i),i=1,29) /0,1,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 4,i),i=1,29) /2,2,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 4,i),i=1,29) /0,2,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 5,i),i=1,29) /2,2,1,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 5,i),i=1,29) /0,2,1,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 6,i),i=1,29) /2,2,2,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 6,i),i=1,29) /0,2,2,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 7,i),i=1,29) /2,2,2,1,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 7,i),i=1,29) /0,2,2,1,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 8,i),i=1,29) /2,2,2,2,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 8,i),i=1,29) /0,2,2,2,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 9,i),i=1,29) /2,2,2,3,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 9,i),i=1,29) /0,2,2,3,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(10,i),i=1,29) /2,2,2,4,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(10,i),i=1,29) /0,2,2,4,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(11,i),i=1,29) /2,2,2,4,1, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(11,i),i=1,29) /0,0,0,0,1, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(12,i),i=1,29) /2,2,2,4,2, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(12,i),i=1,29) /0,0,0,0,2, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(13,i),i=1,29) /2,2,2,4,2, 1,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(13,i),i=1,29) /0,0,0,0,2, 1,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(14,i),i=1,29) /2,2,2,4,2, 2,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(14,i),i=1,29) /0,0,0,0,2, 2,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(15,i),i=1,29) /2,2,2,4,2, 2,1,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(15,i),i=1,29) /0,0,0,0,2, 2,1,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(16,i),i=1,29) /2,2,2,4,2, 2,2,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(16,i),i=1,29) /0,0,0,0,2, 2,2,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(17,i),i=1,29) /2,2,2,4,2, 2,3,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(17,i),i=1,29) /0,0,0,0,2, 2,3,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(18,i),i=1,29) /2,2,2,4,2, 2,4,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(18,i),i=1,29) /0,0,0,0,2, 2,4,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(19,i),i=1,29) /2,2,2,4,2, 2,4,0,0,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(19,i),i=1,29) /0,0,0,0,0, 0,0,0,0,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(20,i),i=1,29) /2,2,2,4,2, 2,4,0,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(20,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(21,i),i=1,29) /2,2,2,4,2, 2,4,1,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(21,i),i=1,29) /0,0,0,0,0, 0,0,1,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(22,i),i=1,29) /2,2,2,4,2, 2,4,2,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(22,i),i=1,29) /0,0,0,0,0, 0,0,2,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(23,i),i=1,29) /2,2,2,4,2, 2,4,3,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(23,i),i=1,29) /0,0,0,0,0, 0,0,3,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(24,i),i=1,29) /2,2,2,4,2, 2,4,4,1,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(24,i),i=1,29) /0,0,0,0,0, 0,0,4,1,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(25,i),i=1,29) /2,2,2,4,2, 2,4,4,1,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(25,i),i=1,29) /0,0,0,0,0, 0,0,4,1,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(26,i),i=1,29) /2,2,2,4,2, 2,4,4,2,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(26,i),i=1,29) /0,0,0,0,0, 0,0,4,2,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(27,i),i=1,29) /2,2,2,4,2, 2,4,4,3,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(27,i),i=1,29) /0,0,0,0,0, 0,0,4,3,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(28,i),i=1,29) /2,2,2,4,2, 2,4,4,4,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(28,i),i=1,29) /0,0,0,0,0, 0,0,4,4,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(29,i),i=1,29) /2,2,2,4,2, 2,4,4,6,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(29,i),i=1,29) /0,0,0,0,0, 0,0,4,6,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(30,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(30,i),i=1,29) /0,0,0,0,0, 0,0,4,6,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(31,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 1,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(31,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 1,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(32,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(32,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(33,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,1,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(33,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,1,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(34,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,2,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(34,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,2,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(35,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,3,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(35,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,3,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(36,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(36,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,4,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(37,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(37,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(38,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(38,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(39,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,1,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(39,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,1,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(40,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,2,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(40,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,2,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(41,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(41,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(42,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(42,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,1,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(43,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(43,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,1,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(44,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,3,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(44,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,3,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(45,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,4,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(45,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,4,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(46,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(46,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(47,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(47,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(48,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(48,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(49,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,1,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(49,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,1,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(50,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(50,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(51,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,1,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(51,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,1,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(52,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,2,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(52,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,2,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(53,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,3,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(53,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,3,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(54,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(54,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,4,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(55,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,0, 0,0,0,1,0, 0,0,0,0/ + data (ival(55,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,1,0, 0,0,0,0/ + data (iocc(56,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(56,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(57,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ + data (ival(57,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ + data (iocc(58,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,2, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(58,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,2, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(59,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,3, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(59,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,3, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(60,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,4, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(60,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,4, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(61,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,5, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(61,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,5, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(62,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(62,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(63,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 1,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(63,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 1,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(64,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 1,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ + data (ival(64,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 1,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ + data (iocc(65,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 3,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(65,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 3,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(66,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 4,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(66,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 4,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(67,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 5,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(67,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 5,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(68,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 6,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(68,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 6,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(69,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 7,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(69,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 7,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(70,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(70,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 8,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(71,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ + data (ival(71,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ + data (iocc(72,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,2, 0,0,0,2,0, 0,0,0,0/ + data (ival(72,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,2, 0,0,0,2,0, 0,0,0,0/ + data (iocc(73,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,3, 0,0,0,2,0, 0,0,0,0/ + data (ival(73,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,3, 0,0,0,2,0, 0,0,0,0/ + data (iocc(74,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 0,0,0,2,0, 0,0,0,0/ + data (ival(74,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 0,0,0,2,0, 0,0,0,0/ + data (iocc(75,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 1,0,0,2,0, 0,0,0,0/ + data (ival(75,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 1,0,0,2,0, 0,0,0,0/ + data (iocc(76,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 2,0,0,2,0, 0,0,0,0/ + data (ival(76,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 2,0,0,2,0, 0,0,0,0/ + data (iocc(77,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 3,0,0,2,0, 0,0,0,0/ + data (ival(77,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 3,0,0,2,0, 0,0,0,0/ + data (iocc(78,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 5,0,0,1,0, 0,0,0,0/ + data (ival(78,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 5,0,0,1,0, 0,0,0,0/ + data (iocc(79,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,1,0, 0,0,0,0/ + data (ival(79,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 6,0,0,1,0, 0,0,0,0/ + data (iocc(80,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,0, 0,0,0,0/ + data (ival(80,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 6,0,0,2,0, 0,0,0,0/ + data (iocc(81,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,1, 0,0,0,0/ + data (ival(81,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,1, 0,0,0,0/ + data (iocc(82,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 0,0,0,0/ + data (ival(82,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 0,0,0,0/ + data (iocc(83,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 1,0,0,0/ + data (ival(83,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 1,0,0,0/ + data (iocc(84,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 2,0,0,0/ + data (ival(84,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 2,0,0,0/ + data (iocc(85,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 3,0,0,0/ + data (ival(85,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 3,0,0,0/ + data (iocc(86,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,0/ + data (ival(86,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 4,0,0,0/ + data (iocc(87,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,1/ + data (ival(87,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,1/ + data (iocc(88,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,2/ + data (ival(88,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,2/ + data (iocc(89,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,1,0,2/ + data (ival(89,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,1,0,2/ + data (iocc(90,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,2,0,2/ + data (ival(90,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,2,0,2/ + data (iocc(91,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,2,0,2,2, 4,1,0,2/ + data (ival(91,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,2,0,0,0, 0,1,0,2/ + data (iocc(92,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,3,0,2,2, 4,1,0,2/ + data (ival(92,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,3,0,0,0, 0,1,0,2/ + data (iocc(93,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,4,0,2,2, 4,1,0,2/ + data (ival(93,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,4,0,0,0, 0,1,0,2/ + data (iocc(94,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,0,2,2, 4,0,0,2/ + data (ival(94,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,0,0,0, 0,0,0,2/ + data (iocc(95,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,1,2,2, 4,0,0,2/ + data (ival(95,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,1,0,0, 0,0,0,2/ + data (iocc(96,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,2,2,2, 4,0,0,2/ + data (ival(96,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,2,0,0, 0,0,0,2/ + data (iocc(97,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,3,2,2, 4,0,0,2/ + data (ival(97,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,3,0,0, 0,0,0,2/ + + if (iz .lt. 1 .or. iz .ge. 97) then + 8 format(' Atomic number ', i5, ' not available.') + write(slog,8) iz + call wlog(slog,1) + stop + endif + + ion = nint(xion) + delion=xion-ion + + + index = iz - ion + ilast = 0 + iscr = 0 + iion = 0 + iholep = ihole +c +c find last occupied orbital (ilast) and iion for delion.ge.0 +c + do 30 i=29,1,-1 + if (iion.eq.0 .and. dble(iocc(index,i)).gt.delion) iion=i + if (ilast.eq.0 .and. iocc(index,i).gt.0) ilast=i + 30 continue +c open(unit=91,file='getorbtuo.dat',status='unknown') +c iz=29 + if (ihole.eq.0) go to 11 + if (ihole.gt.0 .and. iocc(index,ihole) .lt. 1 .or. + 1 (ihole.eq.ilast .and. iocc(index,ihole)-real(delion).lt.1) ) then +c call wlog(' Cannot remove an electron from this level',1) + write(6,*)' Cannot remove an electron from level =', ihole + write(6,*) ' stop in getorb ' + stop 'GETORB-1' + endif + 11 continue +c +c the recipe for final state atomic configuration is changed +c from iz+1 prescription, since sometimes it changed occupation +c numbers in more than two orbitals. This could be consistent +c only with s02=0.0. New recipe remedy this deficiency. +c +c find where to put screening electron +c + index1 = index + 1 + do 10 i = 1, 29 + 10 if (iscr.eq.0 .and. (iocc(index1,i)-iocc(index,i)).gt.0.5) iscr=i +c +c special case of hydrogen like ion +c if (index.eq.1) iscr=2 +c +c find where to add or subtract charge delion (iion). +c if (delion .ge. 0) then +c removal of electron charge +c iion is already found +c + if (delion .lt. 0) then +c +c addition of electron charge +c + iion = iscr +c +c except special cases +c + if (ihole.ne.0 .and. + 1 iocc(index,iscr)+1-real(delion).gt.2*abs(kappa(iscr))) then + iion = ilast + if (ilast.eq.iscr .or. iocc(index,ilast)-real(delion).gt. + 1 2*abs(kappa(ilast)) ) iion = ilast + 1 + endif + endif + + norb = 0 + do 20 i = 1, 29 + if (iocc(index,i).gt.0 .or. (i.eq.iscr .and. ihole.gt.0) + 1 .or. (i.eq.iion .and. iocc(index,i)-real(delion).gt.0)) then + if (i.ne.ihole .or. iocc(index,i).ge.1) then + norb = norb + 1 + nqn(norb) = nnum(i) + nk(norb) = kappa(i) + xnel(norb) = dble(iocc(index,i)) + if (i.eq.ihole) then + xnel(norb) = xnel(norb) - 1 + iholep = norb + endif + if (i.eq.iscr .and. ihole.gt.0) xnel(norb)=xnel(norb)+1 + xnval(norb)= dble(ival(index,i)) + if (i.eq.ihole .and. xnval(norb).ge.1) + 1 xnval(norb) = xnval(norb) - 1 + if (i.eq.iscr .and. ihole.gt.0) + 1 xnval(norb) = xnval(norb) + 1 + if (i.eq.iion) xnel(norb) = xnel(norb) - delion + if (i.eq.iion) xnval(norb) = xnval(norb) - delion + den(norb) = 0.0D0 + endif + endif + 20 continue + norbco = norb +c +c check that all occupation numbers are within limits +c + do 50 i = 1, norb + if ( xnel(i).lt.0 .or. xnel(i).gt.2*abs(nk(i)) .or. + 1 xnval(i).lt.0 .or. xnval(i).gt.2*abs(nk(i)) ) then + write (slog,55) i + 55 format(' error in getorb.f. Check occupation number for ', + 1 i3, '-th orbital. May be a problem with ionicity.') + call wlog(slog,1) + stop + endif + 50 continue +c do 60 i=1,norb +c60 xnval(i) = 0.0d0 +c60 xnval(i) = xnel(i) + + return + end + + subroutine inmuat (ihole, xionin) + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc +c the meaning of common variables is described below + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) +c + dimension xnval(30) +c +c en one-electron energies +c scc factors for acceleration of convergence +c scw precisions of wave functions +c sce precisions of one-electron energies +c nmax number of tabulation points for orbitals +c + common/scrhf1/eps(435),nre(30),ipl +c +c eps non diagonal lagrange parameters +c nre distingue: - the shell is closed (nre <0) +c the shell is open (nre>0) +c - the orbitals in the integral rk if abs(nre) > or =2 +c ipl define the existence of lagrange parameters (ipl>0) +c + common/snoyau/dvn(251),anoy(10),nuc +c +c dvn nuclear potential +c anoy development coefficients at the origin of nuclear potential +c this development is supposed to be written anoy(i)*r**(i-1) +c nuc index of nuclear radius (nuc=1 for point charge) +c + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + data ideps/435/ + + ndor=10 + + + + call getorb( nz, ihole, xionin, norb, norbsc, + 1 iholep, en, nq, kap, xnel, xnval) + xk=0 + do 411 i=1,norb + 411 xk=xk+xnel(i) + if ( abs(nz-xionin-xk) .gt. 0.001D0) then + call wlog('check number of electrons in getorb.f',1) + stop + endif + norbsc=norb +c +c nz atomic number noi ionicity (nz-number of electrons) +c norb number of orbitals +c xnel(i) number of electrons on orbital i. +c first norbsc orbitals will be determined selfconsistently, +c the rest of orbitals are orthogonolized if iorth is non null, +c and their energies are those on cards if iene is non null +c or otherwise are the values obtained from solving dirac equation +c nes number of attempts in program soldir +c nuc number of points inside nucleus (11 by default) +c + do 171 i=1,ideps + 171 eps(i)=0.0d 00 + + idim = 251 + if (mod(idim,2) .eq. 0) idim=idim-1 + + ipl=0 +c +c ipl=0 means no orbitals with the same kappa and no +c orthogonalization needed. Thus it will remain zero only +c for hydrogen atom. +c + do 401 i=1,norb + nre(i)=-1 + llq= abs(kap(i)) + l=llq+llq + if (kap(i).lt.0) llq=llq-1 + if (llq.lt.0.or.llq.ge.nq(i).or.llq.gt.3) then + call wlog('kappa out of range, check getorb.f',1) + stop + endif + nmax(i)=idim + scc(i)=0.3d0 + if (xnel(i) .lt. l) nre(i)=1 + do 385 j=1,i-1 + if (kap(j).ne.kap(i)) go to 385 + if (nre(j).gt.0.or.nre(i).gt.0) ipl=ipl+1 + 385 continue + 401 continue + return + end +c + subroutine intdir(gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0) +c +c solution of the inhomogenios dirac equation +c gg gp initially exchage terms, at the time of return - wave functions +c ag and ap development coefficients of gg and gp +c ggmat gpmat values at the matching point for the inward integration +c en one-electron energy +c fl power of the first development term at the origin +c agi (api) initial values of the first development coefficients +c at the origin of a large (small) component +c ainf initial value for large component at point dr(max0) +c - at the end of tabulation of gg gp +c + implicit double precision (a-h,o-z) + save + common/comdir/cl,dz,bid1(522),dv(251),av(10),bid2(522) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + common/subdir/ell,fk,ccl,imm,nd,node,mat + common/messag/dlabpr,numerr + character*8 dlabpr + dimension gg(251),gp(251),ag(10),ap(10),coc(5),cop(5),dg(5),dp(5) + data cop/2.51d+02,-1.274d+03,2.616d+03,-2.774d+03,1.901d+03/, + 1coc/-1.9d+01,1.06d+02,-2.64d+02,6.46d+02,2.51d+02/, + 2cmixn/4.73d+02/,cmixd/5.02d+02/,hxd/7.2d+02/,npi/5/,icall/0/ +c +c numerical method is a 5-point predictor-corrector method +c predicted value p(n) = y(n-1) + c * somme de i=1,5 cop(i)*y'(n-i) +c corrected value c(n) = y(n-1) + c * somme de i=1,4 coc(i)*y'(n-i) +c + coc(5)*p'(n) +c final value y(n) = cmix*c(n) + (1.-cmix)*p(n) +c cmix=cmixn/cmixd +c + if (icall.eq.0) then + icall=1 + c=cmixn/cmixd + a=1.0d 00-c + cmc=c*coc(5) + f=coc(1) + do 1 j=2,npi + g=coc(j) + coc(j)=c*f+a*cop(j) + 1 f=g + coc(1)=c*cop(1) + endif + c=hx/hxd + ec=en/cl + ag(1)=agi + ap(1)=api + if (imm) 81,15,26 +c +c search for the second sign change point +c + 15 mat=npi + j=1 + 16 mat=mat+2 + if (mat.ge.np) then +c +c i had trouble with screened k-hole for la, for f-electrons. +c below i still define matching point if one electron energy is +c not less than -1ev. ala, january 1995 +c + if (ec .gt. -0.0003D0) then + mat = np - 12 + go to 25 + endif + numerr=56011 +c +c * fail to find matching point +c if you got this error with fractional ionicity, try +c slightly different.(xion=xion+0.01) +c + return + endif + f=dv(mat)+ell/(dr(mat)*dr(mat)) + f=(f-ec)*j + if (f) 25,25,16 + 25 j=-j + if (j.lt.0) go to 16 + if (mat .ge. np-npi) mat=np-12 +c +c initial values for the outward integration +c + 26 do 35 j=2,ndor + k=j-1 + a=fl+fk+k + b=fl-fk+k + ep=a*b+av(1)*av(1) + f=(ec+ccl)*ap(k)+ap(j) + g=ec*ag(k)+ag(j) + do 31 i=1,k + f=f-av(i+1)*ap(j-i) + 31 g=g-av(i+1)*ag(j-i) + + ag(j)=(b*f+av(1)*g)/ep + 35 ap(j)=(av(1)*f-a*g)/ep + do 41 i=1,npi + gg(i)=0.0d 00 + gp(i)=0.0d 00 + dg(i)=0.0d 00 + dp(i)=0.0d 00 + do 41 j=1,ndor + a=fl+j-1 + b=dr(i)**a + a=a*b*c + gg(i)=gg(i)+b*ag(j) + gp(i)=gp(i)+b*ap(j) + dg(i)=dg(i)+a*ag(j) + 41 dp(i)=dp(i)+a*ap(j) + i=npi + k=1 + ggmat=gg(mat) + gpmat=gp(mat) +c +c integration of the inhomogenious system +c + 51 cmcc=cmc*c + + 55 continue + a=gg(i)+dg(1)*cop(1) + b=gp(i)+dp(1)*cop(1) + i=i+k + ep=gp(i) + eg=gg(i) + gg(i)=a-dg(1)*coc(1) + gp(i)=b-dp(1)*coc(1) + do 61 j=2,npi + a=a+dg(j)*cop(j) + b=b+dp(j)*cop(j) + gg(i)=gg(i)+dg(j)*coc(j) + gp(i)=gp(i)+dp(j)*coc(j) + dg(j-1)=dg(j) + 61 dp(j-1)=dp(j) + f=(ec-dv(i))*dr(i) + g=f+ccl*dr(i) + gg(i)=gg(i)+cmcc*(g*b-fk*a+ep) + gp(i)=gp(i)+cmcc*(fk*b-f*a-eg) + dg(npi)=c*(g*gp(i)-fk*gg(i)+ep) + dp(npi)=c*(fk*gp(i)-f*gg(i)-eg) + if (i.ne.mat) go to 55 + + if (k.lt.0) go to 999 + a=ggmat + ggmat=gg(mat) + gg(mat)=a + a=gpmat + gpmat=gp(mat) + gp(mat)=a + if (imm.ne.0) go to 81 +c +c initial values for inward integration +c + a=test1* abs(ggmat) + if (ainf.gt.a) ainf=a + max0=np+2 + 73 a=7.0d+02/cl + 75 max0=max0-2 + if ((max0+1).le.(mat+npi)) then + numerr=138021 +c +c *the last tabulation point is too close to the matching point +c + return + endif + if (((dv(max0)-ec)*dr(max0)*dr(max0)).gt.a) go to 75 + + 81 c=-c + a=- sqrt(-ec*(ccl+ec)) + if ((a*dr(max0)).lt.-1.7d+02) go to 73 + b=a/(ccl+ec) + f=ainf/ exp(a*dr(max0)) + if (f.eq.0.0d 00) f=1.0d 00 + do 91 i=1,npi + j=max0+1-i + gg(j)=f* exp(a*dr(j)) + gp(j)=b*gg(j) + dg(i)=a*dr(j)*gg(j)*c + 91 dp(i)=b*dg(i) + i=max0-npi+1 + k=-1 + go to 51 + + 999 return + end +c + subroutine lagdat (ia,iex) +c +c * non diagonal lagrange parameteres * +c lagrange parameters involving orbital ia if ia is positive +c all lagrange parameters are calculated if ia is negative or zero +c contribution of the exchange terms is omitted if iex=0 +c this program uses akeato(bkeato) fdrirk multrk +c + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1 nq(30),kap(30),nmax(30) + common/scrhf1/eps(435),nre(30),ipl + + i1= max(ia,1) + idep=1 + if (ia.gt.0) go to 15 + 11 idep=i1+1 + 15 ji1=2* abs(kap(i1))-1 + do 201 i2=idep,norbsc + if (i2.eq.i1.or.kap(i2).ne.kap(i1)) go to 201 + if (nre(i1).lt.0.and.nre(i2).lt.0) go to 201 +c +c the following line was included to handle the case of single +c electron in 2 s-shells +c probably need to use schmidt orthogonalization in this case +c + if (xnel(i1).eq.xnel(i2)) go to 201 + d=0.0d 00 + do 101 l=1,norbsc + k=0 + jjl=2* abs(kap(l))-1 + kma= min(ji1,jjl) + 41 a=akeato(l,i1,k)/xnel(i1) + b=a-akeato(l,i2,k)/xnel(i2) + c=b + if (a.ne.0.0d 00) c=c/a + if ( abs(c).lt.1.0d-07) go to 51 + d=d+b*fdrirk(l,l,i1,i2,k) + 51 k=k+2 + if (k.le.kma) go to 41 + if (iex.eq.0) go to 101 + kma=(ji1+jjl)/2 + k= abs(jjl-kma) + if ((kap(i1)*kap(l)).lt.0) k=k+1 + 61 a=bkeato(l,i2,k)/xnel(i2) + b=a-bkeato(l,i1,k)/xnel(i1) + c=b + if (a.ne.0.0d 00) c=c/a + if ( abs(c).lt.1.0d-07) go to 71 + d=d+b*fdrirk(i1,l,i2,l,k) + 71 k=k+2 + if (k.le.kma) go to 61 + 101 continue + i= min(i1,i2) + j= max(i1,i2) + eps(i+((j-1)*(j-2))/2)=d/(xnel(i2)-xnel(i1)) + 201 continue + if (ia.gt.0) go to 999 + i1=i1+1 + if (i1.lt.norbsc) go to 11 + 999 return + end +c + subroutine messer +c +c prints error message on the output device +c + implicit double precision (a-h,o-z) + common/messag/dlabpr,numerr + character*8 dlabpr + character*512 slog + + ilig=numerr/1000 + ier=numerr-1000*ilig + write(slog,'(a,i6,a,i6,a,a8)') 'error number ',ier, + 1 ' detected on a line ',ilig,'in the program',dlabpr + call wlog(slog,1) + return + end +c + subroutine muatco +c +c * angular coefficients * +c sous programmes utilises cwig3j +c + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/mulabk/afgk + dimension afgk(30,30,0:3) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + + do 511 i=1,30 + do 511 j=1,30 + do 511 k=0,3 + 511 afgk(i,j,k)=0.0d 00 + do 701 i=1,norb + li= abs(kap(i))*2-1 + do 701 j=1,i + lj= abs(kap(j))*2-1 + kmax=(li+lj)/2 + kmin= abs(li-lj)/2 + if ((kap(i)*kap(j)).lt.0) kmin=kmin+1 +c +c calculate a_k(i,j) +c + m=0 + if (j.eq.i) m=1 + afgk(j,i,0)=afgk(j,i,0)+xnel(i)*(xnel(j)-m) +c +c calculate b_k(i,j) +c + b=afgk(j,i,0) + if (j.eq.i) then + a=li + b=-b*(a+1.0d 00)/a + kmin = kmin+2 + endif + do 675 k = kmin, kmax,2 + afgk(i,j,k/2)=b*(cwig3j(li,k*2,lj,1,0,2)**2) + 675 continue + 701 continue + return + end +c + subroutine nucdev (a,epai,av,dr,dv,dz,hx,nuc,np,ndor,dr1) +c +c * construction of nuclear potential * +c a atomic mass (negative or null for the point charge) +c epai parameter of the fermi density distribution +c (negative or null for uniform distribution), which is +c cte / (1. + exp((r-rn)/epai) ) +c with nuclear radius rn= 2.2677e-05 * (a**(1/3)) +c av coefficients of the development at the origin of nuclear potential +c dr tabulation points +c dv nuclear potential +c dz nuclear charge +c hx exponential step +c nuc index of the nuclear radius +c np number of tabulation points +c ndor number of the coefficients for development at the origin +c the declared below arguments are saved, dr1 is the first +c + implicit double precision (a-h,o-z) + dimension av(10),dr(251),dv(251),at(251) +c +c calculate radial mesh +c + if (a.le.1.0d-01) then + nuc=1 + else +c dr(nuc)=nuclear radius +c + a=dz*(a**(1.D0/3.D0))*2.2677d-05 + b=a/ exp(hx*(nuc-1)) + if (b.le.dr1) then + dr1=b + else +c +c increase value of nuc +c + b=log(a/dr1)/hx + nuc=3+2*int(b/2.0D0) + if (nuc.ge.np) stop 'dr1 too small' +c +c index of atomic radius larger than dimension of dr +c + dr1=a*exp(-(nuc-1)*hx) + endif + endif + + dr(1)=dr1/dz + do 181 l=2,np + 181 dr(l)=dr(1)* exp(hx*(l-1)) + + if (ndor.lt.5) then +c +c * there should be at least 5 development coefficients +c + call wlog('stopped in programm nucdev, ndor should be > 4.',1) + stop + endif +c +c calculate nuclear potential on calculated radial mesh +c + do 11 i=1,ndor + 11 av(i)=0.0d 00 + if (epai.le.0.0D0) then + do 15 i=1,np + 15 dv(i)=-dz/dr(i) + if (nuc.le.1) then + av(1)=-dz + else + av(2)=-3.0d 00*dz/(dr(nuc)+dr(nuc)) + av(4)=-av(2)/(3.0d 00*dr(nuc)*dr(nuc)) + l=nuc-1 + do 25 i=1,l + 25 dv(i)=av(2)+av(4)*dr(i)*dr(i) + endif + else + b= exp(-dr(nuc)/epai) + b=1.0d 00/(1.0d 00+b) + av(4)=b + av(5)=epai*b*(b-1.0d 00) + if (ndor.le.5) go to 45 + at(1)=1.0d 00 + at(2)=1.0d 00 + nf=1 + do 41 i=6,ndor + n=i-4 + nf=n*nf + dv(1)=n*at(1) + n1=n+1 + dv(n1)=1.0d 00 + do 35 j=2,n + 35 dv(j)=(n-j+2)*at(j-1)+(n-j+1)*at(j) + do 37 j=1,n1 + m=n+1-j + l=1 + if (mod(j,2).eq.0) l=-l + av(i)=av(i)+l*dv(j)*(b**m) + 37 at(j)=dv(j) + 41 av(i)=b*av(i)*(epai**n)/nf + 45 do 47 i=1,np + b=1.0d 00+ exp((dr(i)-dr(nuc))/epai) + if ((b*av(4)).gt.1.0d+15) go to 51 + dv(i)=dr(i)*dr(i)*dr(i)/b + 47 l=i + 51 if (l.ge.(np-1)) l=np-2 + k=l+1 + do 55 i=k,np + 55 dv(i)=0.0d 00 + at(1)=0.0d 00 + at(2)=0.0d 00 + k=2 + do 61 i=4,ndor + k=k+1 + do 58 j=1,2 + 58 at(j)=at(j)+av(i)*(dr(j)**k)/k + av(i)=av(i)/(k*(k-1)) + 61 av(2)=av(2)+av(i)*(dr(1)**k) + a=hx/2.4d+01 + b=a*1.3d+01 + k=l+1 + do 71 i=3,k + 71 at(i)=at(i-1)+b*(dv(i-1)+dv(i))-a*(dv(i-2)+dv(i+1)) + dv(l)=at(l) + do 75 i=k,np + 75 dv(i)=dv(l) + e= exp(hx) + c=1.0d 00/(e*e) + i=l-1 + 83 dv(i)=dv(i+1)/e+b*(at(i+1)/e+at(i))-a*(at(i+2)*c+at(i-1)*e) + i=i-1 + if (i-1) 85,85,83 + 85 dv(1)=dv(3)*c+hx*(at(1)+4.0d 00*at(2)/e+at(3)*c)/3.0d 00 + av(2)=(av(2)+dv(1))/dr(1) + a=-dz/dv(l) + do 95 i=4,ndor + 95 av(i)=-a*av(i) + av(2)=a*av(2) + do 97 i=1,np + 97 dv(i)=a*dv(i)/dr(i) + endif + + return + end +c + subroutine ortdat (ia) +c +c * orthogonalization by the schmidt procedure* +c the ia orbital is orthogonalized toa all orbitals of the same +c symmetry if ia is positive, otherwise all orbitals of the same +c symmetry are orthogonalized +c this program uses dsordf +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) +c dg,ag,dp,ap are used to exchange data only with dsordf + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + + m=norb + l= max(ia,1) + if (ia.gt.0) go to 11 + 5 m=l + l=l+1 + if (l.gt.norb) go to 999 + 11 do 15 i=1,idim + dg(i)=0.0d 00 + 15 dp(i)=0.0d 00 + maxl=nmax(l) + do 21 i=1,maxl + dg(i)=cg(i,l) + 21 dp(i)=cp(i,l) + do 25 i=1,ndor + ag(i)=bg(i,l) + 25 ap(i)=bp(i,l) + do 51 j=1,m + if (j.eq.l.or.kap(j).ne.kap(l)) go to 51 + max0=nmax(j) + a=dsordf (j,j,0,3,fl(l)) + do 41 i=1,max0 + dg(i)=dg(i)-a*cg(i,j) + 41 dp(i)=dp(i)-a*cp(i,j) + do 45 i=1,ndor + ag(i)=ag(i)-a*bg(i,j) + 45 ap(i)=ap(i)-a*bp(i,j) + maxl= max(maxl,max0) + 51 continue + max0= maxl + nmax(l)=max0 + a=dsordf (l,max0,0,4,fl(l)) + a= sqrt(a) + do 71 i=1,max0 + cg(i,l)=dg(i)/a + 71 cp(i,l)=dp(i)/a + do 75 i=1,ndor + bg(i,l)=ag(i)/a + 75 bp(i,l)=ap(i)/a + if (ia.le.0) go to 5 + 999 return + end +c + subroutine potrdf (ia) +c +c this programm uses akeato(bkeato),aprdev,multrk,yzkrdf +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10), + 2 eg(251),ceg(10),ep(251),cep(10) +c dg,dp to get data from yzkrdf, dv,eg,ep -output for soldir + dimension at(251),bt(251) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/scrhf1/eps(435),nre(30),ipl + common/snoyau/dvn(251),anoy(10),nuc + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + dimension bgj(10),bpj(10) + + do 9 i=1,ndor + cep(i)=0.0d 00 + ceg(i)=0.0d 00 + 9 av(i)=anoy(i) + do 11 i=1,idim + at(i)=0.0d 00 + bt(i)=0.0d 00 + ep(i)=0.0d 00 + eg(i)=0.0d 00 + 11 dv(i)=0.0d 00 +c +c coulomb terms +c + jia=2* abs(kap(ia))-1 + k=0 + 21 do 25 i=1,idim + 25 dg(i)=0.0d 00 + do 31 i=1,ndor + 31 ag(i)=0.0d 00 + max0=0 + do 51 j=1,norb + do 33 i = 1,10 + bgj(i) = bg(i,j) + 33 bpj(i) = bp(i,j) + m=2* abs(kap(j))-1 + if (k.gt.m) go to 51 + a=akeato(ia,j,k)/xnel(ia) + if (a.eq.0.0d 00) go to 51 + m=nmax(j) + do 35 i=1,m + 35 dg(i)=dg(i)+a*(cg(i,j)*cg(i,j)+cp(i,j)*cp(i,j)) + n=2* abs(kap(j))-k + l=ndor+2-n + if (l.le.0) go to 51 + do 41 i=1,l + m=n-2+i + 41 ag(m)=ag(m)+a*(aprdev(bgj,bgj,i)+ + 1 aprdev(bpj,bpj,i)) + 51 max0= max(max0,nmax(j)) + call yzkrdf (0,max0,k) + do 61 i=1,ndor + l=k+i+3 + if (l.gt.ndor) go to 61 + av(l)=av(l)-ag(i) + 61 continue + do 81 i=1,idim + 81 dv(i)=dv(i)+dg(i) + k=k+2 + if (k.le.ndor) av(k)=av(k)+ap(1) + if (k.lt.jia) go to 21 +c +c exchange terms +c + if (method.eq.0) go to 411 + do 201 j=1,norb + if (j-ia) 105,201,105 + 105 max0=nmax(j) + jj=2* abs(kap(j))-1 + kma=(jj+jia)/2 + k= abs(jj-kma) + if ((kap(j)*kap(ia)).lt.0) k=k+1 + + 111 a=bkeato(j,ia,k)/xnel(ia) + if (a.eq.0.0d 00) go to 151 + call yzkrdf (j,ia,k) + do 121 i=1,max0 + eg(i)=eg(i)+a*dg(i)*cg(i,j) + 121 ep(i)=ep(i)+a*dg(i)*cp(i,j) + n=k+1+ abs(kap(j))- abs(kap(ia)) + if (n.gt.ndor) go to 141 + do 135 i=n,ndor + ceg(i)=ceg(i)+bg(i+1-n,j)*a*ap(1) + 135 cep(i)=cep(i)+bp(i+1-n,j)*a*ap(1) + 141 i=2* abs(kap(j))+1 + if (i.gt.ndor) go to 151 + do 143 i = 1,10 + bgj(i) = bg(i,j) + 143 bpj(i) = bp(i,j) + do 145 n=i,ndor + ceg(n)=ceg(n)-a*aprdev(ag,bgj,n+1-i) + 145 cep(n)=cep(n)-a*aprdev(ag,bpj,n+1-i) + 151 k=k+2 + if (k.le.kma) go to 111 + 201 continue + 411 if (ipl.eq.0) go to 511 + do 481 j=1,norbsc + if (kap(j).ne.kap(ia).or.j.eq.ia) go to 481 + if (nre(j).lt.0.and.nre(ia).lt.0) go to 481 + m= max(j,ia) + i= min(j,ia)+((m-1)*(m-2))/2 + a=eps(i)*xnel(j) + max0=nmax(j) + do 461 i=1,max0 + at(i)=at(i)+a*cg(i,j) + 461 bt(i)=bt(i)+a*cp(i,j) + do 471 i=1,ndor + ceg(i)=ceg(i)+bg(i,j)*a + 471 cep(i)=cep(i)+bp(i,j)*a + 481 continue +c +c addition of nuclear potential and division of potentials and +c their development limits by speed of light +c + 511 do 527 i=1,ndor + av(i)=av(i)/cl + cep(i)=cep(i)/cl + 527 ceg(i)=ceg(i)/cl + do 531 i=1,idim + dv(i)=(dv(i)/dr(i)+dvn(i))/cl + ep(i)=(ep(i)+bt(i)*dr(i))/cl + 531 eg(i)=(eg(i)+at(i)*dr(i))/cl + return + end +c + subroutine potslw (dv,d,dr,dpas,np) +c +c coulomb potential uses a 4-point integration method +c dv=potential; d=density; dp=bloc de travail; dr=radial mesh +c dpas=exponential step; +c np=number of points +c ********************************************************************** +c + implicit double precision (a-h,o-z) + save + dimension dv(251), d(251), dp(251), dr(251) + das=dpas/24.0D0 + do 10 i=1,np + 10 dv(i)=d(i)*dr(i) + dlo=exp(dpas) + dlo2=dlo*dlo + dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0D0*(dlo-1.0D0)) + dp(1)=dv(1)/3.0D0-dp(2)/dlo2 + dp(2)=dv(2)/3.0D0-dp(2)*dlo2 + j=np-1 + do 20 i=3,j + 20 dp(i)=dp(i-1)+das*(13.0D0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1))) + dp(np)=dp(j) + dv(j)=dp(j) + dv(np)=dp(j) + do 30 i=3,j + k=np+1-i + 30 dv(k)=dv(k+1)/dlo+das*(13.0D0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp + 1 (k-1)*dlo)) + dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0D0*dp(2)/dlo+dp(3)/dlo2)/3.0D0 + do 40 i=1,np + 40 dv(i)=dv(i)/dr(i) + return + end +c + subroutine soldir (en,fl,agi,api,ainf,nq,kap,max0,ifail) +c +c resolution of the dirac equation +c p' - kap*p/r = - ( en/cl-v )*g - eg/r +c g' + kap*g/r = ( 2*cl+en/cl-v )*p + ep/r +c at the origin v approximately is -z/(r*cl) due to the point nucleus +c en one-electron energy in atomic units and negative +c fl power of the first term in development at the origin +c agi (api) initial values of the first development coefficient +c at the origin of the large(small)component +c ainf initial value for the large component at the point dr(max0) +c nq principal quantum number kap quantum number kappa +c max0 the last point of tabulation of the wave function +c this programm uses intdir +c + implicit double precision (a-h,o-z) + save + common/comdir/cl,dz,gg(251),ag(10),gp(251),ap(10),dv(251),av(10), + 2eg(251),ceg(10),ep(251),cep(10) +c +c gg,gp -output, dv,eg,ep - input +c + dimension hg(251),agh(10), + 1hp(251),aph(10),bg(251),bgh(10),bp(251),bph(10) +c +c cl speed of light (approximately 137.037 in atomic units) +c dz nuclear charge +c gg (gp) large (small) component +c hg,hp,bg et bp working space +c dv direct potential (v) eg and ep exchange potentials +c ag,ap,agh,aph,bgh,bph,av,ceg and cep are respectively the +c development coefficients for gg,gp,hg,hp,bg,bp,dv,eg et ep +c + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim +c +c hx exponential step +c dr radial mesh +c test1 precision for the matching the small component if method=1 +c test2 precision for the normalisation if method=2 +c ndor number of terms for the developments at the origin +c np maximum number of the tabulation points +c nes maximum number of attempts to ajust the small component +c method at the initial time distinguish the homoginious (method=0) +c from inhomoginious system. at the end is the index of method used. +c idim dimension of the block dr +c + common/subdir/ell,fk,ccl,imm,nd,node,mat +c +c ell fk*(fk+1)/ccl fk=kap ccl=cl+cl +c imm a flag for the determination of matching point +c nd number of nodes found node number of nodes to be found +c mat index of the matching point +c + common/messag/dlabpr,numerr + character*8 dprlab,dlabpr, drplab +c +c at the time of return numerr should be zero if integration is correct, +c otherwise numerr contains the number of instruction, which +c indicate the sourse and reason for abnornal return. +c + character*512 slog +c + data dprlab/' soldir'/,drplab/' intdir'/ + dlabpr=dprlab + enav=1.0d 00 + ainf= abs(ainf) + ccl=cl+cl + iex=method + if (method.le.0) method=1 +c +c notice that below iex=0,1 and method=1,2 only. +c this was used to simplify block structure of program. ala 11/22/94 +c + fk=kap + if (av(1).lt.0.0d 00.and.kap.gt.0) api=-agi*(fk+fl)/av(1) + if (av(1).lt.0.0d 00.and.kap.lt.0) api=-agi*av(1)/(fk-fl) + ell=fk*(fk+1.0d 00)/ccl + node=nq- abs(kap) + if (kap.lt.0) node=node+1 + emin=0.0D0 + do 91 i=1,np + a=(ell/(dr(i)*dr(i))+dv(i))*cl + if (a.lt.emin) emin=a + 91 continue + if (emin .ge. 0.0D0) then + numerr=75011 +c +c *potential is apparently positive +c + return + endif + if (en.lt.emin) en=emin*0.9d 00 + edep=en + + 101 numerr=0 + test=test1 + if (method.gt.1) test=test2 + einf=1.0d 00 + esup=emin + en=edep + ies=0 + nd=0 + 105 jes=0 + 106 modmat=0 + imm=0 + if ( abs((enav-en)/en).lt.1.0d-01) imm=1 + enav=en +c +c integration of the inhomogenious system +c + 107 do 111 i=1,idim + gg(i)=eg(i) + 111 gp(i)=ep(i) + do 115 i=2,ndor + ag(i)=ceg(i-1) + 115 ap(i)=cep(i-1) + call intdir (gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0) + if (numerr.ne.0) then + dlabpr=drplab + return + endif + if (iex.ne.0) go to 141 +c +c match large component for the homogenios system(method=0) +c + a=ggmat/gg(mat) + do 135 i=mat,max0 + gg(i)=a*gg(i) + 135 gp(i)=a*gp(i) + j=mat + go to 215 +c +c integration of the homogenios system +c + 141 do 151 i=1,idim + hg(i)=0.0d 00 + 151 hp(i)=0.0d 00 + do 155 i=1,ndor + agh(i)=0.0d 00 + 155 aph(i)=0.0d 00 + imm=1 + if (method.eq.1) imm=-1 + call intdir (hg,hp,agh,aph,hgmat,hpmat,en,fl,agi,api,ainf,max0) +c +c match the large component for inhomogenious system(method=1) +c + a=gg(mat)-ggmat + if (method.lt.2) then + b=-a/hg(mat) + else + b=gp(mat)-gpmat + ah=hpmat*hg(mat)-hgmat*hp(mat) + if (ah.eq.0.0d 00) go to 263 + c=(b*hg(mat)-a*hp(mat))/ah + b=(b*hgmat-a*hpmat)/ah + do 165 i=1,ndor + ag(i)=ag(i)+c*agh(i) + 165 ap(i)=ap(i)+c*aph(i) + j=mat-1 + do 168 i=1,j + gg(i)=gg(i)+c*hg(i) + 168 gp(i)=gp(i)+c*hp(i) + endif + do 173 i=mat,max0 + gg(i)=gg(i)+b*hg(i) + 173 gp(i)=gp(i)+b*hp(i) + + if (method.ge.2) then +c +c integration of the system derived from disagreement in energy +c + do 175 i=2,ndor + bgh(i)=ag(i-1)/cl + 175 bph(i)=ap(i-1)/cl + do 177 i=1,max0 + bg(i)=gg(i)*dr(i)/cl + 177 bp(i)=gp(i)*dr(i)/cl + call intdir (bg,bp,bgh,bph,bgmat,bpmat,en,fl,agi,api,ainf,max0) +c +c match both components for inhomogenious system (method=2) +c + f=bg(mat)-bgmat + g=bp(mat)-bpmat + a=(g*hg(mat)-f*hp(mat))/ah + g=(g*hgmat-f*hpmat)/ah + do 181 i=1,j + bg(i)=bg(i)+a*hg(i) + 181 bp(i)=bp(i)+a*hp(i) + do 182 i=1,ndor + bgh(i)=bgh(i)+a*agh(i) + 182 bph(i)=bph(i)+a*aph(i) + do 183 i=mat,max0 + bg(i)=bg(i)+g*hg(i) + 183 bp(i)=bp(i)+g*hp(i) +c +c calculate the norm +c + call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, + 1 gpmat,fl,max0,mat) +c +c correction to the energy (method=2) +c + do 186 i=1,max0 + 186 hg(i)=(gg(i)*bg(i)+gp(i)*bp(i))*dr(i) + ah=0.0d 00 + c=0.0d 00 + do 187 i=2,max0,2 + 187 ah=ah+hg(i)+hg(i)+hg(i+1) + ah=hx*(ah+ah+hg(1)-hg(max0))/3.0d 00+hg(1)/(fl+fl+1.0d 00) + f=(1.0d 00-b)/(ah+ah) + c=1.0d 00-b + do 191 i=1,max0 + gg(i)=gg(i)+f*bg(i) + 191 gp(i)=gp(i)+f*bp(i) + do 195 i=1,ndor + ag(i)=ag(i)+f*bgh(i) + 195 ap(i)=ap(i)+f*bph(i) + endif +c +c search for the maximum of the modulus of large component +c + a=0.0d 00 + bgh(1)=b + bph(1)=ah + do 211 i=1,max0 + g=gg(i)*gg(i) + if (g.le.a) go to 211 + a=g + j=i + 211 continue + if (j.gt.mat .and. modmat.eq.0) then + modmat=1 + mat=j + if (mod(mat,2).eq.0) mat=mat+1 + imm=1 + if (mat.lt.(max0-10)) go to 107 + + mat=max0-12 + j=mat + if (mod(mat,2).eq.0) mat=mat+1 + write(slog,'(a,i4,a,i4)') ' warning mat=',mat,' max0=',max0 + call wlog(slog,1) + endif +c +c this case can happen due to bad starting point in scf procedure. +c ignore this warning unless you are getting it at final norb calls of +c soldir. redirected by ala 11/21/94. +c numerr=220021 +c * impossible matching point +c go to 899 + +c compute number of nodes +c + 215 nd=1 + j= max(j,mat) + do 231 i=2,j + if (gg(i-1).eq.0.0d 00) go to 231 + if ((gg(i)/gg(i-1)).le.0.0d 00) nd=nd+1 + 231 continue + + if (nd-node) 251,305,261 + 251 esup=en + if (einf.lt.0.0d 00) go to 271 + en=en*8.0d-01 + if ( abs(en).gt.test1) go to 285 + numerr=238031 +c *zero energy + go to 899 + + 261 einf=en + if (esup.gt.emin) go to 271 + 263 en=en*1.2d 00 + if (en.gt.emin) go to 285 + numerr=245041 +c +c *energy is lower than the minimum of apparent potential +c + go to 899 + + 271 if ( abs(einf-esup).gt.test1) go to 281 + numerr=249051 +c +c *the upper and lower limits of energy are identical +c + go to 899 + + 281 en=(einf+esup)/2.0d 00 + + 285 jes=jes+1 + if (jes.le.nes) go to 106 +c +c *number of attempts to find good number of nodes is over the limit +c this case can happen due to bad starting point in scf procedure. +c ignore this warning unless you are getting it at final norb calls of +c soldir +c + call wlog('warning jes>nes',1) + ifail=1 +c +c *redirected by ala 11/21/94. +c numerr=255061 +c go to 899 +c +c calculation of the norm +c + 305 call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, + 1 gpmat,fl,max0,mat) + if (method.eq.1) then +c +c correction to the energy (method=1) +c + c=gpmat-gp(mat) + f=gg(mat)*c*cl/b + if (gpmat.ne.0.0d 00) c=c/gpmat + endif + + en=en+f + g= abs(f/(en-f)) + 371 if ((en.ge.0 .or. g.gt.2.0d-01) .or. + 1 (abs(c).gt.test .and. (en.lt.esup.or.en.gt.einf))) then +c +c try smaller step in enrgy under above conditions +c + f=f/2.0d 00 + g=g/2.0d 00 + en=en-f + if (g.gt.test1) go to 371 + numerr=29071 +c +c *zero energy +c + go to 899 + endif + + if ( abs(c).gt.test) then + ies=ies+1 + if (ies.le.nes) go to 105 + ifail=1 + call wlog('warning: iteration stopped because ies=nes',1) +c +c everything is fine unless you are getting this message +c on the latest stage selfconsistent process. +c just stopped trying to match lower component +c because number of trials exceeded limit. +c lines below were commented out. ala 11/18/94 +c + endif +c +c numerr=298081 +c *number of attempts to match the lower component is over the limit +c go to 899 +c +c divide by a square root of the norm, and test the sign of w.f. +c + b= sqrt(b) + c=b + if ((ag(1)*agi).lt.0.0d 00.or.(ap(1)*api).lt.0.0d 00) c=-c + do 711 i=1,ndor + ag(i)=ag(i)/c + 711 ap(i)=ap(i)/c + if ((gg(1)*agi).lt.0.0d 00.or.(gp(1)*api).lt.0.0d 00) b=-b + do 721 i=1,max0 + gg(i)=gg(i)/b + 721 gp(i)=gp(i)/b + if (max0.ge.np) return + j=max0+1 + do 741 i=j,np + gg(i)=0.0d 00 + 741 gp(i)=0.0d 00 +c +c if everything o'k , exit is here. +c + return +c +c abnormal exit is here, if method.ne.1 +c + 899 if (iex.eq.0 .or. method.eq.2) go to 999 + method=method+1 + go to 101 + + 999 return + end +c + subroutine norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, + 1 gpmat,fl,max0,mat) +c +c calculate norm b. this part of original code was used twice, +c causing difficult block structure. so it was rearranged into +c separate subroutine. ala +c + implicit double precision (a-h, o-z) + dimension hp(251),dr(251),gg(251),gp(251),ag(10),ap(10) + + b=0.0d 00 + do 311 i=1,max0 + 311 hp(i)=dr(i)*(gg(i)*gg(i)+gp(i)*gp(i)) + if (method.ne.1) go to 315 + hp(mat)=hp(mat)+dr(mat)*(gpmat**2-gp(mat)**2)/2.0d 00 + 315 do 321 i=2,max0,2 + 321 b=b+hp(i)+hp(i)+hp(i+1) + b=hx*(b+b+hp(1)-hp(max0))/3.0d 00 + do 325 i=1,ndor + g=fl+fl+i + g=(dr(1)**g)/g + do 325 j=1,i + 325 b=b+ag(j)*g*ag(i+1-j)+ap(j)*g*ap(i+1-j) + return + end + +C FUNCTION ISTRLN (STRING) Returns index of last non-blank +C character. Returns zero if string is +C null or all blank. + + FUNCTION ISTRLN (STRING) + CHARACTER*(*) STRING + CHARACTER BLANK, TAB + PARAMETER (BLANK = ' ', TAB = ' ') + +C there is a tab character here ^ + +C -- If null string or blank string, return length zero. + + ISTRLN = 0 + IF (STRING (1:1) .EQ. CHAR(0)) RETURN + IF (STRING .EQ. ' ') RETURN + +C -- Find rightmost non-blank character. + + ILEN = LEN (STRING) + DO 20 I = ILEN, 1, -1 + IF (STRING(I:I).NE.BLANK .AND. STRING(I:I).NE.TAB) GOTO 30 + 20 CONTINUE + 30 ISTRLN = I + + RETURN + END + + subroutine tabrat +c +c tabulation of the results +c do identifications of orbitals +c nmax number of tabulation points for wave function +c this programm uses dsordf +c + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common /charact/ ttl + character*40 ttl + character*2 titre(30) + character*2 ttire(9) + dimension at(8),mbi(8) + parameter (zero=0) + data ttire /'s ', 'p*', 'p ', 'd*', 'd ', 'f*', 'f ','g*', 'g '/ +c + do 110 i=1,norb + if (kap(i) .gt. 0) then + j=2*kap(i) + else + j=-2*kap(i)-1 + endif + titre(i)=ttire(j) + 110 continue +c +c tabulation of number of points and of average values of +c r**n (n=6,4,2,1,-1,-2,-3) +c + do 201 i=2,8 + 201 mbi(i)=8-i-i/3-i/4+i/8 + lttl = istrln(ttl) + write(16,11) ttl(1:lttl) + 11 format (10x,a) + write(16,*) + 1'number of electrons nel and average values of r**n in a.u.' + write(16,2061) (mbi(k),k=2,8) + 2061 format (4x,'nel',' n=',7(i2,8x)) + do 251 i=1,norb + llq= abs(kap(i))-1 + j=8 + if (llq.le.0) j=7 + do 241 k=2,j + 241 at(k)=dsordf(i,i,mbi(k),1, zero) + 251 write(16,2071) nq(i),titre(i),xnel(i),(at(k),k=2,j) + 2071 format(i2,a2,f7.3,7(1pe10.3)) +c +c overlap integrals +c + if (norb.le.1) return + write(16,11) ttl(1:lttl) + write(16,321) + 321 format(10x,'overlap integrals') + do 351 i=1,norb-1 + do 331 j=i+1,norb + if (kap(j).ne.kap(i)) go to 331 + at(1)=dsordf(i,j,0,1, zero) + write(16,2091) nq(i),titre(i),nq(j),titre(j),at(1) + 331 continue + 351 continue + 2091 format (4x,i3,a2,i3,a2,f14.7) + return + end +c + subroutine wfirdf (en,ch,nq,kap,nmax,ido,amass,beta) +c +c calculate initial orbiatls from integration of dirac equation +c cg (cp) large (small) radial components +c bg (bp) development coefficients at the origin of cg (cp) +c en one-electron energies +c fl power of the first term of development at the origin +c ch ionicity (nuclear charge - number of electrons) +c nq principal quantum number +c kap quantum number "kappa" +c nmax number of tabulation points for the orbitals +c ibgp first dimension of the arrays bg and bp +c this programmes utilises nucdev,dentfa,soldir et messer +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + dimension en(30),nq(30),kap(30),nmax(30) + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10), + 1dv(251),av(10),eg(251),ceg(10),ep(251),cep(10) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/inelma/nem + common/messag/dlabpr,numerr + character*8 dlabpr + character*512 slog + common/snoyau/dvn(251),anoy(10),nuc + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim +c +c speed of light in atomic units +c + cl=1.370373d+02 +c +c make r-mesh and calculate nuclear potential +c hx exponential step +c dr1 first tabulation point multiplied by nz +c + dr1=dr(1) + call nucdev (amass, beta,anoy,dr,dvn,dz,hx,nuc,idim,ndor,dr1) +c +c notice that here nuc=1, +c unless you specified nonzero nuclear mass in nucdev.f +c + a=(dz/cl)**2 + if (nuc.gt.1) a=0.0d 00 + do 11 j=1,norb + b=kap(j)*kap(j)-a + 11 fl(j)= sqrt(b) +c +c calculate potential from thomas-fermi model +c + do 21 i=1,idim + 21 dv(i)=(dentfa(dr(i),dz,ch)+dvn(i))/cl + if (numerr.ne.0) return + do 51 i=1,idim + eg(i)=0.0d 00 + 51 ep(i)=0.0d 00 + do 61 i=1,ibgp + ceg(i)=0.0d 00 + cep(i)=0.0d 00 + 61 av(i)=anoy(i)/cl + av(2)=av(2)+dentfa(dr(nuc),dz,ch)/cl + test1=testy/rap(1) + b=test1 +c +c resolution of the dirac equation to get initial orbitals +c + if (ido.ne.1) then + call wlog('only option ido=1 left',1) + ido = 1 + endif +c +c here was a piece to read orbitals from cards +c + do 281 j=1,norb + bg(1,j)=1.0d 00 + i=nq(j)- abs(kap(j)) + if (kap(j).lt.0) i=i-1 + if (mod(i,2).eq.0) bg(1,j)=-bg(1,j) + if (kap(j).lt.0) go to 201 + bp(1,j)=bg(1,j)*cl*(kap(j)+fl(j))/dz + if (nuc.gt.1) bg(1,j)=0.0d 00 + go to 211 + + 201 bp(1,j)=bg(1,j)*dz/(cl*(kap(j)-fl(j))) + if (nuc.gt.1) bp(1,j)=0.0d 00 + 211 np=idim + en(j)=-dz*dz/nq(j)*nq(j) + method=0 + call soldir + 1 (en(j),fl(j),bg(1,j),bp(1,j),b,nq(j),kap(j),nmax(j),0) + + if (numerr.eq.0) go to 251 + call messer + write(slog,'(a,2i3)') + 1 'soldir failed in wfirdf for orbital nq,kappa ',nq(j),kap(j) + call wlog(slog,1) + go to 281 + + 251 do 261 i=1,ibgp + bg(i,j)=ag(i) + 261 bp(i,j)=ap(i) + do 271 i=1,np + cg(i,j)=dg(i) + 271 cp(i,j)=dp(i) + 281 continue + nem=0 + return + end +c + subroutine wlog (string,iprint) + character*(*) string +c +c This output routine is used to replace the PRINT statement +c for output that "goes to the terminal", or to the log file. +c If you use a window based system, you can modify this routine +c to handle the running output elegantly. +c Handle carriage control in the string you pass to wlog. +c +c The log file is also written here, hard coded here. +c +c The log file is unit 11. The log file is opened in the +c main program, program feff. +c +c make sure not to write trailing blanks +c + + 10 format (a) + + il = istrln (string) + if (il .eq. 0) then + if(iprint.eq.1) print 10 + write(11,10) + else + if(iprint.eq.1) print 10, string(1:il) + write(11,10) string(1:il) + endif + return + end +c + subroutine yzkrdf (i,j,k) +c +c * calculate function yk * +c yk = r * integral of f(s)*uk(r,s) +c uk(r,s) = rinf**k/rsup**(k+1) rinf=min(r,s) rsup=max(r,s) +c f(s)=cg(s,i)*cg(s,j)+cp(s,i)*cp(s,j) if nem=0 +c f(s)=cg(s,i)*cp(s,j) if nem is non zero +c f(s) is constructed by the calling programm if i < or =0 +c in the last case a function f (lies in the block dg) is supposedly +c tabulated untill point dr(j), and its' devlopment coefficients +c at the origin are in ag and the power in r of the first term is k+2 + +c the output functions yk and zk are in the blocks dp and dg. +c at the origin yk = cte * r**(k+1) - developement limit, +c cte lies in ap(1) and development coefficients in ag. +c this programm uses aprdev and yzkteg +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) + dimension chg(10) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + common/inelma/nem + dimension bgi(10),bgj(10),bpi(10),bpj(10) +c + if (i.le.0) go to 51 +c +c construction of the function f +c + do 5 l= 1,ibgp + bgi(l) = bg(l,i) + bgj(l) = bg(l,j) + bpi(l) = bp(l,i) + 5 bpj(l) = bp(l,j) + id= min(nmax(i),nmax(j)) + ap(1)=fl(i)+fl(j) + if (nem.ne.0) go to 31 + do 11 l=1,id + 11 dg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) + do 21 l=1,ndor + 21 ag(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l) + go to 55 + + 31 do 35 l=1,id + 35 dg(l)=cg(l,i)*cp(l,j) + do 41 l=1,ndor + 41 ag(l)=aprdev(bgi,bpj,l) + go to 55 +c + 51 ap(1)=k+2 + id=j + 55 call yzkteg (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim) + return + end +c + subroutine yzkteg (f,af,g,ag,dr,ap,h,k,nd,np,idim) +c +c calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to +c infinity of f(u) * u**(-k-1) +c zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k + +c at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1) +c dr tabulation points h exponential step +c np number of tabulation points for f +c idim dimension of the blocks f,g and dr + +c at the origin yk=cte*r**(k+1)-developement limit +c the constant for yk lies in ap +c output functions yk and zk lie in f and g, and their +c development coefficients at the origin in af and ag. + +c integration from point to point by a 4 points method. +c integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24 +c + implicit double precision (a-h,o-z) + dimension f(251),af(10),g(251),ag(10),dr(251) +c +c initialisation and development coefficients of yk +c + np= min(np,idim-2) + b=ap + ap=0.0d 00 + g(1)=0.0d 00 + g(2)=0.0d 00 + do 15 i=1,nd + b=b+1.0d 00 + ag(i)=af(i)/(b+k) + if (af(i).ne.0.0d 00) then + c=dr(1)**b + g(1)=g(1)+ag(i)*c + g(2)=g(2)+ag(i)*(dr(2)**b) + af(i)=(k+k+1)*ag(i)/(b-k-1) + ap=ap+af(i)*c + endif + 15 continue + do 21 i=1,np + 21 f(i)=f(i)*dr(i) + np1=np+1 + f(np1)=0.0d 00 + f(np1+1)=0.0d 00 +c +c calcualation of zk +c + eh= exp(h) + e=eh**(-k) + b=h/2.4d+01 + c=1.3d+01*b + ee=e*e*b + b=b/e + do 51 i=3,np1 + 51 g(i)=g(i-1)*e+(c*(f(i)+f(i-1)*e)-(f(i-2)*ee+f(i+1)*b)) +c +c calcualation of yk +c + f(np)=g(np) + do 61 i=np1,idim + 61 f(i)=f(i-1)*e + i=k+k+1 + b=i*b*eh + ee=i*ee/(eh*eh) + e=e/eh + c=i*c + do 71 i=np-1,2,-1 + 71 f(i)=f(i+1)*e+(c*(g(i)+g(i+1)*e)-(g(i+2)*ee+g(i-1)*b)) + ee=e*e + c=8.0d 00*c/1.3d+01 + f(1)=f(3)*ee+c*(g(3)*ee+4.0d 00*e*g(2)+g(1)) + ap=(ap+f(1))/(dr(1)**(k+1)) + return + end +c + subroutine llmesh +c + include 'msxas3.inc' +c include 'msxasc3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $ n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex v,vcons +c + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +c + character*8 name0 ,nsymbl !added 29/3/2013 +c + common /param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + + complex vcon,xe,ev +c + logical do_r_in +c +c-------------------------------------------------------- +c +c write(69,*) ' in sub cont_sub nat = ', nat +C +C CONSTRUCT LINEAR-LOG MESH +C + DO_R_IN = .FALSE. +C + DO N = 1, NDAT +C + ZAT = FLOAT(NZ(N)) + IF(ZAT.EQ.0.0) THEN + X0 = 9.0 +C X0 = 10.0 + ELSE + X0 = 9.0 + LOG(ZAT) +C X0 = 10.0 + LOG(ZAT) + ENDIF + RKMX = R(KMAX(N),N) + DPAS = 0.1/RKMX +! IF(DPAS.GT.0.03) DPAS = 0.03 + IF(DPAS.GT.0.02) DPAS = 0.02 + ALPHA = 0.5 + BETA = 1.0 + RHO_1 = -BETA*X0 + R_SUB = RS(N) + XMAX = ALPHA*R_SUB + BETA*LOG(R_SUB) + KMX(N) = NINT ( (XMAX + X0 + DPAS) / DPAS ) + IF(KMX(N).GT.RDX_) THEN + WRITE(6,*) + & 'INCREASE PARAMETER RDX_. IT SHOULD BE AT LEAST ', KMX(N) + CALL EXIT + ENDIF + NR = KMX(N) + KPLX(N) = KMX(N)-3 +C +C CHECK IN LLMESH +c write(6,'(2i5,4e15.6)') n,kmx(n),rkmx,r_sub,xmax,rho_1 +c flush(6) +C + CALL LINLOGMESH ( I_END, HX(N), X(1,N), RX(1,N), DO_R_IN, + & KMX(N), KPLX(N), NR, RHO_1, R_SUB, R_IN, + & ALPHA, BETA ) +c +c if(n.eq.ndat) then + +c if(n.eq.ndat) write(6,*) (x(i,n), rx(i,n), i=1,kmx(n)) +c endif +C +c print *, ' inside llmesh loop ', kmx(n) +c do i = 1, kmx(n) +c write(69,*) x(i,n), rx(i,n) +c print *, x(i,n), rx(i,n) +c enddo +c + ENDDO +c +c---------------------------------------------------------- +c + return + end +c + subroutine linlogmesh ( i_end, drho, rho, r_real, do_r_in, + & kmax, kplace, nr, rho_1, r_sub, r_in, + & alpha, beta ) +! +! Set up log + linear radial mesh. +! +! rho = alpha * r_real + beta * log ( r_real ) +! +! rho_i = rho_{i-1} + drho +! +! +! i_end : point at inscribed sphere, for outersphere not used always 0. +! drho : constant step in loglinear space +! rho : log + linear mesh with constant step. +! r_real : real radial mesh correponding to the step of loglinear mesh +! do_r_in : option for outer sphere +! kmax : three points after kplace +! kplace : point on the bounding sphere where the Wronskian is estimated. +! nr : number of radial mesh points +! rho_1 : the first point in loglinear space +! r_sub : radius of bounding sphere in loglinear space, r_sub => rho(kplace) +! r_in : +! alpha : parameter for linear part +! beta : parameter for log part + +c implicit double precision (a-h,o-z) + +!...input +! logical, intent ( in ) :: do_r_in +! integer, intent ( in ) :: nr, kmax, kplace +! real ( kind = double ), intent ( in ) :: rho_1, r_sub, r_in, alpha, beta + +!...output +! integer, intent ( out ) :: i_end +! real ( kind = double ), intent ( out ) :: drho +! real ( kind = double ), intent ( out ), dimension ( : ) :: rho, r_real + +!...local +! logical :: check +! integer :: i, k +! real ( kind = double ) :: rn, rhon, epsilon +c + dimension rho(kmax), r_real(kmax) +c + logical do_r_in, check + + myrank = 0 + dzero = 0.0 + check = .false. +c check = .true. + + rho ( kplace ) = alpha * r_sub + beta * log ( r_sub ) + + rho ( 1 ) = rho_1 + drho = ( rho ( kplace ) - rho ( 1 ) ) / real ( kmax - 4 ) + + rho ( kmax ) = rho ( kplace ) + 3.00 * drho +! +! write(6,*) rho(1), rho(kmax), drho +! write(6,*) ' ** ' + +! if ( myrank .eq. 0 ) then +! write ( unit = 6, fmt = * ) " alpha =", alpha, " beta ", beta +! write ( unit = 6, fmt = * ) "rho_1 =", rho ( 1 ), & +! & " rho ( kplace ) =", rho ( kplace ), " rho ( kmax ) = ", rho ( kmax ) +! write ( unit = 6, fmt = * ) "drho =", drho, " nr =", nr +! end if + +! + do i = 2, nr + + rho ( i ) = rho ( i - 1 ) + drho + + end do +! +!.....Solve non-linear equation by Newton method +! + rhon = rho ( kplace ) + r_real ( kplace ) = r_sub +! rn = ( rhon - beta * log ( rhon ) ) / alpha ! correction 2nd April 2013 + rn = ( rhon - beta * log ( r_sub ) ) / alpha +! + do i = kplace - 1, 1, - 1 + + k = 0 +! + do +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn + + end if +! +! MPI + +! + if ( rn .eq. dzero ) then +! +! MPI +! + if ( myrank .eq. 0 ) then + + write ( unit = 6, fmt = * ) "Error occurred at radialmesh!", + & "rn = 0" + + end if +! +! MPI +! + stop + + end if +! + + epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / + & ( alpha * rn + beta ) +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn, epsilon + + end if +! +! MPI +! + + rn = rn * ( 1.00 - epsilon ) +! + if ( rn .lt. 0.0 ) then + + rn = r_real ( i + 1 ) * 0.100 ** k + k = k + 1 + + end if +! +! + if ( abs ( epsilon ) .le. 1.0e-6 ) then + + exit + + end if +! + end do +! + r_real ( i ) = rn + +! write(6,*) i, r_real ( i ) + + end do +! + + rhon = rho ( kplace ) +! rn = ( rhon - beta * log ( rhon ) ) / alpha ! correction 2nd April 2013 + rn = ( rhon - beta * log ( r_sub ) ) / alpha + +! + do i = kmax - 2, nr + + k = 0 +! + do +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn + + end if +! +! MPI +! + + epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / + & ( alpha * rn + beta ) +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn, epsilon + + end if +! +! MPI +! + rn = rn * ( 1.00 - epsilon ) +! + if ( rn .lt. 0.0 ) then + + rn = r_real ( i - 1 ) * 10.00 ** k + k = k + 1 + + end if +! + if ( abs ( epsilon ) .le. 1.0e-6 ) then + + exit + + end if +! + end do +! + r_real ( i ) = rn + + end do +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 99, fmt = * ) '# i rho r rho ( r )', + & ' dr' + i = 1 + write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i, rho ( i ), + & r_real ( i ), + & alpha * r_real ( i ) + beta * log ( r_real ( i ) ) +! + do i = 2, nr + + write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i,rho ( i ), + & r_real ( i ), + & alpha * r_real ( i ) + beta * log ( r_real ( i ) ), + & r_real ( i ) - r_real ( i - 1 ) + + end do +! + end if +! +! MPI +! +C! if ( .not. do_r_in ) then + if ( do_r_in ) then + + i = 1 +! + do +! + if ( r_real ( i ) > r_in ) then + + exit + + end if +! + i = i + 1 + + end do +! + i_end = i + + else + + i_end = 0 + + end if +! + +! if ( myrank .eq. 0 ) then + +! write ( unit = 6, fmt = * ) +! write ( unit = 6, fmt = "( a7, i5, a20, f12.7 )" ) & +! & "kplace = ", kplace, ", r_real ( kplace ) = ", r_real ( kplace ) +! write ( unit = 6, fmt = "( a7, i5, a20, f12.7, a10, f12.7 )" ) & +! & "kmax = ", kmax, ", r_real ( kmax ) = ", r_real ( kmax ), & +! & ", r_sub = ", r_sub +! write ( unit = 6, fmt = * ) +! write ( unit = 6, fmt = * ) "**** r_in = r_real (",i_end,")= ", & +! & r_real ( i_end ) + +! end if + + end subroutine linlogmesh +C +C + SUBROUTINE VREL +C + include 'msxas3.inc' + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +C + COMMON /FCNR/KXE,H(D_),VCONS(2), + 1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS,V +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev + character*8 nsymbl,name0 +c + + COMPLEX ZTMP(0:RD_), ZX, DZX, D2ZX + REAL*4 RTMP(0:RD_) +C + DATA FSC,FSCS4 /7.29735E-3,1.331283E-5/ +C +C INTERPOLATE POTENTIAL ON THE LOG-LINEAR MESH +C AND ADD RELATIVISTIC CORRECTIONS, INCLUDING SPIN-ORBIT INTERACTION +C +C WRITE(7,*) ' I RX(I), VX(I), VXSR(I), VXSO(I), BX(I) ' +C + RTMP(0) = 0.0 +C + DO N = 1, NDAT +C + ZAT = FLOAT(NZ(N)) + ZTMP(0) = CMPLX(2.0*ZAT,0.0) +C + DO I = 1, KMAX(N) + RTMP(I) = R(I,N) + ENDDO +C + NS = N + DO IS=1,NSPINS + DO I = 1, KMAX(N) + ZTMP(I) = -V(I,NS) * RTMP(I) +C WRITE(6,*) N, IS, I, RTMP(I), ZTMP(I) + ENDDO + +C + DO I=1,KMX(N) +C +C FIND NEAREST POINTS - INITIALIZE HUNTING PARAMETER (SUBROUTINE NEAREST) +C + JLO=1 + CALL NEAREST1(RTMP(0), KMAX(N)+1, RX(I,N), + & IP1, IP2, IP3, JLO) + IP1 = IP1 - 1 + IP2 = IP2 - 1 + IP3 = IP3 - 1 +C +C INTERPOLATE ZR(I) AND RHOTOT(I) +C + CALL CINTERP_QUAD( RTMP(IP1),ZTMP(IP1), + & RTMP(IP2),ZTMP(IP2), + & RTMP(IP3),ZTMP(IP3), + & RX(I,N),ZX,DZX,D2ZX ) + VX(I,NS) = -ZX/RX(I,N) + BX(I,NS) = FSCS4/(1.0 + FSCS4*(E - VX(I,NS))) + DVX(I,NS) = -(DZX/RX(I,N) - ZX/RX(I,N)**2) + VXR(I,NS) = VX(I,NS) - FSCS4*(E - VX(I,NS))**2 + + & 0.5*BX(I,NS)*( -D2ZX/RX(I,N) + + & 1.5*BX(I,NS)*(DVX(I,NS))**2 ) + VXSO(I,NS) = BX(I,NS)*DVX(I,NS)/RX(I,N) +C WRITE(15,1) I, RX(I,N), VX(I,NS), VXR(I,NS), +C & VXSO(I,NS), BX(I,NS) +1 FORMAT(I5,9E15.6) + ENDDO + NS=NS+NDAT + ENDDO +C + ENDDO +C + RETURN +C + END +C +C + SUBROUTINE NEAREST1(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3, + & JLO) +C +C FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X +C AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3 +C This subroutine was taken from Numerical Recipes, +C W. H. Press, B. F. Flanney, S. A. Teukolsky and W. T. +C Vetterling, page 91. Originally called HUNT +C IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C COMMON/MESH_PARAM/JLO +C + DIMENSION XX(*) + LOGICAL ASCND + ASCND=XX(N).GT.XX(1) +C +C EXTRAPOLATE BELOW LOWEST POINT +C + IF(X.LE.XX(1))THEN + I_POINT_1=1 + I_POINT_2=2 + I_POINT_3=3 + RETURN + END IF +C +C EXTRAPOLATE BEYOND HIGHEST POINT +C + IF(X.GE.XX(N))THEN + I_POINT_1=N-2 + I_POINT_2=N-1 + I_POINT_3=N + RETURN + END IF + IF(JLO.LE.0.OR.JLO.GT.N)THEN + JLO=0 + JHI=N+1 + GO TO 3 + ENDIF + INC=1 + IF(X.GE.XX(JLO).EQV.ASCND)THEN +1 JHI=JLO+INC + IF(JHI.GT.N)THEN + JHI=N+1 + ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN + JLO=JHI + INC=INC+INC + GO TO 1 + ENDIF + ELSE + JHI=JLO +2 JLO=JHI-INC + IF(JLO.LT.1)THEN + JLO=0 + ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN + JHI=JLO + INC=INC+INC + GO TO 2 + ENDIF + ENDIF +3 IF(JHI-JLO.EQ.1)THEN + IF((JLO+1).EQ.N)THEN + I_POINT_1=JLO-1 + I_POINT_2=JLO + I_POINT_3=JLO+1 + ELSE + I_POINT_1=JLO + I_POINT_2=JLO+1 + I_POINT_3=JLO+2 + END IF + RETURN + END IF + JM=(JHI+JLO)/2 + IF(X.GT.XX(JM).EQV.ASCND)THEN + JLO=JM + ELSE + JHI=JM + ENDIF + GO TO 3 + END +C +C + SUBROUTINE CINTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4,DY4,D2Y4) +C +C INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2) +C TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT +C PARAMETERS. THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C +C + COMPLEX Y1, Y2, Y3, Y4, DY4, D2Y4 + COMPLEX TOP, A, B, C +C + TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1) + BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1) + B = TOP/BOTTOM + A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1) + C = Y3 - A*X3*X3 - B*X3 + Y4 = A*X4*X4 + B*X4 + C + DY4 = 2.0*A*X4 + B + D2Y4 = 2.0*A +C + RETURN + END +C +C + subroutine smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax, + & ramfnr,ramfsr,ramfsop,ramfsoa) +c + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +C + COMMON/BESSEL/SBF(LTOT_),DSBF(LTOT_),SHF(LTOT_),DSHF(LTOT_) + COMPLEX*16 SBF,DSBF,SHF,DSHF + COMPLEX*16 SBFX(LTOT_),DSBFX(LTOT_),SHFX(LTOT_),DSHFX(LTOT_) +C + COMPLEX*16 Y0(0:LMAX_), Y1(0:LMAX_) + DOUBLE PRECISION RX1, RX2, EXPR +C + COMMON /FCNR/KXE, H(D_),VCONS(2), + 1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS,V +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMPLEX VXP(RDX_), VXA(RDX_), BD(RDX_) +C + COMPLEX PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), PAX(RDX_,F_) + COMPLEX PSX(N_), DPSX(N_), STMAT, RAMFX(N_) + COMPLEX PS0(N_), DPS0(N_), STMAT0, RAMF0(N_) + COMPLEX PS1(N_), DPS1(N_), STMAT1, RAMF1(N_) + COMPLEX PS2(N_), DPS2(N_), STMAT2, RAMF2(N_) + COMPLEX RAMF00, RAMF01, RAMF02 +C + COMPLEX PKMX, PKMX1 +C + COMMON /LLM/ ALPHA, BETA +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + complex pss(6),dpss(6), + & ramfnr(n_), ramfsr(n_), ramfsop(n_), ramfsoa(n_) +c + character*8 name0 ,nsymbl !added 29/3/2013 + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe +c + common /seculrx/ atmnr(n_), atmsr(n_), atmsop(n_), atmsoa(n_) + complex atmnr, atmsr, atmsop, atmsoa +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c + common/auger/calctype,expmode,edge1,edge2 + character*3 calctype, expmode + character*2 edge1,edge2 +c + complex csqrt,arg,arg1 + COMPLEX ONEC +c + character*2 relc +c + data zero,one,two/0.0,1.0,2.0/ + data pi/3.14159265358979/,srt2/1.414213562/ +c + data fsc,fscs4 /7.29735e-3,1.331283e-5/ +c +c.....Define bd for non relativistic calculation +c + do i = 1, rdx_ + bd(i) = cmplx(fscs4,0.0) + enddo + +C + onec = (1.0,0.0) + if(e.eq.0.0) e = 1.0e-8 + ns=(nns-1)*ndat +C + do 5 j=1,ndim + atmnr(j)=(0.00,0.00) + atmsr(j)=(0.00,0.00) + atmsop(j)=(0.00,0.00) + 5 atmsoa(j)=(0.00,0.00) +c +c write(70,*) ' non relativistic stmat and phase shifts ' +c write(80,*) ' scalar relativistic stmat and phase shifts ' +c write(90,*) ' spin-orbit stmat and phase shifts ' +c +c calculate t-matrix elements: +c stmat: inverse t-m elements (atomic spheres) +c ramf: for normalization of ps(k) functions +c +c write(19,18) e, xe + write(81,*) ' e, vcon, xe, relc =', e, real(vcon), + & real(xe), relc +c write(84,*) ' e, vcon, xe =', e, vcon, xe +c 18 FORMAT(' E =', F10.5,5X,' XE =',2F10.5,' GAMMA =',F10.5) +c + do 60 na=1,nuatom + write(35,77) na + write(70,77) na + write(80,77) na + write(90,77) na + ns=ns+1 + 25 nt0a=n0(na) + ntxa=nt0a+nterms(na)-1 + if (na.eq.nas) then + nstart=nt0a + nlast=ntxa + endif + l=-1 + nlat=-1 + arg=xe*rs(na) + ml=lmaxn(na)+1 + if (ml.lt.3) ml = 3 + call csbf(arg,xe,ml,sbf,dsbf) + call cshf2(arg,xe,ml,shf,dshf) + npabs = 0 +C + 43 do 45 nn=nt0a,ntxa + + l=ln(nn) + nlat=nlat+1 + npabs=npabs+1 + if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss + if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45 + np=npabs +C +c if(relc.eq.'nr') then +c + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + y0(l) = dcmplx(rx1**(l+1),0.d0) + y1(l) = dcmplx(rx2**(l+1),0.d0) +c + call pgenll1m(l, e, hx(na), rx(1,na), vx(1,ns), bd, + & kmx(na), kplx(na), rs(na), px(1,np), psx(nn), + & dpsx(nn), ramf00, stmat, y0(l),y1(l)) +c + atmnr(nn)=stmat + ramfx(nn)=ramf00 + ramfnr(nn) = ramf00 + + write(70,1000) xe/0.52917715, stmat + if(relc.eq.'nr') write(35,1000) xe/0.52917715, stmat +c definition of stmat as exp(-i*delta)*sin(delta) + phase=sign(-1.,real(stmat))* + 1 asin(sqrt(abs(aimag(stmat)))) + if(phase.lt.0.0) phase=phase+3.1415926 + write(71,1001)e,xe,na,nlat,stmat,phase + 1001 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3, + & 2x,2e12.6,f10.5,2x,2e12.6,f10.5) + 1000 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6,5x,e12.6,5x,e12.6) +c 1000 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9,5x,f12.9,5x,f12.9) + +c +c elseif(relc.eq.'sr') then +c + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + expr = 0.5d0 + sqrt( dfloat(l*(l+1)) +1 - dble(fsc*z(na))**2 ) + y0(l) = dcmplx(rx1**expr,0.d0) + y1(l) = dcmplx(rx2**expr,0.d0) + call pgenll1m(l, e, hx(na), rx(1,na), vxr(1,ns), bx(1,ns), + & kmx(na), kplx(na), rs(na), px0(1,np), ps0(nn), + & dps0(nn), ramf00, stmat0, y0(l),y1(l)) +c + if(calctype.eq.'els'.or.calctype.eq.'e2e') then + do k = 1, kmx(na) + if(nks.eq.1) p1(k,l+1,na) = px0(k,np) !npabs = np + if(nks.eq.2) p2(k,l+1,na) = px0(k,np) + if(nks.eq.3) p3(k,l+1,na) = px0(k,np) + enddo + if(nks.eq.1) ramfsr1(l+1,na) = ramf00 + if(nks.eq.2) ramfsr2(l+1,na) = ramf00 + if(nks.eq.3) ramfsr3(l+1,na) = ramf00 + endif +c + atmsr(nn)=stmat0 + ramfsr(nn)=ramf00 + + write(80,1000) xe/0.52917715, stmat0 + if(relc.eq.'sr') write(35,1000) xe/0.52917715, stmat0 +C +c definition of stmat as exp(-i*delta)*sin(delta) +C + phase=sign(-1.,real(stmat0))* + 1 asin(sqrt(abs(aimag(stmat0)))) + if(phase.lt.0.0) phase=phase+3.1415926 + write(81,1001)e,xe,na,nlat,stmat,phase +c +c elseif(relc.eq.'so') then +c + ilm = 2 + if(l.eq.0) ilm = 1 + do il = 1, ilm +c + if(il.eq.1) then + do i = 1, kmx(na) + vxp(i) = vxr(i,ns) + float(l)*vxso(i,ns) + enddo + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + expr = 0.5d0 + sqrt( dfloat(l+1)**2 -dble(fsc*z(na))**2 ) + y0(l) = dcmplx(rx1**expr,0.d0) + y1(l) = dcmplx(rx2**expr,0.d0) + call pgenll1m(l, e, hx(na), rx(1,na), vxp, bx(1,ns), + & kmx(na), kplx(na), rs(na), ppx(1,np), + & ps1(nn), dps1(nn), ramf01, stmat1, + & y0(l),y1(l)) + if(na.eq.nas) + & write(81,1) 'rp', na, l, real(stmat1), 1.0/stmat1, + & real(ramf01), e + else + do i = 1, kmx(na) + vxa(i) = vxr(i,ns) - float(l+1)*vxso(i,ns) + enddo + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + expr = 0.5d0 + sqrt( dfloat(l)**2 - dble(fsc*z(na))**2 ) + if(l.eq.0) expr = 0.5d0 +sqrt( 1.0d0 -dble(fsc*z(na))**2) + y0(l) = dcmplx(rx1**expr,0.d0) + y1(l) = dcmplx(rx2**expr,0.d0) + call pgenll1m(l, e, hx(na), rx(1,na), vxa, bx(1,ns), + & kmx(na), kplx(na), rs(na), pax(1,np), + & ps2(nn), dps2(nn), ramf02, stmat2, + & y0(l),y1(l)) +c + endif +c + enddo +c +c + atmsop(nn)=stmat1 + ramfsop(nn)=ramf01 + atmsoa(nn)=stmat2 + ramfsoa(nn)=ramf02 + + write(90,1000) xe/0.52917715, stmat1, stmat2 + if(relc.eq.'so') write(35,1000) xe/0.52917715, stmat1, stmat2 +C +c definition of stmat as exp(-i*delta)*sin(delta) +C + phase1=sign(-1.,real(stmat1))* + 1 asin(sqrt(abs(aimag(stmat1)))) + phase2=sign(-1.,real(stmat2))* + 1 asin(sqrt(abs(aimag(stmat2)))) + if(phase.lt.0.0) phase=phase+3.1415926 + write(91,1001)e,xe,na,nlat,stmat1,phase1,stmat2,phase2 +c + +c endif +1 format(a3,2i5,10e13.5) +30 format(5i3,8e13.5) +c +c + 45 continue + 60 continue +c + 77 FORMAT('-------------------------- ATOM ',I3, + 1 ' -----------------------') +c +c +c calculate singular solution inside muffin tin sphere for the absorbing +c atom, matching to shf in interstitial region +c + if(calctype.eq.'els'.and.nks.eq.3) + & write(6,*)' store irregular solution' + 90 nl=0 + lmsing=5 + mout=4 + nst=n0(nas) + nlst=n0(nas)+nterms(nas)-1 +c if(nks.eq.3) write(6,*)' nst =',nst,' nlst =',nlst + l=-1 + ml=lmaxn(nas)+1 + if (ml.lt.3) ml = 3 + kpp = kmx(nas) -2 + arg=xe*rx(kpp,nas) + call cshf2(arg,xe,ml,sbfx,dsbfx) + arg1=xe*rx(kpp-1,nas) + call cshf2(arg1,xe,ml,shfx,dshfx) +c + do n=nst,nlst + l=ln(n) + if(l.gt.lmsing) cycle + nl=nl+1 + np=npss+nl + np1=nl +c + pkmx = cmplx(sbfx(l+1))*arg/pi + pkmx1 = cmplx(shfx(l+1))*arg1/pi +c + call pgenll2( l, e, hx(nas), rx(1,nas), vx(1,nas), bd, + & kpp, px(1,np), pkmx, pkmx1 ) + + call pgenll2( l, e, hx(nas), rx(1,nas), vxr(1,nas), + & bx(1,nas), kpp, px0(1,np), pkmx, pkmx1 ) + + ilm = 2 + if(l.eq.0) ilm = 1 +c + do i = 1, kmx(nas) + vxp(i) = vxr(i,nas) + float(l)*vxso(i,nas) + vxa(i) = vxr(i,nas) - float(l+1)*vxso(i,nas) + enddo +c + do il = 1, ilm + if(il.eq.1) + & call pgenll2( l, e, hx(nas), rx(1,nas), vxp, + & bx(1,nas), kpp, ppx(1,np), pkmx, pkmx1 ) + if(il.eq.2) + & call pgenll2( l, e, hx(nas), rx(1,nas), vxa, + & bx(1,nas), kpp, pax(1,np), pkmx, pkmx1 ) + enddo +c + if(calctype.eq.'els') then + if(nks.eq.2) then + do k = 1, kmx(nas) + p2irreg(k,l+1) = px0(k,np) +c write(6,*) l, rx(k,nas), px0(k,np) + enddo + elseif(nks.eq.3) then + do k = 1, kmx(nas) + p3irreg(k,l+1) = px0(k,np) +c write(6,*) l, rx(k,nas), px0(k,np) + enddo + endif + endif +c + enddo +c +c + return +c + end +c +c + + subroutine pgenll1m(l, en, h, rx, v, b, kmax, kplx, rs, + & p, ps, dps, ramf, stmat, y0, y1 ) +c +c + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf +c + common/param/eftr,gamma,vcon,xe,ev,e,iout + complex vcon,xe,ev +c + common /llm/ alpha, beta +c + complex v(kmax), p(kmax), b(kmax), ps, dps, ramff, ramf, stmat, x + complex*16 y0, y1, pd(kmax) +c + dimension rx(kmax) +c + double precision dfl, a, hd, hsq12, rxi, den, arb2, + & alphad, betad, rlv, amv + complex*16 dvi +c + complex*16 um(0:kmax), vm(0:kmax), + & am(0:kmax), bm(0:kmax) +c +c + data pi/3.141592653589793d0/, fsc/7.29735E-3/ +c +c calculate coefficients um(m) and vm(m). +c inv = .true. : y0 first starting point; y1 last starting point +c inv = .false. : y0, y1 first two starting points at rx(1) and rx(2) +c In this particular case um=/0. +c + + vm(1) = (0.d0,0.d0) + um(1) = (1.d0,0.d0) + am(0) = (0.d0,0.d0) + bm(0) = (0.d0,0.d0) +c + alphad = dble(alpha) + betad = dble(beta) + den = dble(en) + dfl = dble(float(l)) + a = (dfl + 1)*dfl + hd = dble(h) + hsq12 = hd*hd/12.d0 +c + do i = 1, kmax + rxi = dble(rx(i)) + arb2 = (alphad*rxi + betad)**2 + dvi = dcmplx(v(i)) + am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a - + & betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 + bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) + enddo + + do i = 2, kmax-1 + vm(i) = am(i+1) / ( bm(i) - am(i-1)*vm(i-1) ) + enddo + + do i = 2, kmax + um(i) = um(i-1)*am(i-1) / ( bm(i) - am(i-1)*vm(i-1) ) + enddo +c + pd(1) = y0 * sqrt( alphad + betad/dble(rx(1)) ) + pd(2) = y1 * sqrt( alphad + betad/dble(rx(2)) ) + do i = 2, kmax - 1 + pd(i+1) = (pd(i) - um(i)*pd(1))/vm(i) + enddo +c + do i = 1, kmax + pd(i) = pd(i)*sqrt(dble(rx(i))/(alphad*dble(rx(i))+betad) ) * + & dble(fsc)/2.0D0 /sqrt(dcmplx(b(i)))/ dble(rx(i)) + p(i) = cmplx(pd(i)) + enddo +c + kplx3 = kplx - 3 + call interp(rx(kplx3),p(kplx3),7,rs,ps,dps,.true.) +c + x=dps/ps + ramff=cmplx(sbf(l+1))*x-cmplx(dsbf(l+1)) +c stmat=(shf(l+1)*x-dshf(l+1))/ramff + stmat=ramff/(cmplx(shf(l+1))*x-cmplx(dshf(l+1))) + ramf=ramff*ps*rs*rs*pi + ramf=ramf*xe/pi +c +c + return + end +c +c + subroutine pgenll2( l, en, h, rx, v, b, kmax, p, pkmx, pkmx1 ) +c +c This subroutine for inward integration toward the origin +c + common /llm/ alpha, beta +c + complex v(kmax), p(kmax), b(kmax), pkmx, pkmx1 + dimension rx(kmax) +c + double precision dfl, a, hd, hsq12, rxi, den, arb2, + & alphad, betad +c + complex*16 um(0:kmax), vm(0:kmax), am(0:kmax), bm(0:kmax) + complex*16 dvi, dnm +c + data pi/3.14159265/, fsc/7.29735E-3/ +c +c calculate coefficients um(m) and vm(m). +c + + vm(kmax) = (0.d0,0.d0) + um(kmax) = dcmplx(pkmx*sqrt( alpha + beta/rx(kmax) )) + + alphad = dble(alpha) + betad = dble(beta) + den = dble(en) + dfl = dble(float(l)) + a = (dfl + 1)*dfl + hd = dble(h) + hsq12 = hd*hd/12.d0 +c + do i = 1, kmax + rxi = dble(rx(i)) + arb2 = (alphad*rxi + betad)**2 + dvi = dcmplx(v(i)) + am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a - + & betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 + bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) + enddo + + do i = kmax-1, 2, -1 + dnm = ( bm(i) - am(i+1)*vm(i+1) ) + vm(i) = am(i-1) / dnm + um(i) = am(i+1) * um(i+1) / dnm +c write(6,*) vm(i), um(i) + enddo + + + p(kmax) = pkmx * sqrt( alpha + beta/rx(kmax) ) + p(kmax-1) = pkmx1 * sqrt( alpha + beta/rx(kmax-1) ) + + do i = kmax-1, 2, -1 + p(i-1) = ( p(i) - cmplx(um(i))) / cmplx(vm(i)) + enddo + + do i = 1, kmax + p(i) = p(i) * sqrt( rx(i)/(alpha*rx(i) + beta) ) * + & fsc/2.0 /sqrt(b(i))/ rx(i) + enddo + + return + end +c +C + subroutine get_edge_gap(iz,ihole,i_radial,xion,eatom) +c +c + implicit real*8(a-h,o-z) +c +c + parameter ( mp = 251, ms = 30 ) +c + character*40 title +c + common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy +c + dimension dum1(mp), dum2(mp) + dimension vcoul(mp), rho0(mp), enp(ms) +c + title = ' ' +c + ifr=1 + iprint=0 +C + amass=0.0d0 + beta=0.0d0 +c + call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, + 1 vcoul, rho0, dum1, dum2, enp, eatom) +c + return + end +C +C + subroutine calc_edge(cip) + implicit real*8 (a-h,o-z) + real*4 cip +c + include 'msxas3.inc' + include 'msxasc3.inc' +c + dimension etot(2) +c +c.....Find out ionization potential for chosen edge +c + xion=0.0d0 !corrected 23 June 2017 + iz = nz(1) + ihole1 = 0 +c + if(edge.eq.'k ') ihole2 = 1 + if(edge.eq.'l1') ihole2 = 2 + if(edge.eq.'l2') ihole2 = 3 + if(edge.eq.'l3') ihole2 = 4 + if(edge.eq.'m1') ihole2 = 5 + if(edge.eq.'m2') ihole2 = 6 + if(edge.eq.'m3') ihole2 = 7 + if(edge.eq.'m4') ihole2 = 8 + if(edge.eq.'m5') ihole2 = 9 + if(edge.eq.'n2') ihole2 = 11 + if(edge.eq.'n3') ihole2 = 12 + if(edge.eq.'n4') ihole2 = 13 + if(edge.eq.'n5') ihole2 = 14 + if(edge.eq.'n6') ihole2 = 15 + if(edge.eq.'n7') ihole2 = 16 +c + write(6,*) ' ---' + do i = 1, 2 +c + ityhole = ihole1 +c if(i.eq.2) ityhole = ihole2 ----- corrected 23th June 2017 + if(i.eq.2) then + ityhole = ihole2 + xion = 1.0d0 + endif +c + if(i.eq.1) write(6,*) ' total energy for atom in ground state ' + if(i.eq.2) write(6,*) ' total energy for atom with a hole in ', + & edge, ' edge' +c + + call get_edge_gap(iz,ityhole,ityhole,xion,etot(i)) +c + enddo +c + cip = real(etot(2) - etot(1))*2.0 + cip = sign(cip,1.0) + write(6,*) ' calculated ionization energy for edge ', edge, + & ' = ', cip*13.6, ' eV' +c +c.....Find out energy distance between edges and construct two edge +c dipole cross section +c + xion=1.0d0 +c + if(edge.eq.'k '.or.edge.eq.'l1'.or.edge.eq.'m1'.or.edge.eq.'n1') + & go to 15 + if(edge.eq.'l2'.or.edge.eq.'l3') then + ihole1 = 3 + ihole2 = 4 + else if(edge.eq.'m2'.or.edge.eq.'m3') then + ihole1 = 6 + ihole2 = 7 + else if(edge.eq.'m4'.or.edge.eq.'m5') then + ihole1 = 8 + ihole2 = 9 + else if(edge.eq.'n2'.or.edge.eq.'n3') then + ihole1 = 11 + ihole2 = 12 + else if(edge.eq.'n4'.or.edge.eq.'n5') then + ihole1 = 13 + ihole2 = 14 + else if(edge.eq.'n6'.or.edge.eq.'n7') then + ihole1 = 15 + ihole2 = 16 + endif +c + do i = 1, 2 + + ityhole = ihole1 + if(i.eq.2) ityhole = ihole2 +c + call get_edge_gap(iz,ityhole,ityhole,xion,etot(i)) +c + enddo +c + detot = (etot(1) - etot(2))*2.0d0 + detot = sign(detot,1.0d0) + if(edge.eq.'l2'.or.edge.eq.'l3') then + write(6,*) ' energy distance between edges l2 and l3 = ', + & real( etot(1) - etot(2) )* 27.2, 'eV' + elseif(edge.eq.'m2'.or.edge.eq.'m3') then + write(6,*) ' energy distance between edges m2 and m3 = ', + & real( etot(1) - etot(2) )* 27.2, 'eV' + elseif(edge.eq.'m4'.or.edge.eq.'m5') then + write(6,*) ' energy distance between edges m4 and m5 = ', + & real( etot(1) - etot(2) )* 27.2, 'eV' + endif +c +15 continue +c + write(6,*) ' ---' +c + end +C +C + SUBROUTINE RADIALX(NE,RELC,EIKAPPR) + INCLUDE 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +c.....this subroutine calculates the radial matrix elements d(i) +c.....(i=1,2) for lfin=l0i-1 (i=1) and lfin=l0i+1 (i=2) both for +c.....the regular (dmxx) and irregular solution (dmxx1) using a +c.....linear-log mesh +c + common/mtxele/ nstart,nlast +c + common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), + & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), + & dxxdir,dxxexc + complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, + & dxxdir,dxxexc +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe + character*8 nsymbl,name0 +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf +C + COMMON /LLM/ ALPHA, BETA +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +C COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_) +C COMPLEX PX,DPX,PSX,DPSX,RAMFX +c + COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), + & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), + & RAMFSOA(N_) + COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA +c +C + COMMON/PDQIX/RPIX(RDX_), FNISX + COMPLEX RPIX +C + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +C +c ######### common pottype modified to consider also the Auger calcu +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode +c + common/auger/calctype,expmode,edge1,edge2 +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda + complex qtc, arg, ydf, scprod +c + character*3 calctype, expmode, eikappr + character*2 edge1,edge2 +C + common /lparam/lmax2(nat_),l0i +c + DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_) + COMPLEX RID,CRI,CRI1,DX,DX1,SMX0,SMX1 +C + CHARACTER*2 RELC +C +C +c*************************************************************************** +c note that here rpix(k) = r**3*pi(k). +c wf rpix(k) is already normalized +c (see subroutine corewf) +c*************************************************************************** +c + pi = 3.1415926 +c + id = 1 + nq = nas + kx = kmx(nq) - 3 + dh = hx(nq) +c + write(6,*)' check orthogonality between core and continuum', + & ' state' + np = l0i + 1 + do k = 1, kx + if(relc.eq.'nr') + & rid(k)=rpix(k)*px(k,np+1)/(alpha*rx(k,nq) + beta) + if(relc.eq.'sr') + & rid(k)=rpix(k)*px0(k,np+1)/(alpha*rx(k,nq) + beta) + enddo + call defint1(rid,dh,kx,scprod,id) + write(6,*)' scalar product between core and continuum', + & ' state =', scprod/ramfsr(nstart+np) !*sqrt(xe/pi) + write(6,*) ' sqrt(xe/pi) =', sqrt(xe/pi) +c + if((calctype.eq.'els'.or.calctype.eq.'e2e') + & .and.eikappr.eq.'yes') then + ydf=(0.0,0.0) + qtc = cmplx(qt,0.0) + ml=lmxne(nq,ne)+1 + if (ml.lt.3) ml = 3 + do np = 0, ml-1 + do k = 1, kx + arg=qtc*rx(k,nq) + call csbf(arg,ydf,ml,sbf,dsbf) + if(relc.eq.'nr') + & rid(k)=rpix(k)*px(k,np+1)*cmplx(sbf(np+1))/ + 1 (alpha*rx(k,nq) + beta) + if(relc.eq.'sr') + & rid(k)=rpix(k)*px0(k,np+1)*cmplx(sbf(np+1))/ + 1 (alpha*rx(k,nq) + beta) + enddo +c call defint1(rid,dh,kx,eelsme(np+1),id) +c eelsme(np+1) = (eelsme(np+1)/ramfsr(nstart+np))**2*xe/pi +c write(6,*) 'l =',np,'eelsme =', eelsme(np+1) +c write(6,*) 'l =',np,'sqrt(eelsme) =', sqrt(eelsme(np+1)) + enddo +c + endif +c +c 21 if(calctype.eq.'xpd'.or.eikappr.eq.' no') then + 21 if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex'.or.eikappr.eq.' no') then +c + do 100 i=1,2 + dmxx(i)=(0.,0.) + dmxx1(i)=(0.,0.) + if((l0i.eq.0).and.(i.eq.1))goto 100 + np = l0i + (-1)**i +C + if(relc.eq.'nr') then +c + DO 116 K=1,KX + 116 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXX(I) = (CRI(KX)/RAMFNR(NSTART+NP))**2*(L0I-1+I) +c dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i) + DO 117 K=1,KX + 117 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 118 K=1,KX + 118 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 119 K=1,KX + 119 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFNR(NSTART+NP) +c dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np) +c + else if(relc.eq.'sr') then + DO K=1,KX + RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXX(I) = (CRI(KX)/RAMFSR(NSTART+NP))**2*(L0I-1+I) + DO 120 K=1,KX + 120 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 121 K=1,KX + 121 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 122 K=1,KX + 122 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSR(NSTART+NP) +c + else if(relc.eq.'so') then + DO K=1,KX + RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXX(I) = (CRI(KX)/RAMFSOP(NSTART+NP))**2*(L0I-1+I) + DO 123 K=1,KX + 123 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 124 K=1,KX + 124 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 125 K=1,KX + 125 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSOP(NSTART+NP) +C + DO K=1,KX + RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXXA(I) = (CRI(KX)/RAMFSOA(NSTART+NP))**2*(L0I-1+I) + DO 126 K=1,KX + 126 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 127 K=1,KX + 127 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,DX,ID) + DO 128 K=1,KX + 128 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,DX1,ID) + DMXXA1(I) = (DX + DX1)*(L0I-1+I)/RAMFSOA(NSTART+NP) +c + endif + + 100 continue +C +c write(6,*) ' radialx matrix elements from shell li = ', l0i +c write(6,*) (real(dmxx(l)),aimag(dmxx(l)),l=1,2) +c write(6,*) (real(dmxx1(l)),aimag(dmxx1(l)),l=1,2) +C +C.....CALCULATE RADIAL QUADRUPOLAR TRANSITION MATRIX ELEMENT +C + DO K = 1, KX + RPIX(K) = RPIX(K) * RX(K,NQ) + ENDDO +C + M = 0 + DO 200 I=-2,2,2 + M = M + 1 + QMXX(M)=(0.,0.) + QMXX1(M)=(0.,0.) + LF = L0I + I + IF(LF.LE.0) GO TO 200 + NP = L0I + I +C + if(relc.eq.'nr') then +c + DO 216 K=1,KX + 216 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXX(M) = (CRI(KX)/RAMFNR(NSTART+NP))**2 +c dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i) + DO 217 K=1,KX + 217 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 218 K=1,KX + 218 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 219 K=1,KX + 219 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + QMXX1(M) = (SMX0 + SMX1)/RAMFNR(NSTART+NP) +c dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np) +c + else if(relc.eq.'sr') then + DO K=1,KX + RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXX(M) = (CRI(KX)/RAMFSR(NSTART+NP))**2 + DO 220 K=1,KX + 220 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 221 K=1,KX + 221 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 222 K=1,KX + 222 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + QMXX1(M) = (SMX0 + SMX1)/RAMFSR(NSTART+NP) +c + else if(relc.eq.'so') then + DO K=1,KX + RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXX(M) = (CRI(KX)/RAMFSOP(NSTART+NP))**2 + DO 223 K=1,KX + 223 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 224 K=1,KX + 224 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 225 K=1,KX + 225 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + QMXX1(M) = (SMX0 + SMX1)/RAMFSOP(NSTART+NP) +C + DO K=1,KX + RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXXA(M) = (CRI(KX)/RAMFSOA(NSTART+NP))**2 + DO 226 K=1,KX + 226 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 227 K=1,KX + 227 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,DX,ID) + DO 228 K=1,KX + 228 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,DX1,ID) + QMXXA1(M) = (DX + DX1)/RAMFSOA(NSTART+NP) +c + endif +C + 200 CONTINUE +C +C.....RESET RPI(K) TO INITIAL VALUE +C + DO K = 1, KX + RPIX(K) = RPIX(K) / RX(K,NQ) + ENDDO +C + else !PUT AUGER PART HERE +C + endif +C + RETURN + END +C +C + SUBROUTINE OSBF(X,Y,MAX,SBF,DSBF) +C REAL*8 SBFK,SBF1,SBF2,XF1,PSUM + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR +C FIRST DERIVATIVES WITH RESPECT TO R. X=ARGUMENT= Y*R. +C IF Y=0, NO DERIVATIVES ARE CALCULATED. MAX MUST BE AT LEAST 3. +C OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS. MSBF - MODI- +C FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS; +C MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS +C + DIMENSION SBF(MAX), DSBF(MAX) + LOGICAL ORD + ORD=.TRUE. + GO TO 1 + ENTRY MSBF(X,Y,MAX,SBF,DSBF) + ORD=.FALSE. +1 IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 + IF( ABS(X).LT.0.50D0 ) GO TO 18 +C +C BESSEL FUNCTIONS BY DOWNWARD RECURSION +C + SBF2=0.0D0 + SBF1=1.0D-25 + IF( ABS(X).LT.2.0D0) SBF1=1.0D-38 + JMIN=10+X + KMAX=MAX+JMIN-1 + K=MAX + XF1=2*KMAX+1 + IF (ORD) GO TO 11 + DO 10 J=1,KMAX + SBFK=XF1*SBF1/X+SBF2 + SBF2=SBF1 + SBF1=SBFK + IF (J.LT.JMIN) GO TO 10 + SBF(K)=SBFK + K=K-1 +10 XF1=XF1-2.0D0 + RAT=SINH(X)/(X*SBF(1)) + DSBF1=SBF2*RAT + GO TO 16 +11 CONTINUE + DO 12 J=1,KMAX + SBFK=XF1*SBF1/X-SBF2 + SBF2=SBF1 + SBF1=SBFK + XF1=XF1-2.0D0 + IF (J.LT.JMIN) GO TO 12 + SBF(K)=SBFK + K=K-1 +12 CONTINUE + 15 RAT=SIN(X)/(X*SBF(1)) + DSBF1=-SBF2*RAT + 16 DO 17 K=1,MAX + 17 SBF(K)=RAT*SBF(K) + GO TO 26 +C +C SMALL ARGUMENTS +C + 18 Z=X*X*0.50D0 + IF(ORD) Z=-Z + A=1.0D0 + MMX=MAX + IF (MAX.EQ.1.AND.Y.NE.0.0D0) MMX=2 + DO 30 J=1,MMX + SBFJ=A + B=A + DO 31 I=1,20 + B=B*Z/(I*(2*(J+1)-1)) + SBFJ=SBFJ+B + IF ( ABS(B).LE.1.0D-07* ABS(SBFJ )) GO TO 29 + 31 CONTINUE +29 IF (J.EQ.2) DSBF1=SBFJ + IF (J.LE.MAX) SBF(J)=SBFJ + 30 A=A*X/ DFLOAT(2*J+1) + IF (ORD) DSBF1=-DSBF1 + GO TO 26 + ENTRY OSNF(X,Y,MAX,SBF,DSBF) + ORD=.TRUE. + SBF2=-COS(X)/X + IF (MAX.EQ.1 .AND. Y.EQ.0.0D0) GO TO 2 + SBF1=(SBF2-SIN(X))/X + DSBF1=-SBF1 + GO TO 2 + ENTRY MSNF(X,Y,MAX,SBF,DSBF) + ORD=.FALSE. + SBF2=COSH(X)/X + IF (MAX.EQ.1 .AND. Y.EQ.0.0D0) GO TO 2 + SBF1=(SINH(X)-SBF2)/X + DSBF1= SBF1 + GO TO 2 + ENTRY MSHF(X,Y,MAX,SBF,DSBF) + ORD=.FALSE. + SBF2=EXP(-X)/X + SBF1=-SBF2/X-SBF2 + DSBF1= SBF1 +2 SBF(1)=SBF2 + IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 + IF (MAX.EQ.1) GO TO 26 + SBF(2)=SBF1 + IF (MAX.EQ.2) GO TO 26 + XF1=3.0D0 + IF (ORD) GO TO 21 + DO 8 I=3,MAX + SBFK=SBF2-XF1*SBF1/X + SBF(I)=SBFK + SBF2=SBF1 + SBF1=SBFK +8 XF1=XF1+2.0D0 + GO TO 26 +21 DO 22 I=3,MAX + SBFK=XF1*SBF1/X-SBF2 + SBF(I)=SBFK + SBF2=SBF1 + SBF1=SBFK +22 XF1=XF1+2.0D0 +26 IF (Y.EQ.0.0D0) RETURN + DSBF(1)=Y*DSBF1 + IF (MAX.EQ.1) RETURN + DO 9 I=2,MAX + 9 DSBF(I)=Y*(SBF(I-1)- DFLOAT(I)*SBF(I)/X) + RETURN +99 WRITE(6,100) MAX +100 FORMAT (' SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8) + + STOP 2013 +C + END +C + diff --git a/src/msspec/phagen/fortran/phagen_scf.f.orig b/src/msspec/phagen/fortran/phagen_scf.f.orig new file mode 100644 index 0000000..7dc6b54 --- /dev/null +++ b/src/msspec/phagen/fortran/phagen_scf.f.orig @@ -0,0 +1,14913 @@ + program phagen + +c .................................... +C .. .. +c .. Generates atomic phase shifts .. +c .. for inequivalent atoms in a .. +c .. given cluster. Prototypical .. +c .. atoms selected automatically. .. +c .. Muffin-tin radii and type of .. +c .. final state potential selected .. +c .. via input option .. +C .. .. +c .. By C.R. Natoli 15/10/93 .. +C .. .. +c .. This version can handle ES .. +c .. ES = Empty Spheres 28/09/2007 .. +C .. .. +C .. Scalar-relativistic version .. +C .. with spin-orbit selection .. +C .. by C.R. Natoli 9 june 2011 .. +C .. .. +C .................................... +c .................................... +C +c .. INCOMING WAVE BOUNDARY CONDITIONS +c +C .................................... +C +C bug corrected in subroutine +C GET_CORE_STATE +C (FDP 18th May 2006) +C +C bug corrected in subroutine +C ALPHA0 (DS : 7th May 2007) +C 2nd dimension r: 150 ---> UA_ +C +C LEED case (calctype = 'led') +C added (DS : 30th May 2007). +C +C bug corrected in subroutine +C SETEQS (DS+CRN 30th May 2007) : +C z_shift=5.0 and i_z_shift=5 +C instead of 0.0 and 0. +C +C bug corrected in subroutines +C MOLDAT,GRPNEI,WRIDAT : +C NEIMAX set to nat_ instead +C of 350 in PARAMETER statement +C (FDP+DS 4th June 2007) +C +C all error output redirected to +C unit 6 (DS 4th March 2008). +C +C modified to handle high Z elements +C (CRN : september 2008) +C +C cleaned : DS 17th November 2008 +C +C modified to impose lmaxt externally +C (CRN : july 2009) +C +C modified to include quadrupole +C radial matrix elements +C (CRN : june 2012) +C +C File formats for radial integrals +C modified (DS 8th january 2013) +C +C modified to introduce t-matrix +C calculation in the eikonal approximation +C (CRN : march 2013) +C +C bug corrected in routine linlogmesh: rhon ---> r_sub +C (CRN : april 2013) +C +C modified to calculate tmatrix, radial integrals +C and atomic cross sections on linearlog mesh +C (CRN: september 2012 and april 2013) +C +C bug corrected in routine pgenll2: complex*16 dnm. +C v potential converted to complex*16 in routines +C pgenll1m and pgenll2 +C (CRN: april 2013) +C +C bug corrected in the calculation of the total mfp = amfpt +C (CRN: april 2014) +C +C modified to calculate eels regular radial matrix elements +C (CRN: november 2014) +C +C modified to convert energy input data in data3.ms to Ryd +C (CRN: november 2014) +C +C modified to calculate eels and xas/rexs irregular radial matrix elements +C (CRN: juin 2015) +C +C modified to calculate e2e regular radial matrix elements +C (CRN: december 2015) modification in subroutine smtxllm +C statement 13824 +C +C bug corrected in subroutine calc_edge (xion = 0 for ground state) +C (CNR: June 2017) + + implicit real*8 (a-h,o-z) +c + include 'msxas3.inc' + include 'msxasc3.inc' +c +c.. constants +c + antoau = 0.52917715d0 + pi = 3.141592653589793d0 + ev = 13.6058d0 + zero = 0.d0 +c +c.. threshold for linearity +c + thresh = 1.d-4 +c +c.. fortran io units +c + idat = 5 + iwr = 6 + +c iwr = 16 + iwf=32 + iphas = 30 + iedl0 = 31 + iof = 17 +c....................................................... +c open (iwr,file='results.dat',form='formatted',status='unknown') + write(iwr,1000) +c... +c open (idat,file='data/auger.ms',status='old') +c open (iphas,file='phases.dat',status='unknown') +c if (calctype.eq.'xpd') then + call system('mkdir -p div/wf') + call system('mkdir -p plot') + call system('mkdir -p tl') + + open (iphas,file='div/phases.dat',form='formatted', + 1 status='unknown') + open (iedl0,file='div/exdl0.dat',form='unformatted', + 1 status='unknown') + open (iof,file='div/inf.xas',form='unformatted',status='unknown') +c open (iwr,file='phagen_3.lis',status='unknown') + + open (unit=21,form='unformatted',status='scratch') + open (60,file='div/file060.dat',form='formatted',status='unknown') + open (50,file='div/filerme.dat',form='formatted', + 1 status='unknown') +c open (56,file='div/eelsrme.dat',form='formatted', +c 1 status='unknown') + open (unit=13,file='div/filepot.dat',form='formatted', + 1 status='unknown') + open (unit=14,file='div/filesym.dat',form='formatted', + 1 status='unknown') + open(unit=11,file='div/fort.11',status='unknown') +c open(unit=56,file='div/nchannels.dat',status='unknown') + open(unit=32,file='div/wf/wf1.dat',status='unknown') + open(unit=33,file='div/wf/wf2.dat',status='unknown') + open(unit=66,file='div/file066',status='unknown') +c open(unit=15,file='div/vrel.dat',status='unknown') !in sub vrel +c open(unit=34,file='wf3.dat',status='unknown') + open(unit=70,file='div/tl-nr.dat',status='unknown') + open(unit=71,file='div/phases-nr.dat',status='unknown') +c + open(unit=80,file='div/tl-sr.dat',status='unknown') + open(unit=81,file='div/phases-sr.dat',status='unknown') +c + open(unit=90,file='div/tl-so.dat',status='unknown') + open(unit=91,file='div/phases-so.dat',status='unknown') +C +C Storage of old t_l calculation (subroutine smtx) for reference +C + open(unit=95,file='div/tl_ref.dat',status='unknown') +c + open(unit=98,file='div/cshsm.dat',status='unknown') +c + open(unit=99,file='div/csllm.dat',status='unknown') +c open(unit=69,file='check.log',status='unknown') +c else + +c open(iphas,file='phasesaed.dat',form='formatted',status='unknown' +c open (iwf,file='wfaed.dat',form='formatted',status='unknown') +c open(iedl0,file='exdl0aed.dat',form='unformatted', +c * status='unknown') +c open (iof,file='infaed.xas',form='unformatted',status='unknown') + + +c open (iwr,file='phagen_12aed.lis',status='unknown') +c write(iwr,*)'ciao' + +c open (unit=21,form='unformatted',status='scratch') +c open (60,file='file060aed.dat',form='formatted',status='unknown') +c open (50,file='fileatcsaed.dat',form='formatted',status='unknown' +c open (unit=13,file='filepotaed.dat',form='formatted', +c 1 status='unknown') +c open (unit=14,file='filesymaed.dat',form='formatted', +c 1 status='unknown') +c open(unit=11,file='fortaed.11',status='unknown') +c open(unit=32,file='wf1aed.dat',status='unknown') +c open(unit=33,file='wf2aed.dat',status='unknown') +c open(unit=66,file='fortaed.66',status='unknown') +c open(unit=34,file='wf3aed.dat',status='unknown') +c open(unit=35,file='tlaedmio3.dat',status='unknown') +c open(unit=55,file='radaedmio3.dat',status='unknown') + +c endif +c + rewind idat + rewind iwf + rewind iphas + rewind iedl0 + rewind iof +c +c read control cards +c + call inctrl +c +c read title cards +c + call intit(iof) +c +c read atomic coordinates cards (internal or cartesian) +c + call incoor +c +c compute atomic phase shifts if required +c + call calphas +c +c normal end +c + write(iwr,1100) +c +c.. +c close(69) + close(70) + close(71) + close(80) + close(81) + close(90) + close(91) + close(21) + close(60) + close(13) + close(14) + close(15) + close(7) + close(50) + close(56) + close(35) + close(iwf) + close(iphas) +c + 1000 format(1x,65('_'),//,31x,'PHAGEN',/,1x,65('_'),/) + 1100 format(//,15x,' ** phagen terminated normally ** ',//) +c + end +c + subroutine inctrl + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + real*4 emin,emax,delta,cip,gamma,eftri,db + common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c + common/typot/ ipot +c +c I define the shells and orbitals of the primary core hole, and the +c two holes in the final state: +c + character shell,shell1,shell2,orbital1,orbital,orbital2 +c................................................................ + namelist/job/edge,edge1,edge2,l2h,potype,norman,absorber,coor, + $ emin,emax,delta,gamma,eftri,cip,vc0,rs0,vinput,eikappr,rsh,db, + $ lmaxt,ovlpfac,ionzst,charelx,calctype,potgen,lmax_mode,relc, + $ einc,esct,scangl,optrsh,enunit,lambda,expmode +c +c initialize namelist +c + vinput = .false. + potype='hedin' + potgen='in' + cip=0.0 + relc='nr' + eikappr=' no' + coor='angs' + edge='k' + edge1='k' + edge2='k' + lmaxt=60 + lmax_mode=2 + l2h=0 + absorber = 1 + charelx = 'ex' + norman = 'stdcrm' + ovlpfac=0.d0 + ionzst='neutral' +c mode = 0 + calctype='xpd' + expmode='cis' + optrsh='n' + enunit='Ryd' +c + vc0 = -0.7d0 + rs0 = 3.d0 +c + emin = 0.5 + emax = 40.0 + delta= 0.05 + gamma= 0.0 + eftri= 0.0 + rsh = 0.0d0 !used as a flag; set below to default in au + db = 0.01 +c +c data initialization for calctype='els' or 'e2e' +c if(calctype.eq.'els'.or.calctype.eq.'e2e') then +c + einc= 1200.0 + esct= 1000.0 + scangl= 7.0/180.0*3.1415926 + lambda = 0.0 !used as a flag; set below to default in au +c endif +c +c.....definition of lmax_mode: +c..... lmax_mode = 0: lmaxn(na)=lmax_, independent of energy and atom number +c..... lmax_mode = 1: lmaxn(na)= km*rs(na)+1, where km=(emax)^{1/2} +c..... lmax_mode = 2: lmaxn(na)= ke*rs(na)+1, where ke=(e)^{1/2}, where +c..... e is the running energy +c +c.. read control cards in namelist &job +c + read(idat,job) + read(idat,*) +c +c.....convert lengths in au if coor='angs'. Coordinates will be converted +c in subroutine inoor + if(coor.eq.'angs'.and.lambda.ne.0) then + lambda = lambda/real(antoau) + else + lambda = 20.0 ! in au corresponding to kappa = 0.05 (see subroutine cont) + endif +c + if(coor.eq.'angs'.and.rsh.ne.0) then + rsh = rsh/antoau + else + rsh = 1.0d0 ! in au + endif +c.....convert all energies to Ryd (when they are inputed in eV) +c + if(enunit.eq.' ev') then +c vc0 = vc0/ev +c + cip = cip/real(ev) + emin = emin/real(ev) + emax = emax/real(ev) + delta= delta/real(ev) + gamma= gamma/real(ev) + eftri= eftri/real(ev) + einc= einc/real(ev) + esct= esct/real(ev) + endif +c + if(lmax_mode.gt.2) then + write(iwr,*) 'lmax_mode should be less than 3' + call exit + endif +c + if(calctype.eq.'els') then + lmax_mode = 2 + einl = dble(einc - esct - cip) + if(cip.ne.0.0.and.einl.lt.0.0d0) then + write(6,*)' unable to excite chosen edge:', + & ' einc - esct - cip less than zero =', einl + call exit + endif + endif +c + if(calctype.eq.'led') charelx = 'gs' + if ((calctype.eq.'xpd').or.(calctype.eq.'led').or. + & (calctype.eq.'els')) then +c + write(iwr,1000) calctype + write(iwr,1001) + if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex'.or.calctype.eq.'els') write(iwr,1005)edge + write(iwr,1010)potype,norman,absorber + write(iwr,1015)coor,emin,emax + write(iwr,1020)delta,gamma,eftri +c write(iwr,1025)cip,lmax + write(iwr,1038) ionzst +c if (mode.eq.0) write(iwr,1036) + if (potgen.eq.'in') write(iwr,1036) +c if (mode.eq.1) write(iwr,1037) + if (potgen.eq.'ex') write(iwr,1037) + 1000 format(' parameters for this ',a3,' calculation:') + 1001 format(1x,65('-')) + 1005 format(2x,'edge= ',a2) + 1010 format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2) + 1015 format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ', + $ f7.2,' Ry') + 1020 format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2, + $ 2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry') + 1025 format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2) + 1036 format(2x,'final state potential generated internally') + 1037 format(2x,'final state potential read in from extnl file') + 1038 format(2x,'ionization state : ',a7) +c + else +c + write(iwr,10001) calctype + write(iwr,10011) + write(iwr,10051)edge,edge1,edge2 + write(iwr,10101)potype,norman,absorber + write(iwr,10151)coor,emin,emax + write(iwr,10201)delta,gamma,eftri +c write(iwr,10251)cip,lmax + write(iwr,10381) ionzst +c if (mode.eq.0) write(iwa,10361) +c if (mode.eq.1) write(iwa,10371) +10001 format(' parameters for this 'a3,' calculation:') +10011 format(52('-')) +10051 format(2x,'edge= ',a2,2x,'edge1= ',a2,2x,'edge2= ',a2) +10101 format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2) +10151 format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ', + $ f7.2,' Ry') +10201 format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2, + $ 2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry') +10251 format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2) +10381 format(2x,'ionization state :',a7) +c + end if +c +c......check number of energy points +c + kxe = nint((emax-emin)/delta + 1.) + if(kxe.gt.nep_)then + write(6,731) kxe +731 format(//, + & ' increase the dummy dimensioning variable, nep_. ', + & /,' it should be at least equal to: ', i5,/) + call exit + end if +c +c.. set other options and seek for errors +c + ierror=0 +c +c potgen determines whether the potential is generated internally +c by the present program or read in externally +c potype determines which which kind of exchange-correlation potential +c is used +c mode is 0 if the potential is to be computed and 1 if the +c potential is to be read +c iexcpot is defined after the potential type according to +c the values found below +c + mode = 0 + if (potgen.eq.'ex') mode=1 +c + iexcpot = 0 + ipot = 0 +c + if(potype.eq.'xalph')then + iexcpot=1 + else + if(potype.eq.'hedin')then + ipot = 1 + iexcpot=5 + else + if(potype.eq.'dhrel')then + iexcpot=2 + else + if(potype.eq.'dhcmp')then + ipot = 1 + iexcpot=4 + else + if(potype.eq.'hdrel')then + iexcpot=3 + else + if(potype.eq.' lmto') then + iexcpot=6 + else + ierror=1 + endif + endif + endif + endif + endif + endif +c + shell=edge(1:1) + orbital=edge(2:2) +c + if(shell.eq.'k')then + lin=0 + hole=1 + else + if(shell.eq.'l')then + if(orbital.eq.'1') then + lin=0 + hole=2 + else + if(orbital.eq.'2')then + lin=1 + hole=3 + else + if(orbital.eq.'3')then + lin=1 + hole=4 + else + ierror=1 + endif + endif + endif +c + else + if(shell.eq.'m')then + if(orbital.eq.'1')then + lin=0 + hole=5 + else + if(orbital.eq.'2')then + lin=1 + hole=6 + else + if(orbital.eq.'3')then + lin=1 + hole=7 + else + if(orbital.eq.'4')then + lin= 2 + hole=8 + else + if(orbital.eq.'5')then + lin=2 + hole=9 + else + ierror=1 + endif + endif + endif + endif + endif +c + else +c + if(shell.eq.'n')then + if(orbital.eq.'1')then + lin=0 + hole=10 + else + if(orbital.eq.'2')then + lin=1 + hole=11 + else + if(orbital.eq.'3')then + lin=1 + hole=12 + else + if(orbital.eq.'4')then + lin= 2 + hole=13 + else + if(orbital.eq.'5')then + lin=2 + hole=14 + else + if(orbital.eq.'6')then + lin=3 + hole=15 + else + if(orbital.eq.'7')then + lin=3 + hole=16 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + else +c + if(shell.eq.'o')then + if(orbital.eq.'1')then + lin=0 + hole=17 + else + if(orbital.eq.'2')then + lin=1 + hole=18 + else + if(orbital.eq.'3')then + lin=1 + hole=19 + else + if(orbital.eq.'4')then + lin= 2 + hole=20 + else + if(orbital.eq.'5')then + lin=2 + hole=21 + else + if(orbital.eq.'6')then + lin=3 + hole=22 + else + if(orbital.eq.'7')then + lin=3 + hole=23 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + endif + endif + endif + endif + endif +c + + if (calctype.eq.'aed') then +c +c We take the substrings of the final holes in the Auger decay +c + shell1=edge1(1:1) + orbital1=edge1(2:2) + shell2=edge2(1:1) + orbital2=edge2(2:2) +c + if(shell1.eq.'k')then + lin1=0 + hole1=1 + else + if(shell1.eq.'l')then + if(orbital1.eq.'1') then + lin1=0 + hole1=2 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=3 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=4 + else + ierror=1 + endif + endif + endif +c + else +c + if(shell1.eq.'m')then + if(orbital1.eq.'1')then + lin1=0 + hole1=5 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=6 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=7 + else + if(orbital1.eq.'4')then + lin1= 2 + hole1=8 + else + if(orbital1.eq.'5')then + lin1=2 + hole1=9 + else + ierror=1 + endif + endif + endif + endif + endif +c + else +c + if(shell1.eq.'n')then + if(orbital1.eq.'1')then + lin1=0 + hole1=10 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=11 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=12 + else + if(orbital1.eq.'4')then + lin1= 2 + hole1=13 + else + if(orbital1.eq.'5')then + lin1=2 + hole1=14 + else + if(orbital1.eq.'6')then + lin1=3 + hole1=15 + else + if(orbital1.eq.'7')then + lin1=3 + hole1=16 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + else +c + if(shell1.eq.'o')then + if(orbital1.eq.'1')then + lin1=0 + hole1=17 + else + if(orbital1.eq.'2')then + lin1=1 + hole1=18 + else + if(orbital1.eq.'3')then + lin1=1 + hole1=19 + else + if(orbital1.eq.'4')then + lin1= 2 + hole1=20 + else + if(orbital1.eq.'5')then + lin1=2 + hole1=21 + else + if(orbital1.eq.'6')then + lin1=3 + hole1=22 + else + if(orbital1.eq.'7')then + lin1=3 + hole1=23 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + endif + endif + endif + endif + endif +c + if(shell2.eq.'k')then +c + lin2=0 + hole2=1 +c + else +c + if(shell2.eq.'l')then + if(orbital2.eq.'1') then + lin2=0 + hole2=2 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=3 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=4 + else + ierror=1 + endif + endif + endif +c + else +c + if(shell2.eq.'m')then + if(orbital2.eq.'1')then + lin2=0 + hole2=5 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=6 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=7 + else + if(orbital2.eq.'4')then + lin2= 2 + hole2=8 + else + if(orbital2.eq.'5')then + lin2=2 + hole2=9 + else + ierror=1 + endif + endif + endif + endif + endif +c + else +c + if(shell2.eq.'n')then + if(orbital2.eq.'1')then + lin2=0 + hole2=10 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=11 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=12 + else + if(orbital2.eq.'4')then + lin2= 2 + hole2=13 + else + if(orbital2.eq.'5')then + lin2=2 + hole2=14 + else + if(orbital2.eq.'6')then + lin2=3 + hole2=15 + else + if(orbital2.eq.'7')then + lin2=3 + hole2=16 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + else +c + if(shell2.eq.'o')then + if(orbital2.eq.'1')then + lin2=0 + hole2=17 + else + if(orbital2.eq.'2')then + lin2=1 + hole2=18 + else + if(orbital2.eq.'3')then + lin2=1 + hole2=19 + else + if(orbital2.eq.'4')then + lin2= 2 + hole2=20 + else + if(orbital2.eq.'5')then + lin2=2 + hole2=21 + else + if(orbital2.eq.'6')then + lin2=3 + hole2=22 + else + if(orbital2.eq.'7')then + lin2=3 + hole2=23 + else + ierror=1 + endif + endif + endif + endif + endif + endif + endif +c + endif + endif + endif + endif + endif +c + endif +c +c.. stop if errors occurred +c + if(ierror.eq.0)goto 10 +c + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** error in inctrl **' + write(iwr,*)' -> check namelist values' + write(iwr,*) ' ' + write(iwr,*) ' ' +c + stop + 10 continue +c +c.. check dimensions for lmax +c + if(lmaxt.gt.lmax_) then + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** error in inctrl **' + write(iwr,*)' -> check dimensions for lmax_' + write(iwr,*) ' ' + write(iwr,*) ' ' + stop + endif +c + end +c + subroutine intit(iof) +C +c... read title cards until a blank card is encountered +C + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + logical blank + logical line1 + character*1 card(80) +c + write(iwr,1001) + + line1=.true. +c + 1 call incard (idat,card,ierr) + if(ierr.eq.0) goto 3 + if(ierr.eq.1) then + + write(iwr,2000) + + if(ierr.eq.2) then + + write(iwr,2001) + + endif + endif + 2000 format(//,' ** intit : end input -> stop **',//) + 2001 format(//,' ** intit : input error -> stop **',//) + stop + 3 continue +c +c.. write the 1st line of title into iof +c + if (line1) write(iof) (card(j),j=1,79) + line1=.false. + if ( blank(card) ) goto 2 + write(iwr,1000) (card(j),j=1,79) + goto 1 + 2 continue + write(iwr,1001) +1000 format(1x,80a1) +1001 format(/) + end +c + subroutine incard (idat,card,ierr) +c + character*1 card(80) + ierr=0 + do 2 i=1,80 + 2 card(i)=' ' + read(idat,1000,end=9,err=10) (card(i),i=1,80) + return + 9 ierr=1 + return + 10 ierr=2 + return + 1000 format(80a1) + end +c + logical function blank(card) + character*1 card(80) + data iasc/32/ +c +c iasc is the ascii code for ' ' (32) +c here a blank card is a card with ascii codes < 32 +c i.e., control characters are ignored +c + blank=.true. + do 1 i=1,80 + if (ichar(card(i)).gt.iasc) then + blank=.false. + return + endif + 1 continue + end +c + subroutine incoor +c + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + common/lmto/ rdsymbl,tag(nat_) + character*2 tag,tagi + logical rdsymbl +c + if( coor.eq.'au ') write(iwr,2000) + if( coor.eq.'angs') write(iwr,2001) + write(iwr,2002) + i=1 + 1 continue +c + rdsymbl=.false. + read (idat,*,iostat=ios) tagi,nzi + backspace(idat) + if (ios.eq.0) rdsymbl=.true. +c + if (rdsymbl) then +c + if (norman.eq.'stdcrm') then + radi = 0.0d0 + redfi = 0.0d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'stdfac') then + radi = 0.d0 + redfi = 0.8d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'scaled') then + radi = 0.0d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,redfi + endif +c + if (norman.eq.'extrad') then + redfi = 0.0d0 + read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,radi + endif +c + else +c + if (norman.eq.'stdcrm') then + radi = 0.0d0 + redfi = 0.0d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'stdfac') then + radi = 0.d0 + redfi = 0.8d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3 + endif +c + if (norman.eq.'scaled') then + radi = 0.0d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3,redfi + endif +c + if (norman.eq.'extrad') then + redfi = 0.0d0 + read (idat,*,err=2) nzi,ci1,ci2,ci3,radi + endif +c + endif +c + if (nzi.lt.0) goto 2 +c + if (i.gt.natoms) then + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** error in incoor **' + write(iwr,*)' -> too many atoms, ', + 1 'check dimensions' + write(iwr,*) ' ' + write(iwr,*) ' ' + stop + endif +c + nz(i) = nzi + c(i,1) = ci1 + c(i,2) = ci2 + c(i,3) = ci3 + rad(i) = radi + redf(i) = redfi + tag(i) = tagi + if(rdsymbl) then + write (iwr,101) tag(i),nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i) + else + write (iwr,100) nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i) + endif + 100 format(2x,i3,3f10.4,3x,2f7.4) + 101 format(2x,a2,3x,i3,3f10.4,3x,2f7.4) + i=i+1 + goto 1 + 2 nat = i-1 +C print *, 'nat =', nat + write(iwr,2002) + write(iwr,2003) + if(ionzst.eq.' ionic') then + 10 read(idat,*) nzat + if(nzat.lt.0) goto 20 + backspace(idat) + read(idat,*) ndummy,charge_ion(nzat) + goto 10 + endif + 20 continue +c +c.. default units are angtroms, convert to a.u. if necessary +c + if (coor.eq.'au ') return + if (coor.eq.'angs') then + do 3 i=1,nat + if (norman.eq.'extrad') + & rad(i) = rad(i)/antoau + do 3 iz=1,3 + c(i,iz)= c(i,iz) / antoau + 3 continue + return + endif +c + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*)' ** incoor: unit type unknown -> ', + 1 'stop ** ' + write(iwr,*) ' ' + write(iwr,*) ' ' +c + 2000 format(' coordinates in a.u. ',25x,'Radii') + 2001 format(' coordinates in angstroms',25x,'Radii') + 2002 format(1x,65('-')) + 2003 format(/) + stop + end +c + subroutine calphas +c + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c +c + real*4 emin,emax,delta,cip,gamma,eftri,db + common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c + character*8 nsymbl +c +c ######## Modified to introduce the two state wave functions for the +c Auger decay +c ######## let's introduce i_absorber_hole1 and i_absorber_hole2 +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + common/dimens/nats,ndat,nout,lmaxx,irreps +c + common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), + u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), + u lmaxat(natoms), ktau(ua_),natau(neq_,ua_) +c + common/aparms_extra/rs_(natoms),redf_(natoms),ovlf +c +c real*4 emin,emax,delta,cip,gamma,eftri +c + write(iwr,*) ' ** enter calphas **' +c + if(cip.eq.0.0) then +c +c calculate edge ionization potential +c + call calc_edge(cip) + write(6,*) ' calculated ionization potential (ryd) =',cip + else + write(6,*) ' given ionization potential (ryd) =',cip + endif + write(6,*) ' ---' +c +c check consistency of input data in case of calctype = 'els' +c + if(calctype.eq.'els') then + einl = dble(einc - esct - cip) + if(einl.lt.0.0d0) then + write(6,*)' unable to excite chosen edge:', + & ' einc - esct - cip less than zero =', einl + call exit + endif + endif +c +c phase shifts computation +c initializes some variables for symmetry+potential programs +c nat is the total number of physical atoms as read in in +c subroutine incoor and is listed in common/atoms/ +c + nats=nat + i_absorber = absorber + i_absorber_hole = hole +c +c ################## Modified to introduce the two state wave functions +c for the Auger decay +c ################## hole1 is the electron that will go down to fill +c the primary core hole +c + i_absorber_hole1 = hole1 + + + i_absorber_hole2 = hole2 + + + + + + + i_norman = 1 +c if (norman.eq.'extrad') i_norman = 0 + i_mode = mode + do 100 i=2,nat+1 + + nzeq(i) = nz(i-1) + xv(i) = c(i-1,1) + yv(i) = c(i-1,2) + zv(i) = c(i-1,3) + rs_(i)=rad(i-1) + redf_(i)=redf(i-1) + 100 continue + ovlf = ovlpfac +c + write(iwr,*) ' ' + write(iwr,*) ' ' + write(iwr,*) ' symmetrizing coordinates... ' + open (7,file='div/sym.out',status='unknown') + + call xasymfn_sub + + +c +c.....Warning: in subroutine xasymfn_sub nats has been assigned +c.....the value (nat+1) to take into account the outer sphere. +c +c create equivalence table neqat +c i=1 is the outer sphere in xasym programs +c + do 200 i=1,nat + if (neq(i+1).eq.0) then + neqat(i)=i + else + neqat(i)=neq(i+1)-1 + endif + 200 continue +c +c.....Write out atomic coordinates in symmetry-program order: +c each prototypical atom is followed by its sym-equivalent atoms +c +c open (10,file='clus/clus.out',status='unknown') + if( coor.eq.'au ') then + ipha=1 + coef=1.d0 + endif + if( coor.eq.'angs') then + ipha=2 + coef=0.529177d0 + endif + write(10,888) ipha + 888 format(30x,i1) + write(7,10) (neqat(i),i=1,nat) + 10 format (/,16i5,//) +c +c write(7,10) nat, ndat-1 +c + x0 = xv(2) + y0 = yv(2) + z0 = zv(2) +c + no = 0 + do na = 1, ndat-1 + do k = 2, nat+1 + if (neqat(k-1).eq.na) then + no = no + 1 + write(7,20) no,nsymbl(k),nzeq(k),xv(k)-x0, + & yv(k)-y0,zv(k)-z0,neqat(k-1) + write(10,20) no,nsymbl(k),nzeq(k),(xv(k)-x0)*coef, + & (yv(k)-y0)*coef,(zv(k)-z0)*coef,neqat(k-1) + endif + continue + enddo + enddo +c + close(10) +c + 20 format (i5,6x,a4,i5,3f10.4,i5) +c + write(iwr,*) + write(iwr,*)' computing muffin tin potential and phase shifts' + call cont_sub(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db) +c +ctn write(iwr,*)'calphas: neq', (neq(i),i=1,nat+1) +ctn write(iwr,*)'calphas: neqat', (neqat(i),i=1,nat) +c tstop=cputim() +c elapsed=tstop-tstart +c write(iwr,2000)elapsed +c 2000 format(' ** end calphas ** elapsed time ',f10.3,' seconds') + return + end +c +c + subroutine exit +c + write(6,*) ' ' + write(6,*) ' ' + write(6,*)' ** stop via call exit **' + write(6,*) ' ' + write(6,*) ' ' + stop + end +c + subroutine xasymfn_sub +c +c*********************************************************************** +c +c xasymfn: xalpha symmetry function program (version 3, 11 feb 1981) +c +c written by m. cook, 1981. +c +c calls: input(at input,outpot),seteqs,symops,closur,ctable,basfns +c +c*********************************************************************** +c + + implicit real*8 (a-h,o-z) +c include 'mscalc.inc' + include 'msxas3.inc' + integer op_,ord_,two_npr_ + parameter (natm2_=nat_-2,npr_=24,op_=48,ntax_=250, + 1 ir_=14,ib_=28,ord_=8,l_=3,lp1_=4, + 2 nms_=7,nfac_=9,nbf_=nat_*4,ncs_=24) + parameter(two_npr_=2*npr_,npr_p1_=npr_+1) +c + common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, + u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +c +c !flag for reformatted output + common/sym_out/isym_format + + +c +c----- define maximum array dimensions --------------------------------- +c warning : natmx est dans le common +cman data natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, +cman u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +cman u /nat_,ua_,neq_,npr_,two_npr_,npr_p1_, +cman u ord_,ir_,ib_,l_,nbf_,ncs_,ntax_/ +c + data natm2m,nopmax,lp1mx,nmsmx,mxfct + u /natm2_,op_,lp1_,nms_,nfac_/ +cman + natmx = nat_ + ndatmx = ua_ + neqsmx = neq_ + nprmx = npr_ + nopmx = two_npr_ + nimp1 = npr_p1_ + nordmx = ord_ + nirpmx = ir_ + nibmx = ib_ + lbasmx = l_ + nbfmx = nbf_ + ncsmx = ncs_ + ntaxmx = ntax_ + +c +c + if (natm2m.lt.natmx-2) go to 10 + if (nopmax.ne.2*nprmx) go to 20 + if (lp1mx.ne.lbasmx+1) go to 30 + if (nmsmx.ne.2*lbasmx+1) go to 40 + if (mxfct.lt.2*lbasmx+1) go to 50 + if (nordmx.lt.3) go to 60 +c +c----- call major calculational subroutines ---------------------------- +c + + call input_xasymfn + + + call seteqs + call outpot_xasymfn +c + return +c +c----- error prints and stops ------------------------------------------ +c + 10 write (6,500) natm2m + stop + 20 write (6,510) nopmax + stop + 30 write (6,520) lp1mx + stop + 40 write (6,530) nmsmx + stop + 50 write (6,540) mxfct + stop + 60 write (6,550) nordmx + stop +c + 500 format (//,' error stop: natm2m =',i6,' is less than', + u ' natmx-2 : redimension',//) + 510 format (//,' error stop: nopmax =',i6,' is not equal to', + u ' 2*nprmx : redimension',//) + 520 format (//,' error stop: lp1mx =',i6,' is not equal to', + u ' lbasmx+1 : redimension',//) + 530 format (//,' error stop: nmsmx =',i6,' is not equal to', + u ' 2*lbasmx+1 : redimension',//) + 540 format (//,' error stop: mxfct =',i6,' is less than', + u ' 2*lbasmx+1 : redimension',//) + 550 format (//,' error stop: nordmx =',i6,' : must be', + u ' redimensioned to 3 or greater',//) + end +c +c + subroutine input_xasymfn +c +c*********************************************************************** +c +c reads in the molecular geometry information, desired +c l-values, and mode control variables. modes of operation: +c +c iprt=0, rot'n matrices not printed +c iprt=1, rot'n matrices will be printed out from ctable +c +c mdin=0, geometry, nz, neq data all read from card input +c mdin=1, non-sym data read from a molec stpot; sym data from cards +c +c mdou=0, only 1st col of degenerate irreps output to ktape +c mdou=1, all columns of degenerate irreps will be written +c +c mdco=0, single-atom core functions will be generated +c mdco=1, symmetry-adapted core functions will be generated +c +c mdeq=0, calc'd symmetry-eq list (neq) overrides any input neq +c mdeq=1, input list of symmetry-equivalences will be used +c +c if mdin=1, mdeq=1 is automatically enforced by this program +c because the form of the stpot depends on the list of sym-eq ats. +c +c called by: main (at input,outpot) +c +c*********************************************************************** +c + implicit real*8(a-h,o-z) +c include 'mscalc.inc' + include 'msxas3.inc' +c + logical cmplxc,frezeq,inpot,nonint,onecol,symcor + character*8 nsymbl,nsymbl2 + common/aparms_extra/rs(nat_),redf(nat_) + common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_), + u nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_), + u ktau(ua_),natau(neq_,ua_) + common/aparms2/xv2(nat_),yv2(nat_),zv2(nat_),rs2(nat_), + u alpha2(nat_),redf2(nat_),z2(nat_),q2(nat_),qspnt2(2), + u qint2(2), + u watfac(nat_),alpha02,volint2,ovout2,rmxout2,nsymbl2(nat_), + u nz2(nat_),neq2(nat_),kmax2(nat_),kplace2(nat_),ktau2(ua_) + common/lparam/lmax2(nat_),l0i + common/coords/s(3,nat_) + dimension s2(3,nat_) + common/dimens/nat,ndat,nout,lmaxx,irreps + common/dimens2/nat2,ndat2 + common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor + common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, + u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +c !flag for reformatted output + common/sym_out/isym_format +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + +c !generate potential file + common/out_ascii/iout_ascii +c + common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc + logical shift_cc +c + common/lmto/ rdsymbl,tag(nat_) + character*2 tag + logical rdsymbl + + character*2 nameat + dimension nameat(100) +c + DATA NAMEAT/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', + 1 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca', + 1 'Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn', + 1 'Ga','Ge','As','Se','Br','Kr','Rb','Sr',' Y','Zr', + 1 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', + 1 'Sb','Te',' I','Xe','Cs','Ba','La','Ce','Pr','Nd', + 1 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', + 1 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg', + 1 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', + 1 'Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm'/ +c + data thr/0.001d0/ + data zero/0.d0/ + data lunout,lunout2/7,60/ + +c + iprt=0 + mdou=0 + mdco=0 + mdeq=0 + isym_format=0 + +c !nout defined + nout=1 +c !same as nout but global + i_outer_sphere=1 +c + frezeq=.false. + symcor=.false. + onecol=.true. + if (mdeq.eq.1) frezeq=.true. + if (mdco.eq.1) symcor=.true. + if (mdou.eq.1) onecol=.false. +c +c----------------------------------------------------------------------- +c mdin = 0 : only geometry & atomic # data, from card input +c----------------------------------------------------------------------- +c + inpot=.false. +c !nout defined + nout=1 +ctn +ctn Values passed through the subroutines parameters +ctn read (lunin,*) nat,i_absorber,i_absorber_hole,i_norman, +ctn &i_mode +c + nat=nat+i_outer_sphere + if (nout.eq.0) write (lunout,570) nat + if (nout.ne.0) write (lunout,580) nat + if (nat.gt.natmx) go to 140 + write (lunout,530) + + +c + r_sphere=0.0d0 + + + + do 10 na=2,nat + + +ctn read (lunin,*) nsymbl(na),nz(na),xv(na),yv(na),zv(na), +ctn u rs(na),redf(na) +ctn modifs : + + +c nsymbl(na)=nameat(nz(na)) +c......modification for Empty Spheres +c + if(rdsymbl) then + nsymbl(na)=tag(na-1) + else + if(nz(na).eq.0) then + nsymbl(na)='ES' + else + nsymbl(na)=nameat(nz(na)) + endif + endif + z(na)=dfloat(nz(na)) + neq(na)=0 +c !needed to determine point group + lmax(na)=3 + ncores(na)=0 + + + write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na), + u neq(na),lmax(na),ncores(na) + 10 continue +c +c define outer sphere parameters (i. e. atomic center) +c + na=1 + nsymbl(na)='osph' + nz(na)=0 + z(na)=0.0d0 + neq(na)=0 + rs(na)=0.0d0 + redf(na)=0.0d0 +c !needed to determine point group + lmax(na)=3 + ncores(na)=0 +c +c define outer sphere coordinates at center of charge +c + xo=zero + yo=zero + zo=zero + wt=zero + do 910 na1=2,nat + xo=xo+z(na1)*xv(na1) + yo=yo+z(na1)*yv(na1) + zo=zo+z(na1)*zv(na1) + wt=wt+z(na1) + 910 continue + xo=xo/wt + yo=yo/wt + zo=zo/wt + if (dabs(xo).lt.thr) xo=zero + if (dabs(yo).lt.thr) yo=zero + if (dabs(zo).lt.thr) zo=zero + xv(na)=xo + yv(na)=yo + zv(na)=zo +c + if(i_norman.ne.1)then + do 15 na1=2,nat + r_sphere_temp=sqrt((xv(na1)-xv(1))**2+ + u (yv(na1)-yv(1))**2+ + u (zv(na1)-zv(1))**2)+rs(na1) + if(r_sphere.lt.r_sphere_temp)then + r_sphere=r_sphere_temp + end if +15 continue + rs(1)=r_sphere + end if + write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na), + u neq(na),lmax(na),ncores(na) + write (lunout,560) +c +c*** check coordinates of atoms +c + do 1150 na1=1,nat + do 1140 na2=1,na1 + dist =dsqrt((xv(na1)-xv(na2))**2 + u +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 ) + if((na2.gt.1).and.(na1.ne.na2)) then + if(dist.lt.thr)then + write(6,562)na1,na2 + call exit + end if + end if + 1140 continue + 1150 continue +c + return +c +c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c entry outpot_xasymfn +c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c +c----- molecule will usually have been rotated: +c print the new atomic coordinates in standard orientation ------ +c + entry outpot_xasymfn + write (lunout,590) + print 595 + write (lunout,530) + print 535 + nashf=1 +c + + nat2=nat + ndat2=ndat + i_absorber_real=i_absorber+i_outer_sphere +c +c set z on absorbing atom back to original value +c + z(i_absorber_real)=z(i_absorber_real)-z_shift + nz(i_absorber_real)=nz(i_absorber_real)-i_z_shift +c !symmetry distinct atoms + do 70 nda=1,ndat + if(shift_cc)then +c !go back to real cente + s2(1,nashf)=s(1,nashf)-cc_dif(1,1) +c !of charge + s2(2,nashf)=s(2,nashf)-cc_dif(2,1) + s2(3,nashf)=s(3,nashf)-cc_dif(3,1) + if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero + if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero + if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero + else + s2(1,nashf)=s(1,nashf) + s2(2,nashf)=s(2,nashf) + s2(3,nashf)=s(3,nashf) + endif + write (lunout,550) nda,nsymbl(nda),nz(nda), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda), + u lmax(nda),ncores(nda) + print 555, nda,nsymbl(nda),nz(nda), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda) + if(nda.ne.1)write (lunout2,552) s2(1,nashf),s2(2,nashf), + u s2(3,nashf),nsymbl(nda) +c + rs2(nda)=rs(nda) + redf2(nda)=redf(nda) + nsymbl2(nda)=nsymbl(nda) + xv2(nda)=s2(1,nashf) + yv2(nda)=s2(2,nashf) + zv2(nda)=s2(3,nashf) + nz2(nda)=nz(nda) + z2(nda)=z(nda) + neq2(nda)=neq(nda) + ktau2(nda)=ktau(nda) + nashf=nashf+ktau(nda) + 70 continue + nashf=0 + do 90 nda=1,ndat + nashf=nashf+1 + neqs=ktau(nda) + if (neqs.eq.1) go to 90 + do 80 ne=2,neqs +c !equivalent sets + nashf=nashf+1 + na=natau(ne,nda) + if(shift_cc)then +c !go back to real cente + s2(1,nashf)=s(1,nashf)-cc_dif(1,1) +c !of charge + s2(2,nashf)=s(2,nashf)-cc_dif(2,1) + s2(3,nashf)=s(3,nashf)-cc_dif(3,1) + if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero + if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero + if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero + else + s2(1,nashf)=s(1,nashf) + s2(2,nashf)=s(2,nashf) + s2(3,nashf)=s(3,nashf) + endif + write (lunout,550) na,nsymbl(na),nz(na), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na),lmax(na),ncores(na) + print 555, na,nsymbl(na),nz(na), + u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na) + write (lunout2,552) s2(1,nashf),s2(2,nashf),s2(3,nashf), + u nsymbl(na) + rs2(na)=rs(na) + redf2(na)=redf(na) + nsymbl2(na)=nsymbl(na) + xv2(na)=s2(1,nashf) + yv2(na)=s2(2,nashf) + zv2(na)=s2(3,nashf) + nz2(na)=nz(na) + z2(na)=z(na) + neq2(na)=neq(na) + 80 continue + 90 continue + if(nout.eq.1) then + + + z2(1)=1.0d0 + nz2(1)=1 + end if + write (lunout,560) + + return +c +c----- error prints and stops ------------------------------------------ +c + 140 write (6,600) natmx,nat + stop +c + 530 format (t53,'position'/30x,'atom no.',4x,'x',9x,'y',9x,'z',8x, + u 'eq',5x,'lmax',5x,'#cores'/) + 535 format (t35,'position'/12x,'atom no.',4x,'x',9x,'y',9x,'z',8x, + u 'eq'/) + 550 format (26x,i4,2x,a4,i6,3f10.4,i6,i8,i9) + 552 format (3(2x,f10.3),2x,a4) + 555 format (8x,i4,2x,a4,i6,3f10.4,i6) + 560 format (/46x,6('*****')/) + 562 format (//,'error: check coordinates of atoms # ',i4, + & ' and # ',i4,//) + 570 format (//38x,'number of centers=',i5,' no outer sphere'/) + 580 format (//38x,'number of centers=',i5,' outer sphere at ' + u ,'center 1'/) + 590 format (///38x,'molecular orientation for basis fn projection:'/) + 595 format (//14x,' symmetrized atomic coordinates of cluster '/) + 600 format (//' error stop: variable nat is .gt.',i6, + u ' : redimension natmx to',i6,//) + end +c + subroutine seteqs +c +c*********************************************************************** +c +c translates the molecule to the center of nuclear charge +c and tentatively identifies symmetry-equivalent sets of atoms +c on the basis of interatomic distances. +c checks that the atoms are arranged in correct order for +c xascf: nda's first and eq atoms following. if input is from +c a molec starting pot, error stop if order is not correct. if +c input is not from a pot, the atoms will be shuffled into +c the appropriate xascf order at output time. +c note that during the execution of the symmetry program, the +c atoms are not kept in the scf order: they are in sym-program +c order, each nda followed immediately by its sym-eq partners. +c +c called by: main +c +c*********************************************************************** +c + implicit real*8 (a-h,o-z) +c include 'mscalc.inc' + include 'msxas3.inc' + parameter (natm2_=nat_-2) +c + character*8 nsymbl + logical doshuf,equiv,found,match,frezeq + logical cmplxc,inpot,nonint,onecol,symcor + dimension neqt(nat_) + dimension found(natm2_),nbrz(natm2_,nat_),dnbr(natm2_,nat_) + integer trans(nat_) + common/aparms_extra/rs(nat_),redf(nat_) + common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_), + u nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_), + u ktau(ua_),natau(neq_,ua_) + common/coords/s(3,nat_) + common/dimens/nat,ndat,nout,lmaxx,irreps + common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor + common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, + u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + +c + common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc + common/transform/trans + logical shift_cc +c + data zero,thr/0.0d0,0.001d0/ +c + data jtape/21/ + data lunout/7/ +c +c----------------------------------------------------------------------- +c find the center of charge of the nuclear framework and +c translate the molecule to that origin +c----------------------------------------------------------------------- +c !define nuclear charge shift + z_shift=5.0d0 + i_z_shift=5 + shift_cc=.true. +c + xo=zero + yo=zero + zo=zero + wt=zero + nastrt=nout+1 +c !set up to make absorbing atom unique by addin + cc_dif(1,1)=zero +c !z_shift units of charge to its nucleus + cc_dif(2,1)=zero + cc_dif(3,1)=zero + wt_real=zero + + do 5 na=nastrt,nat + cc_dif(1,1)=cc_dif(1,1)+z(na)*xv(na) + cc_dif(2,1)=cc_dif(2,1)+z(na)*yv(na) + cc_dif(3,1)=cc_dif(3,1)+z(na)*zv(na) + wt_real=wt_real+z(na) + 5 continue + cc_dif(1,1)=cc_dif(1,1)/wt_real + cc_dif(2,1)=cc_dif(2,1)/wt_real + cc_dif(3,1)=cc_dif(3,1)/wt_real +c + i_absorber_real=i_absorber+i_outer_sphere +c increase z value of absorbing atom + z(i_absorber_real)=z(i_absorber_real)+z_shift + nz(i_absorber_real)=nz(i_absorber_real)+i_z_shift +c + do 10 na=nastrt,nat + xo=xo+z(na)*xv(na) + yo=yo+z(na)*yv(na) + zo=zo+z(na)*zv(na) + wt=wt+z(na) + 10 continue + xo=xo/wt + yo=yo/wt + zo=zo/wt + if (dabs(xo).lt.thr) xo=zero + if (dabs(yo).lt.thr) yo=zero + if (dabs(zo).lt.thr) zo=zero +c !cc_dif is difference between + cc_dif(1,1)=cc_dif(1,1)-xo +c !real and shifted centers of + cc_dif(2,1)=cc_dif(2,1)-yo +c !charge + cc_dif(3,1)=cc_dif(3,1)-zo + if (dabs(cc_dif(1,1)).lt.thr) cc_dif(1,1)=zero + if (dabs(cc_dif(2,1)).lt.thr) cc_dif(2,1)=zero + if (dabs(cc_dif(3,1)).lt.thr) cc_dif(3,1)=zero + r_dif_cc=sqrt( cc_dif(1,1)*cc_dif(1,1)+cc_dif(2,1)* + u cc_dif(2,1)+cc_dif(3,1)*cc_dif(3,1) )/dsqrt(3.0d0) + if(r_dif_cc.lt.thr)shift_cc=.false. + do 20 na=1,nat + xv(na)=xv(na)-xo + yv(na)=yv(na)-yo + zv(na)=zv(na)-zo + if (dabs(xv(na)).lt.thr) xv(na)=zero + if (dabs(yv(na)).lt.thr) yv(na)=zero + if (dabs(zv(na)).lt.thr) zv(na)=zero + 20 continue +c +c----------------------------------------------------------------------- +c classify sym-eq sets of atoms: two atoms are eqiv +c if they have same number of neighbors of same nz at same distances +c----------------------------------------------------------------------- +c +c----- calculate the distances of each atom from the others ------------ +c + neqt(1)=0 + do 40 na1=nastrt,nat + nabor=0 + neqt(na1)=0 + do 30 na2=nastrt,nat + if (na1.eq.na2) go to 30 + nabor=nabor+1 + nbrz(nabor,na1)=nz(na2) + rab=dsqrt((xv(na1)-xv(na2))**2 + u +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 ) + dnbr(nabor,na1)=rab + 30 continue + 40 continue +c +c----- compare the neighbor charges and distances ---------------------- +c + nabors=nat-(nout+1) + do 90 na1=nastrt,nat + na1p1=na1+1 + if (na1p1.gt.nat) go to 90 + do 80 na2=na1p1,nat + if (nz(na1).ne.nz(na2)) go to 80 + if (neqt(na2).ne.0) go to 80 + do 50 nabor=1,nabors + 50 found(nabor)=.false. + equiv=.true. +c +c----- try to match the neighbors of na1 & na2 one-to-one -------------- +c + do 70 nabor1=1,nabors + nzt= nbrz(nabor1,na1) + rabt=dnbr(nabor1,na1) + match=.false. + do 60 nabor2=1,nabors + if (found(nabor2)) go to 60 + if (nbrz(nabor2,na2).ne.nzt) go to 60 + if (dabs(dnbr(nabor2,na2)-rabt).gt.thr) go to 60 + found(nabor2)=.true. + match=.true. + go to 65 + 60 continue + 65 if (match) go to 70 + equiv=.false. + go to 75 + 70 continue +c +c----- if all nabor2 found and each nabor1 had match=.true., +c na1 and na2 have equivalent sets of neighbors ----------------- +c + 75 if (equiv) neqt(na2)=na1 + 80 continue + 90 continue +c +c----------------------------------------------------------------------- +c compare the calculated and input neq arrays +c----------------------------------------------------------------------- +c + write (lunout,500) + write (lunout,510) (na,neqt(na),na=1,nat) + equiv=.true. + do 100 na=1,nat + if (neqt(na).ne.neq(na)) equiv=.false. + if (.not.frezeq) neq(na)=neqt(na) + 100 continue + if (equiv) write (lunout,520) + if (.not.equiv.and.frezeq) write (lunout,530) + if (.not.equiv.and..not.frezeq) write (lunout,540) +c +c----------------------------------------------------------------------- +c check that the atoms are arranged in the correct scf order: +c all nda's first, then the sym-eq atoms for each nda in same order +c----------------------------------------------------------------------- +c + doshuf=.false. + do 110 na=nastrt,nat + if (neq(na).eq.0.and.neq(na-1).ne.0) doshuf=.true. + if (neq(na).lt.neq(na-1)) doshuf=.true. + 110 continue + if (inpot.and.doshuf) go to 230 +c +c----- if not running from a molecular starting pot, +c shuffle the atoms into xascf order ---------------------------- +c + rewind jtape + nda=0 + do 130 na=1,nat + if (neq(na).gt.0) go to 130 + nda=nda+1 + write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) + write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) + do 120 na2=1,nat + if (neq(na2).eq.na) neq(na2)=nda + 120 continue + 130 continue + ndat=nda + if (ndat.gt.ndatmx) go to 240 + do 150 nda=1,ndat + do 140 na=1,nat + if (neq(na).ne.nda) go to 140 + write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) + write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) + 140 continue + 150 continue + + nda=0 + do 310 i=2,nat + if (neq(i).eq.0) then + nda=nda+1 + trans(i-1)=nda + endif + 310 continue + + + do 320 na=2,ndat + do 325 i=2,nat + if (neq(i).eq.na) then + nda=nda+1 + trans(i-1)=nda + endif + 325 continue + 320 continue + + +c +c----- read the shuffled atomic parameters back in --------------------- +c + rewind jtape + do 160 na=1,nat + read (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) + read (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) + 160 continue + rewind jtape +c +c----------------------------------------------------------------------- +c calculate the final symmetry-equivalence list ( natau ) +c----------------------------------------------------------------------- +c + do 200 nda=1,ndat + neqs=1 + natau(1,nda)=nda + do 190 na=1,nat + if (neq(na).ne.nda) go to 190 + neqs=neqs+1 + if (neqs.gt.neqsmx) go to 250 + natau(neqs,nda)=na + 190 continue + ktau(nda)=neqs + 200 continue + +c +c----------------------------------------------------------------------- +c arrange the atomic x,y,z coords in symmetry-program order: +c each nda is followed immediately by its sym-equivalent atoms +c----------------------------------------------------------------------- +c + nashuf=0 + do 220 nda=1,ndat + neqs=ktau(nda) + do 210 ne=1,neqs + na=natau(ne,nda) + nashuf=nashuf+1 + s(1,nashuf)=xv(na) + s(2,nashuf)=yv(na) + s(3,nashuf)=zv(na) + 210 continue + 220 continue + + return +c +c----- error prints and stops ------------------------------------------ +c + 230 write (6,550) + stop + 240 write (6,560) ndatmx,ndat + stop + 250 write (6,570) neqsmx + stop +c + 500 format (//25x,'calculated atomic symmetry equivalences,'/ + u 30x,'based on interatomic distance matrix:',7x,'na', + u 4x,'neq(na)'/) + 510 format (69x,i7,i8) + 520 format (/t35,'the calculated symmetry-eq sets agree with', + u ' the input'/) + 530 format (/t25,'calculated & input symmetry-eq sets do not', + u ' agree: input sets will be used'/) + 540 format (/t22,'calculated & input symmetry-eq sets do not', + u ' agree: calculated sets will be used'/) + 550 format (//t25,'input molecular pot does not have distinct', + u ' & sym-eq atoms in correct order for input to xascf',//) + 560 format (//' error stop: variable ndat is .gt.',i6, + u ' : redimension ndatmx to',i6,//) + 570 format (//' error stop: variable neqs is .gt.',i6, + u ' : redimension neqsmx',//) + end +c +c + subroutine vgen +c write(6,*) 'check1' + call rhoat +c write(6,*) 'check2' + call molpot +c write(6,*) 'check3' + call inpot +c write(6,*) 'check4' + return + end +c +C*********************************************************************** + SUBROUTINE RHOAT +C*********************************************************************** +C +C MAY-92 +C +C GENERATES ATOMIC CHARGE DENSITY FOR PROTOTYPICAL ATOMS +C +C DICTIONARY : +C NDAT Number of prototypical atoms +C INV Logical unit on which to write the output [8] +C ZAT Atomic number +C MESH Number of radial mesh points [441] +C +C************************************************ + implicit real*8 (a-h,o-z) +c + include 'msxas3.inc' + include 'msxasc3.inc' +c + common/dimens/nats,ndat +c + character*8 nsymbl +c.. + + +c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1 +c *i_absorber_hole2,i_norman,i_alpha, +c 1i_outer_sphere,i_exc_pot,i_mode + + + + COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1, + * I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA, + 1 I_OUTERSPHERE,I_EXC_POT,I_MODE + + + + +C COMMON/APARMS/XV(NATOMS),YV(NATOMS),ZV(NATOMS),Z(NATOMS), +C u NSYMBOL(NATOMS),NZEQ(NATOMS),NEQ(NATOMS),NCORES(NATOMS), +C . LMAXAT(NATOMS) + +C COMMON/APARMS_EXTRA/RS_(NATOMS),REDF_(NATOMS),OVLF + + + common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), + u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), + u lmaxat(natoms),ktau(ua_),natau(neq_,ua_) +C + COMMON/CRHOAT/RO(441,UA_,1) +c + DIMENSION X(441),RMESH(441) +C + REAL*4 XC,YC,ZC + DIMENSION XC(NAT_),YC(NAT_),ZC(NAT_) +C + DIMENSION NPAC(100) +C + LOGICAL OK +C + OK = .TRUE. +C +C* * * Initialize variables for subroutine molpot * * * +C + MESH = 441 +C +C Prepare coordinate vectors to input subroutine moldat +C + DO 10 I=1,NAT + XC(I) = sngl(XV(I+1)) + YC(I) = sngl(YV(I+1)) +10 ZC(I) = sngl(ZV(I+1)) +C Initialize to zero the vector indicating for which atom the density +C has already been calculated + DO N = 1, 100 + NPAC(N) = 0 + ENDDO +C +C compute x and r mesh (441 points) +C + NBLOCK=11 + I=1 + X(I)=0.0D0 + RMESH(I)=0.0D0 + DELTAX=0.0025D0 + DO 120 J=1,NBLOCK + DO 121 K=1,40 + I=I+1 + X(I)=X(I-1)+DELTAX +121 CONTINUE +C +C For each new block, double the increment +C + DELTAX=DELTAX+DELTAX +120 CONTINUE +C +C Loop over prototypical atoms excluding outer sphere +C + NDAT1 = NDAT-1 + + DO 100 M=2,NDAT + DO NR = 1, 441 + RO(NR,M,1) = 0.D0 + ENDDO + IHOLE = 0 + IF (M.EQ.2.AND.CHARELX.EQ.'ex') IHOLE=HOLE + NZAT = NZEQ(M) + IF(NZAT.NE.0) CION=CHARGE_ION(NZAT) + ZAT = Z(M) +C +C.....CHANGE FOR EMPTY SPHERES; CHS=0.88534138D0/ZAT**(1.D0/3.D0) +C + IF(ZAT.NE.0.D0) THEN + CHS=0.88534138D0/ZAT**(1.D0/3.D0) + ELSE + CHS=0.88534138D0 + ENDIF +C +C Factor CHS is to go from X values to R values +C (the latter in atomic units; See Herman-Skillman p.5-3) +C + DO 130 I=2,MESH + RMESH(I)=CHS*X(I) +130 CONTINUE +C + IF(NZAT.EQ.0) GO TO 100 + IF(NPAC(NZAT).EQ.0) THEN + CALL atom_sub(NZAT,IHOLE,RMESH(1),RO(1,M,1),0,0,CION) + IF(M.NE.2) NPAC(NZAT) = M + GO TO 100 + ELSE + DO I = 1, 441 + RO(I,M,1) = RO(I,NPAC(NZAT),1) + ENDDO + ENDIF +C +100 CONTINUE +C +C* * * * Generate input structural parameters for subroutine molpot * * +C +C + CALL MOLDAT(XC,YC,ZC,NZEQ(1),NEQAT(1),NAT,NDAT1,OK) +C + RETURN +C + END +C +C******************************* +C + subroutine atom_sub(iz,ihole,r_hs,rho0_hs,i_mode_atom, + $ i_radial,xion) +c +c i_mode_atom = 1 pass_back P_nK corresponding to neutr +c atom. i_radial designates radial function +c which is passed back in array rho0_hs re +c to mesh r_hs. +c I_radial has same label convention +c as ihole (1 = 1s1/2 ...). +c = all else pass back charge density in rho0_hs. +c +c + implicit real*8(a-h,o-z) +c + parameter ( mp = 251, ms = 30 ) +c + character*40 title +c + common/mesh_param/jlo + common dgc(mp,ms),dpc(mp,ms),bidon(630),IDUMMY +c +c common /pass/ passd, passvt(251), passvc(251), passc(251) +c rho0 not renormalized +c common /rho/rho0(251) +c dgc contains large component radial functions +c common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30) +c passc and rho0 contain 4*pi*r^2*rho(r) +c + dimension r(mp),r_hs(440),rho0_hs(440) +C + dimension dum1(mp), dum2(mp) + dimension vcoul(mp), rho0(mp), enp(ms) +c + title = ' ' +c + ifr=1 + iprint=0 +C + amass=0.0d0 + beta=0.0d0 +c +c There are no nodes in relativistic radial charge density +c + small=1.0d-11 +c !Hence a lower limit on rho(r) can be used. + dpas=0.05d0 + dr1=dexp(-8.8d0) + dex=exp(dpas) + r_max=44.447d0 +c +c compute relativistic Hartree-Fock charge density (on log mesh) +C and core state orbital wave function +c open(unit=543,file='atom_.dat',status='unknown') +c + + call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, + 1 vcoul, rho0, dum1, dum2, enp, eatom) + + +c +c compute radial log mesh (see subroutine phase in J.J. Rehr's progr +c FEFF.FOR) +c + ddex=dr1 + do 10 i=1,251 + r(i)=ddex + ddex=ddex*dex +10 continue +C + DO JMP=1,MP + WRITE(66,*) R(JMP),RHO0(JMP) + ENDDO +c + do 15 i=1,441 + rho0_hs(i)=0.0d0 +15 continue + +c +cman if(i_mode_atom.eq.1)goto 30 +c + if(i_mode_atom.eq.1)goto 31 +c +c using mesh form xainpot (r=0 not included) +c + do 30 i=1,441 + if(r_hs(i).gt.r_max) goto 30 +c +c find nearest points +c initialize hunting parameter (subroututine nearest) +c + jlo=1 + call nearest(r,251,r_hs(i), + 1 i_point_1,i_point_2,i_point_3) + if(abs(rho0(i_point_3)).lt.small) goto 30 +c interpolate charge density + call interp_quad( r(i_point_1),rho0(i_point_1), + 1 r(i_point_2),rho0(i_point_2), + 1 r(i_point_3),rho0(i_point_3), + 1 r_hs(i),rho0_hs(i) ) +c +c branch point +c +30 continue +31 continue +c +c + if(i_mode_atom.ne.1)goto 50 +c +c wave function generation +c using mesh form xainpot (r=0 not included) +c + do 40 i=1,441 + if(r_hs(i).gt.r_max) goto 50 +c +c find nearest points +c initialize hunting parameter (subroututine nearest) +c + jlo=1 + call nearest(r,251,r_hs(i), + 1 i_point_1,i_point_2,i_point_3) +c interpolate wavefunction + call interp_quad( + 1 r(i_point_1),dgc(i_point_1,i_radial), + 1 r(i_point_2),dgc(i_point_2,i_radial), + 1 r(i_point_3),dgc(i_point_3,i_radial), + 1 r_hs(i),rho0_hs(i) + 1 ) +40 continue +c +c branch point +c +50 continue +c + return + end + + SUBROUTINE NEAREST(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3) +C +C FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X +C AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3 +C This subroutine was taken from Numerical Recipes, +C W. H. Press, B. F. Flanney, S. A. Teukolsky and W. T. +C Vetterling, page 91. Originally called HUNT +c + IMPLICIT REAL*8(A-H,O-Z) + COMMON/MESH_PARAM/JLO +C + DIMENSION XX(N) + LOGICAL ASCND + ASCND=XX(N).GT.XX(1) +C +C EXTRAPOLATE BELOW LOWEST POINT +C + IF(X.LE.XX(1))THEN + I_POINT_1=1 + I_POINT_2=2 + I_POINT_3=3 + RETURN + END IF +C +C EXTRAPOLATE BEYOND HIGHEST POINT +C + IF(X.GE.XX(N))THEN + I_POINT_1=N-2 + I_POINT_2=N-1 + I_POINT_3=N + RETURN + END IF + IF(JLO.LE.0.OR.JLO.GT.N)THEN + JLO=0 + JHI=N+1 + GO TO 3 + ENDIF + INC=1 + IF(X.GE.XX(JLO).EQV.ASCND)THEN +1 JHI=JLO+INC + IF(JHI.GT.N)THEN + JHI=N+1 + ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN + JLO=JHI + INC=INC+INC + GO TO 1 + ENDIF + ELSE + JHI=JLO +2 JLO=JHI-INC + IF(JLO.LT.1)THEN + JLO=0 + ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN + JHI=JLO + INC=INC+INC + GO TO 2 + ENDIF + ENDIF +3 IF(JHI-JLO.EQ.1)THEN + IF((JLO+1).EQ.N)THEN + I_POINT_1=JLO-1 + I_POINT_2=JLO + I_POINT_3=JLO+1 + ELSE + I_POINT_1=JLO + I_POINT_2=JLO+1 + I_POINT_3=JLO+2 + END IF + RETURN + END IF + JM=(JHI+JLO)/2 + IF(X.GT.XX(JM).EQV.ASCND)THEN + JLO=JM + ELSE + JHI=JM + ENDIF + GO TO 3 + END +C +C + SUBROUTINE INTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4) +C +C INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2) +C TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT +C PARAMETERS. THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C +C + IMPLICIT REAL*8(A-H,O-Z) +C + TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1) + BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1) + B = TOP/BOTTOM + A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1) + C = Y3 - A*X3*X3 - B*X3 + Y4 = A*X4*X4 + B*X4 + C +C + RETURN + END + +C*********************************************************************** +C + SUBROUTINE MOLDAT(XCOORD,YCOORD,ZCOORD,ZNUMBE,GROUPN,NATOMSM, + 1 NTYPES,OK) +C +C 8-dec-86 C.Brouder +C This subroutine builds the file containing the additional input +C required for MOLPOT once CLEM has been run. +C 15-dec-86 If program CONTINUUM is to be run with complex +C potential, set all alpha parametres to zero. +C If program MOLPOT is to be run with an outer sphere, +C write corresponding parametres. +C +C Arguments description : +C XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms +C ZNUMBE Array of the atomic numbers of the atoms +C GROUPN Array of the number of the group to which the +C atoms belong. (A group is a class of atoms equivalent +C by the symmetry operations of the symmetry group) +C NATOMSM Number of atoms +C NTYPES Number of groups (prototypical atoms) +C +C DATA description (Value of data is [value]) : +C NRUNS Number of cluster for which potential is computed [1] +C INV Logical unit from which output from CLEM is read [8] +C +C NOUT 0 No outer sphere, 1 an outer sphere [0] +C NWR1 Punched output to be punched [PCH] +C NWR2 Print charge densities, charge, potential [PRT] +C 1NSPINS 1 spin restricted potential, 2 spin polarized potential [1] +C EXAFCO Slater alpha parameter for exchange for the interstitial regi +C OVLF Overlap factor of neighbouring spheres [.10] +C CHPERC The charge radius of the atom, is defined as the radius +C for which the integrated density of charge is Z*(1+CHPER +C This is used to compute the muffin-tin radii [0.005] +C NCUT A control number intended to change the mesh size for high +C energy calculations [0] (= no change) +C +C NSYMBL 4 character description of the atom (Symbol + number) +C NEQ 0 for prototypical atoms +C NTYPE of the prototypical atom for atoms equivalent to N +C NGBR The number of neighbours surrounding the atom. +C NTYPE Type of the atom (Group number) +C XV,YV,ZV Coordinates in atomic units +C EXFACT Slater alpha parameter +C +C ALPHAP Alpha Parameter of elements, from Schwarz, (Phys.Rev.B 5(7) +C 2466 (1972)) up to Z=41 (Nb), some possible "interpolation" +C for the other elements. +C NAMEAT Name of atoms +C OUTER Logical. .TRUE. if MOLPOT is to be run with an outer sphere +C BOHRAD Bohr radius in Angstrom +C +C*********************************************************************** +C + INCLUDE 'msxas3.inc' +C + COMMON/CONTINUUM/EMIN,EMAX,DELTA,CIP,GAMMA,EFTRI,IEXCPOT +C + REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM +C + COMMON/MOLINP/ + 1 EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM, + 1 NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_), + 1 NAM(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 + +C + PARAMETER (NEIMAX=nat_) + REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS) + INTEGER ZNUMBE(NATOMS),ZNBRE,GROUPN(NATOMS) + INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX) + LOGICAL OK,OUTER,PROTO,DEUX + CHARACTER*5 NWR1,NWR2 + REAL ALPHAP(100) + DATA NRUNS/1/,INV/8/ + DATA NOUT/0/,NSPINS/1/ + DATA OVLF/0.0/,CHPERC/0.005/,NCUT/1/ +C DATA BOHRAD/.529177/ + DATA BOHRAD/1.0/ +C H-Ne,Na-Ca,Sc-Zn,Ga-Zr,Nb-Sn,Sb-Nd,Pm-Yb + DATA ALPHAP/.978,.773,.781,.768,.765,.759,.752,.744,.737,.731, + 1 .731,.729,.728,.727,.726,.725,.723,.722,.721,.720, + 1 .718,.717,.716,.714,.713,.712,.710,.709,.707,.707, + 1 .707,.707,.707,.706,.706,.706,.706,.705,.705,.704, + 1 .704,.704,.704,.704,.704,.704,.704,.704,.704,.704, + 1 .703,.703,.703,.703,.703,.703,.703,.703,.703,.703, + 1 .702,.702,.702,.702,.702,.702,.702,.702,.702,.702, + 1 30*.702/ + NWR1=' PCH' + NWR2=' PRT' +C +C Check whether complex potential will be used +C + IF (IEXCPOT.EQ.4.OR.IEXCPOT.EQ.5) THEN + DO 100 I=1,100 + ALPHAP(I)=0. +100 CONTINUE + END IF +C +C Ask whether an outer sphere is to be used. +C 13-APR-87 In this new version, the file is always generated with an o +C sphere. +C + OUTER=.TRUE. +C +C* * * * Open file and write header * * * * * * * +C + OPEN(UNIT=2,FILE='div/STRPARM.DAT',STATUS='UNKNOWN', + & FORM='FORMATTED') +C +C Write first line +C + WRITE(2,2000) NRUNS,INV +2000 FORMAT(2I5) +C +C Compute EXAFCO (EXAFCO is taken as the average of all alpha parametr +C and write second line. +C +C Correction for the presence of empty spheres: 27th Sept 2007 +C + NPA = 0 + EXAFCO=0. + DO 200 I=1,NATOMSM + NZAT = ZNUMBE(I) + IF(NZAT.NE.0) THEN + NPA = NPA + 1 + EXAFCO=EXAFCO+ALPHAP(NZAT) + ENDIF +200 CONTINUE + EXAFCO=EXAFCO/NPA + IF (OUTER) THEN + IITYPE=NTYPES+1 + IIATOM=NATOMSM+1 + NOUT=1 + ELSE + IITYPE=NTYPES + IIATOM=NATOMSM + NOUT=0 + END IF + WRITE(2,2010) IITYPE,IIATOM,NOUT,NWR1,NWR2,NSPINS,EXAFCO,OVLF, + 1 CHPERC,NCUT +2010 FORMAT(3I5,2A5,I5,3F10.5,I5) +C + EXAFCOM=DBLE(EXAFCO) + OVLFM=DBLE(OVLF) + CHPERCM=DBLE(CHPERC) +C +C* * * * * * Write outer sphere description if any * * * * +C + IF (OUTER) THEN + XV=0. + YV=0. + ZV=0. + ITYPE=0 + CALL GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) + IF (.NOT.OK) THEN + CLOSE(UNIT=2) + RETURN + END IF + EXFACT=EXAFCO + ZNBRE=0 + PROTO=.TRUE. + N = 1 + CALL WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) + END IF +C +C* * * * * * Write prototypical atom description * * * * * +C + DO 300 NTYPE=1,NTYPES + XV=XCOORD(NTYPE)/BOHRAD + YV=YCOORD(NTYPE)/BOHRAD + ZV=ZCOORD(NTYPE)/BOHRAD +C +C + CALL GRPNEI(NTYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) + IF (.NOT.OK) THEN + CLOSE(UNIT=2) + RETURN + END IF + ZNBRE=ZNUMBE(NTYPE) +C +C.......CHANGE FOR ES +C + IF(ZNBRE.EQ.0.D0) THEN + EXFACT=EXAFCO + ELSE + EXFACT=ALPHAP(ZNBRE) + ENDIF + PROTO=.TRUE. + N=NTYPE+1 + CALL WRIDAT(XV,YV,ZV,NTYPE,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) +300 CONTINUE +C +C* * * * * Write non prototypical atom description * * * * * * +C + IF (NATOMSM.GT.NTYPES) THEN + DO 400 I=NTYPES+1,NATOMSM + XV=XCOORD(I)/BOHRAD + YV=YCOORD(I)/BOHRAD + ZV=ZCOORD(I)/BOHRAD + ZNBRE=ZNUMBE(I) +C +C.......CHANGE FOR ES +C + IF(ZNBRE.EQ.0.D0) THEN + EXFACT=EXAFCO + ELSE + EXFACT=ALPHAP(ZNBRE) + ENDIF + CALL GRPNEI(I,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) + IF (.NOT.OK) THEN +C CLOSE(UNIT=2) + RETURN + END IF + PROTO=.FALSE. + N = I + 1 + CALL WRIDAT(XV,YV,ZV,I,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) +400 CONTINUE + END IF +C CLOSE (UNIT=2) +C +C * * * * * * * Create MOLSYM.COO * * * * * * * * +C +C Now we create a file called MOLSYM.COO which lists the coordinates +C and the number of each atom in the cluster, according to the +C FORMAT required by MOLSYM. This file will be used later on to +C make the input file of MOLSYM. In this file, the atoms must be +C ordered according to their group (all equivalent atoms must follow +C each other), and numbered according to the way their are declared +C in the input of MOLPOT. If an outer sphere is to be used, it must +C be declared to be atom number 1. +C According to the FORMAT required by MOLSYM, the atoms must +C be written in pairs. The logical variable DEUX is here to say +C that two atoms are available and it is time to write them. +C + OPEN(UNIT=2,FILE='div/molsym.coo',STATUS='unknown') +C*************************************************** +C*************************************************** + DEUX=.TRUE. +C**** IF (OUTER) THEN +C**** XX1=0. +C**** YY1=0. +C** ZZ1=0. +C** NN1=1 +C** DEUX=.FALSE. +C** END IF +C + X0 = XCOORD(1) + Y0 = YCOORD(1) + Z0 = ZCOORD(1) +C + DO 500 ITYPE=1,NTYPES + DO 500 I=1,NATOMSM +C +C Order atoms according to their groups +C + IF (GROUPN(I).EQ.ITYPE) THEN + IF (DEUX) THEN + XX1=XCOORD(I)/BOHRAD - X0 + YY1=YCOORD(I)/BOHRAD - Y0 + ZZ1=ZCOORD(I)/BOHRAD - Z0 +C*** IF (OUTER) THEN +C*** NN1=I+1 +C*** ELSE + NN1=I +C*** END IF + DEUX=.FALSE. + ELSE + XX2=XCOORD(I)/BOHRAD - X0 + YY2=YCOORD(I)/BOHRAD - Y0 + ZZ2=ZCOORD(I)/BOHRAD - Z0 +C*** IF (OUTER) THEN +C*** NN2=I+1 +C*** ELSE + NN2=I +C*** END IF + WRITE (2,3000) XX1,YY1,ZZ1,NN1,XX2,YY2,ZZ2,NN2 +3000 FORMAT(2(3F10.6,I5,5X)) + DEUX=.TRUE. + END IF + END IF +500 CONTINUE +C +C If the number of atoms written in the file (including possibly +C the outer sphere) is not even, there is an atom that is left +C to be written, so write it. In any case, close the file. +C + IF (.NOT.DEUX) THEN + WRITE (2,3010) XX1,YY1,ZZ1,NN1 +3010 FORMAT(3F10.6,I5,5X) + END IF + CLOSE (UNIT=2) + RETURN + END +C +C*********************************************************************** +C + SUBROUTINE GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, + 1 NGBR,NEIGHB,NUMNEI,OK) +C +C 9-dec-86 C.Brouder +C This subroutine finds the groups of neighbours of atom number ITYPE +C A group of neighbours of atom ITYPE is a set of all atoms +C at the same distance from atom ITYPE and belonging to the same group +C (i.e. equivalent to the same prototypical atom, i.e.having the same +C group number GROUPN). +C At the end, the groups of neigbours are sorted according to increasi +C distances. +C +C Arguments description : +C ITYPE # of atom (0 if outer sphere) whose neighbours +C are to be determined. +C XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms. +C GROUPN Array of the number of the group to which the +C atoms belong. (A group is a class of atoms equivalent +C by the symmetry operations of the symmetry group). +C NATOMSM Number of atoms +C NGBR Number of groups of neighbours +C NEIGHB # of an atom in the group of neigbours +C NUMNEI Number of atoms in the group of neighbours +C NEIMAX Maximum number of groups of neighbours. +C +C DISTAN Array of distances of neigbours +C EPSILO If the distances are smaller than EPSILO, they are +C supposed to be identical. +C +C********************************************************************* +C + INCLUDE 'msxas3.inc' +C + PARAMETER (NEIMAX=nat_) + REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS) + REAL DISTAN(NEIMAX) + INTEGER GROUPN(NATOMS),NEIGHB(NEIMAX),NUMNEI(NEIMAX) + LOGICAL OK,NEW + DATA EPSILO/1.E-5/ + NGBR=1 +C +C Initialize arrays +C + DO 100 I=1,NATOMSM + NEIGHB(I)=0 + NUMNEI(I)=0 +100 CONTINUE + IF (ITYPE.EQ.0) THEN + X0=0. + Y0=0. + Z0=0. + ELSE + X0=XCOORD(ITYPE) + Y0=YCOORD(ITYPE) + Z0=ZCOORD(ITYPE) + END IF +C +C Scan all other atoms +C + DO 200 I=1,NATOMSM + IF (I.NE.ITYPE) THEN +C +C Compute distance +C + NEW=.TRUE. + DISTAN(NGBR)=(XCOORD(I)-X0)*(XCOORD(I)-X0) + DISTAN(NGBR)=DISTAN(NGBR)+(YCOORD(I)-Y0)*(YCOORD(I)-Y0) + DISTAN(NGBR)=DISTAN(NGBR)+(ZCOORD(I)-Z0)*(ZCOORD(I)-Z0) + DISTAN(NGBR)=SQRT(DISTAN(NGBR)) + IF (NGBR.NE.1) THEN +C +C Check whether this distance already exists and the corresponding +C atom belongs to the same group. +C + DO 210 I2=1,NGBR-1 + IF ((ABS(DISTAN(I2)-DISTAN(NGBR)).LT.EPSILO).AND. + 1 (GROUPN(NEIGHB(I2)).EQ.GROUPN(I))) THEN + NEW=.FALSE. + NUMNEI(I2)=NUMNEI(I2)+1 + END IF +210 CONTINUE + END IF +C +C If it does not, this is a new group +C + IF (NEW) THEN + NUMNEI(NGBR)=1 + NEIGHB(NGBR)=I + NGBR=NGBR+1 + IF (NGBR.GT.NEIMAX) THEN + PRINT 4000 +4000 FORMAT(' Too many neighbours, increase NEIMAX in', + 1 ' subroutines GRPNEI and MOLDAT') + OK=.FALSE. + RETURN + END IF + END IF + END IF +200 CONTINUE + NGBR=NGBR-1 +C +C Order groups of neighbours according to increasing distances +C + DO 300 I=1,NGBR +C +C Look for the smallest remaining distance +C + DISMIN=1.E20 + IDISMI=I + DO 310 J=I,NGBR + IF (DISTAN(J).LT.DISMIN) THEN + DISMIN=DISTAN(J) + IDISMI=J + END IF +310 CONTINUE +C +C Transpose values +C + IF (IDISMI.NE.I) THEN + N1TEMP=NEIGHB(I) + N2TEMP=NUMNEI(I) + DTEMPO=DISTAN(I) + NEIGHB(I)=NEIGHB(IDISMI) + NUMNEI(I)=NUMNEI(IDISMI) + DISTAN(I)=DISTAN(IDISMI) + NEIGHB(IDISMI)=N1TEMP + NUMNEI(IDISMI)=N2TEMP + DISTAN(IDISMI)=DTEMPO + END IF +300 CONTINUE + RETURN + END +C +C*********************************************************************** +C + SUBROUTINE WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN, + 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) +C +C This subroutine writes on file 2 the data collected by MOLDAT, +C for each atom. There are many cases to consider : the outer sphere +C (ITYPE=0), prototypical atoms (PROTO=.TRUE.), non prototypical atoms +C (PROTO=.FALSE.) and in the latter cases, the outputs are different +C if there is an outer sphere (OUTER=.TRUE.) or not. +C Variable description +C XV,YV,ZV Position +C ITYPE # of atom whose data are involved +C ZNBRE Z number of atom +C NGBR Number of neighbours +C EXFACT Alpha parametre +C GROUPN Group numbers +C NUMNEI Number of neighbours +C NEIGHB Example of neighbour +C NATOMSM Number of atoms +C OUTER .TRUE. if there is an outer sphere +C PROTO .TRUE. if this is a prototypical atom +C +C NSYMBL Symbol +C +C******************************************************************** +C + INCLUDE 'msxas3.inc' +C + REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM +C + COMMON/MOLINP/ + 1 EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM, + 1 NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_), + 1 NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 +C + PARAMETER (NEIMAX=nat_) + INTEGER GROUPN(NATOMS),ZNBRE + INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX) + LOGICAL PROTO,OUTER + CHARACTER*5 NWR1,NWR2 +C +C* * * * * * Initialize data * * * * * * * +C +C +C NEQ (0 if prototypical atom, NTYPE of prototypical atom otherwise +C + IF (PROTO) THEN + NEQ=0 + ELSE + IF (OUTER) THEN + NEQ=GROUPN(ITYPE)+1 + ELSE + NEQ=GROUPN(ITYPE) + END IF + END IF +C +C NTYPE (if outer sphere, outer sphere is number 1, so add 1 to +C all group numbers) +C + IF (PROTO) THEN + IF (OUTER) THEN + NTYPE=ITYPE+1 + ELSE + NTYPE=ITYPE + END IF + ELSE + NTYPE=NEQ + END IF +C +C* * * Initialize variables for subroutine molpot * * * +C + NGBRM(N)=NGBR + NTYPEM(N)=NTYPE + EXFCTM(N)=DBLE(EXFACT) +C +C* * * Initialize variables for subroutine molpot * * * +C + IF (PROTO) THEN + DO 300 K=1,NGBR + IF (OUTER) THEN + NATAN(K,N) = GROUPN(NEIGHB(K)) + 1 + NAT1(K,N) = NEIGHB(K) + 1 + ELSE + NATAN(K,N) = GROUPN(NEIGHB(K)) + NAT1(K,N) = NEIGHB(K) + ENDIF +300 NA(K,N) = NUMNEI(K) + ENDIF +C + RETURN + END +C +C*********************************************************************** +C + SUBROUTINE MOLPOT +C +C SPIN-RESTRICTED MOLECULAR POTENTIAL PROGRAM +C GENERATES SUPERPOSED-ATOM POTENTIAL USED TO START SCF CALCULATION +C + implicit real*8 (a-h,o-z) + include 'msxas3.inc' +c + include 'msxasc3.inc' +c + character*8 nsymbl +c.. +c common/dimens/nats,ndat,nout,lmaxx,irreps + common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), + u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), + u lmaxat(natoms) + common/aparms_extra/rs_(natoms),redf_(natoms),ovlf +c + integer trans + common/transform/trans(natoms) +C + COMMON/MOLINP/ + * EXFAC0,EXFACT(NAT_),OVLFM,CHPERC,NTYPES,NATOMSM, + * NGBR(NAT_),NTYPE(NAT_),NATAN(NAT_,UA_), + * NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 +C + COMMON/CRHOAT/ RO(441,UA_,1) +C + COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT +C + COMMON/MTRAD/ RS(NAT_) +C + COMMON/STRUCT/NTNABS(NAT_),NGBRABS +C + DIMENSION R(441,UA_),V(441,1),RV(441,UA_),Q(441),ALPHA(441), + 1 BETA(441),GAMMA(441,1),SNLO(441),XI(441),XJ(441), + 2 ZPALPH(441),ROTOTL(441,1),ROT(441) +C + DIMENSION ZM(NAT_),NZM(NAT_),NIMAX(NAT_),AN(NAT_,NAT_), + * FAC2(NAT_),RSC(NAT_) +C + CHARACTER*5 NWR1,NWR2 +C +c DATA PI/3.14159265358979/ +c DATA PI4/12.56637061435916/,THIRD/.333333333333333/ +C + LOGICAL SKIP + PI=3.14159265358979D0 + PI4=12.56637061435916D0 + THIRD=.333333333333333D0 + NRUNS = 1 + DO 999 IRUNS=1,NRUNS +1002 FORMAT(15I5) + SKIP=.FALSE. +C +C.....MOUT: CONTROLS THE OUTPUT OF PROGRAM INPOT. IF MOUT=1 THIS +C..... OUTPUT WILL CONTAIN THE OUTER SPHERE. IF MOUT=0 IT +C..... WILL NOT. THIS VERSION INITIALIZED TO MOUT=0 +C.....0VLF: THIS IS THE OVERLAP FACTOR FOR THE MUFFIN-TIN RADII +C..... DEFAULT=0.1 IN SUBROUTINE MOLDAT +C.....CHPERC: THIS IS THE PERCENTAGE OF ATOMIC CHARGE INSIDE THE +C..... ATOMIC SPHERES WHEN APPLYING NORMAN CRITERIUM +C..... DEFAULT=0.005 IN SUBROUTINE MOLDAT +C + MOUT=0 + NOUT=1 + NSPINS=1 + NSAT=1 + NCUT=1 + FAC1=NSPINS + NDAT=NATOMSM + OPEN (UNIT=7,FILE='div/molinpot3.out',STATUS='unknown') + DO 43 N=1,NATOMSM +C READ(5,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N), +C 1 EXFACT(N) + 1001 FORMAT(1X,A8,3I5,4F10.6) + WRITE(7,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N), + 1 EXFACT(N) + FAC2(N)=6.D0*EXFACT(N)*(FAC1*3.D0/(32.D0*PI*PI))**THIRD + IF(NEQ(N).NE.0) GO TO 443 + NGBRS=NGBR(N) +C READ(5,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS) +C NATAN=TYPE OF NEIGHBOR NA=NUMBER OF ATOMS IN GROUP NAT1=LABEL OF +C ONE OF THE NEIGHBORS +C + WRITE(7,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS) + IF(SKIP) GO TO 4511 + GO TO 43 + 4511 WRITE(7,1045) + 1045 FORMAT(' DIFFERENT ATOMS MUST COME FIRST') + SKIP=.FALSE. + GO TO 43 + 443 IF(SKIP) GO TO 43 + SKIP=.TRUE. + NDAT=N-1 + 43 CONTINUE +C +C AN(I,N): DISTANCE OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I +C + WRITE(7,*) + WRITE(7,*) 'DIST. OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I' + ANMAX = 0.0D0 + DO 44 N=1,NDAT + ANPR=0.0D0 + NGBRS=NGBR(N) + IF(N.EQ.2) NGBRABS=NGBRS + DO 44 I=1,NGBRS + NT = NATAN(I,N) + IF(N.EQ.2) NTNABS(I)=NT-1 +C write(6,*) i,nt,ntnabs(i),ngbrabs + NB=NAT1(I,N) + AN(I,N)=DSQRT((XV(NB)-XV(N))**2+(YV(NB)-YV(N))**2+(ZV(NB)-ZV(N))** + 1 2) + WRITE(7,*) N, NT, AN(I,N) + IF(I.EQ.1) THEN + ANPR=AN(I,N) + GO TO 440 + ENDIF + IF(AN(I,N).LT.ANPR) THEN + WRITE(7,30) I,N + 30 FORMAT(' **WARNING** : NEIGHBOR OF TYPE',I3,' TO ATOM',I3, + * ' NOT ARRANGED IN ASCENDING ORDER OF DISTANCE') +C +C CALL EXIT +C + ENDIF + 440 IF(N.NE.1) GO TO 44 + IF(AN(I,N).GT.ANMAX) ANMAX = AN(I,N) + 44 CONTINUE + SKIP=NOUT.NE.0 + WRITE(7,104) NATOMSM,NDAT,FAC1 + 104 FORMAT(30X,I3,7H ATOMS,,I3,17H DIFFERENT, FAC1=,F11.7) + WRITE(7,105) (NSYMBL(N),NEQ(N),XV(N),YV(N),ZV(N),EXFACT(N),N=1, + 1 NATOMSM) + 105 FORMAT(//28X,6HSYMBOL,4X,2HEQ,5X,1HX,11X,1HY,11X,1HZ,7X,6HEXFACT + 1 /(30X,A5,I6,4F11.7)) + DO 1 N=1,NTYPES + IF(SKIP) GO TO 89 + WRITE(7,2002) NZEQ(N),NSAT + 2002 FORMAT(6I4) + KMAX=441 + ZM(N)=NZEQ(N) + NZM(N)=NZEQ(N) + TZ=2.D0*ZM(N) + GO TO 90 + 89 DELTAR=.88534138D0*.0025D0 + NZM(1)=1 + GO TO 91 + 90 IF(ZM(N).EQ.0.D0) THEN + DELTAR=.88534138D0*.0025D0 + ELSE + DELTAR=.88534138D0*.0025D0/ZM(N)**THIRD + ENDIF + 91 I=1 + R(1,N)=0.D0 + DO 87 J=1,11 + DO 88 K=1,40 + I=I+1 + 88 R(I,N)=R(I-1,N)+DELTAR + 87 DELTAR=2.0D0*DELTAR + IF(SKIP) GO TO 49 + DO 52 K=1,441 + 52 ROT(K)=RO(K,N,1) + CALL MINTEGR(ROT,XI,R(1,N),441) + Q(1)=0.D0 + DO 10 I=2,441 + 10 Q(I)=ROT(I)/R(I,N) + CALL MINTEGR(Q,XJ,R(1,N),441) +C +C RV=R*( COULOMB POTENTIAL ) +C + DO 12 I=1,441 + 12 RV(I,N)=-TZ+2.D0*(XI(I)+R(I,N)*(XJ(441)-XJ(I))) + IF(NSPINS.EQ.1.AND.ZM(N).NE.0) + 1 WRITE(7,101) N,(I,R(I,N),RV(I,N),ROT(I),XI(I),I=1,KMAX) + 101 FORMAT(1H1,40X,22HATOMIC DATA FOR CENTER,I3,4X,/, + & 2(9X,1HR,15X,2HRV, + 1 14X,3HRHO,11X,6HCHARGE,3X),/,2(I4,1P4E15.6)) + GO TO 1 + 49 DO 50 J=1,441 + 50 RV(J,N)=0.D0 + 1 SKIP=.FALSE. + IF(NWR1.NE.' PCH') GO TO 1041 + OPEN (UNIT=4,FORM='UNFORMATTED',STATUS='unknown') + REWIND(4) + WRITE(4) NATOMSM,NDAT,NOUT,EXFAC0,NSPINS + KC=2 + 1041 DO 1000 M=1,NDAT + N=NTYPE(M) + NZM(M)=NZM(N) + NIMAX(M)=441 + IF(M.EQ.1.AND.NOUT.NE.0) GO TO 450 + DO 1043 J=1,441 + IF(R(J,N).LT.AN(1,M)) GO TO 1043 + NIMAX(M)=J + GO TO 450 + 1043 CONTINUE + 450 NBRS=NGBR(M) + IMAX=NIMAX(M) + DO 600 I=1,441 + ZPALPH(I)=0.D0 + BETA(I)=0.D0 + DO 600 ISPIN=1,NSPINS + ROTOTL(I,ISPIN)=0.D0 + 600 GAMMA(I,ISPIN)=0.D0 + DO 45 I=1,NBRS + MVAL=NATAN(I,M) + IF(NOUT.NE.0.AND.MVAL.EQ.1) GO TO 45 +C +C ITH SET OF NEIGHBORS TO CENTER M +C N IS TYPE OF CENTER M +C MVAL IS THE TYPE OF ITH SET OF NEIGHBORS TO CENTER M +C + IF(AN(I,M).GT..00001D0) GO TO 650 +C +C FOR A CENTER COINCIDING WITH THE MOLECULAR CENTER +C AVERAGE VALUES ARE EQUAL TO THE VALUES AT THE POINT +C + DO 652 J=2,IMAX + CALL MINTERP(R(J,N),RV(1,MVAL),XVAL,R(1,MVAL)) + ZPALPH(J)=ZPALPH(J)+NA(I,M)*XVAL + BETA(J)=BETA(J)-0.5D0*XVAL*NA(I,M)*R(J,N)**2 + DO 652 ISPIN=1,NSPINS + CALL MINTERP(R(J,N),RO(1,MVAL,ISPIN),XVAL,R(1,MVAL)) + ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*XVAL/R(J,N) + 652 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)-0.5D0*XVAL*NA(I,M)*R(J,N) + DO 451 ISPIN=1,NSPINS + CALL MINTEGR(RO(1,MVAL,ISPIN),SNLO,R(1,MVAL),441) + DO 451 J=1,441 + CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL)) + XJ(J)=R(J,MVAL)*RV(J,MVAL) + 451 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*XVAL + CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) + DO 452 J=1,441 + CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL)) + 452 BETA(J)=BETA(J)+NA(I,M)*XVAL + GO TO 45 +C +C FOR SEPARATED CENTERS CALCULATE SPHERICAL AVERAGES AROUND CENTER M +C + 650 CALL MINTEGR(RV(1,MVAL),SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL) + DO 65 J=2,IMAX + 65 ZPALPH(J)=NA(I,M)*ALPHA(J)+ZPALPH(J) + Q(1)=0.D0 +C +C SPHERICAL AVERAGE CHARGE DENSITY +C + DO 95 ISPIN=1,NSPINS + DO 901 J=2,441 + 901 Q(J)=RO(J,MVAL,ISPIN)/R(J,MVAL) + CALL MINTEGR(Q,SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL) + DO 95 J=2,IMAX + 95 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*ALPHA(J) + IF(N.NE.1.OR.NOUT.EQ.0) GO TO 45 + XJ(1)=0.D0 +C +C TOTAL CHARGE FOR OUTER SPHERE +C + DO 37 ISPIN=1,NSPINS + DO 36 J=2,441 + 36 XJ(J)=-RO(J,MVAL,ISPIN)*(R(J,MVAL)-AN(I,M))**2/R(J,MVAL) + CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,Q,R,441,N,MVAL) + CALL MINTEGR(RO(1,MVAL,ISPIN),XJ,R(1,MVAL),441) + DO 37 J=2,441 + CALL MINTERP(R(J,N)-AN(I,M),XJ,XVAL,R(1,MVAL)) + 37 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*(XVAL+0.5D0*Q(J)) +C +C INTEGRATED POTENTIAL FOR OUTER SPHERE +C + XI(1)=0.D0 + XJ(1)=-RV(1,MVAL)*AN(I,M)**2 + DO 46 J=2,441 + XI(J)=RV(J,MVAL)*R(J,MVAL) + 46 XJ(J)=-RV(J,MVAL)*(R(J,MVAL)-AN(I,M))**2 + CALL MINTEGR(XI,Q,R(1,MVAL),441) + CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) + CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,441,N,MVAL) + DO 47 J=2,441 + CALL MINTERP(R(J,N)-AN(I,M),Q,XVAL,R(1,MVAL)) + 47 BETA(J)=BETA(J)+NA(I,M)*(XVAL+0.5D0*ALPHA(J)) + 45 CONTINUE + IF(N.NE.1.OR.NOUT.EQ.0) GO TO 2003 + DO 2005 J=1,IMAX + BETA(J)=(BETA(J)+0.5D0*ZPALPH(J)*R(J,N)**2)*PI4 + DO 2005 ISPIN=1,NSPINS + ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N) + 2005 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+0.5D0*ROTOTL(J,ISPIN)*R(J,N) + GO TO 112 +C +C INTEGRATED POTENTIAL AND TOTAL CHARGE FOR MUFFIN-TIN SPHERE +C GAMMA(I,ISPIN) IS TOTAL INTEGRATED CHARGE, BETA(I) IS INTEGRATED +C POTENTIAL, ZPALPH(I) IS R*VCOULOMB CALCULATED WITH PROJECTED +C DENSITY +C + 2003 DO 2001 J=1,IMAX + ZPALPH(J)=ZPALPH(J)+RV(J,N) + Q(J)=PI4*R(J,N)*ZPALPH(J) + DO 2001 ISPIN=1,NSPINS + 2001 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N)+RO(J,N,ISPIN) + DO 2004 ISPIN=1,NSPINS + 2004 CALL MINTEGR(ROTOTL(1,ISPIN),GAMMA(1,ISPIN),R(1,N),IMAX) + CALL MINTEGR(Q,BETA,R(1,N),IMAX) + 112 DO 111 ISPIN=1,NSPINS + V(1,ISPIN)=0 + DO 111 J=2,IMAX +C +C VC(J) = ZPALPH(J)/R(J,N) +C + 111 V(J,ISPIN)=(ZPALPH(J)-FAC2(M)*(R(J,N)*DABS(ROTOTL(J,ISPIN)))**THIR + 1D)/R(J,N) +C +C...FIND RADIUS CONTAINING THE ATOMIC NUMBER OF ELECTRONS WITHIN CHPERC +C + RSC(M) = AN(1,M)/2.D0 + IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 14 + IF(NZM(M).EQ.0) GO TO 14 + DO 13 I=1,IMAX +C IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 13 + CHPCI=(ZM(M)-GAMMA(I,1))/ZM(M) + IF(CHPCI.GT.CHPERC)GO TO 13 + RSC(M) = R(I,M) + GO TO 14 + 13 CONTINUE + 14 IF(NWR2.NE.' PRT') GO TO 1032 + WRITE(7,6)M + 6 FORMAT(1H1,35X,11HATOM NUMBER,I6) + WRITE(7,7) (NA(I,M),NATAN(I,M),AN(I,M),I=1,NBRS) + 7 FORMAT(/ 23H NO. OF CENTERS TYPE,7X,8HDISTANCE/(5X,I4,10X,I + 1 4,F17.8)) + IF(NSPINS.EQ.1) WRITE(7,9)(J,R(J,N),ZPALPH(J),BETA(J),GAMMA(J,1),V + 1 (J,1),ROTOTL(J,1),J=1,IMAX) + 9 FORMAT(16X,1HR,16X,6HZPALPH,5X,20HINTEGRATED POTENTIAL,7X,12HTOTAL + 1 CHARGE,13X,1HV,18X,3HRHO/(I4,6E20.8)) + 1032 IF(NWR1.NE.' PCH') GO TO 1000 + NIMAX(M)=NIMAX(M)-1 + WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M), + 1 ZV(M),EXFACT(M),KC + KC=KC+1 + DO 1014 ISPIN=1,NSPINS + DO 1014 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,( V(I,ISPIN),I=K,KCARD) + 1014 KC=KC+1 +C DO 1020 K=2,IMAX,5 +C KCARD=MIN0(IMAX,K+4) +C WRITE(4,1015) KC,( VC(I),I=K,KCARD) +C 1020 KC=KC+1 + DO 2214 ISPIN=1,NSPINS + DO 2214 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,(ROTOTL(I,ISPIN) ,I=K,KCARD) + 2214 KC=KC+1 + DO 1016 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,(BETA(I),I=K,KCARD) + 1016 KC=KC+1 + DO 1019 ISPIN=1,NSPINS + DO 1019 K=2,IMAX,5 + KCARD=MIN0(IMAX,K+4) + WRITE(4) KC,(GAMMA(I,ISPIN) ,I=K,KCARD) + 1019 KC=KC+1 + 1000 CONTINUE +C + WRITE(7,*) 'CHECKING MUFFIN-TIN RADII' + IF(OPTRSH.EQ.'y') THEN + WRITE(6,*) ' MT radii for Hydrogen atoms set to rsh' + WRITE(7,*) ' MT radii for Hydrogen atoms set to rsh =', RSH + ELSE + WRITE(6,*) ' MT radii for Hydrogen atoms determined by stdcrm', + & ' unless other options are specified' + WRITE(7,*) ' MT radii for Hydrogen atoms determined by stdcrm', + & ' unless other options are specified' + ENDIF + WRITE(7,*) ' M, Z(M), MN, Z(MN), AN(MN,M),', + & ' RSC(M), RSC(MN), RS(M), RS(MN)' +C +C FIND MUFFIN-TIN RADIUS FOR PAIR IJ ACCORDING TO NORMAN CRITERIUM (STDCRM) +C + DO 18 M=1,NDAT + IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 18 + NBRS=NGBR(M) + IF(NZM(M).NE.0) THEN + DO NG = 1, NBRS + MN=NATAN(NG,M) + IF(NZM(MN).NE.0) GO TO 191 + ENDDO +191 RS(M)=AN(NG,M)*(1.D0+OVLF)/(1.D0+RSC(MN)/RSC(M)) +C +C IF OPTRSH='y' MT RADIUS FOR H ATOMs SET TO RSH IN INPUT ! Added 16 Jul 2013 +C + IF(NZM(M).EQ.1.AND.OPTRSH.EQ.'y') THEN + WRITE(6,*) ' MT radius', RS(M),' for H atom', M, + & ' set to', RSH + RS(M) = RSH + ENDIF + WRITE(7,190) M, NZM(M), MN, NZM(MN), AN(NG,M), + & RSC(M), RSC(MN), RS(M), RS(MN) + GO TO 18 + ENDIF + MN = NATAN(1,M) + IF (NZM(MN).EQ.0.D0) THEN + RS(M) = AN(1,M)*(1.D0+OVLF)/2.D0 + ELSE + RS(M) = (AN(1,M)-RS(MN))*(1.D0+OVLF) + ENDIF + WRITE(7,190) M, NZM(M), MN, NZM(MN), AN(1,M), + & RSC(M), RSC(MN), RS(M), RS(MN) +190 FORMAT(4I5, 5F10.5) + IF(NORMAN.EQ.'stdfac'.OR.NORMAN.EQ.'scaled') + *RS(M)=REDF_(M)*RSC(M) + 18 CONTINUE + IF(NOUT.EQ.1) RS(1) = ANMAX + RS(NDAT) + IF(NDAT.EQ.NATOMSM) GO TO 5001 + NDAT1=NDAT+1 + DO 221 M=NDAT1,NATOMSM + NZM(M)= NZM(NEQ(M)) + RS(M)= RS(NEQ(M)) + NIMAX(M)=0 + WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M), + 1 ZV(M),EXFACT(M),KC + 221 KC=KC+1 + 5001 CONTINUE + IF (NORMAN.EQ.'extrad') THEN + RS(1) = ANMAX + RS_(NDAT) + DO 5002 M=2,NATOMSM + 5002 RS(M)=RS_(M) + END IF + IF (NORMAN.NE.'extrad') THEN + WRITE(6,*) + WRITE(6,5003) + 5003 FORMAT(1X,65('-')) + WRITE(6,*) ' i rs(i) i=1,natoms ' + WRITE(6,5004) (I, RS(I), I=1,NATOMSM) + WRITE(6,*) ' N.B.: Order of atoms as reshuffled by', + * ' symmetry routines ' + 5004 FORMAT(8(I5,1X,F7.2)) + WRITE(6,5003) + WRITE(6,*) + END IF + IF(NWR1.NE.' PCH') GO TO 999 + WRITE(7,*) + WRITE(7,*) ' Radion, qion, ncut, rs(i), i=1,nat' + WRITE(7,19) RADION,QION,NCUT,(RS(M),M=1,NATOMSM) + 19 FORMAT(/,1X,2F10.5,I5/(8F10.5),//) + 999 CONTINUE +C + REWIND(4) +C + RETURN + END +C +CLAGRNG + SUBROUTINE LAGRNG(F,LPLACE,B,RES) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION F(4),B(4) + RES=0.D0 + DO 5 N=1,4 + M=LPLACE-2+N + 5 RES=RES+B(N)*F(M) + RETURN + END +CBSET + SUBROUTINE BSET(PINTRP,B) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION B(4) + PM=PINTRP*(PINTRP**2-1.D0)*(PINTRP-2.D0) + B(1)=-PM/(6.D0*(PINTRP+1.D0)) + B(2)= PM/(2.D0*PINTRP) + B(3)=-PM/(2.D0*(PINTRP-1.D0)) + B(4)= PM/(6.D0*(PINTRP-2.D0)) + RETURN + END +CINTERP +C L.F. MATTHEISS SUBROUTINE INTERP(B,X1,M2,D,R) +C B IS THE RADIAL DISTANCE +C X1 IS THE INTEGRATED FUNCTION +C D IS THE INTERPOLATED VALUE OF THE INTEGRAL FROM 0 TO B. +C R IS THE RADIAL MESH +C + SUBROUTINE MINTERP(B,X1,D,R) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION X1(441),R(441),B1(4),C(4) + IF(B-R(2 ))10,11,12 + 10 D=0.0D0 + GOTO 100 + 11 D=X1(2) + GOTO 100 + 12 IF(B-R(440 ))15,14,13 + 13 D=X1(441) + GOTO 100 + 14 D=X1(440) + GOTO 100 + 15 DO 22 I=1,441 + L=441+1-I + IF(R(L)-B) 23,24,22 + 22 CONTINUE + 23 LPLACE=L + DO 29 N=1,11 + ISCALE=41+40*(N-1)-LPLACE + IF(ISCALE)25,46,25 + 25 IF(ISCALE-1)29,48,29 + 29 CONTINUE + B1(1)=X1(LPLACE-1) + B1(2)=X1(LPLACE) + B1(3)=X1(LPLACE+1) + B1(4)=X1(LPLACE+2) + H=R(LPLACE+1 )-R(LPLACE ) + 50 PINTRP=(B-R(LPLACE ))/H + 51 CALL BSET(PINTRP,C) + CALL LAGRNG(B1,2,C,D) + 100 RETURN + 24 D=X1(L) + RETURN + 46 B1(1)=X1(LPLACE-2) + B1(2)=X1(LPLACE) + B1(3)=X1(LPLACE+1) + B1(4)=X1(LPLACE+2) + H=R(LPLACE+1 )-R(LPLACE ) + GOTO 50 + 48 B1(1)=X1(LPLACE-3) + B1(2)=X1(LPLACE-1) + B1(3)=X1(LPLACE+1) + B1(4)=X1(LPLACE+2) + H=R(LPLACE+2 )-R(LPLACE+1 ) + PINTRP=(B-R(LPLACE-1 ))/H + GO TO 51 + END +CINTEGR +C SIMPSON'S RULE INTEGRATION +C + SUBROUTINE MINTEGR(X,Y,R,M2) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION X(441),Y(441),R(441) + H=R(2) + Y(1)=0.D0 + Y(2)=H*(5.D0*X(1 )+8.D0*X(2 )-X(3 ))/12.D0 + DO 20 J=1,11 + DO 10 K=1,40 + I=40*(J-1)+K + IF(I.GT.M2) RETURN + IF(I-440) 5,10,10 + 5 Y(I+2)=Y(I)+H*(X(I )+4.D0*X(I+1 )+X(I+2 ))/3.D0 + 10 CONTINUE + H=H+H + IF (I-440) 15,20,15 + 15 Y(I+2)=Y(I+1)+H*(5.D0*X(I+1 )+8.D0*X(I+2 )-X(I+3 ))/12.D0 + 20 CONTINUE + RETURN + END +CALPHAO +C L.F. MATTHEISS SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2) +C AP IS THE DISTANCE OF THE NEIGHBORING ATOM +C ZINT IS THE INDEFINITE INTEGRAL +C ALPHA IS A TABLE OF THE DESIRED ALPHA FUNCTIONS +C R IS THE RADIAL DISTANCE +C IMAX IS THE NUMBER OF ALPHA FUNCTIONS TO BE COMPUTED +C M1 IS THE ATOM NO. AT THE ORIGIN +C M2 IS THE ATOM NO. AT AP +C + SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2) +C + IMPLICIT REAL*8(A-H,O-Z) +C + include 'msxas3.inc' +C + DIMENSION ZINT(441),ALPHA(441),R(441,UA_) + DO 100 I=2,IMAX + APLUSR=AP+R(I,M1) + AMINSR=DABS(AP-R(I,M1)) + CALL MINTERP(APLUSR,ZINT,XVAL1,R(1,M2)) + CALL MINTERP(AMINSR,ZINT,XVAL2,R(1,M2)) + ALPHA(I)=(XVAL1-XVAL2)/(2.0D0*AP) + 100 CONTINUE + RETURN + END +C + SUBROUTINE INPOT +C + IMPLICIT REAL*8 (A-H,O-Z) +C + INCLUDE 'msxas3.inc' +C + character*2 potgen + character*4 coor + character*5 potype + character*7 ionzst + character*2 edge,charelx + character*6 norman + integer absorber,hole + logical*4 vinput + + + common/options/rsh,ovlpfac,vc0,rs0,vinput,absorber,hole,mode, + & ionzst,potype,norman,coor,charelx,edge,potgen + +C +C**** CONT_SUB DIMENSIONING VARIABLES +C + INTEGER AT_,D_,RD_,SD_ + PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) +C +C**** +C + COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT +C + COMMON/MTRAD/ RS(NAT_) +C + DIMENSION XV(NAT_),YV(NAT_),ZV(NAT_),Z(NAT_),NEQ1(NAT_), + 1EXFACT(NAT_),NZ(NAT_),NSYMBL(NAT_),NEQ(NAT_),H(NAT_), + 2VCONS(2),R(441,UA_),V(441,UA_),ICHG(10,UA_),KPLACE(NAT_), + 3KMAX(NAT_),VINT(UA_),CHARGE(UA_,2),ROCON(2),RHO(441,UA_) +C 4,VC(441,UA_) +C + DIMENSION RTEMP(440),VTEMP(441,2),GAMMA(440,2),DENSTEMP(441,2) + EQUIVALENCE (VTEMP(1,1),BETA(1)),(ROTEMP(1,1),GAMMA(1,1)) + DIMENSION BETA(440),ROTEMP(440,2) +C DIMENSION VCTEMP(441) +C +C +CC**** CONT_SUB COMMON BLOCKS +C + COMMON /DENS/ IRHO2,RHOTOT2(RD_,SD_),RHOINT2(2), + $ vcoul(rd_,sd_),vcoulint(2) + REAL*4 RHOTOT2,RHOINT2,vcoul,vcoulint +C + COMMON /FCNR/KXE2, H2(D_),VCONS2(2),R2(RD_,D_),V2(2,RD_,SD_), + $ ICHG2(10,D_),KPLACE2(AT_),KMAX2(AT_) + REAL*4 H2,R2,V2 + COMPLEX VCONS2 +C + COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, + 1 IMVHL,NEDHLP +C + CHARACTER*8 NAME0 ,NSYMBL2 +C + REAL*4 EFTR2,GAMMA2,E2,RS2,XV2,YV2,ZV2 + REAL*4 EXFACT2,Z2,CIP,EMAX,EMIN,DE + COMPLEX VCON2,XE2,EV2 + COMMON/PARAM/EFTR2,GAMMA2,VCON2,XE2,EV2,E2,IOUT2,NAT2, + 1 NDAT2,NSPINS2,NAS2,RS2(AT_),XV2(AT_),YV2(AT_),ZV2(AT_), + 2 EXFACT2(AT_),Z2(AT_),LMAXX2(AT_),NZ2(AT_),NSYMBL2(AT_), + 4 NEQ2(AT_),NAME0,CIP,EMAX,EMIN,DE +C +C ############MODIFIED TO INCLUDE THE TWO CORE STATE WAVE FUNCTIONS +c ############FOR THE AUGER CALCULATION +c + common/pot_type/i_absorber,i_absorber_hole, + 1 i_absorber_hole1,i_absorber_hole2, + 2 i_norman,i_alpha,i_outer_sphere, + 3 i_exc_pot,i_mode + + + + + + +C +C***** +C +C + CHARACTER*8 NSYMBL +C + DATA PI/3.14159265358979D0/,THIRD/.333333333333333D0/ +C +C FORMAT FOR ALL FUNCTIONS OF RADIAL MESH POINTS +C FORMAT FOR ERROR MESSAGE IF INPUT CARD IS OUT OF ORDER +C + 400 FORMAT(' CARD',I5,' OUT OF SEQUENCE') + LOGICAL OUTER + READ(4) NAT,NDAT,NOUT,EXFAC0,NSPINS +C READ(10,8853)RADION,QION,NCUT,MOUT + + + IF(NCUT.EQ.0) NCUT=2 +C READ(10,8854)(RS(I),I=1,NAT) + IF (NAT.EQ.0) STOP 4602 + FAC1=NSPINS + IF(NOUT.EQ.0) WRITE(7,110) NAT + ROCON(2)=0 + ROCON(1)=0 + VCON=0.0D0 + IN = 0 +C +C IN=1 SECTION. INPUT DATA FROM MOLECULAR POTENTIAL PROGRAM +C + IF (IN.GT.1) GO TO 4300 + NC0=1 + 113 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,26H OUTER SPHERE AT CENTE + *R 1 ) + 110 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,17H NO OUTER SPHERE) + IF(NOUT.NE.0) WRITE(7,113)NAT + WRITE(7,8852)NCUT,RADION,QION +8852 FORMAT(30X,'NCUT=',I3,' RADION=',F7.3,' QION=', F7.1) + VOLUME=0.0D0 + DO 422 N=1,NAT + OUTER=NOUT.NE.0.AND.N.EQ.1 + READ(4) NSYMBL(N),NEQ(N),NZ(N),KMAX(N),XV(N),YV(N), + U ZV(N),EXFACT(N),NC + IF(NC.EQ.NC0+1) GO TO 423 + WRITE(7,400) NC + 423 NC0=NC + Z(N)=NZ(N) + IF(NEQ(N).NE.0) GO TO 439 + KMAXN=KMAX(N) + KMAXL=KMAXN +C +C CALCULATE RADIAL MESH FOR INPUT DATA +C + ZINO=Z(N) + IF(NZ(N) .EQ. 0) ZINO=1.D0 + HH=.0025D0*.88534138D0/ZINO**THIRD + RTEMP(1)=HH + KK=1 + K0=2 + DO 4285 I=1,11 + DO 4286 K=K0,40 + KK=KK+1 + IF(KK.GT.KMAXN) GO TO 1014 + 4286 RTEMP(KK)=RTEMP(KK-1)+HH + K0=1 + 4285 HH=2.0D0*HH + 1014 DO 1020 ISPIN=1,NSPINS +C +C READ STARTING POTENTIAL +C + DO 1019 K=1,KMAXN,5 + KCARD=MIN0(K+4,KMAXN) + READ(4) NC,( VTEMP(I,ISPIN),I=K,KCARD) + IF(NC.EQ.NC0+1) GO TO 1019 + WRITE(7,400) NC + 1019 NC0=NC + 1020 CONTINUE +C DO 1200 K=1,KMAXN,5 +C KCARD=MIN0(K+4,KMAXN) +C READ(4,1015) NC,( VCTEMP(I),I=K,KCARD) +C IF(NC.EQ.NC0+1) GO TO 1200 +C WRITE(7,400) NC +C ERROR=.TRUE. +C 1200 NC0=NC + DO 2720 ISPIN=1,NSPINS +C +C READ STARTING CH[AARGE DENSITY +C + DO 2723 K=1,KMAXN,5 + KCARD=MIN0(K+4,KMAXN) + READ(4) NC,(DENSTEMP(I,ISPIN),I=K,KCARD) + IF(NC.EQ.NC0+1) GO TO 2723 + WRITE(7,400) NC + 2723 NC0=NC + 2720 CONTINUE +C +C CONVERT INPUT DATA TO FORM FOR MOLECULAR CALCULATION +C + KMIN=1 + 428 KPL=(KMAXN+KMIN)/2 + IF(RTEMP(KPL)-RS(N)) 424,434,426 + 424 KMIN=KPL + IF(KMAXN-KMIN-1) 427,427,428 + 426 KMAXN=KPL + IF(KMAXN-KMIN-1) 427,427,428 + 427 KPL=KMIN + 434 KPL0=KPL + N40=40/NCUT + KPL=KPL/NCUT + IF(RTEMP(KPL*NCUT+NCUT)+RTEMP(KPL*NCUT)-2.D0*RS(N)) 429,430,430 + 429 KPL=KPL+1 + 430 IF(OUTER) GO TO 433 + KMAX(N)=KPL+3 + KMAXN=KMAX(N) + NMOD=MOD(KMAXN,N40) + IF(NMOD.GE.5.OR.NMOD.EQ.0) GO TO 431 + KMAXN=KMAXN-NMOD + 431 ICHGN=KMAXN + DO 432 K=1,KMAXN + KN=NCUT*K + R(K,N)=RTEMP(KN) + NS=N + DO 4320 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 4320 NS=NS+NDAT + 432 CONTINUE + IF(KMAXN.EQ.KMAX(N)) GO TO 441 + KX1=KMAXN+1 + KMAXN=KMAX(N)+1 + IF(NCUT.EQ.1) GO TO 435 + DO 436 K=KX1,KMAXN + KN=(KX1+K-1)*NCUT/2 + R(K,N)=RTEMP(KN) + NS=N + DO 4360 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 4360 NS=NS+NDAT + 436 CONTINUE + GO TO 440 + 435 DO 437 K=KX1,KMAXN + KN=(KX1+K-1)/2 + IF(2*((K-KX1+1)/2).EQ.(K-KX1+1)) GO TO 438 + R(K,N)=.5D0*(RTEMP(KN)+RTEMP(KN+1)) + NS=N + DO 4310 IS=1,NSPINS + CALL DINTERP(RTEMP(KN-3),VTEMP(KN-3 ,IS),7,R(K,N),V(K,NS),DUMMY, + 1 .FALSE.) +C CALL DINTERP(RTEMP(KN-3),VCTEMP(KN-3 ),7,R(K,N),VC(K,NS),DUMMY, +C 1 .FALSE.) + CALL DINTERP(RTEMP(KN-3),DENSTEMP(KN-3 ,IS),7,R(K,N), + 1 RHO(K,NS),DUMMY,.FALSE.) + 4310 NS=NS+NDAT + GO TO 437 + 438 R(K,N)=RTEMP(KN) + NS=N + DO 4311 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 4311 NS=NS+NDAT + 437 CONTINUE + 440 IF( ABS(R(KPL,N)-RS(N)).LE. ABS(R(KPL+1,N)-RS(N))) GO TO 441 + KPL=KPL+1 + KMAX(N)=KMAX(N)+1 + 441 KPLACE(N)=KPL + ICHG(1,N)=N40 + DO 443 K=2,10 + ICHG(K,N)=ICHG(K-1,N)+N40 + IF(ICHG(K,N).GE.ICHGN) ICHG(K,N)=400/NCUT + 443 CONTINUE + GO TO 448 +C +C.....FOR OUTER REGION +C + 433 KMIN=(KPL-3)*NCUT + KMAX(N)=MIN0((440/NCUT-KPL+4),200) + ICHG(1,N)=(40-MOD(KMIN,40))/NCUT+1 + ICHGN=1 + IF(ICHG(1,N).GT.4) GO TO 444 + ICHGN=ICHG(1,N)-1 + DO 445 K=1,ICHGN + KN=KMIN+NCUT*(2*K-ICHG(1,N)-1) + R(K,N)=RTEMP(KN) + NS=N + DO 445 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 445 NS=NS+NDAT + ICHG(1,N)=ICHG(1,N)+N40 + ICHGN=ICHGN+1 + 444 KMAXN=KMAX(N) + DO 446 K=ICHGN,KMAXN + KN=KMIN+(K-1)*NCUT + R(K,N)=RTEMP(KN) + NS=N + DO 446 IS=1,NSPINS + V(K,NS)=VTEMP(KN,IS) +C VC(K,NS)=VCTEMP(KN) + RHO(K,NS)=DENSTEMP(KN,IS) + 446 NS=NS+NDAT + DO 447 K=2,10 + 447 ICHG(K,N)=ICHG(K-1,N)+N40 + KPLACE(N)=4 +C +C.....FOR ATOMIC SPHERES +C + 448 NQ=N + K=KPL0 + IF(RTEMP(K+1)+RTEMP(K)-2.D0*RS(N).LT.0.0D0 ) K=KPL0+1 +C +C READ INTEGRATED POTENTIAL AND INTERPOLATE FOR VALUE ON BOUNDARY +C + DO 1016 KK=1,KMAXL,5 + KCARD=MIN0(KK+4,KMAXL) + READ(4) NC,(BETA(I),I=KK,KCARD) + IF(NC.EQ.NC0+1) GO TO 1016 + WRITE(7,400) NC + 1016 NC0=NC + CALL DINTERP(RTEMP(K-3), BETA(K-3),7,RS(N), VINT(N),DUMMY,.FALSE.) +C +C READ TOTAL CHARGE AND INTERPOLATE FOR VALUE ON BOUNDARY +C + DO 1022 ISPIN=1,NSPINS + DO 1021 KK=1,KMAXL,5 + KCARD=MIN0(KK+4,KMAXL) + READ(4) NC, (GAMMA(I,ISPIN),I=KK,KCARD) + IF(NC.EQ.NC0+1) GO TO 1021 + WRITE(7,400) NC + 1021 NC0=NC + 1022 CALL DINTERP(RTEMP(K-3),GAMMA(K-3,ISPIN),7,RS(N),CHARGE(N,ISPIN), + 1 DUMMY,.FALSE.) + GO TO 4281 +C +C.....FOR EQUIVALENT ATOMS +C + 439 NQ=NEQ(N) + KPLACE(N)=KPLACE(NQ) + 4281 IF(OUTER) GO TO 4280 + VOLUME=VOLUME-RS(N)**3 + VCON=VCON-VINT(NQ) + DO 455 IS=1,NSPINS + 455 ROCON(IS)=ROCON(IS)-CHARGE(NQ,IS) + IF(NEQ(N).NE.0) GO TO 422 + GO TO 4221 + 4280 VCON=VCON+VINT(NQ) + VOLUME=VOLUME+RS(N)**3 + DO 456 IS=1,NSPINS + 456 ROCON(IS)=ROCON(IS)+CHARGE(NQ,IS) + 4221 H(N)=R(2,N)-R(1,N) + 422 CONTINUE + VOLUME=1.3333333333333D0*PI*VOLUME + VCON=VCON/VOLUME + VCONC=VCON + IF (RADION.NE.0) THEN + DVSPH = -2.D0*QION/RADION + VCONC = VCONC + DVSPH + ENDIF + NS=1 + RH0 = 3.D0 / (NSPINS*4.D0*PI*RS0**3) +c write (*,*) ' vc0 =', vc0, ' rs0 =',rs0 + DO 453 IS=1,NSPINS + ROCON(IS)=ROCON(IS)/VOLUME + VCONS(IS)=VCON-6*EXFAC0*(3*FAC1*ROCON(IS)/(8*PI))**THIRD + VC0X = VC0 - 6*EXFAC0*(3*FAC1*RH0/(8*PI))**THIRD + IF(RADION.EQ.0) GO TO 453 + VCONS(IS)=VCONS(IS)+DVSPH + KX=KMAX(1) + DO 451 K=1,KX + IF(R(K,1).LT.RADION) GO TO 452 + V(K,NS)=V(K,NS)-2.D0*QION/R(K,1) +C VC(K,NS)=VC(K,NS)-2.*QION/R(K,1) + GO TO 451 + 452 V(K,NS)=V(K,NS)+DVSPH +C VC(K,NS)=VC(K,NS)+DVSPH + 451 CONTINUE + NS=NS+1 + DO 454 N=2,NDAT + KX=KMAX(N) + DO 450 K=1,KX +C VC(K,NS)=VC(K,NS)+DVSPH + 450 V(K,NS)=V(K,NS)+DVSPH + 454 NS=NS+1 + 453 CONTINUE + GO TO 4220 + 4300 WRITE(7,105) + 105 FORMAT(' IN IS EQUAL 2') +C +C OUTPUT AND CHECK FOR CONSISTENCY OF INPUT DATA +C + 4220 WRITE(7,111) + 111 FORMAT(30X,10HATOM NO.,12X,8HPOSITION,14X,13HRADIUS EQ ) + WRITE(7,112) (I,NSYMBL(I),NZ(I),XV(I),YV(I),ZV(I),RS(I),NEQ(I), + 1 I=1,NAT) + 112 FORMAT(26X,I3,A6,I6,4F10.4,I6) +C IF(NOUT.NE.0.AND.NOUT.NE.1) GO TO 205 +C GO TO 1130 +C 205 WRITE(7,200) I,J +C ERROR=.TRUE. + DO 211 I=1,NAT + IF(RS(I).LT.0.0D0) GO TO 213 + IF(NEQ(I).EQ.0)GO TO 210 + IF(NEQ(I).GE.I) GO TO 213 + 210 I1=I+1 + IF(NOUT.EQ.0) GO TO 212 + IF(NEQ(I).EQ.1) GO TO 213 + 212 IF(I1.GT.NAT) GO TO 216 + GO TO 2135 + 213 CONTINUE +C WRITE(6,200) I,J + 2135 DO 211 J=I1,NAT + RIJ = SQRT((XV(J)-XV(I))**2+(YV(J)-YV(I))**2+(ZV(J)-ZV(I))**2) + IF(NOUT.EQ.1.AND.I.EQ.1) GO TO 214 + RSUM = RS(I)+RS(J) + IF (RSUM.GT.RIJ) GO TO 215 + GO TO 211 + 214 RSUM = RIJ+RS(J) + IF (RSUM.GT.RS(1)) GO TO 215 + GO TO 211 + 215 CONTINUE +C WRITE (6,200) I,J,RSUM,RIJ,RDIF + 211 CONTINUE + 216 IF(RADION.EQ.0.0D0) GO TO 217 + IF(RADION.EQ.RS(1)) GO TO 217 + KX=KMAX(1) + DO 219 K=1,KX + IF(RADION.GT.R(K,1)) GO TO 219 + 219 CONTINUE + 217 CONTINUE + NDUMMY = 0 +C +C SHIFT BACK ORIGIN TO PHOTOABSORBER +C + X0=XV(2) + Y0=YV(2) + Z0=ZV(2) +C + DO 150 N=1,NAT + XV(N)=XV(N)-X0 + YV(N)=YV(N)-Y0 + ZV(N)=ZV(N)-Z0 + NEQ1(N)=0 + IF(NEQ(N).NE.0) NEQ1(N)=NEQ(N)-1 + 150 CONTINUE +C +C WRITE OUT POTENTIAL AND DENSITY FILES +C + IF (potype.EQ.'xalph') THEN + OPEN (19, FILE = 'div/XALPHA.POT', STATUS = 'unknown') + ELSE + OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown') + OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown') + ENDIF +C + INV = 20 + IF (potype.EQ.'xalph') INV = 19 + INRHO= 9 + NST=2 + NC=2 + DO 4401 N=NST,NAT + WRITE(INV,311) NSYMBL(N),NEQ1(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N), + 1 XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC + 311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5) + NC=NC+1 + IF(NEQ(N).NE.0) GO TO 4401 + WRITE(INV,308) (ICHG(I,N),I= 1,10),NC + 308 FORMAT(10I5,T76,I5) + NC=NC+1 + WRITE(INV,319) NC,(R(I,N),I=1,5) + 319 FORMAT(T76,I5,T2,1P5E14.7) + NS=N + NC=NC+1 + KX=KMAX(N) + NS = N + DO 142 ISPIN=1,NSPINS + DO 141 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INV,319) NC,(V(I,NS),I=K,KCARD) + 141 NC=NC+1 + 142 NS=NS+NDAT + NS=N + IF (potype.NE.'xalph') THEN + DO 555 ISPIN=1,NSPINS + DO 551 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INRHO,319) NC,(RHO(I,NS),I=K,KCARD) + 551 NC=NC+1 + 555 NS=NS+NDAT + ENDIF + 4401 CONTINUE +C + IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS) +C + IF (INV.EQ.20) THEN + WRITE(INV,319) NC, VCONC + + WRITE( INRHO,319) NC,(ROCON(IS),IS=1,NSPINS) + ENDIF +C +c CLOSE (4) + IF(potype.EQ.'xalph') THEN + CLOSE (UNIT=19) + ELSE + CLOSE (UNIT=20) + CLOSE (UNIT=9) + ENDIF +C +C CLOSE (UNIT=7) +C +C----------------------------------------------------------------------- +C +C PASS POTENTIAL AND/OR CHARGE DENSITY TO CONT_SUB. +C +C990 IF(IOUT_ASCII.NE.2) GO TO 999 +C +C----------------------------------------------------------------------- + NAT2=NAT-NOUT + NDAT2=NDAT-NOUT + NSPINS2=NSPINS +c +c A.Kuzmin 10.06.93 +c Correction of the atomic coordinates due to the outer +c sphere non central position +c + xv0=0.D0 + yv0=0.D0 + zv0=0.D0 +c if(nout.eq.1)then +c xv0=xv(1) +c yv0=yv(1) +c zv0=zv(1) +c endif +c +c End of correction +c + DO 780 I=1,NAT2 +C +C SKIP OUTER SPHERE +C + J=I+NOUT + NSYMBL2(I)=NSYMBL(J) + NZ2(I)=NZ(J) + + + IF(NEQ(J).EQ.0)THEN + NEQ2(I)=0 + ELSE + NEQ2(I)=NEQ(J)-NOUT + END IF + XV2(I)=SNGL(XV(J)-xv0) + YV2(I)=SNGL(YV(J)-yv0) + ZV2(I)=SNGL(ZV(J)-zv0) + Z2(I)=SNGL(Z(J)) + RS2(I)=SNGL(RS(J)) + EXFACT2(I)=SNGL(EXFACT(J)) + KMAX2(I)=KMAX(J) + KPLACE2(I)=KPLACE(J) + IF(NEQ(J).NE.0)GOTO 780 + DO 735 K=1,10 + ICHG2(K,I)=ICHG(K,J) +735 CONTINUE + H2(I)=SNGL(R(2,J)-R(1,J)) + ISDA=I + JSDA=J + DO 745 IS=1,NSPINS + DO 740 K=1,KMAX(J) + IF(IS.EQ.1)R2(K,ISDA)=SNGL(R(K,JSDA)) + RHOTOT2(K,ISDA)=SNGL(RHO(K,JSDA)) + V2(1,K,ISDA)=SNGL(V(K,JSDA)) + V2(2,K,ISDA)=0.0 +740 CONTINUE + ISDA=ISDA+NDAT2 + JSDA=JSDA+NDAT +745 CONTINUE +780 CONTINUE +C + RHKM1 = DBLE(RHOTOT2(KMAX2(1),1))/ + 1 (4.D0*PI*DBLE(R2(KMAX2(1),1))**2) + RHKM2 = DBLE(RHOTOT2(KMAX2(2),2))/ + 1 (4.D0*PI*DBLE(R2(KMAX2(2),2))**2) + RHKM = ( RHKM1 + RHKM2 ) / 2.D0 + RSKM = (3.D0 / ( 4.D0 * PI * RHKM * NSPINS ) ) ** THIRD + VCKM = DBLE((V2(1,KMAX2(1),1)+V2(1,KMAX2(2),2)))/2.D0 + + WRITE(*,*) ' input value for coulomb interst. potential =', + 1 real(vc0) + WRITE(*,*) ' and interstitial rs =', real(rs0) + WRITE(*,*) ' lower bound for coulomb interst. potential =', + 1 real(vckm) + WRITE(*,*) ' and for interst. rs =',real(rskm) + + DO 790 M=1,NSPINS + IF (VINPUT) THEN + VCONS2(M) = CMPLX(VC0X) + RHOINT2(M) = REAL(RH0) + ELSE + VCONS2(M)=CMPLX(SNGL(VCONS(M))) + RHOINT2(M)=SNGL(ROCON(M)) + ENDIF + 790 CONTINUE +C +C +C BRANCH POINT +C + RETURN + END +C + SUBROUTINE DINTERP(R,P,N,RS,PS,DPS,DERIV) + IMPLICIT REAL*8 (A-H,O-Z) + LOGICAL DERIV,NODRIV + DIMENSION R(N),P(N) + NODRIV=.NOT.DERIV + DPS=0.0D0 + PS=0.0D0 + DO 1 J=1,N + TERM=1.0D0 + DENOM=1.0D0 + DTERM=0.0D0 + DO 2 I=1,N + IF(I.EQ.J) GO TO 2 + DENOM=DENOM*(R(J)-R(I)) + TERM=TERM*(RS-R(I)) + IF(NODRIV) GO TO 2 + DTERM1=1.0D0 + DO 3 K=1,N + IF(K.EQ.J.OR.K.EQ.I) GO TO 3 + DTERM1=DTERM1*(RS-R(K)) + 3 CONTINUE + DTERM=DTERM+DTERM1 + 2 CONTINUE + IF(NODRIV) GO TO 1 + DPS=DPS+DTERM*P(J)/DENOM + 1 PS=PS+TERM*P(J)/DENOM + RETURN + END +c----------------------------------------------------------------------- +C + SUBROUTINE CSBF(X0,Y0,MAX,SBF,DSBF) + IMPLICIT REAL*8(A-H,O-Z) + REAL*8 XF1 + COMPLEX*8 X0,Y0 + COMPLEX*16 X,Y,RAT,DSBF1,Z,SBFJ,B,A + COMPLEX*16 SBFK,SBF1,SBF2 + COMPLEX*16 SBF,DSBF + INTEGER MAX,K,JMIN,KMAX + DIMENSION SBF(MAX), DSBF(MAX) +C +C +C GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR +C FIRST DERIVATIVES WITH RESPECT TO R. X=ARGUMENT= Y*R. +C IF Y=0, NO DERIVATIVES ARE CALCULATED. MAX MUST BE AT LEAST 3. +C OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS. MSBF - MODI- +C FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS; +C MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS +C +C +C + X=DCMPLX(X0) + Y=DCMPLX(Y0) + + IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 + IF(ABS(X).LT.0.50D0 ) GO TO 18 +C +C BESSEL FUNCTIONS BY DOWNWARD RECURSION +C + SBF2=(0.0D0,0.0D0) + SBF1=1.0D-25*(0.5D0,0.5D0) + IF(ABS(X).LT.2.0D0) SBF1=1.0D-38*(0.5D0,0.5D0) + JMIN=10+INT(ABS(X)) + KMAX=MAX+JMIN-1 + K=MAX + XF1=2*KMAX+1 + DO 10 J=1,KMAX + SBFK=XF1*SBF1/X-SBF2 + SBF2=SBF1 + SBF1=SBFK + XF1=XF1-2.0D0 + IF (J.LT.JMIN) GO TO 10 + SBF(K)=SBFK + K=K-1 +10 CONTINUE + RAT=SIN(X)/(X*SBF(1)) + DO 17 K=1,MAX + 17 SBF(K)=RAT*SBF(K) + DSBF1=-SBF(2) + GO TO 26 +C +C SMALL ARGUMENTS +C + 18 Z=-(X*X*0.50D0) + A=(1.0D0,0.0D0) + MMX=MAX + IF (MAX.EQ.1.AND.Y.NE.(0.0D0,0.0D0)) MMX=2 + DO 30 J=1,MMX + SBFJ=A + B=A + DO 31 I=1,20 + B=B*Z/(I*(2*(J+I)-1)) + SBFJ=SBFJ+B + IF (ABS(B).LE.1.0D-07*ABS(SBFJ)) GO TO 29 + 31 CONTINUE +29 IF (J.EQ.2) DSBF1=-SBFJ + IF (J.LE.MAX) SBF(J)=SBFJ + 30 A=A*X/DCMPLX(FLOAT(2*J+1)) +C +C +26 IF (Y.EQ.(0.0D0,0.0D0)) RETURN + DSBF(1)=Y*DSBF1 + IF (MAX.EQ.1) RETURN + DO 9 I=2,MAX + 9 DSBF(I)=Y*(SBF(I-1)- DCMPLX(FLOAT(I))*SBF(I)/X) + RETURN +99 WRITE(6,100) MAX +100 FORMAT (' SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8) + STOP + END +C +c + subroutine cshf2(x0,y0,max,sbf,dsbf) + implicit real*8(a-h,o-z) + real*8 xf1 + complex*8 x0,y0 + complex*16 x,y,rat,z,sbfj,b,a + complex*16 sbfk,sbf1,sbf2,cplu + complex*16 sbf,dsbf + integer max,k,jmin,kmax + dimension sbf(max), dsbf(max) +c +c cshf2 - May 1992 +c generates spherical hankel functions of type 2 of order 0 - max-1. +c max must be at least 3. cshf2 is calculated as csbf - i*csnf, wher +c csbf(csnf) are spherical Bessel(Neuman) functions. csbf(csnf) are +c calculated using downward(upward) recurrence realations. +c ***** This subroutine returns i*cshf2 = csnf + i*csbf and its +c derivative if y0 ne. 0. In this case dsbf = i*y0*(cshf")'*** +c +c + cplu = (0.d0,1.d0) +c + x=dcmplx(x0) + y=dcmplx(y0) + + if (max.lt.1.or.max.gt.2000) go to 99 + if(abs(x).lt.0.50D0 ) go to 18 +c +c bessel functions sbf by downward recursion +c + sbf2=(0.0D0,0.0D0) + sbf1=1.0D-25*(0.5D0,0.5D0) + if(abs(x).lt.2.0D0) sbf1=1.0d-38*(0.5D0,0.5D0) + jmin=10+int(abs(x)) + kmax=max+jmin-1 + k=max + xf1=2*kmax+1 + do 10 j=1,kmax + sbfk=xf1*sbf1/x-sbf2 + sbf2=sbf1 + sbf1=sbfk + xf1=xf1-2.0d0 + if (j.lt.jmin) go to 10 + sbf(k)=sbfk + k=k-1 +10 continue + rat=sin(x)/(x*sbf(1)) + do 17 k=1,max + 17 sbf(k)=rat*sbf(k) + go to 2 +c +c sbf for small arguments +c + 18 z=-(x*x*0.50D0) + a=(1.0D0,0.0D0) + mmx=max + if (max.eq.1.and.y.ne.(0.0D0,0.0D0)) mmx=2 + do 30 j=1,mmx + sbfj=a + b=a + do 31 i=1,20 + b=b*z/(i*(2*(j+i)-1)) + sbfj=sbfj+b + if (abs(b).le.1.0d-07*abs(sbfj)) go to 29 + 31 continue + 29 if (j.le.max) sbf(j)=sbfj + 30 a=a*x/ dcmplx(float(2*j+1)) +c +c spherical neumann functions snf by upward recursion +c damped in dsbf +c + 2 sbf2=-cos(x)/x + sbf1=(sbf2-sin(x))/x + dsbf(1)=sbf2 + if (max.eq.1) go to 26 + dsbf(2)=sbf1 + if (max.eq.2) go to 26 + xf1=3.0d0 + do 22 i=3,max + sbfk=xf1*sbf1/x-sbf2 + dsbf(i)=sbfk + sbf2=sbf1 + sbf1=sbfk +22 xf1=xf1+2.0d0 +c +c hankel functions as sbf + i*snf +c + do 3 i=1,max + 3 sbf(i) = cplu*sbf(i) + dsbf(i) + +26 if (y.eq.(0.0D0,0.0D0)) return +c +c calculate derivative of shf +c + dsbf(1) = -y*sbf(2) + if (max.eq.1) return + do 9 i=2,max + 9 dsbf(i)=y*(sbf(i-1)- dcmplx(float(i))*sbf(i)/x) + return +99 write(6,100) max +100 format (' spherical bessel function routine - max=',i8) + stop + end +c + SUBROUTINE DEFINT(F,R,KMAX,ICHG,A,ID) + DIMENSION F(KMAX),R(KMAX),ICHG(10) + COMPLEX F,A,F0 +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=R(2)-R(1) + A0=0.0 + K0=0 + IF (ID.NE.1) GO TO 11 + F0=(0.0,0.0) + GO TO 12 + 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) +12 KX=KMAX + N=1 + A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* + 1 F(K0+4))/S720 + A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* + 1 F(K0+4))/S720 + A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* + 1 F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + KICH=K-ICHG(N) + IF (KICH.EQ.1) GO TO 30 + IF (KICH.EQ.2) GO TO 40 + A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 + GO TO 50 +30 H=H+H + A=A+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 + GO TO 50 +40 N=N+1 + A=A+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 +50 CONTINUE + RETURN + END +C +C +C + SUBROUTINE defint0(F,DX,KMAX,A,ID) + COMPLEX F, A, A0, F0 + DIMENSION F(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=DX + A0=0.0 + K0=0 + IF (ID.NE.1) GO TO 11 + F0=(0.0,0.0) + GO TO 12 + 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) +c 11 F0 = F(1) +c K0 = 1 +c write(6,*) 'defint', f0 +12 KX=KMAX + N=1 + A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* + 1 F(K0+4))/S720 + A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* + 1 F(K0+4))/S720 + A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* + 1 F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 +50 CONTINUE + RETURN +C + END +C +C + SUBROUTINE defint1(F,DX,KMAX,A,ID) + COMPLEX F, A, A0, F0 + DIMENSION F(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=DX + A0=0.0 + K0=0 + IF (ID.NE.1) GO TO 11 + F0=(0.0,0.0) + GO TO 12 +c 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) + 11 F0 = F(1) + K0 = 1 +12 KX=KMAX + N=1 + A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* + 1 F(K0+4))/S720 + A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* + 1 F(K0+4))/S720 + A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* + 1 F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 +50 CONTINUE + RETURN +C + END +C +C + SUBROUTINE INTEGR(F,R,KMAX,ICHG,A,ID) + DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=R(2)-R(1) + A0=0.0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=0.0 + GO TO 12 + 11 K0=1 + A(1)=0.0 + F0=F(1) +12 KX=KMAX + N=1 + A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F + 1 (K0+4))/S720 + A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S + 1 11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 + 1 9*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + KICH=K-ICHG(N) + IF (KICH.EQ.1) GO TO 30 + IF (KICH.EQ.2) GO TO 40 + A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 + GO TO 50 +30 H=H+H + A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 + GO TO 50 +40 N=N+1 + A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C + SUBROUTINE CINTEGR(F,R,KMAX,ICHG,A,ID) + COMPLEX F,A,F0 + DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=R(2)-R(1) + A0=0.0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=(0.0,0.0) + GO TO 12 + 11 K0=1 + A(1)=(0.0,0.0) + F0=F(1) +12 KX=KMAX + N=1 + A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F + 1 (K0+4))/S720 + A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S + 1 11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 + 1 9*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + KICH=K-ICHG(N) + IF (KICH.EQ.1) GO TO 30 + IF (KICH.EQ.2) GO TO 40 + A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 + GO TO 50 +30 H=H+H + A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 + GO TO 50 +40 N=N+1 + A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C +C + SUBROUTINE INTEGRCM(F,DX,KMAX,A,ID) + COMPLEX F,A,F0 + DIMENSION F(KMAX),A(KMAX) +C + DATA S720,S251,S646,S264 /720.,251.,646.,264./ +C + DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ +C + H=DX + A0=0.0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=(0.0,0.0) + GO TO 12 + 11 K0=1 + A(1)=(0.0,0.0) + F0=F(1) +12 KX=KMAX + A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F + 1 (K0+4))/S720 + A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S + 1 11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 + 1 9*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C +C + SUBROUTINE INTEGRCMDP(F,DX,KMAX,A,ID) + COMPLEX*16 F,A,F0 + REAL*8 S106,S19,S346,S456,S74,S11,S720,S251,S646,S264,A0 + DIMENSION F(KMAX),A(KMAX) +C + DATA S720,S251,S646,S264 /720.D0,251.D0,646.,264.D0/ +C + DATA S106,S19,S346,S456,S74,S11 /106.0D0,19.0D0,346.0D0,456.0D0, + 1 74.0D0,11.0D0/ +C + H=DX + A0=0.0D0 + IF (ID.NE.1) GO TO 11 + K0=0 + F0=(0.0D0,0.0D0) + GO TO 12 + 11 K0=1 + A(1)=(0.0D0,0.0D0) + F0=F(1) +12 KX=KMAX + A(K0+1)=A0+DBLE(H)*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+ + 1 S106*F(K0+3)-S19*F(K0+4))/S720 + A(K0+2)=A(K0+1)+DBLE(H)*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)- + 1 S74*F(K0+3)+S11*F(K0+4))/S720 + A(K0+3)=A(K0+2)+DBLE(H)*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+ + 1 S346*F(K0+3)-S19*F(K0+4))/S720 + K0=K0+4 + DO 50 K=K0,KX + A(K)=A(K-1)+DBLE(H)*( 9.0D0*F(K)+19.0D0*F(K-1)-5.0D0*F(K-2)+ + 1 F(K-3))/24.0D0 +50 CONTINUE + IF (MOD(ID,2).NE.0) RETURN + DO 150 K=1,KMAX +150 A(K)=A(KMAX)-A(K) + RETURN +C # + END +C +C + SUBROUTINE INTERP(R,P,N,RS,PS,DPS,DERIV) + LOGICAL DERIV,NODRIV + DIMENSION R(N),P(N) + COMPLEX P,PS,DPS + NODRIV=.NOT.DERIV + DPS=(0.0,0.0) + PS=(0.0,0.0) + DO 1 J=1,N + TERM=1.0 + DENOM=1.0 + DTERM=0.0 + DO 2 I=1,N + IF(I.EQ.J) GO TO 2 + DENOM=DENOM*(R(J)-R(I)) + TERM=TERM*(RS-R(I)) + IF(NODRIV) GO TO 2 + DTERM1=1.0 + DO 3 K=1,N + IF(K.EQ.J.OR.K.EQ.I) GO TO 3 + DTERM1=DTERM1*(RS-R(K)) + 3 CONTINUE + DTERM=DTERM+DTERM1 + 2 CONTINUE + IF(NODRIV) GO TO 1 + DPS=DPS+DTERM*P(J)/DENOM + 1 PS=PS+TERM *P(J)/DENOM + RETURN +C + END +C + SUBROUTINE INTERPR(R,P,N,RS,PS,DPS,DERIV) + LOGICAL DERIV,NODRIV + DIMENSION R(N),P(N) + NODRIV=.NOT.DERIV + DPS=0.0 + PS=0.0 + DO 1 J=1,N + TERM=1.0 + DENOM=1.0 + DTERM=0.0 + DO 2 I=1,N + IF(I.EQ.J) GO TO 2 + DENOM=DENOM*(R(J)-R(I)) + TERM=TERM*(RS-R(I)) + IF(NODRIV) GO TO 2 + DTERM1=1.0 + DO 3 K=1,N + IF(K.EQ.J.OR.K.EQ.I) GO TO 3 + DTERM1=DTERM1*(RS-R(K)) + 3 CONTINUE + DTERM=DTERM+DTERM1 + 2 CONTINUE + IF(NODRIV) GO TO 1 + DPS=DPS+DTERM*P(J)/DENOM + 1 PS=PS+TERM *P(J)/DENOM + RETURN +C + END +C +C +C + SUBROUTINE SORT(NINI,VALIN,NFIN,VALFIN) +C +C Given a set of **real** numbers VALINI, this routine orders them and +C suppresses the values appearing more than once. The remaining +C values are stored in VALFIN. +C +C VALINI(K+1).GT.VALINI(K) : decreasing order +C VALINI(K+1).LT.VALINI(K) : increasing order +C +C + DIMENSION VALIN(NINI),VALINI(NINI),VALFIN(NINI) +C + LOGICAL BUBBLE +C + DATA SMALL /0.00001/ +C +C.....STORE INPUT ARRAY +C + DO I=1,NINI + VALINI(I)=VALIN(I) + ENDDO +C + DO J=1,NINI-1 + K=J + BUBBLE=.TRUE. +150 IF(K.GE.1.AND.BUBBLE) THEN + IF(VALINI(K+1).LT.VALINI(K)) THEN + R1=VALINI(K) + VALINI(K)=VALINI(K+1) + VALINI(K+1)=R1 + ELSE + BUBBLE=.FALSE. + END IF + K=K-1 + GOTO 150 + ENDIF + ENDDO +C + JFIN=1 + VALFIN(1)=VALINI(1) + DO J=1,NINI-1 + IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN + JFIN=JFIN+1 + VALFIN(JFIN)=VALINI(J+1) + ENDIF + ENDDO + NFIN=JFIN +C + RETURN +C + END +C +C + SUBROUTINE STARTP(ZZ0,L,E,R,V,KMAX,KI,P) +C + IMPLICIT COMPLEX*16 (A-B) + REAL*4 ZZ0,R + REAL*8 XL,Z0,H,RC +C + COMPLEX*8 V + COMPLEX*16 P,Z +C + DIMENSION R(KMAX),V(KMAX),Z(300),P(KMAX) +C 1,ZA(150) +C + Z0=DBLE(ZZ0) + RC = 1.0D0 +C IF(L.GT.10) RC = 0.01/R(1) + KM=KI/4 + IF(KI.EQ.1) KM=1 + KI1=KI+2 + DO 1 K=1,KI1 + 1 Z(K)=DCMPLX(R(K)*V(K)) + XL=DFLOAT(L) + H=DBLE(KM*R(1)) + B1=-2.0D0*Z0 + B2=(22.D0*Z0+18.D0*Z(KM)-9.D0*Z(2*KM)+2.D0*Z(3*KM))/(6.D0*H)- + 1 DBLE(E) + B3=(-12.D0*Z0-15.D0*Z(KM)+12.D0*Z(2*KM)-3.D0*Z(3*KM))/(6.D0*H*H) + B4=(2.D0*Z0+3.D0*Z(KM)-3.D0*Z(2*KM)+Z(3*KM))/(6.D0*H**3) + A1=-Z0/(XL+1.0D0) + A2=(B1*A1+B2)/(4.0D0*XL+6.0D0) + A3=(B1*A2+B2*A1+B3)/(6.0D0*XL+12.0D0) + A4=(B1*A3+B2*A2+B3*A1+B4)/(8.0D0*XL+20.0D0) + A5=(B1*A4+B2*A3+B3*A2+B4*A1)/(10.D0*XL+30.D0) + A6=(B1*A5+B2*A4+B3*A3+B4*A2)/(12.D0*XL+42.D0) + A7=(B1*A6+B2*A5+B3*A4+B4*A3)/(14.D0*XL+56.D0) + DO 4 K=1,KI1 + 4 P(K)=DCMPLX((1.0D0+DBLE(R(K))*(A1+DBLE(R(K))*(A2+DBLE(R(K))* + 1 (A3+DBLE(R(K))*(A4+DBLE(R(K))*(A5+DBLE(R(K))* + 2 (A6+DBLE(R(K))*A7)))))))*(DBLE(R(K))*RC)**(L+1)) +C DO 2 K=1,KI1 +C 2 ZA(K)=B1+R(K)*(B2+(R(K)*(B3+R(K)*B4))) +C WRITE(6,3) (I,(R(I+J-1),Z(I+J-1),ZA(I+J-1),J=1,2),I=1,KI1,2) + RETURN + END +C + subroutine rhl(erl,eim,pi) +c +c +c this is a new hl subroutine, using interpolation for the +c real part while calculating the imaginary part is calculated +c analitically. +c it uses hl to calculate values at the mesh points for the inter +c polation of the real part. the imaginary part is calculated +c using subroutine imhl. +c +c written by jose mustre +c polynomial in rs has a 3/2 power term. j.m. +c + implicit double precision (a-h,o-z) + common /corr/ rs,blt,xk1,vii,index2 + common /hlin/ xk + common /cusp/ icusp +c +c for the right branch the interpolation has the form: +c hl(rs,x) = e/x + f/x**2 + g/x**3 +c where e is known and +c f = sum (i=1,3) ff(i) rs**(i+1)/2 +c g = sum (i=1,3) gg(i) rs**(i+1)/2 +c +c +c lrs=number of rs panels, in this case one has 4 panels +c nrs=number of standard rs values, also order of rs expansion +c if you change nrs you need to change the expansion of hl +c in powers of rs that only has 3 terms! +c nleft=number of coefficients for xx0 +c + parameter (lrs=4,nrs=3,nleft=4,nright=2) + dimension rcfl(lrs,nrs,nleft),rcfr(lrs,nrs,nright) + dimension cleft(nleft),cright(nright) + data conv /1.9191583/ + data rcfr/-0.173963d+00,-0.173678d+00,-0.142040d+00,-0.101030d+00, + 1 -0.838843d-01,-0.807046d-01,-0.135577d+00,-0.177556d+00, + 2 -0.645803d-01,-0.731172d-01,-0.498823d-01,-0.393108d-01, + 3 -0.116431d+00,-0.909300d-01,-0.886979d-01,-0.702319d-01, + 4 0.791051d-01,-0.359401d-01,-0.379584d-01,-0.419807d-01, + 5 -0.628162d-01, 0.669257d-01, 0.667119d-01, 0.648175d-01/ + data rcfl/ 0.590195d+02, 0.478860d+01, 0.812813d+00, 0.191145d+00, + 1 -0.291180d+03,-0.926539d+01,-0.858348d+00,-0.246947d+00, + 2 0.363830d+03, 0.460433d+01, 0.173067d+00, 0.239738d-01, + 3 -0.181726d+03,-0.169709d+02,-0.409425d+01,-0.173077d+01, + 4 0.886023d+03, 0.301808d+02, 0.305836d+01, 0.743167d+00, + 5 -0.110486d+04,-0.149086d+02,-0.662794d+00,-0.100106d+00, + 6 0.184417d+03, 0.180204d+02, 0.450425d+01, 0.184349d+01, + 7 -0.895807d+03,-0.318696d+02,-0.345827d+01,-0.855367d+00, + 8 0.111549d+04, 0.156448d+02, 0.749582d+00, 0.117680d+00, + 9 -0.620411d+02,-0.616427d+01,-0.153874d+01,-0.609114d+00, + 1 0.300946d+03, 0.109158d+02, 0.120028d+01, 0.290985d+00, + 2 -0.374494d+03,-0.535127d+01,-0.261260d+00,-0.405337d-01/ + +c +c calcualte hl using interplation coefficients +c + rkf=conv/rs + ef=rkf*rkf*0.5D0 + wp=sqrt(3.0D0/rs**3) + call imhl (erl,eim,pi) + eim=eim +c +c eim already has a factor of ef in it j.m. +c eim also gives the position of the cusp +c + xx=xk1/rkf +c +c calculate right hand side coefficients +c + if (rs .lt. 0.2D0) then + mrs=1 + go to 209 + endif + if (rs .ge. 0.2D0 .and. rs .lt. 1.0D0) then + mrs=2 + go to 209 + endif + if (rs .ge. 1.0D0 .and. rs .lt. 5.0D0) then + mrs=3 + go to 209 + endif + if (rs .ge. 5.0D0) mrs=4 + 209 do 210 j=1,nright + cright(j)=rcfr(mrs,1,j)*rs+rcfr(mrs,2,j)*rs*sqrt(rs) + 1 +rcfr(mrs,3,j)*rs*rs +c +c jm written this way to calculate powers of rs quicker. +c cright(j)=0.0 +c do 205 k=1,nrs +c 205 cright(j)=cright(j)+rcfr(mrs,k,j)*rs**((k+1.)/2.) + 210 continue + eee=-pi*wp/(4.0D0*rkf*ef) +c + if (icusp .ne. 1) then + do 230 j=1,nleft + cleft(j)=rcfl(mrs,1,j)*rs+rcfl(mrs,2,j)*rs*sqrt(rs) + 1 +rcfl(mrs,3,j)*rs*rs +c cleft(j)=0.0 +c do 225 k=1,nrs +c 225 cleft(j)=cleft(j)+rcfl(mrs,k,j)*rs**((k+1.)/2.) + 230 continue +c + erl=cleft(1) + do 250 j=2,nleft + 250 erl=erl+cleft(j)*xx**(j-1) +c + else +c +c right branch +c + erl=eee/xx + do 280 j=1,nright + 280 erl=erl+cright(j)/xx**(j+1) + endif +c + erl=erl*ef + return + end +c +c +c + subroutine imhl(erl,eim,pi) +C +c********************************************************************** +c********************************************************************** +C +c writen by j. mustre march 1988 based on analytical expression derived +c by john rehr. +c it leaves the real part unchanged. +C +c********************************************************************** +c********************************************************************** + implicit double precision (a-h,o-z) + common /corr/rs,blt,xk1,vii,index2 + common/hlin/xk + common /cusp/ icusp + common/inter/wp,alph,ef,xf + common/cube/a0,a1,a2 + external ffq + icusp=0 + fa=1.9191583D0 + xf=fa/rs + ef=xf*xf/2.0D0 + xk=xk1 + xk=xk/xf +c +c wp is given in units of the fermi energy in the formula below. +c + wp=sqrt(3.0D0/(rs*rs*rs))/ef + alph=4.0D0/3.0D0 +c write(*,225) +c 225 format(1x'xk,wp') +c write(*,*)xk,wp + xs=wp*wp-(xk*xk-1.0D0)**2 +c write (*,*)xs + if (xs .ge. 0.D0) go to 10 + q2=sqrt((sqrt(alph*alph-4.0D0*xs)-alph)/2.0D0) + qu=min(q2,(1.0D0+xk)) + d1=qu-(xk-1.0D0) + if(d1.gt.0.D0) goto 11 + 10 eim=0.0D0 + go to 20 + 11 eim=ffq(qu)-ffq((xk-1.0D0)) + +c write(*,223) +c 223 format(1x'xk,eim,d1') +c write(*,*)xk,eim,d1 + 20 call cubic (rad,qplus,qminus) +c write(*,224) +c 224 format(1x'xk,rad,qplus,qminus') +c write(*,*)xk,rad,qplus,qminus + if (rad.gt. 0.0D0) goto 32 + d2=qplus-(xk+1.0D0) + if(d2.gt.0.D0)go to 21 + eim=eim + go to 30 + 21 eim=eim+ffq(qplus)-ffq((xk+1.0D0)) +c write(*,221) +c 221 format(1x'xk,eim,d2') +c write (*,*)xk,eim,d2 + 30 d3=(xk-1.0D0)-qminus + if(d3.gt.0.D0)go to 31 + return + 31 eim=eim+ffq((xk-1.0D0))-ffq(qminus) +c +c beginning of the imaginary part and position of the cusp x0 +c + icusp=1 +c write(*,222) +c 222 format(1x'xk,eim,d3') +c write (*,*)xk,eim,d3 + 32 return + end +c +c +c + subroutine cubic ( rad,qplus,qminus) + implicit double precision (a-h, o-z) + complex*16 s1,s13 + common/hlin/xk + common/inter/wp,alph,ef,xf + common/cube/a0,a1,a2 +c +c this subroutine finds the roots of the equation +c 4xk*q^3+(alph-4xk^2)q^2+wp^2=0. +c see abramowitz and stegun for formulae. + + a2=(alph/(4.0D0*xk*xk)-1.0D0)*xk + a0=wp*wp/(4.0D0*xk) + a1=0.0D0 + q=a1/3.0D0-a2**2/9.0D0 + r=(a1*a2-3.0D0*a0)/6.0D0-a2**3/27.0D0 + rad=q**3+r**2 + if (rad .gt. 0.0D0) then + qplus=0.0D0 + qminus=0.0D0 + return + endif + s13=dcmplx(r,sqrt(-rad)) + s1=s13**(1.0D0/3.0D0) + qz1=2.0D0*dreal(s1)-a2/3.0D0 + qz3=-(dreal(s1)-dsqrt(3.0D0)*dimag(s1)+a2/3.0D0) + qplus=qz1 + qminus=qz3 + return + end +c +c +c + double precision function ffq(q) + implicit double precision (a-h,o-z) + common /corr/rs,blt,xk1,vii,index2 + common /hlin/xk + common /inter/wp,alph,ef,xf + wq=sqrt(wp*wp+alph*q*q+q*q*q*q) + ffq=(wp+wq)/(q*q)+alph/(2.0D0*wp) +c +c check prefactor (wp/4xk) to see if units are correct. +c + ffq=(ef*wp/(4.0D0*xk1))*log(ffq) + return + end + + subroutine cont_sub(potype,potgen,lmax_mode,lmaxt,relc, + & eikappr,db) +c +c.... continuum program version for phase shift calculation: +c.... february 1990 +c + include 'msxas3.inc' +c include 'msxasc3.inc' + + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $ n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common /dens/ irho,rhotot(rd_,sd_),rhoint(2), + $ vcoul(rd_,sd_),vcoulint(2) +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex v,vcons +c + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + + character*8 name0 ,nsymbl +c + common /param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + + complex vcon,xe,ev +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_), + * ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c +c ##############common /pdqi/ modified to include the two wavefuncti +c ############### for the final two holes state in the Auger decay r +c + common /pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_) +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + character*2 potgen,relc + character*3 eikappr + character*5 potype +c + logical do_r_in +c +c write(6,11) jat,jd,jf,jlmax,jn,jrd,jsd,j1d +c +c 11 format('0 final state parameters:' +c $ /'0 jat =',i6,2x,'number of centers (tb)' +c $ /'0 jd =',i6,2x,'number of inequivalent centers (nun)' +c $ /'0 jf =',i6,2x,'storage location for radial functions:=10' +c $ /'0jlmax =',i6,2x,'maximum l-value on any atomic sphere' +c $ /'0 jn =',i6,2x,'number of basis functions on all atoms' +c $ /'0 jrd =',i6,2x,'maximum number of radial mesh points (npt)' +c $ /'0 jsd =',i6,2x,'nspins*jd (for spin restriction)' +c $ /'0 j1d =',i6,2x,'is jd+1') +c +c +c +ctn write(30,13) +ctn 13 format(2x,' e xe natom l ' +ctn $ ' atmat ') +c +C WARNING: COMMONS /FCNR/ AND /PARAM/ ARE AVAILABLE ONLY AFTER SUBROUTINE +C INPUT_CONT IS CALLED +c +c do not change in this version! + nns=1 +c*********************************************************************** +c get initial state radial function +c*********************************************************************** +c + print 660 +660 format( 1x,' generating core state wavefunction ') +c + call get_core_state +c +c*********************************************************************** +c compute parameters for final state and call subroutine cont +c*********************************************************************** +c + id=1 +c + + call input_cont(id,potype,potgen,lmax_mode,lmaxt) + + call output_cont(id) +c + call setup +c + vcon=vcons(nns) +c + write(6,10) eftr + 10 format(/,1x,' fermi level =', f10.5,/) +c + emmef=emin-eftr + if(emmef.lt.0.0) write(6,556) emin,eftr + 556 format(/,' ***warning***: emin=',f10.5,' less than the fermi ', + * 'level eftr=',f10.5, 'a stop is caused in the case ', + * 'of hedin-lundqvist potential') + if(emmef.lt.0.0.and.irho.ne.0) then + print 780 +780 format (//,1x, 'emin less than the Fermi level; see file: ', + * ' results.dat',//) + stop + endif +c + print 770 +770 format( 1x,' generating t_l (for030) and', + &' atomic cross section (for050)') +c +c construct log-linear x mesh +c + call llmesh +c +c and generate core state wavefunction on log-linear x-mesh +c + call corewf(nas,nz(nas),i_absorber_hole) +c + call cont(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db) +c + + return + end +c +c + subroutine cont(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db) +c +c include 'mscalc.inc' + include 'msxas3.inc' + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +c + common/bessel/sbf(ltot_),dsbf(ltot_),snf(ltot_),dsnf(ltot_) + complex*16 sbf,dsbf,snf,dsnf +c + common /dens/ irho,rhotot(rd_,sd_),rhoint(2), + $ vcoul(rd_,sd_),vcoulint(2) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +c + COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), + & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), + & RAMFSOA(N_) + COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA +c + common /seculrx/ atmnr(n_), atmsr(n_), atmsop(n_), atmsoa(n_) + complex atmnr, atmsr, atmsop, atmsoa +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c + common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), + & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), + & dxxdir,dxxexc + complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, + & dxxdir,dxxexc +c + character*8 name0 ,nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,argc,yc,p3irreg, + & p2irreg + real*4 einc,esct,scangl,qt,lambda +c + common/msbhf/ il(rdx_,lexp_,d_), kl(rdx_,lexp_,d_), kappa + dimension msbfi(lexp_), mshfk(lexp_), ylc(lexp_*(lexp_+1)) + dimension dmsbfi(lexp_), dmshfk(lexp_) + real*8 kappa, arg, y, msbfi, mshfk, il, kl, dmsbfi, dmshfk +c + common/struct/ntnabs(nat_),ngbrabs +c +c ############# I include the common auger to take into account also the +c ############# to make the auger calculation +c + + common/auger/calctype,expmode,edge1,edge2 + + character*3 calctype, expmode + character*2 edge1,edge2 + + common /pdq/ p(rd_,f_),ps(n_),dps(n_), + * ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss + +c ###################common /pdqi/ modified to include the two core hole +c ##################of the electrons which interacts and give rise +c + common /pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_) +c + common /seculr/ atm(n_) + complex*16 atm +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/lparam/lmax2(nat_),l0i +c + common/typot/ ipot +c + complex amem,amem1,pamel,pamel0,cofct,vrr,qcofct,rexsrme,rexssme +c + dimension es(nep_),xkrn(rd_),xkri(rd_),xkrs(d_),cofct(nep_,2) + dimension qcofct(nep_,3) +c + logical*4 doit, do_r_in + logical*4 xasxpd +c +c fortran units +c + common/funit/idat,iwr,iphas,iedl0,iwf + +c + complex atmd +c + dimension distin(d_), distor(d_), ntnabs1(nat_) + character*20 correction + character*9 reg_type,irr_type + character*5 potype + character*4 spectro + character*2 potgen,relc + character*8 filename + character*3 eikappr +c + data facts/8.067/,ot/.3333333/,pai/3.1415927/ + data fsc,fscs4 /7.29735e-3,1.331283e-5/ +c +c.....facts=4.*(pi)**2/137*(0.529)**2*100.0 if cross section is expresse +c..... in megabarns = 10.e-18 cm**2 +c +c +c start energy do loop: +c +c 67 if( irho .eq. 0 ) write(6,40) vcon +c 40 format(//,' interstitial potential vcon = (',E12.6,E12.6,')',//) +c + reg_type='regular ' + irr_type='irregular' +c + if(relc.eq.'nr') then + correction='non relativistic ' + elseif(relc.eq.'sr') then + correction='scalar relativistic ' + elseif(relc.eq.'so') then + correction='spin-orbit ' + else + correction=' ' + endif +c + if (calctype.eq.'xpd') then + spectro='PED ' + elseif (calctype.eq.'xas') then + spectro='XAS ' + elseif (calctype.eq.'aed') then + spectro='AED ' + elseif (calctype.eq.'led') then + spectro='LEED' + elseif (calctype.eq.'rex') then + spectro='REXS' + elseif (calctype.eq.'els') then + spectro='EELS' + elseif (calctype.eq.'e2e') then + spectro='E,2E' + endif +c + if (emin.lt.real(vcon)) then + write(6,45) + stop + endif +c + 45 format(//,' emin less than the interstitial potential vcon',//) +c + xasxpd = (calctype.eq.'xpd'.or.calctype.eq.'xas') +c + if(irho.eq.0) go to 68 + ot = 1./3. + rsint = (3./(4.*pai*rhoint(1)))**ot + write(6,41) gamma,rsint + 41 format(/,1x,' gamma =',f10.6,' rsint =',f10.6,/) + 68 doit = .true. + if(calctype.eq.'xas') then + write(50,803) + elseif(calctype.eq.'rex') then + write(50,804) + elseif(calctype.eq.'xpd') then + write(50,807) + endif +c + 803 format(2x,' e vcon mfp ', + $ ' sigma0 regrme singrme ') +c + 804 format(2x,' e vcon mfp ', + $ ' rexsrme rexssme ') +c + 807 format(2x,' e vcon mfp ', + $ ' sigma0 regrme ') +c +c +c de = alog(emax - emin + 1.)/(kxe - 1.) +c con = 27.2116/7.62 +c wvb = sqrt(con*emin) +c wve = sqrt(con*emax) +c kxe = nint((wve-wvb)/0.05 + 1.) + kxe = nint((emax-emin)/de + 1.) +c + nval=1 + do jat=1,nuatom + nval=max0(nval,nterms(jat)) + enddo + write(35,111) nuatom,kxe,1,ipot,lmax_mode + write(95,111) nuatom,kxe,1,ipot,lmax_mode + write(70,111) nuatom,kxe,1,ipot,lmax_mode + write(80,111) nuatom,kxe,1,ipot,lmax_mode + write(90,111) nuatom,kxe,1,ipot,lmax_mode + 111 format(5(5x,i4)) +c + if(potgen.eq.'in') then + write(6,*) ' check in subroutine cont' +c + write(6,*) ' order of neighb. -- symb. -- dist. from absorber' + write(6,*) ' ' +c +c.....check with molpot data: ok (14/12/2007) +c + do i=1,ngbrabs + nb=ntnabs(i) + dist=sqrt((xv(nb)-xv(1))**2+(yv(nb)-yv(1))**2+(zv(nb)-zv(1))**2) + write(6,*) nb, nsymbl(nb), dist + enddo +c + endif +c + write(6,*) ' ---------------------------------------------------', + 1 '--------------' +c + do nb=1,ndat + dist=sqrt((xv(nb)-xv(1))**2+(yv(nb)-yv(1))**2+(zv(nb)-zv(1))**2) + distin(nb) = dist + enddo +c +c endif +c +c.....Order prototypical atoms in order of increased distance from absor +c + call sort(ndat,distin,ndiff,distor) + small=0.00001 +c nbrs=ngbrabs + nbrs = ndiff +c nbrs=8 +c + do i=1,nbrs + do j=1,ndat + if(abs(distin(j)-distor(i)).lt.small) then + ntnabs1(i)=j + write(6,12) j, nsymbl(j), distin(j) + endif + enddo + enddo + 12 format(5X,I4,12X,A2,10X,F10.6) +c +c do i=2,nbrs +c write(6,*) ntnabs1(i), ntnabs(i-1) +c enddo +c + +c +c write(6,*) 'irho =', irho +c write(6,*) '----------------------------------' + nunit=40 + nunit1=nunit+1 +c +c.....write out potential and density file for first neighbors to absorb +c +100 format(1x,a5,a5,a6,f10.5,a10,3f10.5) +c + if(irho.ne.0) then +c + open(unit=nunit,file='plot/plot_vc.dat',status='unknown') + open(unit=nunit1,file='plot/plot_dens.dat',status='unknown') +c + do i=1,nbrs +c + j = ntnabs1(i) + write(6,12) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), vcoul(k,j) +c +c do ith=0,nthe +c theta = dthe*float(ith) +c do iph=0,nphi +c phi = dphi*float(iph) +c write(nunit1,*) r(k,j), theta, phi, rhotot(k,j) + write(nunit1,*) r(k,j), rhotot(k,j) +c enddo +c enddo +c + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c + else +c + open(unit=nunit,file='plot/plot_v.dat',status='unknown') + open(unit=nunit1,file='plot/plot_dens.dat',status='unknown') + do i=1,nbrs +c + j = ntnabs1(i) + write(6,12) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), real(v(k,j)) +c +c do ith=0,nthe +c theta = dthe*float(ith) +c do iph=0,nphi +c phi = dphi*float(iph) +c write(nunit1,*) r(k,j), theta, phi, rhotot(k,j) + write(nunit1,*) r(k,j), rhotot(k,j) +c enddo +c enddo +c + + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c +c + endif +c + close(nunit) + close(nunit1) +c +c endif +c write(6,*) '----------------------------------' +c do i=1,ndat +c write(6,*) i, nsymbl(i),distin(i),distor(i) +c enddo +C +c +c + cl = (l0i + 1.5)**2 + nid = 1 + write(6,*) ' ' +c +c nels = 1 + if(calctype.eq.'els'.or.calctype.eq.'e2e') then +c nels = 3 +c +c calculate cluster size for effective integration of eels tme +c + kappa = 1.d0/dble(lambda) ! to account for thomas-fermi screening + ! length = 2.9*0.529/(r_s)^(1/2) + ! default = 1/20 = 0.05 (au)^{-1} +c + do i = 1, ndat + rcut = distor(i) + scrcoul = exp(-real(kappa)*rcut)/rcut + if(scrcoul.le.0.05) go to 11 + enddo + 11 neff = i - 1 +c + ltc = lexp_ + y = 0.0d0 + do na = 1, ndat + do k = 1, kmx(na) + arg = kappa*dble(rx(k,na)) + call msbf(arg,y,ltc,msbfi,dmsbfi) + call mshf(arg,y,ltc,mshfk,dmshfk) + do l = 1, ltc + il(k,l,na) = msbfi(l) + kl(k,l,na) = mshfk(l)*(-1)**(l-1)*kappa !correction 15 march 2014 + enddo + enddo + enddo +c + scangl = scangl/180.0*pai + qt2 = einc + esct - 2.0*sqrt(einc*esct)*cos(scangl) + qt = sqrt(qt2) + write(6,*) ' ' + write(6,*)' Calculating eels in DWBA. einc =',einc, + & ' esct =', esct,' einl =', einc - esct - cip + write(6,*)' Momentum transfer qt =', qt, ' au^{-1}' + write(6,*)' Scattering angle', scangl, 'radians' + write(6,*)' Scattering angle', scangl*180.0/pai, 'degrees' + write(6,*) ' ' + write(6,*) ' Coulomb screening inverse length kappa =', kappa + write(6,*) ' ' +c + endif +c +c.....Calculation of tl and rme for xpd, xas and rexs +c +c + if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + 1 calctype.eq.'rex' .or. calctype.eq.'aed'.or. + 2 calctype.eq.'led') then +c + nks = 1 !ficticious: in this section only for writing purposes +c +c writing the headers of the rme file +c + write(55,821) + write(55,822) spectro,correction + write(55,821) +c + if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + 1 calctype.eq.'rex') then + write(55,830) + write(55,840) + write(55,850) + write(55,840) + endif +c + do 9 ne=1,kxe + es(ne) = emin + float(ne-1)*de + e=es(ne) + ev=e-vcon +c +c calculate energy dependent potential: +c + if( irho .ne. 0 ) then + if(ne.eq.1) write(6,*) ' irho =', irho, + & ' entering vxc to calculate energy', + & ' dependent exchange' + call vxc ( doit ) + else + if(ne.eq.1.and.nks.eq.1) then + write(6,*) ' irho =', irho, ' energy independent potential' + write(6,*)' constant interstitial potential vcon =', vcon + endif + endif + ev=e-vcon + write(6,*) ' energy dependent vcon = ', vcon,' at energy', e +C +C CONSTRUCT RELATIVISTIC POTENTIAL ON LINEAR-LOG MESH +C + CALL VREL +C + xe=csqrt(ev) +c +c.....write out potential ans rs files for first neighbors to +c.....absorber for the first energy point +c + nunit=40 + nunit1=nunit+1 + open(unit=nunit,file='plot/plot_v(e).dat',status='unknown') + open(unit=nunit1,file='plot/plot_rs.dat',status='unknown') +c + if(ne.eq.1) then +c + do i=1,nbrs +c + j = ntnabs1(i) + +c write(6,*) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), real(v(k,j)) + write(nunit1,*) r(k,j), rhotot(k,j) + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c + endif +c + close(nunit) + close(nunit1) +c +c calculate maximum l-value lmxne(n,ne) for each prototipical atom +c at the energy e=es(ne) +c +c if(lmax_mode.eq.2.or.calctype.eq.'els'.or.calctype.eq.'e2e') then + if(lmax_mode.eq.2) then + do n=1,nuatom + lmxne(n,ne) = nint(sqrt(e)*rs(n))+2 + if(lmxne(n,ne).lt.l0i+1) lmxne(n,ne)=l0i+2 +c lmxels(nks,n) = lmxne(n,ne) +c write(6,*) nks, n, e, rs(n), lmxne(n,ne) + enddo + endif +c + NBL1=NUATOM/4 + XNBL1=FLOAT(NBL1)+0.0001 + XNBL2=FLOAT(NUATOM)/4. + IF(XNBL1.LT.XNBL2) NBL1=NBL1+1 + 112 FORMAT(4(7X,I2)) + if (lmax_mode.eq.2) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(95,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(70,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(80,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(90,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + ENDDO + else if (lmax_mode.eq.1) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(95,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(70,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(80,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(90,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + ENDDO + else + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmaxt,lmaxt,lmaxt,lmaxt + write(95,112) lmaxt,lmaxt,lmaxt,lmaxt + write(70,112) lmaxt,lmaxt,lmaxt,lmaxt + write(80,112) lmaxt,lmaxt,lmaxt,lmaxt + write(90,112) lmaxt,lmaxt,lmaxt,lmaxt + ENDDO + endif +c +c calculate atomic t-matrix elements atm(n) +C +c if(ne.eq.1.and.nks.eq.1) write(6,*) + if(ne.eq.1) write(6,*) + & ' calculating atomic t-matrix elements atm(n)' +c + call smtx(ne,lmax_mode) +c +c calculate the radial integrals of transition matrix elements: +c + if(calctype.ne.'led') then + call radial(doit,imvhl) + endif + +c +c calculate atomic t-matrix with relativistic corrections +c + call smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax, + & ramfnr,ramfsr,ramfsop,ramfsoa) +c +c and corresponding radial integrals of transition matrix elements: +c + call radialx(ne,relc,eikappr) +c +c modified to write the continuum radial wavefunction for eels +c + lxp = lmxne(nas,ne) + if(lxp.gt.f_) lxp=f_ - 1 + call writewf(lxp) +c +c energy dependent factors for dipole and quadrupole absoprtion; +c factor 1/3 for unpolarized absorption +c + if(ne.eq.1) + & write(6,*) ' check ionization potential:', cip + edfct= facts*(cip+e)*2./3.0 + edfctq = 2.0/5.0*3.0/16.0*edfct*((cip+e)*fsc)**2 + dafsfct = (cip+e)**4 * pai**2 +c + write(6,*) ' ' + write(6,*) ' ' + write(6,*) ' value of the mean free path:' + write(6,44) + 44 format(' --------------------------------------------------', + 1 '---------------') + if(gamma.ne.0.0.and.ne.eq.1.and.nks.eq.1) then + amfph = 0.529/gamma/2 + write(6,43) amfph,e + 43 format(' average mean free path due to finite gamma: mfp =' + * ,f10.5,' angstrom at energy ', f10.5 ,/) + endif +c + if(irho.eq.0.and.imvhl.eq.0.and.nks.eq.1) then + write(6,*)' infinite cluster mfp for real potential' + go to 802 + endif +ctn write(6,40) vcon,eftr + xeim = -aimag(xe) +c +c calculate average mean free path (= amfp). define r-dependent +c wave vector xkr and its indefinite integral xkri +c + + + amfpi = 0.0 + do 20 n = 1,ndat + kxn = kmax(n) + do 30 k = 1,kxn + vrr = v(k,n) + cl/r(k,n)**2 + if ((e-real(vrr)).lt.0.0) then + xkrn(k) = 0.0 + go to 30 + endif + xkrn(k) = -aimag(csqrt(e-vrr)) + 30 continue +c +c calculate integral of xkr +c + call integr (xkrn(1),r(1,n),kxn,ichg(1,n),xkri,nid) + call interpr (r(kplace(n)-3,n),xkri(kplace(n)-3),7,rs(n), + * xkrs(n),dummy,.false.) + xkrs(n) = xkrs(n)/rs(n) + 20 amfpi = amfpi + xkrs(n) +c +c it is assumed that the average interstitial path is 2/3 of the total +c + amfpi = 1./3.*amfpi/ndat + 2.0*xeim/3. + if (amfpi.ne.0.0) then + amfp = 0.529/amfpi/2. + write(6,42) amfp, e + 42 format(' average mean free path in the cluster : mfp =' + * ,f10.5,' angstrom at energy ', f10.5 ,/) + endif + 802 continue + if(gamma.ne.0.0.and.ne.eq.1) then + amfpt = 0.529/(amfpi + gamma)/2.0 + write(6,46) amfpt, e + endif + 46 format(' total mean free path due to Im V and gamma: mfp =' + * ,f10.5,' angstrom at energy ', f10.5) + if(ne.eq.1.and.amfpt.eq.0.0.and.nks.eq.1) write(6,*) + & ' infinite mean free path for gamma: mfp = 0.0 and Im V = 0.0 ' + write(6,44) + write(6,*) ' ' +c +c.....calculate dipole cross section and atomic matrix elements +c + write(50,*)' ------------------------- ' + write(50,*)' &&&&&&&&&&&&&&&&&&&&&&&&& ' + write(50,*)' ------------------------- ' +c + if (xasxpd) then + write(50,*) ' dipole atomic cross section' + else + write(50,*) ' dipole rexs matrix elements' + endif +c + sigmasum = 0.0 +c + do 800 i=1,2 + if((l0i.eq.0).and.(i.eq.1)) goto 800 + np= l0i + (-1)**i + amem = dmx(i) + amem1 = dmx1(i) + pamel = amem1*cmplx(atm(nstart+np))*edfct +c write(50,*)'nr ', amem1*xe/pai/(l0i - 1 + i) + cofct(ne,i) = amem*cmplx(atm(nstart+np))**2*edfct*xe/pai + pamel0 = cofct(ne,i)/cmplx(atm(nstart+np)) + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = dmx(i)*xe/pai/(l0i-1+i) + rexssme = dmx1(i)/(l0i-1+i) +c cofct(ne,i) = cofct(ne,i)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + if(i.eq.2) write(98,*) e*13.6, sigma0 + 800 continue +c + do i=1,2 + cofct(ne,i) = cofct(ne,i)/sigmasum + enddo +c +c.....calculate quadrupole atomic matrix elements for cross section (temp) +c + if (xasxpd) then + write(50,*) ' quadrupole atomic cross section ' + else + write(50,*) ' quadrupole rexs matrix elements ' + endif +c + n = 0 + sigmasum = 0.0 + do 900 i=-2,2,2 + n = n + 1 + lf = l0i + i + if(lf.le.0) go to 900 + np = l0i + i + amem = qmx(n) + amem1 = qmx1(n) + pamel = amem1*cmplx(atm(nstart+np))*edfctq + qcofct(ne,n) = amem*cmplx(atm(nstart+np))**2*edfctq*xe/pai + pamel0 = qcofct(ne,n)/cmplx(atm(nstart+np)) + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = qmx(n)*xe/pai + rexssme = qmx1(n) +c qcofct(ne,i) = qcofct(ne,n)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif + 900 continue +c + if (xasxpd) then + write(50,*)' ------------------------- ' + write(50,*) ' dipole and quadrupole cross section with ', + & 'relativistic corrections of type: ', relc + write(50,*)' ------------------------- ' + else + write(50,*)' ------------------------- ' + write(50,*) ' dipole and quadrupole rexs matrix elements', + & ' with relativistic corrections of type: ', relc + write(50,*)' ------------------------- ' + endif +c +c + if (xasxpd) then + write(50,*) ' dipole atomic cross section with rel. corr.s' + else + write(50,*) ' dipole rexs matrix elements with rel. corr.s' + endif +c + sigmasum = 0.0 +c + do 910 i=1,2 + if((l0i.eq.0).and.(i.eq.1)) goto 910 + np= l0i + (-1)**i + amem = dmxx(i) + amem1 = dmxx1(i) + if(relc.eq.'nr') then + atmd = atmnr(nstart+np) + else if (relc.eq.'sr') then + atmd = atmsr(nstart+np) + else + atmd = atmsop(nstart+np) + endif + pamel = amem1*atmd*edfct +c write(50,*)'nr-rc ', amem1*xe/pai/(l0i - 1 + i) + cofct(ne,i) = amem*atmd**2*edfct*xe/pai + pamel0 = cofct(ne,i)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = dmxx(i)*xe/pai/(l0i-1+i) + rexssme = dmxx1(i)/(l0i-1+i) +c cofct(ne,i) = cofct(ne,i)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + if(i.eq.2) write(99,*) e*13.6, sigma0 + 910 continue +c + do i=1,2 + cofct(ne,i) = cofct(ne,i)/sigmasum + enddo +c +c.....calculate quadrupole atomic matrix elements for cross section (temp) +c + if (xasxpd) then + write(50,*) ' quadrupole atomic cross section with rel. corr.s' + else + write(50,*) ' quadrupole rexs matrix elements with rel. corr.s' + endif +c + n = 0 + sigmasum = 0.0 + do 920 i=-2,2,2 + n = n + 1 + lf = l0i + i + if(lf.le.0) go to 920 + np = l0i + i + amem = qmxx(n) + amem1 = qmxx1(n) + if(relc.eq.'nr') then + atmd = atmnr(nstart+np) + else if (relc.eq.'sr') then + atmd = atmsr(nstart+np) + else + atmd = atmsop(nstart+np) + endif + pamel = amem1*atmd*edfctq + qcofct(ne,n) = amem*atmd**2*edfctq*xe/pai + pamel0 = qcofct(ne,n)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = qmxx(n)*xe/pai + rexssme = qmxx1(n) +c qcofct(ne,i) = qcofct(ne,n)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + 920 continue +c + if(relc.eq.'so') then +c + if (xasxpd) then + write(50,*)' dipole atomic cross section for second so component' + else + write(50,*)' dipole rexs matrix elements for second so component' + endif +c + do 930 i=1,2 + if((l0i.eq.0).and.(i.eq.1)) goto 930 + np= l0i + (-1)**i + amem = dmxxa(i) + amem1 = dmxxa1(i) + atmd = atmsoa(nstart+np) + pamel = amem1*atmd*edfct + cofct(ne,i) = amem*atmd**2*edfct*xe/pai + pamel0 = cofct(ne,i)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = dmxxa(i)*xe/pai/(l0i-1+i) + rexssme = dmxxa1(i)/(l0i-1+i) +c cofct(ne,i) = cofct(ne,i)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + 930 continue +c + do i=1,2 + cofct(ne,i) = cofct(ne,i)/sigmasum + enddo +c +c.....calculate quadrupole atomic matrix elements for cross section (temp) +c + if (xasxpd) then + write(50,*)'quadrupole atomic cross section for second so ', + & 'component' + else + write(50,*)'quadrupole rexs matrix elements for second so ', + & 'component' + endif +c + n = 0 + sigmasum = 0.0 + do 940 i=-2,2,2 + n = n + 1 + lf = l0i + i + if(lf.le.0) go to 940 + np = l0i + i + amem = qmxxa(n) + amem1 = qmxxa1(n) + atmd = atmsoa(nstart+np) + pamel = amem1*atmd*edfctq + qcofct(ne,n) = amem*atmd**2*edfctq*xe/pai + pamel0 = qcofct(ne,n)/atmd + sigma0 = -aimag(pamel) + sigmasum = sigmasum + sigma0 + sigma0r = -aimag(pamel0) + rexsrme = qmxxa(n)*xe/pai + rexssme = qmxxa1(n) +c qcofct(ne,i) = qcofct(ne,n)/sigma0 +c write(6,*) sigma0,sigma0r + if (calctype.eq.'xas') then + write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme + else + write(50,806) e,vcon,amfpt,rexsrme,rexssme + endif +c + 940 continue +c + endif +C +C Writing the radial integrals in unit 55 +C eliminated division of dmx (qmx) by nfis: 29-3-2013 due to reorganization +C of normalization of initial core state +C + if(l0i.eq.0) then +C +c write(55,860) 0.0,0.0, +c 1 csqrt(dmx(2)*xe/pai), +c 2 0.0,0.0, +c 3 0.0,0.0, +c 4 csqrt(qmx(3)*xe/pai) +C + elseif(l0i.eq.1) then +C +c write(55,860) csqrt(dmx(1)*xe/pai/l0i), +c 1 csqrt(dmx(2)*xe/pai/(l0i+1)), +c 2 0.0,0.0, +c 3 csqrt(qmx(2)*xe/pai), +c 4 csqrt(qmx(3)*xe/pai) +C + else +C +c write(55,860) csqrt(dmx(1)*xe/pai/l0i), +c 1 csqrt(dmx(2)*xe/pai/(l0i+1)), +c 2 csqrt(qmx(1)*xe/pai), +c 3 csqrt(qmx(2)*xe/pai), +c 4 csqrt(qmx(3)*xe/pai) +C + endif +C + if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + 1 calctype.eq.'rex') then + if(l0i.eq.0) then +C + write(55,860) 0.0,0.0, + 1 csqrt(dmxx(2)*xe/pai), + 2 0.0,0.0, + 3 0.0,0.0, + 4 csqrt(qmxx(3)*xe/pai),reg_type +C + elseif(l0i.eq.1) then +C + write(55,860) csqrt(dmxx(1)*xe/pai/l0i), + 1 csqrt(dmxx(2)*xe/pai/(l0i+1)), + 2 0.0,0.0, + 3 csqrt(qmxx(2)*xe/pai), + 4 csqrt(qmxx(3)*xe/pai),reg_type +C + else +C + write(55,860) csqrt(dmxx(1)*xe/pai/l0i), + 1 csqrt(dmxx(2)*xe/pai/(l0i+1)), + 2 csqrt(qmxx(1)*xe/pai), + 3 csqrt(qmxx(2)*xe/pai), + 4 csqrt(qmxx(3)*xe/pai),reg_type +C + endif +c + if(relc.eq.'so') then + write(55,*) ' second component of so matrix element ' +C + if(l0i.eq.0) then +C + write(55,860) 0.0,0.0, + 1 csqrt(dmxxa(2)*xe/pai), + 2 0.0,0.0, + 3 0.0,0.0, + 4 csqrt(qmxxa(3)*xe/pai) +C + elseif(l0i.eq.1) then +C + write(55,860) csqrt(dmxxa(1)*xe/pai/l0i), + 1 csqrt(dmxxa(2)*xe/pai/(l0i+1)), + 2 0.0,0.0, + 3 csqrt(qmxxa(2)*xe/pai), + 4 csqrt(qmxxa(3)*xe/pai) +C + else +C + write(55,860) csqrt(dmxxa(1)*xe/pai/l0i), + 1 csqrt(dmxxa(2)*xe/pai/(l0i+1)), + 2 csqrt(qmxxa(1)*xe/pai), + 3 csqrt(qmxxa(2)*xe/pai), + 4 csqrt(qmxxa(3)*xe/pai) +C + endif +c + endif +c + if(calctype.ne.'xpd') then + if(l0i.eq.0) then +c write(55,*) '========dq irregular me: hs mesh===============' +C +c write(55,860) 0.0,0.0, +c 1 dmx1(2)/(l0i+1), +c 2 qmx1(1), +c 3 qmx1(2), +c 4 qmx1(3) +C +c write(55,*) '========dq irregular me: ll mesh===============' +C + write(55,860) 0.0,0.0, + 1 dmxx1(2)/(l0i+1), + 2 qmxx1(1), + 3 qmxx1(2), + 4 qmxx1(3),irr_type + else +c write(55,*) '========dq irregular me: hs mesh===============' +C +c write(55,860) dmx1(1)/l0i, +c 1 dmx1(2)/(l0i+1), +c 2 qmx1(1), +c 3 qmx1(2), +c 4 qmx1(3) +C +c write(55,*) '========dq irregular me: ll mesh===============' +C + write(55,860) dmxx1(1)/l0i, + 1 dmxx1(2)/(l0i+1), + 2 qmxx1(1), + 3 qmxx1(2), + 4 qmxx1(3),irr_type + endif + endif + endif +C +c +c 810 format(29x,2f8.5,4x,2f8.5) +c + doit = .false. +c + 9 continue !end energy loop +c + write(iedl0) ((cofct(ne,i),ne=1,kxe),i=1,2) +c + else !perform eels or e2e calculation +c + write(6,*)' calculating eels radial matrix elements' + write(6,*)' n. of prototypical atoms in the effective cluster', + & ' chosen for eels (e2e) radial matrix elements',neff + write(6,*) ' ' + write(6,*) ' ' +c +c + write(55,821) + write(55,822) spectro,correction + write(55,821) +c +c +c write(55,815) +c +c 815 format(2x,'single and two-site eels (e2e) radial matrix elements') +c + do ne = 1, kxe + deltae = float(ne-1)*de + write(6,*) ' ---> start of calculation of eels (e2e) rme at', + 1 ' energy point ',ne +c +c nks: loop on the 3 electrons involved: +c = 1 : incoming electron +c = 2 : scattered electron +c = 3 : excited electron +c + do 10 nks = 1, 3 + if(expmode.eq.'cis') then + if(nks.eq.1) e = einc + if(nks.eq.2) e = einc - cip - emin - deltae + if(nks.eq.3) e = emin + deltae + elseif(expmode.eq.'cfs') then + if(nks.eq.1) e = esct + cip + emin + deltae + if(nks.eq.2) e = esct + if(nks.eq.3) e = emin + deltae + elseif(expmode.eq.'cel') then + if(nks.eq.1) e = einc + deltae + if(nks.eq.2) e = einc - cip - emin + deltae + if(nks.eq.3) e = emin + endif +c + ev=e-vcon +c + if(nks.eq.1) write(6,*)' einc =',e,' Ryd' + if(nks.eq.2) write(6,*)' esct =',e,' Ryd' + if(nks.eq.3) write(6,*)' eloss =',e,' Ryd', + 1 ' (excluding the ion. pot.)' +c +c calculate energy dependent potential: +c + if( irho .ne. 0 ) then + if(ne.eq.1) write(6,*) ' irho =', irho, + & ' entering vxc to calculate energy', + & ' dependent exchange' + call vxc ( doit ) + else + if(ne.eq.1.and.nks.eq.1) then + write(6,*) ' irho =', irho, ' energy independent', + 1 ' potential' + write(6,*)' constant interstitial potential vcon =', + 1 vcon + endif + endif + ev=e-vcon + if( irho .ne. 0 ) + & write(6,*) ' energy dependent vcon = ', vcon, + 1 ' at energy', e,' Ryd' + +C +C CONSTRUCT RELATIVISTIC POTENTIAL ON LINEAR-LOG MESH +C + CALL VREL +C + xe=csqrt(ev) +c +c.....write out potential ans rs files for first neighbors to +c.....absorber for the first energy point +c + nunit=40 + nunit1=nunit+1 + open(unit=nunit,file='plot/plot_v(e).dat',status='unknown') + open(unit=nunit1,file='plot/plot_rs.dat',status='unknown') +c + if(ne.eq.1) then +c + do i=1,nbrs +c + j = ntnabs1(i) + +c write(6,*) j, nsymbl(j), distin(j) + write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord = ', xv(j), yv(j), zv(j) + write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j), + & ' coord ', xv(j), yv(j), zv(j) + do k=1,kmax(j) + write(nunit,*) r(k,j), real(v(k,j)) + write(nunit1,*) r(k,j), rhotot(k,j) + enddo +c close(nunit) +c close(nunit1) +c nunit=nunit+2 +c nunit1=nunit1+2 + enddo +c + endif +c + close(nunit) + close(nunit1) +c +c calculate maximum l-value lmxne(n,ne) for each prototipical atom +c at the energy e=es(ne) +c + if(lmax_mode.eq.2) then + do n=1,nuatom + lmxne(n,ne) = nint(sqrt(e)*rs(n))+2 + lmxels(nks,n) = lmxne(n,ne) + if(lmxne(n,ne).lt.l0i+1) lmxne(n,ne)=l0i+2 + write(6,*) nks, n, e, rs(n), lmxne(n,ne) + enddo + endif +c + NBL1=NUATOM/4 + XNBL1=FLOAT(NBL1)+0.0001 + XNBL2=FLOAT(NUATOM)/4. + IF(XNBL1.LT.XNBL2) NBL1=NBL1+1 +c 112 FORMAT(4(7X,I2)) + if (lmax_mode.eq.2) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(95,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(70,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(80,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + write(90,112) lmxne(jln,ne),lmxne(jln+1,ne), + & lmxne(jln+2,ne),lmxne(jln+3,ne) + ENDDO + else if (lmax_mode.eq.1) then + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(95,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(70,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(80,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + write(90,112) lmax2(jln),lmax2(jln+1), + & lmax2(jln+2),lmax2(jln+3) + ENDDO + else + DO JL=1,NBL1 + JLN=4*(JL-1)+1 + write(35,112) lmaxt,lmaxt,lmaxt,lmaxt + write(95,112) lmaxt,lmaxt,lmaxt,lmaxt + write(70,112) lmaxt,lmaxt,lmaxt,lmaxt + write(80,112) lmaxt,lmaxt,lmaxt,lmaxt + write(90,112) lmaxt,lmaxt,lmaxt,lmaxt + ENDDO + endif +c +c +c calculate atomic t-matrix with relativistic corrections +c + call smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax, + & ramfnr,ramfsr,ramfsop,ramfsoa) +c + if(eikappr.eq.'yes') then + write(6,*) ' ' + write(6,*) ' calculating phases in the eikonal approximation' + call eikonal(nuatom,xe,z,rs,db) + endif +c +c and corresponding radial integrals of transition matrix elements: +c + if(nks.eq.3) then + write(55,823) ne ! energy point + call radialx_eels(neff) + call writeelswf + endif +c +c + doit = .false. +c + 10 continue !end loop for eels +c + write(6,*) ' ---> end of calculation of eels (e2e) rme', + 1 ' at energy point ',ne + write(6,*) ' ' +c + enddo !end energy do loop +c +c + endif !end of if clause beginning at line 5606 +c +c + 801 format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,f10.5,2x,2f10.5) + 805 format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,f10.5,2x,2e15.6,2x,2e15.6) + 806 format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,2e15.6,2x,2e15.6) + 810 FORMAT(29X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 820 FORMAT(29X,f8.5,1X,f8.5,4X,f8.5,1X,f8.5,4X,f8.5,1X,f8.5) + 821 FORMAT(138('-')) + 822 FORMAT(35x,'matrix elements of ',a4,' with corrections of type: ', + 1 a20) + 823 FORMAT(50x,'---> energy point number ',i5,' <---') + 830 FORMAT(' electric dipole radial integrals +', + 1 ' electric quadrupole radial ', + 2 'integrals') + 840 FORMAT('------------------------------------------------------', + 1 '-+----------------------------------------------------', + 2 '------------------------------') + 850 FORMAT(' R(li --> li - 1) R(li --> li + 1) +', + 1 ' R(li --> li - 2) R(li --> li) ', + 2 ' R(li --> li + 2)') + 860 FORMAT(1X,e12.5,1X,e12.5,2X,e12.5,1X,e12.5,4X,e12.5,1X,e12.5, + 1 2X,e12.5,1X,e12.5,2X,e12.5,1X,e12.5,4x,a9) +c +c ######### the auger matrix elements are written in the output file +c radaed.dat directly from the subroutine radial, since they m +c for each interaction momentum lk + + +c + return +c + end +c +c +c + subroutine output_cont(iq) +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,d_,rd_,sd_ + parameter (at_=nat_-1,d_=ua_-1,rd_=440,sd_=ua_-1) +c +c modified output subroutine for complex potentials +c + common /dens/ irho,rhotot(rd_,sd_),rhoint(2), + $ vcoul(rd_,sd_),vcoulint(2) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + character*8 name0 ,nsymbl + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex ev,xe,vcon +c +c + character*4 label(2) + logical pott,rhoo + data label/'down',' up '/ +c + pott=(irho .ne. 1) + rhoo=(irho .ne. 0) +c + write (6,5) iovrho + 5 format(1x,' starting potentials and/or charge densities', + x ' written to file',i3) +ctn if(radion.ne.0.0. and . nout.eq.1) write(6,10) radion,qion + 15 format(7x,'constant potential=(',1pe14.6,' , ',1pe14.6,')') + 20 format(7x,'interstitial charge=',1pe14.6) +c +c + do 300 ispin=1,nspins + if(nspins.eq.2) write(6,25) label(ispin) + 25 format(///40x,'spin ',a4,' potential') + if( pott ) write (iovrho,15) vcons(ispin) + if( rhoo ) write (iovrho,20) rhoint(ispin) + do 200 n=1,nat + if(neq(n).eq.0) goto 35 + write(iovrho,30) n,neq(n) + 30 format(' mesh and potential for',i4,' same as for',i4) + goto 200 + 35 write(iovrho,40) n,h(n),(ichg(i,n),i=1,10),kplace(n),exfact(n) + 40 format(///i8,' h=',f10.4,' change points:',10i4,' kplace=' + 1 ,i4,' exchange=',f8.6) + kmaxn=kmax(n) + m=n+(ispin-1)*ndat + if( rhoo ) goto 55 + write(iovrho,45) + 45 format(72x/12x,4('r',11x,'real(v)',11x)) + write(iovrho,50) (i,(r(i+j-1,n),v(1,i+j-1,m),j=1,4),i=1,kmaxn,4) + 50 format(1x,i3,8e15.7) + goto 200 + 55 if( pott ) goto 65 + write(iovrho,60) + 60 format(72x/12x,4('r',13x,'rho',13x)) + write(iovrho,50) (i,(r(i+j-1,n),rhotot(i+j-1,m),j=1,4), + x i=1,kmaxn,4) + goto 200 + 65 write(iovrho,70) + 70 format(72x/27x,2('r',11x,'real(v)',10x,'rho',13x)) + write(iovrho,75) (i,(r(i+j-1,n),v(1,i+j-1,m),rhotot(i+j-1,m), + x j=1,2),i=1,kmaxn,2) + 75 format(16x,i3,6e15.7) + goto 200 +c 80 if( rhoo ) goto 90 +c write(iovrho,85) +c 85 format(72x/27x,2('r',11x,'real(v)',9x,'lcore',12x)) +c write(iovrho,75) (i,(r(i+j-1,n),v(1,i+j-1,m), +c x j=1,2),i=1,kmaxn,2) +c goto 200 +c 90 if( pott ) goto 100 +c write(iovrho,95) +c 95 format(72x/27x,2('r',13x,'rho',11x,'lcore',12x)) +c write(iovrho,75) (i,(r(i+j-1,n),rhotot(i+j-1,m), +c x j=1,2),i=1,kmaxn,2) +c goto 200 +c 100 write(iovrho,105) +c 105 format(72x/27x,2('r',11x,'real(v)',10x,'rho', +c x 10x)) +c write(iovrho,50) (i,(r(i+j-1,n),v(1,i+j-1,m), +c x rhotot(i+j-1,m),j=1,2),i=1,kmaxn,2) + 200 continue + 300 continue +c +c + return +c + end +c +c + subroutine radial(doit,imvhl) +c +c include 'mscalc.inc' + include 'msxas3.inc' + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +c +c.....this subroutine calculates the radial matrix elements d(i) +c.....(i=1,2) for lfin=l0i-1 (i=1) and lfin=l0i+1 (i=2) both for +c.....the regular (dmx) and irregular solution (dmx1) +c + common /fcnr/kxe, h(d_),vcons(2,2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) +c + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c +c ######### I introduce a new common with the orbital momentum of +c ######### the two electrons which interacts and give rise to +c ######### to the auger decay; these two momentum are necessary +c ######### to do the loop over the interaction momentum when I perf +c the integrals +c + common/l2holes/l01i,l02i + integer l01i,l02i + + character*8 name0 ,nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_),ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c +c ########## common pdqi modified to include also the Auger two +c wavefunctions + common/pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_) +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) + +c +c ######### common pottype modified to consider also the Auger calcu +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + + + + + + common/auger/calctype,expmode,edge1,edge2 + + character*3 calctype, expmode + character*2 edge1,edge2 + integer nct,l2hmin,l2hmax + + data pai/3.1415927/ +c + common /lparam/lmax2(nat_),l0i +c +c +c + dimension rid(rd_),rid0(rd_),riq0(rd_),cri(rd_),cri1(rd_) + dimension rid2(rd_),cri2(rd_) + complex rid,cri,cri1,dx,qx,dx1,dx2,dx3,dx4 + + + +c + logical*4 doit +c + integer nchannel,lkmaxdir1,lkmaxdir2,lkminexc2 + integer lkmindir1,lkmindir2,lkmaxexc1,lkmaxexc2,lkminexc1 + integer lamin,lamax,lkmin,lkmin1,lkmax,lkmax1,lkm,lkmn + + + +c +c iout = 5 + + + id=1 + n = nas +c +c kx = kmax(n) ! value used in older versions (contains the 3 points +C outside the muffin-tin radius that were used for interpolation) +c + kx = kmax(n) - 3 +c +c ################# Modified the subsequent "if" to take into account +c also the possibility to make an auger calcula +c + if(.not.doit) go to 21 + +c go to 20 + +c +c*********************************************************************** +c find normalization factor for initial state: nfis +c*********************************************************************** +c +c + +c if (calctype.eq.'xpd') then + if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex') then +c n=nas +c kx=kmax(n) + do 156 k=1,kx + 156 rid(k)=rpi(k)**2 + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) + nfis=sqrt(real(dx)) + if(iout .eq. 5) write(6,*) (i, r(i,n), rpi(i)/nfis, i=1,kx) + + + + + WRITE(33,*) CIP + write(33,*) l0i + do i=1,kx + write(33,*) r(i,n), rpi(i)/(nfis*r(i,n)) + enddo + nfis = nfis**2 + + + else +c +c ######## normalization of primary core hole wave function +c +c n=nas +c kx=kmax(n) + do 1560 k=1,kx + 1560 rid(k)=rpi(k)**2 + +c + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) +c + nfis=sqrt(real(dx)) + if(iout .eq. 5) write(6,*) (i, r(i,n), rpi(i)/nfis, i=1,kx) + + + + +c WRITE(33,*) CIP +c write(33,*) l0i + do i=1,kx + write(33,*) r(i,n), rpi(i)/(nfis*r(i,n)) + enddo + + + + +c +c ######### Auger normalization +c + rid(k)=rpi1(k)**2 + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + rid(k)=rpi2(k)**2 + call defint(rid,r(1,n),kx,ichg(1,n),dx2,id) +c + nfis1=sqrt(real(dx1)) + nfis2=sqrt(real(dx2)) + + end if + + +c +c*********************************************************************** +c note that for the initial state rpi(k) = r*pi(k) +c*********************************************************************** +c +c ################ I introduce an if condition to take into account +c ################ also the possibility to make an Auger calculation +c +c 21 if(calctype.eq.'xpd') then + 21 if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex') then +C + do 30 k=1,kx + rid0(k) = r(k,n)**2*rpi(k) + 30 riq0(k) = r(k,n)*rid0(k) +c +c.....calculate regular and irregular dipole matrix elements +c + do 100 i=1,2 + dmx(i)=(0.,0.) + dmx1(i)=(0.,0.) + if((l0i.eq.0).and.(i.eq.1))goto 100 + np = l0i + (-1)**i + do 110 k=1,kx + 110 rid(k) = rid0(k)*p(k,np+1) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri,id) + dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i)/nfis + do 120 k=1,kx + 120 rid(k) = rid0(k)*p(k,np+1+npss) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri1,id) + do 130 k=1,kx + 130 rid(k) = rid(k)*cri(k) + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) + do 140 k=1,kx + 140 rid(k) = rid0(k)*p(k,np+1)*(cri1(kx)-cri1(k)) + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np)/nfis + 100 continue +C +c write(6,*) 'radial matrix elements from shell li = ', l0i +c write(6,*) (real(dmx(l)),aimag(dmx(l)),l=1,2) +c write(6,*) (real(dmx1(l)),aimag(dmx1(l)),l=1,2) +c.....calculate regular and irregular quadrupole matrix elements +c + m = 0 + do 10 i=-2,2,2 + m = m + 1 + qmx(m)=(0.,0.) + qmx1(m)=(0.,0.) + lf = l0i + i + if(lf.le.0) go to 10 + np = l0i + i + do 11 k=1,kx + 11 rid(k) = riq0(k)*p(k,np+1) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri,id) + qmx(m) = (cri(kx)/ramf(nstart+np))**2/nfis + do 12 k=1,kx + 12 rid(k) = riq0(k)*p(k,np+1+npss) + call cintegr(rid,r(1,n),kx,ichg(1,n),cri1,id) + do 13 k=1,kx + 13 rid(k) = rid(k)*cri(k) + call defint(rid,r(1,n),kx,ichg(1,n),dx,id) + do 14 k=1,kx + 14 rid(k) = riq0(k)*p(k,np+1)*(cri1(kx)-cri1(k)) + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + qmx1(m) = (dx+dx1)/ramf(nstart+np)/nfis + 10 continue +C + else +c +c ######## start the auger part; first write +c ######## the orbital momentum of the electrons involved +c + write(55,8110)l0i,l01i,l02i +8110 format(5x,i2,5x,i2,5x,i2) + +c +c ######### Start calculation of auger matrix elements +C ######### rpi is the wavefunction of the primary core hole +C ######### rpi1 and rpi2 are the wavefunction for the two holes in t +c ######### nchannel is the number of channels allowed for +c ######### the Auger continuum electron; +c ######### l2h is the orbital angular momentum given by the coupling +c ######### two orbital momentum of the two final holes +c ######### lk is the 'angular momentum' of the interaction-transferr +c ######### here we count the u_er and lower bound for l of the cont +c + + + l2hmin=abs(l01i-l02i) + l2hmax=l01i+l02i + lamin=abs(l0i-l2hmin) + lamax=l0i+l2hmax +c +c here we count the number of the channels for the continuum auger e +c + nchannel=0 + do 101 np=lamin,lamax + nchannel=nchannel+1 +101 continue + + write(55,8120) lamin,nchannel + 8120 format(12x,i2,5x,i2) +c +c loop over the number of continuum channels +c + nct=0 + do 1 i=1,nchannel + np=lamin+(i-1) + + +c +c ###### establish the range for the interaction momentum for +c ###### the direct integral +c ###### from the selection rules we have: +c ###### abs(np-l01i)r +c + do 1040 k=1,kx +1040 rid2(k)=rpi(k)*rpi2(k)*(r(k,n)**lk) + call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id) + + + do 1050 k=1,kx +1050 rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1)) + call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) + dxdir=(dx+dx1)*2* + * sqrt(xe/pai)/(nfis*nfis1*nfis2*ramf(nstart+np)) + + + end if +c +c ###### now the exchange integral +c + + lsum3=np+lk+l02i + lsum4=l0i+lk+l01i + + if((lk.lt.lkmin1).or.(lk.gt.lkmax1).or. + * (((lsum3/2)*2).ne.lsum3).or.(((lsum4/2)*2).ne.lsum4)) then + dxexc=(0.,0.) + + else + + do 1060 k=1,kx +1060 rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*(r(k,n)**lk) + call cintegr (rid,r(1,n),kx,ichg(1,n),cri,id) + + + do 1070 k=1,kx + +1070 rid(k)=rpi(k)*rpi1(k)*cri(k)/(r(k,n)**(lk+1)) + + call defint(rid,r(1,n),kx,ichg(1,n),dx3,id) + +c +c ####### now the other region where r'>r +c + do 1788 k=1,kx +1788 rid2(k)=rpi(k)*rpi1(k)*(r(k,n)**lk) + call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id) + + + + do 1799 k=1,kx +1799 rid(k)=r(k,n)*rpi2(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1)) + + call defint(rid,r(1,n),kx,ichg(1,n),dx4,id) + + + dxexc=(dx3+dx4)*2* + * sqrt(xe/pai)/(nfis1*nfis2*nfis*ramf(nstart+np)) + + end if +c +c ############## Write the auger matrix elements +c + +c write(55,8111) 'L =',np,'LB =',lk,dxdir,dxexc +c8111 format(2x,a3,i2,4x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5) + write(55,8111) 'LB =',lk,dxdir,dxexc +8111 format(12x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5) + + + + +2 continue + +1 continue + +c write(55,*) 'nct=',nct + + end if + + return + end +c + subroutine radialx_eels(neff) +c + include 'msxas3.inc' +c + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +c.....this subroutine calculates the radial matrix elements +c.....necessary for eels cross-section +c.....using a linear-log mesh +c + common/mtxele/ nstart,nlast +c + common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), + & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), + & dxxdir,dxxexc + complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, + & dxxdir,dxxexc +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe + character*8 nsymbl,name0 +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf +C + COMMON /LLM/ ALPHA, BETA +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +C COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_) +C COMPLEX PX,DPX,PSX,DPSX,RAMFX +c + COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), + & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), + & RAMFSOA(N_) + COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA +c +C + COMMON/PDQIX/RPIX(RDX_), FNISX + COMPLEX RPIX +C + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +C +c ######### common pottype modified to consider also the Auger calcu +c + + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode +c + common/auger/calctype,expmode,edge1,edge2 +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,ramfprd,ramfprx, + & p3irreg,p2irreg,trop1(rdx_) + complex*16 trop(rdx_) + real*4 einc,esct,scangl,qt,lambda + complex qtc, arg, ydf, scprod +c + common/msbhf/ il(rdx_,lexp_,d_), kl(rdx_,lexp_,d_), kappa + double precision kappa, il, kl +c + character*3 calctype, expmode, eikappr + character*2 edge1,edge2 +C + common /lparam/lmax2(nat_),l0i +c + DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_) + DIMENSION RID1(RDX_),RID2(RDX_),RID3(RDX_),RID4(RDX_) + COMPLEX RID,RID1,RID2,RID3,RID4 + COMPLEX VC,VCX,VCD,VCDX,VCDR,VCDXR +C + CHARACTER*2 RELC +C +C +c*************************************************************************** +c note that here rpix(k) = r**3*pi(k). +c wf rpix(k) is already normalized +c (see subroutine corewf) +c*************************************************************************** +c + pi = 3.1415926 +c + id = 1 + na = nas +c +c.....calculate direct and exchange Coulomb integral on absorber and different +c.....spheres +c + nt0a=n0(na) + ntxa=nt0a+nterms(na)-1 + dxa = hx(na) + nstart = nt0a + nlast = ntxa +c write(6,*) 'in radialx_eels', nt0a, ntxa +c + write(6,*) ' ' + write(6,*)' writing eels (e2e) regular direct terms' + write(55,100) + write(55,821) +c + do 20 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(3,na)) goto 20 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 30 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 40 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 40 + do 50 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(2,nb)) goto 50 + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call coulss(rid1,rid2,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,vc) + write(55,10) na, l, lp, ls, lc, vc/ramfprd !, vc + enddo + endif +c + 50 continue +c + 40 continue +c + 30 continue + + 20 continue +c + write(55,821) + write(55,104) + write(55,821) +c + do 120 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(3,na)) goto 120 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 130 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 140 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 140 + do 150 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(2,nb)) goto 150 + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.ne.nb) then + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call coulds(rid1,rid2,dxa,dxb,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,vcd) + vcdr = vcd/ramfprd + if(abs(vcdr).lt.1.e-9) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr + enddo + enddo + endif +c + 150 continue +c + 140 continue +c + 130 continue + + 120 continue +c + write(6,*)' writing eels (e2e) regular exchange terms' + write(55,821) + write(55,102) + write(55,821) +c + do 21 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(2,na)) goto 21 + do k = 1, kmx(na) + rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 31 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 41 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 41 + do 51 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(3,nb)) goto 51 + do k = 1, kmx(nb) + rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call coulss(rid3,rid4,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,vcx) + write(55,10) na, l, lp, ls, lc, vcx/ramfprx + enddo + endif +c + 51 continue +c + 41 continue +c + 31 continue + + 21 continue +c + write(55,821) + write(55,106) + write(55,821) +C + do 121 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(2,na)) goto 121 + do k = 1, kmx(na) + rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) + enddo +c + do 131 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 141 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 141 + do 151 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(3,nb)) goto 151 + do k = 1, kmx(nb) + rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + enddo +c + ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na) + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.ne.nb) then + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call coulds(rid3,rid4,dxa,dxb,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,vcdx) + vcdxr = vcdx/ramfprx + if(abs(vcdxr).lt.1.e-9) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdxr + enddo + enddo + endif +c + 151 continue +c + 141 continue +c + 131 continue + + 121 continue +c + 10 format(5i5,4e15.7) + 11 format(7i5,4e15.7) +c +c write(6,*) alpha, beta +c + if(calctype.eq.'els') then + write(6,*) ' ' + write(6,*)' writing eels irregular direct terms' + write(55,821) + write(55,101) + write(55,821) +c + do 22 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(3,na)) goto 22 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) + if(l.le.5) then + rid(k) = rpix(k)*p3irreg(k,l+1)/(alpha*rx(k,na) + beta) + else + rid(k) = (0.0,0.0) + endif + enddo +c + do 32 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 42 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 42 + do 52 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(2,nb)) goto 52 +c + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + & /ramfsr1(lp+1,nb)/ramfsr2(ls+1,nb) + enddo +c +c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) +c + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call sstrop(rid2,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,trop) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop(k) + rid3(k) = rid(k)*trop(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vc) + if(abs(vc/ramfsr3(l+1,na)).lt.1.e-10) cycle + write(55,10) na, l, lp, ls, lc, vc/ramfsr3(l+1,na) + enddo + else + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call dstrop(rid2,dx2,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop1(k) + rid3(k) = rid(k)*trop1(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vcd) + vcdr = vcd/ramfsr3(l+1,na) + if(abs(vcdr).lt.1.e-10) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr + enddo + enddo + endif +c + 52 continue +c + 42 continue +c + 32 continue + + 22 continue +c +c + write(6,*)' writing eels irregular exchange terms' + write(55,821) + write(55,103) + write(55,821) +c + do 23 n1 = nt0a, ntxa + l=ln(n1) + if(l.gt.lmxels(2,na)) goto 23 + do k = 1, kmx(na) + rid1(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) + if(l.le.5) then + rid(k) = rpix(k)*p2irreg(k,l+1)/(alpha*rx(k,na) + beta) + else + rid(k) = (0.0,0.0) + endif + enddo +c + do 33 nat2 = 1, neff + nb = nat2 + if(neq(nat2).ne.0) nb = neq(nat2) + nt0b=n0(nb) + ntxb=nt0b+nterms(nb)-1 + dxb = hx(nb) + do 43 n2 = nt0b, ntxb + lp = ln(n2) + if(lp.gt.lmxels(1,nb)) goto 43 + do 53 n3 = nt0b, ntxb + ls = ln(n3) + if(ls.gt.lmxels(3,nb)) goto 53 +c + do k = 1, kmx(nb) + rid2(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 + & /(alpha*rx(k,nb) + beta) + & /ramfsr1(lp+1,nb)/ramfsr3(ls+1,nb) + enddo +c +c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) +c + lc_min=max(abs(l-l0i), abs(lp-ls)) + lc_max=min(l+l0i, lp+ls) +c + if(na.eq.nb) then + do lc = lc_min, lc_max, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + call sstrop(rid2,il(1,l1,na), + & kl(1,l1,na),kmx(na),dxa,pi,trop) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop(k) + rid3(k) = rid(k)*trop(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vc) + if(abs(vc/ramfsr2(l+1,na)).lt.1.e-10) cycle + write(55,10) na, l, lp, ls, lc, vc/ramfsr2(l+1,na) + enddo + else + do lc=abs(l-l0i), l+l0i, 2 + l1 = lc + 1 + if(l1.gt.lexp_) cycle + do lcp=abs(lp-ls), lp+ls, 2 + l1p = lcp + 1 + if(l1p.gt.lexp_) cycle + call dstrop(rid2,dx2,il(1,l1,na), + & il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1) + do k = 1, kmx(na) + rid4(k) = rid1(k)*trop1(k) + rid3(k) = rid(k)*trop1(k) + enddo + call irregint1(rid3,rid4,kmx(na),dxa,vcd) + vcdr = vcd/ramfsr2(l+1,na) + if(abs(vcdr).lt.1.e-10) cycle + write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr + enddo + enddo + endif +c + 53 continue +c + 43 continue +c + 33 continue + + 23 continue +c + endif !end of if clause to write irregular terms in case of calctype = els +c + write(55,821) +c + 100 format(10x,'single site regular direct terms:') + 101 format(10x,'irregular direct terms:') + 102 format(10x,'single site regular exchange terms:') + 103 format(10x,'irregular exchange terms') + 104 format(10x,'two-site regular direct terms:') + 106 format(10x,'two-site regular exchange terms:') + 821 FORMAT(138('-')) +c + return + end +c +c + subroutine coulss(rho1,rho2,il,kl,kmx,dx,pi,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho1, rho2, vc, vc1, vc2 + complex*16 rid, a, p + real*8 il, kl +c + id = 1 + do k = 1, kmx + rid(k) = il(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = kl(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*il(k)*dcmplx(rho1(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + vc1 = cmplx(p(kmx)) +c write(6,*) 'vc1 = ',vc1 + do k = 1, kmx + rid(k) = a(k)*kl(k)*dcmplx(rho1(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + vc2 = cmplx(p(kmx)) +c write(6,*) 'vc2 = ',vc2 + vc = (vc1 + vc2)*8.0*pi +c + return + end +c +c + subroutine coulds(rho1,rho2,dx1,dx2,ila,ilb, + & kmx1,kmx2,pi,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx1), rho2(kmx2), ila(kmx1), ilb(kmx2) + dimension a1(rdx_), a2(rdx_), rid(rdx_) + complex rho1, rho2, a1, a2, rid, vc1, vc2, vc + real*8 ila, ilb +c + id = 1 + do k = 1, kmx1 + rid(k) = rho1(k)*real(ila(k)) + enddo + call integrcm(rid,dx1,kmx1,a1,id) +c call interp(r1(kpl1-3),a1(kpl1-3),7,rs1,vc1,dummy,.false.) + vc1 = a1(kmx1) +c + id = 1 + do k = 1, kmx2 + rid(k) = rho2(k)*real(ilb(k)) + enddo + call integrcm(rid,dx2,kmx2,a2,id) +c call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.) + vc2 = a2(kmx2) +c + vc = vc1*vc2*8.0*pi + return + end +c +c + subroutine sstrop(rho2,il,kl,kmx,dx,pi,trop) +c + include 'msxas3.inc' +c + dimension rho2(kmx), il(kmx), kl(kmx), trop(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho2 + complex*16 rid, a, p, trop + real*8 il, kl +c + id = 1 + do k = 1, kmx + rid(k) = il(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = kl(k)*dcmplx(rho2(k)) + enddo + call integrcmdp(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*il(k) + enddo +c + do k = 1, kmx + trop(k) = (rid(k) + a(k)*kl(k))*8.0*pi + enddo +c +c + return + end +c +c + subroutine dstrop(rho2,dx2,ila,ilb,kmx1,kmx2,pi,rid) +c + include 'msxas3.inc' +c + dimension rho2(kmx2), ila(kmx1), ilb(kmx2) + dimension a2(rdx_), rid(rdx_) + complex rho2, a2, rid + real*8 ila, ilb +c + id = 1 + do k = 1, kmx2 + rid(k) = rho2(k)*real(ilb(k)) + enddo + call integrcm(rid,dx2,kmx2,a2,id) +c call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.) + do k = 1, kmx1 + rid(k) = ila(k)*a2(kmx2)*8.0*pi + enddo +c + return + end +c +c + subroutine irregint(rho1,rho2,rl,hl,kmx,dx,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho1, rho2, vc, vc1, vc2 + complex rid, a, p, rl, hl +c + id = 1 + do k = 1, kmx + rid(k) = rl(k)*dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = hl(k)*dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*rl(k)*dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc1 = cmplx(p(kmx)) +c write(6,*) 'vc1 = ',vc1 + do k = 1, kmx + rid(k) = a(k)*hl(k)*dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc2 = cmplx(p(kmx)) +c write(6,*) 'vc2 = ',vc2 + vc = (vc1 + vc2) +c + return + end +c +c + subroutine irregint1(rho1,rho2,kmx,dx,vc) +c + include 'msxas3.inc' +c + dimension rho1(kmx), rho2(kmx) + dimension rid(rdx_), a(rdx_), p(rdx_) + complex rho1, rho2, vc, vc1, vc2 + complex rid, a, p +c + id = 1 + do k = 1, kmx + rid(k) = dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,a,id) + do k = 1, kmx + rid(k) = dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + do k = 1, kmx + rid(k) = (p(kmx)-p(k))*dcmplx(rho2(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc1 = cmplx(p(kmx)) +c write(6,*) 'vc1 = ',vc1 + do k = 1, kmx + rid(k) = a(k)*dcmplx(rho1(k)) + enddo + call integrcm(rid,dx,kmx,p,id) +c + vc2 = cmplx(p(kmx)) +c + vc = (vc1 + vc2) +c + return + end +c +c + subroutine setup +c +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,ltot_ + parameter ( at_=nat_-1,ltot_=lmax_+1,n_=ltot_*ua_) +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common/funit/idat,iwr,iphas,iedl0,iwf +c + character*8 name0, name0i, nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode + + + + common/auger/calctype,expmode,edge1,edge2 + + + character*3 calctype, expmode + character*2 edge1,edge2 + + common/lparam/lmax2(nat_),l0i +c +c ########## I introduce a common/l2holes to take into account the +c ########## the orbital momentum of the two electrons which interac +c ########## and give rise to the Auger decay; the two orbital momen +c ########## are necessary in subroutine radial to do the loop over +c ########## the interaction momentum +c + common/l2holes/l01i,l02i + + integer l01i,l02i +c + character*8 core_basis_name(25) + integer core_basis_l(25) + character*8 exc_basis_name + integer exc_basis_l(lmax_+1),exc_basis_dim + integer exc_basis_ndg +c + data core_basis_name/'1s1/2','2s1/2','2p1/2','2p3/2', + 1'3s1/2','3p1/2','3p3/2','3d3/2','3d5/2','4s1/2','4p1/2', + 2 '4p3/2','4d3/2','4d5/2','4f5/2','4f7/2','5s1/2','5p1/2', + 3 '5p3/2','5d3/2','5d5/2','5f5/2','5f7/2','5g7/2','5g9/2'/ +c + data core_basis_l/0,0,1,1,0,1,1,2,2,0,1,1,2,2,3,3,0, + 1 1,1,2,2,3,3,4,4/ +c + data exc_basis_name/'no sym'/ + data lmaximum/lmax_/ + + data exc_basis_ndg/1/ +c + do 7001 i=1,lmaximum+1 + exc_basis_l(i)=i-1 +7001 continue + exc_basis_dim=0 + do 7002 i=1,ndat + exc_basis_dim=exc_basis_dim+lmax2(i)+1 +7002 continue +c + + do 59 n=1,nat + lmaxx(n)=0 + n0(n)=0 + n0l(n)=0 + lmaxn(n)=0 + nterms(n)=0 + 59 nls(n)=0 + nuatom=0 + write (6,327)iosym + 327 format(1x,' symmetry information generated internally'/, + x 1x,' symmetry information written to file',i3) +c + name0i=core_basis_name(i_absorber_hole) + write(iwr,120) name0i + write(iosym,120) name0i + + + 120 format(1x,//,' core initial state of type: ',a5) +c + ndim=exc_basis_dim + ndg=exc_basis_ndg + name0=exc_basis_name +c + write (iosym,103) ndim,ndg,name0 + 103 format(' # basis function including o.s. =',i4,' degeneracy=', + 1 i3,5x,a6) + i_l=1 + i_atom=1 + + + + + l0i = core_basis_l(i_absorber_hole) +c +c ############## Modified to consider also the Auger part +c + if (calctype.eq.'aed') then + l01i = core_basis_l(i_absorber_hole1) + l02i = core_basis_l(i_absorber_hole2) + end if +c +c + do 125 n=1,ndim + + ln(n)=exc_basis_l(i_l) + write (iosym,104) n, ln(n) +104 format ( 1x,'basis function no.',i5,' l=',i3) + natom(n)=i_atom + i_l=i_l+1 + if(i_l.gt.(lmax2(i_atom)+1))then + i_l=1 + i_atom=i_atom+1 + endif +c + write(iosym,106) natom(n) + 106 format (30x, ' atom no.=',i3) +c + na=natom(n) + lmaxn(na)=max0(lmaxn(na),ln(n)) + nuatom=max0(nuatom,na) + nterms(na)=nterms(na)+1 + nls(na)=nls(na)+1 + 125 continue +ctn write(6,1099) ndim + write(iosym,112) nuatom, name0 + 112 format(' number of inequivalent atoms =',i4, + * ' for representation:',a6) + if (nuatom.ne.ndat) then + write(6,122) nuatom, ndat + stop + endif + 122 format(//,' fatal error: nuatom not equal ndat',2i5,//) +c + n0(1)=1 + n0l(1)=1 + lmaxx(1)=max0(lmaxx(1),lmaxn(1)) + if(nuatom.eq.1) go to 127 + do 124 na=2,nuatom + n0(na)=n0(na-1)+nterms(na-1) + n0l(na)=n0l(na-1)+nls(na-1) + 124 lmaxx(na)=max0(lmaxn(na),lmaxx(na)) +c branch point + 127 continue + return +c + end +c +c + subroutine smtx(ne,lmax_mode) +c +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf + complex*16 sbfrs(ltot_),dsbfrs(ltot_) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_),ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c + character*8 name0 ,nsymbl +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe +c + common /seculr/ atm(n_) + complex*16 atm,stmat +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c + complex csqrt,arg,ramf0 +c + common/auger/calctype,expmode,edge1,edge2 + character*3 calctype, expmode + character*2 edge1,edge2 +c + + xe= csqrt(ev) + ns=(nns-1)*ndat +c + do 5 j=1,ndim + 5 atm(j)=(0.0D0,0.0D0) +c +c calculate t-matrix elements: +c stmat: inverse t-m elements (atomic spheres) +c ramf: for normalization of ps(k) functions +c + do 60 na=1,nuatom + WRITE(95,77) NA + ns=ns+1 + mout=1 + nt0a=n0(na) + ntxa=nt0a+nterms(na)-1 + if (na.eq.nas) then + nstart=nt0a + nlast=ntxa + endif + l=-1 + nlat=-1 + arg=xe*rs(na) + ml=lmaxn(na)+1 + call csbf(arg,xe,ml,sbf,dsbf) + call cshf2(arg,xe,ml,shf,dshf) + npabs=0 + do 45 nn=nt0a,ntxa + l=ln(nn) + nlat=nlat+1 + npabs=npabs+1 + if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss + if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45 + call tmat(l,rs(na),kmax(na),z(na),h(na),r(1,na),v(1,ns), + 1 ichg(1,na),mout,kplace(na),p(1,npabs),stmat,ps(nn), + 2 dps(nn),ramf0) +c + atm(nn)=stmat + ramf(nn)=ramf0 + IF(LMAX_MODE.EQ.0) THEN + write(95,1001)xe/0.52917715,stmat + ELSE + write(95,1002)xe/0.52917715,stmat + ENDIF +c +C definition of stmat as exp(-i*delta)*sin(delta) +c + fasi=sign(-1.,real(cmplx(stmat)))* + 1 real(asin(sqrt(abs(dimag(stmat))))) + if(fasi.lt.0.0) fasi=fasi+3.1415926 + write(30,1000)e,xe,na,nlat,stmat,fasi +c write(30)e,xe,na,nlat,stmat +c write(*,*)e,xe,na,nlat,stmat + 1000 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3,2x,2e16.6,f10.5) + 1001 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6) + 1002 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9) + 45 continue + 60 continue +C + 77 FORMAT('-------------------------- ATOM ',I3, + 1 ' -----------------------') +c +c calculate singular solution inside muffin tin sphere for the absorbing +c atom, matching to sbf in interstitial region +c + nl=0 + lmsing=5 + mout=4 + kp=kplace(nas) + kpx=kmax(nas) + do 92 k=kp-3,kpx + if(r(k,nas)-rs(nas)) 92,93,93 + 92 continue +c +c define points (first) kp1 and kp2 outside the absorbing sphere +c and use them to start computation of singular solution (s_l) +c + 93 kp1=k+1 + kpl=kp1-3 + nst=n0(nas) + nlst=n0(nas)+nterms(nas)-1 + l=-1 + ml=lmaxn(nas)+1 + arg=xe*r(kp1,nas) + call cshf2(arg,xe,ml,sbf,dsbf) + arg=xe*r(kp1-1,nas) + call cshf2(arg,xe,ml,shf,dshf) + arg=xe*rs(nas) + call cshf2(arg,xe,ml,sbfrs,dsbfrs) + do 95 n=nst,nlst + l=ln(n) +c +c skip high and divergent l-values of +c singular solution h_l +c + if(l.gt.lmsing)go to 95 + nl=nl+1 + np=npss+nl + np1=nl +c + call tmat(l,rs(nas),kp1,z(nas),h(nas),r(1,nas),v(1,nas), + $ichg(1,nas),mout,kpl,p(1,np),stmat,pss(np1),dpss(np1),ramf0) +c +c shfp = shf(l+1)*xepi +c dshfp = dshf(l+1)*xepi +c print *, ps(np),dps(np),shfp,dshfp +c do 96 k=1,kpx +c if(k.lt.kp2)then +c p(k,np)=p(k,np)*(sbfrs(l+1)/pss(np1))*xepi !rescale h_l +c else ! to match h_l at rs +c p(k,np)=(0.,0.) +c end if +c 96 continue + 95 continue +c + return + end +c + subroutine tmat(l,rs,kmax,z,delh,r,v,ichg,mout,kplace,p,stmat, + 1 ps,dps,ramf) +c +c include 'mscalc.inc' + include 'msxas3.inc' + integer ltot_, rd_ + parameter (ltot_=lmax_+1, rd_=440) +c +c +c +c t-matrix calculation - integrates radial schrodinger equation +c using numerov procedure - does outward and inward integration +c for atomic spheres - gives inverse of t-matrix and log deriva- +c tive at sphere surface. +c +c modified for complex potentials +c +c calculates : +c +c mout=4 solution matching to (0.,1.)*hf2 at r=rs +c +c +c mout=1 atomic spheres t-matrix elements +c returns: +c stmat=[sbfc,ps]/[shfc,ps] (@rs atomic sphere +c ramf=[sbfc,ps]*xe*rs**2 (@rc atomic sphere +c +c +c + common/bessel/sbfc(ltot_),dsbfc(ltot_),shfc(ltot_), + 1 dshfc(ltot_) + complex*16 sbfc,shfc,dsbfc,dshfc +c + common/param/eftr,gamma,vcon,xe,ev,e,iout + complex vcon,xe,ev +c +c + dimension v(kmax),p(kmax),r(kmax),ichg(10) + complex v,p,ps,dps,ramf + complex*16 stmat,x,ramff + complex*16 pk,pk1,pkm,dkm,dk1,dk,gk,gk1,gkm + complex*16 pn(rd_) + data pi/3.141592653589793d0/ +c +c +c + kstop=1 + a=l*(l+1) + if(mout.eq.4) go to 60 +c +c outward integration for atomic spheres +c + ki=1 + if(l.ge.5) ki=ichg(1) + call startp(z,l,e,r,v,kmax,ki,pn) + h=r(ki+1)-r(ki) + hsq=h**2 + pkm=pn(ki) + pk1=pn(ki+1) + dkm=-dcmplx((e-v(ki)-a/r(ki)**2)*hsq)*pn(ki)/12.d0 + dk1=-dcmplx((e-v(ki+1)-a/r(ki+1)**2)*hsq)*pn(ki+1)/12.d0 + kis=ki+2 + n=1 + if(ki.eq.ichg(1)) n=2 + do 34 k=kis,kmax + gk=dcmplx((e-v(k)-a/r(k)**2)*hsq)/12.d0 + pk=dcmplx((2.d0*(pk1+5.d0*dk1)-(pkm-dkm))/(1.d0+gk)) + pn(k)=pk + if(k.lt.ichg(n)) go to 30 + n=n+1 + hsq=4.*hsq + dkm=4.d0*dkm + dk1=-4.d0*gk*pk + pk1=pk + go to 34 + 30 pkm=pk1 + dkm=dk1 + dk1=-gk*pk + pk1=pk + 34 continue +c + go to 78 +c +c inward integration to find solution matching to (0.,1.)*hf2 at r=rs +c + 60 n=11 + 61 n=n-1 + if(n.eq.0) go to 66 + kn=ichg(n) + if(kn.ge.kmax) go to 61 +c + 66 kn=kmax + pkm=sbfc(l+1)*dcmplx(xe/pi*r(kn)) + pk1=shfc(l+1)*dcmplx(xe/pi*r(kn-1)) + hsq=delh**2*4**n + pn(kn)=pkm + pn(kn-1)=pk1 + dkm=-dcmplx((e-a/r(kn)**2-vcon))*pkm*dble(hsq)/12.d0 + dk1=-dcmplx((e-a/r(kn-1)**2-vcon))*pk1*dble(hsq)/12.d0 + k=kn+1 + if(k.gt.kmax) go to 79 + do 76 i=k,kmax + 76 pn(i)=(0.0d0,0.0d0) + 79 k=kn-1 + 73 k=k-1 + 74 gk=dcmplx((e-v(k)-a/r(k)**2))*dble(hsq)/12.d0 + pk=dcmplx((2.d0*(pk1+5.d0*dk1)-pkm+dkm)/(1.d0+gk)) + pn(k)=pk + if(k.eq.kstop) go to 78 + if(n.eq.0) go to 69 + if(k.gt.ichg(n)) go to 69 + if(k.le.2) go to 75 + n=n-1 + dk=-pk*gk + gk1=dcmplx((e-v(k-2)-a/r(k-2)**2))*dble(hsq)/12.d0 + pk1=dcmplx((2.d0*(pk+5.d0*dk)-pk1+dk1)/(1.d0+gk1)) + dk1=-pk1*gk1/4.d0 + hsq=hsq/4. + gkm=dcmplx((e-v(k-1)-a/r(k-1)**2))*dble(hsq)/12.d0 + dk=dk/4.d0 + pkm=0.5d0*((pk-dk)+(pk1-dk1))/(1.d0-5.d0*gkm) + dkm=-pkm*gkm + k=k-3 +c +c keller modification subroutine tmat +c + pn(k+2)=pkm + if(k+1.lt.kstop) go to 78 + pn(k+1) = pk1 + if(k+1.eq.kstop) go to 78 + go to 74 + 69 pkm=pk1 + dkm=dk1 + dk1=-pk*gk + pk1=pk + go to 73 + 75 write(6,103) + stop + 103 format(//,18h error stop - tmat,//) +c +c + 78 continue + do 77 k=1,kmax + 77 p(k)=cmplx(pn(k)/dble(r(k))) + call interp(r(kplace-3),p(kplace-3),7,rs,ps,dps,.true.) + if(mout.eq.4) return + x=dcmplx(dps/ps) + ramff=sbfc(l+1)*x-dsbfc(l+1) + + stmat=ramff/(shfc(l+1)*x-dshfc(l+1)) + ramf=cmplx(ramff)*ps*rs*rs*xe + return +c + end +c +c + subroutine eikonal(nuatom,xe,z,rs,db) +c + include 'msxas3.inc' +c + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + dimension z(at_), rs(at_) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + complex xe +c + open(unit=45, file='tl/tbmat.dat',status='unknown') +c + write(45,*) 'impinging electron wave vector kappa =', real(xe) + write(35,*) 'impinging electron wave vector kappa =', real(xe) + write(6,*) ' impinging electron wave vector kappa =', real(xe) +c + do na=1,nuatom + write(45,*)'atom number ', na,'(z =', z(na),')' + write(35,*)'atom number ', na,'(z =', z(na),')' +c write(6,*)' atom number ', na,'(z =', z(na),')' + z0 = z(na) + call tbmat(db,rs(na),kplace(na),z0,r(1,na),v(1,na),real(xe)) + enddo +c + close(45) +c +c write(6,*) ' normal exit in subroutine eikonal ' +c stop +c + return + end +c +c + subroutine tbmat(db,rs,kmax,z0,r,v,xer) +c + integer rd_ + parameter (rd_=440, nt_=1500) +c + dimension v(kmax),r(kmax), z(rd_) + complex v, z +c + dimension x(nt_), rx(nt_), rid(nt_), rid1(nt_) +c + complex cu, tb, zb, z1, zx, dzx, d2zx, rid, rid1, dbf, dbs +c + data pi/3.1415926/ +c + + do i = 1, kmax + z(i) = r(i)*v(i) +c write(45,*) r(i), z(i) + enddo +c + id = 1 !for subroutine defint + idr = 0 !for subroutine defint + cu = (0.0,1.0) +c write(6,*) + twz = -2.0*z0 +c write(6,*) ' twz =', twz +c +c db = 0.01 +c b0 = -5.3 +c nb = (-b0 + log(rs))/db +c do ib = 1, nb +c b = exp((ib-1)*db + b0) + nb = nint(rs/db) +c write(6,*) 'nb =', nb + do ib = 1, nb - 1 + b = (ib-1)*db + db +c + dx = 0.005 + nx = nint(rs/dx) + rmx = nx*dx + t = rmx/b + rt = log(t + sqrt(t**2-1.0)) +c + nt = nint(rt/dx) +c write(6,*) 'nt =', nt,' for ib =', ib + if(nt.gt.nt_) then + write(6,*) ' ' + write(6,*) ' ' + write(6,*) ' stop in subroutine tbmat ' + write(6,*) ' increase dimension nt_; ', + & ' it should be greater than nt =', nt + write(6,*) ' ' + write(6,*) ' ' + call exit + endif + if(nt.le.4) cycle + x(1) = dx + rx(1) = b*(exp(dx) + exp(-dx))/2.0 +c write(2,*) x(1), rx(1) + do i = 2, nt + x(i) = x(i-1) + dx + rx(i) = b*(exp(x(i)) + exp(-x(i)))/2.0 +c write(2,*) x(i), rx(i) + enddo +c + do i = 1, nt + jlo = 1 + call nearest1(r, kmax, rx(i), ip1, ip2, ip3, jlo) +c + call cinterp_quad( r(ip1), z(ip1), r(ip2), z(ip2), + & r(ip3),z(ip3),rx(i),zx,dzx,d2zx) + rid(i) = zx - twz + rid1(i) = zx + enddo +c + call defint0(rid,dx,nt,zb,id) + call defint0(rid1,dx,nt,z1,idr) +c + zbc = twz*rt + dbf = zb + zbc +c write(6,*) ' coulomb eikonal phase zbc =', zbc +c write(6,*) ' eikonal phase zb =', zb +c write(6,*) ' total eikonal phase dbf =', dbf +c +c write(6,*) ' integrated zx =', z1 +c + dbs = -dbf/xer/2.0 + tb = cu/pi*(cexp(2.0*cu*dbs) - 1.0) +c +c write(6,*) ' eikonal t(b) =', tb,' at b =', b +c + write(45,'(3e15.7)') b, tb + write(35,'(3e15.7)') b, tb +c + enddo +c +c + return + end +c +c + subroutine vxc ( doit ) +c include 'mscalc.inc' + include 'msxas3.inc' + integer at_,d_,rd_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,rd_=440,sd_=ua_-1) +c +c calculation of ex-correlation h-l potential +c +c +c + common /dens/ irho,rs(rd_,sd_),rsint(2), + $ vcoul(rd_,sd_),vcoulint(2) + + common /fcnr/kxe, h(d_),vcons(2,2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + common /hedin/ wp2,xk,e,eta2,pi,ot,kdens +c +c x_k_0 not divided by k_f +c + common/corr/r_s,blt,x_k_0 +c + character*8 name0 ,nsymbl + common/param/eftr,gamma,vcon(2),xe,ev,ekn,iout,nat,ndat, + 1 nspins,nas,rmuftin(at_),xv(at_),yv(at_),zv(at_),exfact(at_), + 3 z(at_),lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + + complex xe,ev + external f1,f2,f3 + + real*8 r_s,blt,x_k_0,im_vxc,re_vxc,pi_8 + real*4 re_vxc_4,im_vxc_4 + + logical doit, iskip + + nout = 0 + anns=float(nspins) + eps=1.e-3 + eta=1.e-3 + eta2=eta*eta + ot=1./3. + ts2=27.*27. + t2=32. + sqr3=sqrt(3.) + pi=3.1415926 + pi_8 = dble(pi) + a=(4./(9.*pi))**ot + eken=ekn-eftr + +c +c do na = 1, ndat +c print *, ' atom number =', na +c do k = 1 , kmax(na) +c print *, k, r(k,na), rs(k,na) +c enddo +c enddo +c +c calculate rs from charge density first time through subroutine: +c remember that rhotot read in input is actually 4*pi*rho*r**2 +c +c print *, nspins, ndat, kmax(1), 'check point' + if( .not. doit ) goto 100 + do 50 isp=1,nspins + do 40 nb=1,ndat + ns=nb+(isp-1)*ndat + do 30 k=1,kmax(nb) + rs(k,ns)=((3.*(r(k,nb)**2))/(rs(k,ns)*anns))**ot +c if(ns.eq.1) +c & print *, 'r, rs(k,1) =', r(k,1), rs(k,1) + 30 continue + 40 continue + rsint(isp)=(3./(pi*4.*rsint(isp)*anns))**ot + 50 continue +c +c +c calculate self-energy +c + 100 do 300 isp=1,nspins + iskip=.false. + do 280 nb=1,ndat+1 + ns=nb+(isp-1)*ndat + if(.not.iskip)then +c +c compute vxc for atomic and outer spheres +c + km=kmax(nb) + else +c +c compute vxc for interstitial region +c + km=1 + endif + do 260 k=1,km + if(.not.iskip)then + rsp=rs(k,ns) + else + rsp=rsint(isp) + endif + ef=1./(a*rsp)**2 + xk=sqrt(1.0+eken/ef) + if(eken.lt.0.0) xk=1.0 + wp2=4.*a*rsp/(3.*pi) + wp=sqrt(wp2) + xk2=xk*xk + e=.5*xk2 + xkp=xk+1. + xkm=xk-1. + xkpi=1./xkp + if(nedhlp.eq.2)then +c +c define variables used by rehr's subroutine rhl +c + x_k_0=dble(xk/(a*rsp)) + r_s=dble(rsp) + call rhl(re_vxc,im_vxc,pi_8) +c +c conversion to single precision and ryd +c + re_vxc_4 = 2.0*sngl(re_vxc) +c +c conversion to single precision and ryd +c + im_vxc_4 = 2.0*sngl(im_vxc) + if (iskip) goto 1200 + v(1,k,ns)=vcoul(k,ns) + re_vxc_4 + if(imvhl.ne.0)v(2,k,ns)=-im_vxc_4 + gamma + goto 1210 +1200 vcons(1,isp)=vcoulint(isp) + re_vxc_4 + if(imvhl.ne.0)vcons(2,isp)=-im_vxc_4 + gamma +1210 continue + if(imvhl.ne.0)goto 260 + goto 210 + end if +c + flg=alog((xkp+eta2)/(xkm+eta2)) + edxc=(1.-xk2)/xk*.5*flg + vedx=1.5*wp2*(1.+edxc) + vsex = 0.0 + vch = 0.0 + if(nedhlp.ne.0) go to 199 + if(nb.eq.1.and.nout.eq.1) go to 199 + vsex=.75*wp2**2/xk*gauss(f2,xkm,xkp,eps) + vch1=gauss(f3,0.,xkp,eps) + vch2=gauss(f1,0.,xkpi,eps) + vch=.75*wp2**2/xk*(vch1+vch2) + 199 continue + if (iskip) goto 200 + v(1,k,ns)=vcoul(k,ns) - ef*(vedx+vsex+vch) + goto 210 + 200 vcons(1,isp)=vcoulint(isp) - ef*(vedx+vsex+vch) + 210 continue +c +c calculate vim, imaginary part of self energy: +c + if(imvhl.eq.0) goto 260 + rfct = 1.0 ! renormalizes the imaginary part +c if((icplxv.eq.1).and.(.not.iskip)) go to 260 + if(wp2.ge.t2/ts2) go to 215 + c1=ts2*wp2/16. + phi=acos(1.-c1) + phit=phi*ot + xkl=1.+2./9.*(-1.+cos(phit)+sqr3*sin(phit)) + goto 216 + 215 q=(16.-ts2*wp2)/54. + del=(ts2*wp2-t2)*wp2/4. + srdel=sqrt(del) + v2=-q-srdel + v2m=abs(-q-srdel) + xkl=7./9.+ot*((-q+srdel)**ot+sign(1.,v2)*v2m**ot) + 216 xkl2m=xkl**2-1. + xkmm=1.+sqrt(-2./3.+sqrt(4./9.-4.*wp2+xkl2m**2)) + if(abs(xkl-xkmm).gt.1.e-4) + x write(iovrho,221) xkl,xkmm,nb,k,rsp + 221 format(' xkl(=',e14.6,') not equal to xkmm(=',e14.6,') for ', + x ' nb,k,rs=',2i10,e20.6) + xmm=sqrt(1.+2.*wp) + if(xkl.lt.xmm) write(iovrho,222) xkl,xmm,nb,k,rsp + 222 format(' xkl(=',e14.6,') less than xmm(=',e14.6,') for ', + x 'nb,k,rs=',2i10,e20.6) + if(.not.iskip) v(2,k,ns)=gamma + if(iskip) vcons(2,isp)=gamma + if(xk.le.xkl) go to 260 + del1=27.*xk2*wp2-4.*(xk2-ot)**3 + if(del1.ge.0.) write(iovrho,223) nb,k,rsp + 223 format(' discriminant del1 positive for nb,k,rs=',2i10,e20.6) + xm2=-2*ot+sqrt(4./9.-4.*wp2+(xk2-1.)**2) + c1=27.*xk2*wp2/(2.*(xk2-ot)**3) + if(c1.gt.2.) write(iovrho,224) c1,nb,k,rsp + 224 format(' c1(=',e14.6,') gt 2. for nb,k,rs=',2i10,e20.6) + phi=acos(1.-c1) + phit=ot*phi + xk1=(1.-cos(phit)+sqr3*sin(phit))*(xk2-ot)/(3.*xk) + xk12=xk1*xk1 + an=xm2*(xk12*(1.-3.*wp)+6.*wp*(wp+xk*xk1)) + ad=xk12*(xm2+3.*wp*(xk2-1.+2.*wp)) + if (iskip) goto 258 + v(2,k,ns)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma + goto 260 + 258 vcons(2,isp)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma + 260 continue + if(nb.eq.ndat)iskip=.true. + 280 continue + 300 continue +c +c transfer constant for interstitial potential +c + vcon(1)=vcons(1,1) + vcon(2)=vcons(2,1) +c + return + end +c + FUNCTION F1(X) + COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT + YI=1./X + YI2=YI*YI + WQ=SQRT(WP2+OT*YI2+(.5*YI2)**2) + T1=.5*(XK+YI)**2-E+WQ + T2=.5*(XK-YI)**2-E+WQ + R=(T1*T1+ETA2)/(T2*T2+ETA2) + F1=.5*ALOG(R)*YI/WQ + RETURN + END + FUNCTION F2(X) + COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT + X2=X*X + WQ=SQRT(WP2+OT*X2+(.5*X2)**2) + T1=.5-E-WQ + T2=.5*(XK-X)**2-E-WQ + T3=T2+2.*WQ + T4=.5-E+WQ + R=(T1*T1+ETA2)*(T3*T3+ETA2)/((T2*T2+ETA2)*(T4*T4+ETA2)) + F2=.5*ALOG(R)/(WQ*X) + RETURN + END + FUNCTION F3(X) + COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT + X2=X*X + WQ=SQRT(WP2+OT*X2+(.5*X2)**2) + T1=.5*(XK+X)**2-E+WQ + T2=.5*(XK-X)**2-E+WQ + R=(T1*T1+ETA2)/(T2*T2+ETA2) + F3=.5*ALOG(R)/(WQ*X) + RETURN + END + FUNCTION GAUSS(F,A,B,EPS) + LOGICAL MFLAG,RFLAG + EXTERNAL F + DIMENSION W(12),X(12) +C +C ****************************************************************** +C +C ADAPTIVE GAUSSIAN QUADRATURE. +C +C GAUSS IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF +C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER +C EPS. +C +C ****************************************************************** +C + DATA W + */1.01228536E-01, 2.22381034E-01, 3.13706646E-01, + * 3.62683783E-01, 2.71524594E-02, 6.22535239E-02, + * 9.51585117E-02, 1.24628971E-01, 1.49595989E-01, + * 1.69156519E-01, 1.82603415E-01, 1.89450610E-01/ + + DATA X + */9.60289856E-01, 7.96666477E-01, 5.25532410E-01, + * 1.83434642E-01, 9.89400935E-01, 9.44575023E-01, + * 8.65631202E-01, 7.55404408E-01, 6.17876244E-01, + * 4.58016778E-01, 2.81603551E-01, 9.50125098E-02/ +C +C ****************************************************************** +C +C START. +C + GAUSS=0. + IF(B.EQ.A) RETURN + CONST=0.005/(B-A) + BB=A +C +C COMPUTATIONAL LOOP. +C + 1 AA=BB + BB=B + 2 C1=0.5*(BB+AA) + C2=0.5*(BB-AA) + S8=0. + DO 3 I=1,4 + U=C2*X(I) + S8=S8+W(I)*(F(C1+U)+F(C1-U)) + 3 CONTINUE + S8=C2*S8 + S16=0. + DO 4 I=5,12 + U=C2*X(I) + S16=S16+W(I)*(F(C1+U)+F(C1-U)) + 4 CONTINUE + S16=C2*S16 + IF( ABS(S16-S8) .LE. EPS*(1.+ABS(S16)) ) GO TO 5 + BB=C1 + IF( 1.+ABS(CONST*C2) .NE. 1. ) GO TO 2 + GAUSS=0. + CALL KERMTR('D103.1',LGFILE,MFLAG,RFLAG) + IF(MFLAG) THEN + IF(LGFILE.EQ.0) THEN + WRITE(*,6) + ELSE + WRITE(LGFILE,6) + ENDIF + ENDIF + IF(.NOT. RFLAG) CALL ABEND + RETURN + 5 GAUSS=GAUSS+S16 + IF(BB.NE.B) GO TO 1 + RETURN +C + 6 FORMAT( 4X, 'FUNCTION GAUSS ... TOO HIGH ACCURACY REQUIRED') + END +C + SUBROUTINE KERSET(ERCODE,LGFILE,LIMITM,LIMITR) + PARAMETER(KOUNTE = 28) + CHARACTER*6 ERCODE, CODE(KOUNTE) + LOGICAL MFLAG, RFLAG + INTEGER KNTM(KOUNTE), KNTR(KOUNTE) + DATA LOGF / 0 / + DATA CODE(1), KNTM(1), KNTR(1) / 'C204.1', 100, 100 / + DATA CODE(2), KNTM(2), KNTR(2) / 'C204.2', 100, 100 / + DATA CODE(3), KNTM(3), KNTR(3) / 'C204.3', 100, 100 / + DATA CODE(4), KNTM(4), KNTR(4) / 'C205.1', 100, 100 / + DATA CODE(5), KNTM(5), KNTR(5) / 'C205.2', 100, 100 / + DATA CODE(6), KNTM(6), KNTR(6) / 'C205.3', 100, 100 / + DATA CODE(7), KNTM(7), KNTR(7) / 'C305.1', 100, 100 / + DATA CODE(8), KNTM(8), KNTR(8) / 'C308.1', 100, 100 / + DATA CODE(9), KNTM(9), KNTR(9) / 'C312.1', 100, 100 / + DATA CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 / + DATA CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 / + DATA CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 / + DATA CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 / + DATA CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 / + DATA CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 / + DATA CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 / + DATA CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 / + DATA CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 / + DATA CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 / + DATA CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 / + DATA CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 / + DATA CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 / + DATA CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100, 0 / + DATA CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100, 0 / + DATA CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100, 0 / + DATA CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100, 0 / + DATA CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 / + DATA CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 / + LOGF = LGFILE + IF(ERCODE .EQ. ' ') THEN + L = 0 + ELSE + DO 10 L = 1, 6 + IF(ERCODE(1:L) .EQ. ERCODE) GOTO 12 + 10 CONTINUE + 12 CONTINUE + ENDIF + DO 14 I = 1, KOUNTE + IF(L .EQ. 0) GOTO 13 + IF(CODE(I)(1:L) .NE. ERCODE(1:L)) GOTO 14 + 13 KNTM(I) = LIMITM + KNTR(I) = LIMITR + 14 CONTINUE + RETURN + ENTRY KERMTR(ERCODE,LOG,MFLAG,RFLAG) + LOG = LOGF + DO 20 I = 1, KOUNTE + IF(ERCODE .EQ. CODE(I)) GOTO 21 + 20 CONTINUE + WRITE(*,1000) ERCODE + CALL ABEND + RETURN + 21 RFLAG = KNTR(I) .GE. 1 + IF(RFLAG .AND. (KNTR(I) .LT. 100)) KNTR(I) = KNTR(I) - 1 + MFLAG = KNTM(I) .GE. 1 + IF(MFLAG .AND. (KNTM(I) .LT. 100)) KNTM(I) = KNTM(I) - 1 + IF(.NOT. RFLAG) THEN + IF(LOGF .LT. 1) THEN + WRITE(*,1001) CODE(I) + ELSE + WRITE(LOGF,1001) CODE(I) + ENDIF + ENDIF + IF(MFLAG .AND. RFLAG) THEN + IF(LOGF .LT. 1) THEN + WRITE(*,1002) CODE(I) + ELSE + WRITE(LOGF,1002) CODE(I) + ENDIF + ENDIF + RETURN +1000 FORMAT(' KERNLIB LIBRARY ERROR. ' / + + ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR', + + ' ERROR MONITOR. RUN ABORTED.') +1001 FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ', + + 'CONDITION ',A6) +1002 FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6) + END +C + SUBROUTINE ABEND +C +C CERN PROGLIB# Z035 ABEND .VERSION KERNVAX 1.10 811126 + + STOP '*** ABEND ***' + END +C==================================================================== +C + SUBROUTINE GET_CORE_STATE +C + IMPLICIT REAL*8(A-H,O-Z) +C +c INCLUDE 'mscalc.inc' + include 'msxas3.inc' +c +c ############ I include the file msxasc3.inc +c + include 'msxasc3.inc' + +cman + integer rd_ + PARAMETER(RD_=440) +C + + + + + + COMMON/APARMS2/XV2(NAT_),YV2(NAT_),ZV2(NAT_),RS2(NAT_), + U ALPHA2(NAT_),REDF2(NAT_),Z2(NAT_),Q2(NAT_),QSPNT2(2), + U QINT2(2), + U WATFAC(NAT_),ALPHA02,VOLINT2,OVOUT2,RMXOUT2,NSYMBL2(NAT_), + U NZ2(NAT_) + + CHARACTER*8 NSYMBL2 + +C + +c #############common/pot_type modified to include the core states +c #############to the two hole in the final state of Auger decay i_ +c ##############common /pdqi modified to consider also the two auger wav +C +C common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, +C * i_absorber_hole2,i_norman,i_alpha, +C 1 i_outer_sphere,i_exc_pot,i_mode +C + + COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1, + * I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA, + 1 I_OUTER_SPHERE,I_EXC_POT,I_MODE + + + + +C + + COMMON/PDQI/RPI(RD_),RPI1(RD_),RPI2(RD_) + REAL*4 RPI,RPI1,RPI2 + INTEGER I_HOLE +c INTEGER HOLE +C + DIMENSION R(440),P_NK(440),P_NK1(440),P_NK2(440),ICHG(12) +C + DATA THIRD,XINCR,CTFD + &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/ +C + DATA KMX,MESH/RD_,440/ +C + IZ=NZ2(I_ABSORBER+I_OUTER_SPHERE) +c open(unit=697,file='get1.dat',status='unknown') + if(iz.eq.0) then + iz=1 ! in case an empty sphere is the first atom + write(6,*) ' warning check! empty sphere is the first atom ' + endif + + I_RADIAL=I_ABSORBER_HOLE +C +C ######### Modified to consider also the Auger calculation +C + I_RADIAL1=I_ABSORBER_HOLE1 + I_RADIAL2=I_ABSORBER_HOLE2 + I_HOLE=0 + NCUT=1 +C +C SET-UP HERMAN-SKILLMAN MESH FOR Z OF ABSORBING ATOM +C + MESH=MESH/NCUT + H=XINCR*CTFD/(DFLOAT(IZ)**THIRD)*NCUT + R(1)=H + DO 10 N=1,12 +10 ICHG(N)=(40/NCUT)*N + N=1 + DO 20 K=2,MESH + R(K)=R(K-1)+H + IF (K.LT.ICHG(N)) GO TO 20 + H=H+H + N=N+1 +20 CONTINUE +C +C*** COMPUTE FUNCTION P_NK ON RADIAL MESH R +C + CALL ATOM_SUB(IZ,I_HOLE,R,P_NK,1,I_RADIAL,0.d0) +C + + +C +C*** PASS VIA COMMON BLOCK THE FIRST KMX POINTS. NOTE THAT +C P_NK IS NOT NORMALIZED SINCE Q_NK MUST ALSO BE CONSIDERED. +C ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION +C R*R_L = P_NK. THIS RELATION HOLDS IN THE LIMIT C --> INFINITY. +C + DO 30 I=1,KMX + RPI(I)=SNGL(P_NK(I)) + + +30 CONTINUE + + +c +c ############# modified to make the calculations also for the two +c ############# wave functions necessary for the auger decay calcula +c ############# these two wavefunction are calculated with Z+1 appro +c ############# with one hole=to the deeper first core hole (hole) +c + IF (calctype.EQ.'aed') THEN + + + I_HOLE=HOLE2 + + + CALL ATOM_SUB(IZ,I_HOLE,R,P_NK1,1,I_RADIAL1,0.d0) + CALL ATOM_SUB(IZ,I_HOLE,R,P_NK2,1,I_RADIAL2,0.d0) + DO 3011 I=1,KMX + RPI1(I)=SNGL(P_NK1(I)) + RPI2(I)=SNGL(P_NK2(I)) + + + + +3011 CONTINUE + + + + + + END IF +C + + RETURN + END +c +C + SUBROUTINE COREWF(NAS,IZC,HOLE) +C + INCLUDE 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +C + COMMON/PDQIX/RPIX(RDX_), FNISX + COMPLEX RPIX +C + DOUBLE PRECISION CWFX(RDX_),RXD(RDX_),XION + COMPLEX RIDX(RDX_),DX +C + INTEGER HOLE +C + DATA THIRD,XINCR,CTFD + &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/ +C +C + IZ=IZC + ITYRADIAL=HOLE +C + XION=0 + ITYHOLE=0 +C + KMXN = KMX(NAS) + DO I = 1, KMXN + RXD(I) = DBLE(RX(I,NAS)) + ENDDO +c write(6,*) ' corewf: kmx = ', kmxn +C +C*** COMPUTE FUNCTION P_NK ON RADIAL MESH RD AND LL MESH RX +C + XION = 0.D0 + CALL GET_INTRP_CORE(IZ,ITYHOLE,ITYRADIAL,XION,CWFX,RXD,KMXN) +C +C*** NOTE THAT CWFX=P_NK (UPPER COMPONENT OF DIRAC EQU.) IS NOT NORMALIZED +C SINCE ALSO Q_NK (LOWER COMPONENT) MUST ALSO BE CONSIDERED. +C ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION R*R_L = P_NK. +C THIS RELATION HOLDS IN THE LIMIT C --> INFINITY. +c +c.....Find normalization constant in ll-mesh. +c + do i = 1, kmxn + xi = sngl(cwfx(i)) + rpix(i)=cmplx(xi) +c write(6,*) rx(i,nas), xi + enddo + +c dh = x(2,n) - x(1,n) +c write(6,*) ' dh ', dh, hx(n), alpha, beta + n = nas + id = 1 + do k = 1,kmxn + ridx(k)=rpix(k)**2*rx(k,n)/(alpha*rx(k,n) + beta) + enddo + call defint0(ridx,hx(n),kmxn,dx,id) + fnisx=sqrt(real(dx)) +c +c write(6,*) 'corewf: fnisx = ', fnisx +c + do k=1,kmxn + rpix(k)=rx(k,n)**2*rpix(k)/fnisx + enddo +c + RETURN + END +C +C +C*********************************************************************** +C + subroutine get_intrp_core(iz,ihole,i_radial,xion,cwfx,rx,kmxn) +c +c + implicit real*8(a-h,o-z) +c +c + parameter ( mp = 251, ms = 30 ) +c + character*40 title +c + common/mesh_param/jlo + common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy +c +c For interpolation on rx mesh +c + dimension rx(kmxn), cwfx(kmxn) + dimension p(0:mp), rat(0:mp), r(mp) +c +c + dimension dum1(mp), dum2(mp) + dimension vcoul(mp), rho0(mp), enp(ms) +c + title = ' ' +c + ifr=1 + iprint=0 +C + amass=0.0d0 + beta=0.0d0 +c +c There are no nodes in relativistic radial charge density +c + small=1.0d-11 +c !Hence a lower limit on rho(r) can be used. + dpas=0.05d0 + dr1=dexp(-8.8d0) + dex=exp(dpas) + r_max=44.447d0 +c + radius=10.0d0 +c + xion=0.d0 +c +c compute relativistic Hartrer-Fock-Slater charge density (on log mesh) +c + call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, + 1 vcoul, rho0, dum1, dum2, enp, eatom) +c +c compute radial log mesh (see subroutine phase in J.J. Rehr's program +c FEFF.FOR) +c + ddex=dr1 + do 10 i=1,251 + r(i)=ddex + ddex=ddex*dex +10 continue +c +c write(6,*) ' interpolating on rx mesh ' +c Dump upper componen of Dirac wf into p +c + p(0) = 0.d-8 + rat(0) = 0.d-8 + do i = 1, 251 + p(i) = dgc(i,i_radial) + rat(i) = r(i) +c write(6,*) rat(i), p(i) + enddo +c + do i=1,kmxn + if(rx(i).gt.r_max) goto 60 +c find nearest points +c initialize hunting parameter (subroututine nearest) +c + jlo=1 + call nearest(rat,252,rx(i), + 1 i_point_1,i_point_2,i_point_3) +c + i_point_1 = i_point_1 -1 + i_point_2 = i_point_2 -1 + i_point_3 = i_point_3 -1 +c +c interpolate wavefunction +c + call interp_quad( rat(i_point_1),p(i_point_1), + 1 rat(i_point_2),p(i_point_2), + 1 rat(i_point_3),p(i_point_3), + 1 rx(i),cwfx(i) ) + enddo +c +60 continue +c + return + end +C +C +C*********************************************************************** +c + subroutine input_cont(id,potype,potgen,lmax_mode,lmaxt) +c + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +c modified input subroutine for (optionally) complex potentials +c + common /dens/ irho,rhotot(rd_,sd_),rhoconi(2), + $ vcoul(rd_,sd_),vcoulint(2) + + common/auger/calctype,expmode,edge1,edge2 +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(2,rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + character*8 name0 ,nsymbl + character*3 calctype, expmode + character*5 potype + character*2 potgen + character*2 edge1,edge2 +c +ctn common block from msxas3.inc +c .... redundant variables with param.... +c + common/continuum/xemin,xemax,xdelta,xcip,xgamma,xeftri,iexcpot +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode +c !pass pots and rhos to this sub + common/out_ascii/iout_ascii +c + common/lparam/lmax2(nat_),l0i +c + logical check +c + character*65 exc_pot_label(5) + character*65 exc_pot_label_extnl(6) + data exc_pot_label/ + &'generating final potential (x_alpha exchange)', + &'generating final potential (real dirac-hara exchange)', + &'generating final potential (real hedin-lundqvist exchange)', + &'generating final potential (complex dirac-hara exchange)', + &'generating final potential (complex hedin-lundqvist exchange)' + &/ + data exc_pot_label_extnl/ + &'potential from extnl file (x_alpha exchange)', + &'potential from extnl file (real dirac-hara exchange)', + &'potential from extnl file (real hedin-lundqvist exchange)', + &'potential form extnl file (complex dirac-hara exchange)', + &'potential form extnl file (complex hedin-lundqvist exchange)', + &'potential form extnl file (potential from lmto calculation)' + &/ +c + data lunout/7/, ot/.333333/, pi/3.1415926/ +c +c**** definitions for this version of continuum +c + iout=2 + nspins=1 + iout_ascii=2 +c !output check files + iovrho=13 + iosym=14 +c +c*** define state dependent parameters +c read cip (core ionization potential),emin,emax and deltae +c in order to check array sizes. +ctn read(5,*) cip,emin_exc,emax_exc,de_exc +ctn read(5,*) i_exc_pot,gamma,eftri +ctn initializes from common continuum +c + emin_exc=xemin + emax_exc=xemax + de_exc=xdelta + cip=xcip + gamma=xgamma + eftri=xeftri + i_exc_pot=iexcpot +ctn write(*,*)'dans inpot_cont:' +ctn write(*,*) cip,emin_exc,emax_exc,de_exc +ctn write(*,*) i_exc_pot,gamma,eftri +c +c de_exc = 0.05 +c con = 27.2116/7.62 +c wvb = sqrt(con*emin_exc) +c wve = sqrt(con*emax_exc) +c kxe = nint((wve-wvb)/0.05 + 1.) +c kxe = nint(alog(emax_exc - emin_exc + 1.)/de_exc + 1.) + kxe = nint((xemax-xemin)/xdelta + 1.) + if(kxe.gt.nep_)then +c write(lunout,730) kxe + write(6,730) kxe +730 format(//, + & ' increase the dummy dimensioning variable, nep_. ', + & /,'it should be at least equal to: ', i5,/) + write(6,'(3f10.5)') xemax, xemin, xdelta + call exit + end if +c !define absorbing atom + nas=i_absorber +c + emin=emin_exc + emax=emax_exc + de=de_exc + if(i_exc_pot.eq.1)then +c !define exchange potential types + nedhlp=0 + irho=0 + imvhl=0 + if(i_mode.eq.1)then + + print 745,exc_pot_label_extnl(1) + else + print 745,exc_pot_label(1) + end if +745 format(2x,a65) + else if(i_exc_pot.eq.2)then + nedhlp=1 + irho=2 + imvhl=0 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(2) + else + print 745,exc_pot_label(2) + end if + else if(i_exc_pot.eq.3)then +c +c nedhlp=2 !use rehr's approximation to re(vxc) +c + nedhlp=0 !use exact integral expression for re(vxc) + irho=2 + imvhl=0 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(3) + else + print 745,exc_pot_label(3) + end if + else if(i_exc_pot.eq.4)then + nedhlp=1 + irho=2 + imvhl=1 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(4) + else + print 745,exc_pot_label(4) + end if + else if(i_exc_pot.eq.5) then +c +c nedhlp=2 !use rehr's approximation to re(vxc) and im(vxc) +c + nedhlp=0 !use exact integral expression for vxc +c + irho=2 + imvhl=1 + if(i_mode.eq.1)then + print 745,exc_pot_label_extnl(5) + else + print 745,exc_pot_label(5) + end if + else if(i_exc_pot.eq.6) then + irho = 0 + print 745, exc_pot_label_extnl(6) +c + end if +c + + if(irho.ne.0)then + i_alpha=0 + else + i_alpha=1 + end if + if (i_mode.eq.1)then +c call get_external_pot + if(potype.eq.' lmto') print 745, exc_pot_label_extnl(6) + call get_ext_pot_lmto(potype) + else + call vgen + end if +c +c... calculate fermi level eftr = vcint + kf**2 - .72*3./2.*kf/pi*2. +c + if (irho.eq.0) then + eftr = real(vcons(1))/2. + else + fmkf = (3.*pi**2*rhoconi(1))**ot + eftr = real(vcons(1)) + fmkf*(fmkf - 2.16/pi) + endif +c + if (eftri.ne.0.0) eftr = eftri +c + if (lmax_mode.eq.0) then +c write(lunout,741) + write(6,741) lmaxt +741 format(/,1x,' lmax constant on each atom equal to: ', i5) +c + else if (lmax_mode.eq.1) then +c write(lunout,741) + write(6,742) emax +742 format(/,1x,' lmax assignment based on', + & ' lmax = r_mt * k_max + 2',/, + & ' at energy emax =',f12.6) +c + else +c write(lunout,741) + write(6,743) +743 format(/,1x,' lmax assignment based on', + & ' l_max = r_mt * k_e + 2',/, + & ' where e is the running energy') +c + endif + +c ###### problem: for low energy continuum auger electron it can happen +c that lmax2 is less than the higher value of the orbital mom +c allowed for the continuum auger electron; thus I set the lm +c value equal to the lmax_ value given in the include file +c msxas3.inc +c + l_max = 0 +c + if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or. + & (calctype.eq.'rex').or.(calctype.eq.'led')) then +c +c !assign lmax values and check max(lm) +c + if (lmax_mode.eq.0) then + do i=1,ndat + lmax2(i) = lmaxt +c write(lunout,842) lmax2(i),i + write(6,842) lmax2(i),i +842 format(10x,' lmax =', i3, ' on center =', i3) + enddo +c + else if (lmax_mode.eq.1) then + do i=1,ndat + lmax2(i) = nint(rs(i)*sqrt(emax)) + 2 + if(l_max.lt.lmax2(i)) l_max=lmax2(i) +c write(lunout,843) lmax2(i),i + write(6,843) lmax2(i),i +843 format(10x,' optimal lmax =', i3, ' on center =', i3) + enddo +c + else + do i=1,ndat + lmax2(i) = nint(rs(i)*sqrt(emax)) + 2 + if(l_max.lt.lmax2(i)) l_max=lmax2(i) + if(i.eq.ndat) then +c write(lunout,844) + write(6,844) + endif +844 format(1x,' optimal lmax chosen according to the running', + & ' energy e for each atom') + enddo +c + endif +c +c...give warning for insufficient lmax dimensions +c + check = .false. + if(lmax_mode.ne.0) then + if(l_max.gt.lmax_) then +c manolo + check=.true. +c write(lunout,746)l_max + write(6,746)l_max +746 format(///, + & ' increase the dummy dimensioning variable, lmax_. ', + & /,' it should be at least equal to: ', i5) + call exit + endif + else + if(lmaxt.gt.lmax_) then +c manolo + check=.true. +c write(lunout,746)lmaxt + write(6,746)lmaxt + call exit + endif + endif +c +c + else +c +c ##### auger part: +c + do i=1,ndat + lmax2(i)=lmax_ + l_max=lmax_ + enddo + + end if +c +c...set lmax equal on any atom if check='true' +c + if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or. + & (calctype.eq.'rex').or.(calctype.eq.'led')) then + if(check) then + do i=1,ndat + lmax2(i) = l_max + write(6,7422)lmax2(i),i +7422 format(10x,' lmax =', i3, ' on center =', i3) + enddo +c + write(6,*) ' ' + write(6,*)' ** input_cont warning **' + write(6,*)' -> estimated l_max is greater than lmax_' + write(6,*)' computation proceeds with l_max=lmax_' + write(6,*)' but convergence is not guaranteed' +c + endif +c + else +c do i=1,ndat +c lmax2(i) = l_max +c write(6,7422)lmax2(i),i +c enddo + endif +c + write(6,*) + +c +c + write (iovrho,408) nedhlp,irho,imvhl,eftr,gamma + 408 format(' nedhlp=',i5,' irho=',i5,' imvhl=',i5, + x /,' eftr = ',f10.6,' gamma =',f10.6) + write (iovrho,409) nat,ndat,nspins, + 1 inmsh,inv,inrho,insym,iovrho,iosym + 409 format(9i5) +c + write(iovrho,110) nat + if (iovrho .ne. 6 ) write(6,110) nat + 110 format(/,2x,18hnumber of centers=,i5,/) +c +c store coulomb potential if energy dependent exchange is to be used +c + if(irho.ne.0)then + do 4304 isp=1,nspins + do 4303 nb=1,ndat + ns=nb+(isp-1)*ndat + do 4302 k=1,kmax(nb) + vcoul(k,ns)=v(1,k,ns) +4302 continue +4303 continue + vcoulint(isp)=real(vcons(isp)) +4304 continue + end if +c +c check for consistency of input data: +c + write(iovrho,111) + 111 format(30x,10hatom no.,12x,8hposition,14x,13hradius eq ) + write(iovrho,112) (i,nsymbl(i),nz(i),xv(i),yv(i),zv(i),rs(i), + 1 neq(i),i=1,nat) + write (iovrho,112) + 112 format(26x,i3,2x,a4,i6,4f10.4,i6) + do 211 i=1,nat + if(rs(i).lt.0.0) then + write(iovrho,201) i, rs(i) + write(6,201) i, rs(i) + call exit + endif + if(neq(i).eq.0)go to 210 + if(neq(i).ge.i) go to 213 + 210 i1=i+1 + if(i1.gt.nat) go to 5000 + go to 2135 + 213 write(iovrho,202) neq(i), i + write(6,202) neq(i), i + call exit + 2135 do 211 j=i1,nat + rij = sqrt((xv(j)-xv(i))**2+(yv(j)-yv(i))**2+(zv(j)-zv(i))**2) + rsum = rs(i)+rs(j) + rdif = rsum-rij + if (rsum.gt.rij) go to 215 + go to 211 + 215 write (iovrho,200) i,j,rsum,rij,rdif + 200 format(' spheres',2i5,' overlap ',3f12.6) + 201 format(' sphere',i5,' has negative rs', f12.6) + 202 format(' neq(i)',i5,' for atom i=', i5,' is inconsistent' ) + 211 continue +c + 5000 return + end +c +C + SUBROUTINE GET_EXTERNAL_POT +C +c INCLUDE 'mscalc.inc' + include 'msxas3.inc' + INTEGER AT_,D_,RD_,SD_ + PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) + + COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2), + $ VCOUL(RD_,SD_),VCOULINT(2) +C + COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_), + $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS +C + COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, + 1 IMVHL,NEDHLP +C + CHARACTER*8 NAME0 ,NSYMBL +C + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV +C + COMMON/DIMENS2/NAT2,NDAT2 +C +cman DATA INV,INRHO/2,3/ + inv=2 + inrho=3 +C + NAT = NAT2 - 1 + NDAT = NDAT2 - 1 +C + OPEN(INV, status='unknown') + DO 4444 N=1,NAT + READ (INV,311) NSYMBL(N),NEQ(N), NZ(N),IDUMMY,KMAX(N), + 1 KPLACE(N),XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC +311 FORMAT (1X,A4,3I2,2I4,5F11.6,T76,I5) + Z(N)=NZ(N) + IF(NEQ(N).NE.0) GO TO 4444 +C +C RECONSTRUCT RADIAL MESH +C + READ (INV,308) (ICHG(I,N),I=1,10),NC + 308 FORMAT(10I5,T76,I5) + KX=KMAX(N) + READ (INV,319) NC,(R(I,N),I=1,5) + H(N)=R(2,N)-R(1,N) + HH=H(N) + ICH=1 + KICH=ICHG(ICH,N) + DO 133 K=3,KX + R(K,N)=R(K-1,N)+HH + IF (K.LT.KICH) GO TO 133 + ICH=ICH+1 + KICH=ICHG(ICH,N) + HH=HH+HH +133 CONTINUE + 319 FORMAT(T76,I5,T2,1P5E14.7) + H(N)=R(2,N)-R(1,N) + NS=N +C + DO 142 ISPIN=1,NSPINS + DO 141 K=1,KX,5 + KCARD=MIN0(KX,K+4) + READ (INV,319) NC,(V(1,I,NS),I=K,KCARD) + DO 7474 KKK=K,KCARD + 7474 V(2,KKK,NS) = 0.000 + 141 CONTINUE + 142 NS=NS+NDAT +C + IF(IRHO.EQ.0) GOTO 4444 + OPEN(INRHO, status='unknown') + DO 423 ISPIN=1,NSPINS + NS=N+(ISPIN-1)*NDAT + DO 424 K=1,KX,5 + KCARD=MIN0(KX,K+4) + READ(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD) + 424 CONTINUE + 423 CONTINUE + 4444 CONTINUE +C +C READ INTERSTITIAL V AND RHO +C + READ (INV,319) NC,(VCONS(ISPIN),ISPIN=1,NSPINS) + IF(IRHO.NE.0)READ (INRHO,319) NC,(RHOCONI(ISPIN),ISPIN=1,NSPINS) +C + WRITE(6,120) INV + 120 FORMAT (' STARTING POTENTIAL READ IN FROM FILE',I4) + IF( IRHO .NE. 0) WRITE(6,121) INRHO + 121 FORMAT (' STARTING CHARGE DENSITY READ IN FROM FILE',I4) +C + REWIND(INV) + REWIND(INRHO) +C + RETURN + END +C + SUBROUTINE GET_EXT_POT_LMTO(potype) +C + include 'msxas3.inc' +C + INTEGER AT_,D_,RD_,SD_ + PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) +C + PARAMETER (MRP = 500) +C + COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2), + $ VCOUL(RD_,SD_),VCOULINT(2) +C + COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_), + $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS +C + COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, + 1 IMVHL,NEDHLP +C + CHARACTER*8 NAME0 ,NSYMBL +C + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV +C + COMMON/DIMENS2/NAT2,NDAT2 +C + common/aparms/xa(natoms),ya(natoms),za(natoms),zat(natoms), + & nsymbla(natoms),nzeq(natoms),neqa(natoms),ncores(natoms), + & lmaxat(natoms) +C + REAL*8 xa,ya,za,zat + CHARACTER*8 nsymbla +C + DIMENSION RL(MRP,D_), VCL(MRP,SD_), RHOL(MRP,SD_), HL(D_), + & VLMTO(MRP,SD_), KMXP(SD_), KPLP(SD_), RSL(SD_), + & NPAC(-10:100), NZL(D_), KMX(SD_), ICHGL(SD_,D_) +C + DIMENSION RHS(MRP,D_), VHS(MRP,SD_), RHOHS(MRP,SD_) +C + REAL*8 RL, VCL, RHOL, HL, VLMTO, RSL, RHS, VHS, RHOHS, + & HR, VINT, RHOINT, DVT, DVTRHOINT +C + EXTERNAL NEAREST +C + CHARACTER*5 POTYPE + CHARACTER*5 CHECK +C + DATA THIRD,XINCR,CTFD + &/0.33333333,0.0025E0,0.88534137E0/ +C + INP=2 +C + NDUMMY = 0 + NSPINS = 1 + NAT = NAT2 - 1 + NDAT = NDAT2 - 1 +C + OPEN(INP, file='data/inpot.ext',status='unknown') +C +C Initialize to zero the vector indicating for which atomic species +C the lmto data have been already interpolated. Positions from 1 to +C 100 indicates physical atoms, from 0 to -1010 empty inequivalent +C spheres +C + DO N = -10, 100 + NPAC(N) = 0 + ENDDO +C +C VCOULINT : interstitial Coulomb potential in Ry +C RHOCONI : interstitial charge density in Ry +C VCLMTO : intsrstitial LMTO potential in Ry +C + READ(INP,*) VCOULINT(1), RHOCONI(1), VCLMTO +C + NES=1 +C + DO N=1,NDAT +C + READ(INP,*,END=50) NZL(N), KMX(N), RSL(N) + WRITE(6,*) 'N=',N,'ZATL(N)=', NZL(N),'KMX(N)=',KMX(N), + & 'RS(N)=',RSL(N) + IF (KMX(N).GT.MRP) THEN + WRITE(6,*) ' ' + WRITE(6,*) ' ' + WRITE(6,*)' MRP =', MRP,' TOO SMALL, INCREASE UP TO ', KMX(N) + WRITE(6,*) ' ' + WRITE(6,*) ' ' + CALL EXIT + ENDIF +C + IF(NZL(N).NE.0) THEN + NPAC(NZL(N)) = N +C WRITE(6,*) 'N, NZL(N), NPAC(NZL(N))', N, NZL(N) , NPAC(NZL(N)) + ELSE + NES=NES-1 + NPAC(NES)=N +C WRITE(6,*) 'N, NZL(N), NES, NPAC(NES)', N,NZL(N),NES,NPAC(NES) + ENDIF +C +C NOTE: COULOMB AND LMTO POTENTIALS ARE MULTIPLIED BY RL +C + DO K = 1, KMX(N) + READ(INP,*) RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N) +C WRITE(6,*) K, RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N) + ENDDO + +C +C SET-UP HERMAN-SKILLMAN MESH FOR ATOM OF ATOMIC NUMBER Z +C + MESH=400 + NCUT=1 + MESH=MESH/NCUT + IF(NZL(N).EQ.0) THEN + HL(N)=DBLE(XINCR*CTFD*NCUT) + ELSE + HL(N)=DBLE(XINCR*CTFD/(FLOAT(NZL(N))**THIRD)*NCUT) + ENDIF + HR = HL(N) + RHS(1,N)=HR + DO 10 K=1,12 +10 ICHGL(K,N)=(40/NCUT)*K + I=1 + DO 20 K=2,MESH + RHS(K,N)=RHS(K-1,N)+HR + IF (K.LT.ICHGL(I,N)) GO TO 20 + HR=HR+HR + I=I+1 +20 CONTINUE +C +C FIND KMAX(N) IN THE H-S MESH ACCORDING TO RS(N) +C + KMXP(N) = 0 + KPLP(N) = 0 + DO K = 1, MESH + IF (RHS(K,N).GT.RSL(N)) GO TO 40 + ENDDO + 40 KPLP(N) = K - 1 + KMXP(N) = K + 2 +C + WRITE(6,*) 'ATOMIC SPECIES, HS KPLACE AND KMAX' + WRITE(6,*) 'N=',N, 'KPLP(N)= ',KPLP(N), ' KMXP(N)= ', KMXP(N) +C WRITE(6,*) 'RHSMAX=', RHS(400,N), 'RSL(N) =', RSL(N) +C + DO I=1,KMXP(N) +C FIND NEAREST POINTS +C INITIALIZE HUNTING PARAMETER (SUBROUTUTINE NEAREST) +C + CALL NEAREST(RL(1,N), KMX(N), RHS(I,N), IP1, IP2, IP3) +C + IF(IRHO.NE.0) THEN +C +C INTERPOLATE COULOMB POTENTIAL +C + CALL INTERP_QUAD( RL(IP1,N),VCL(IP1,N),RL(IP2,N),VCL(IP2,N), + & RL(IP3,N),VCL(IP3,N),RHS(I,N),VHS(I,N)) +C +C INTERPOLATE CHARGE DENSITY +C + CALL INTERP_QUAD( RL(IP1,N),RHOL(IP1,N),RL(IP2,N), + & RHOL(IP2,N),RL(IP3,N),RHOL(IP3,N), + & RHS(I,N),RHOHS(I,N)) + ELSE +C +C INTERPOLATE LMTO POTENTIAL +C + CALL INTERP_QUAD( RL(IP1,N),VLMTO(IP1,N), + & RL(IP2,N),VLMTO(IP2,N), + & RL(IP3,N),VLMTO(IP3,N),RHS(I,N),VHS(I,N)) + ENDIF + ENDDO +C + WRITE(6,*) 'INTERPOLATED VALUES ON HS MESH' +C + DO I = 1, KMXP(N) +C WRITE(6,*) I, RHS(I,N), VHS(I,N), RHOHS(I,N) + IF(RHOHS(I,N).LT.0.D0) THEN + WRITE(6,*) ' WARNING: DENSITY INTERPOLATED TO NEGATIVE', + & ' VALUES AT RHS =', RHS(I,N),' FOR ATOM', + & ' NUMBER N =', N + CALL EXIT + ENDIF + ENDDO +C +C......TEST LAST THREE INTERPOLATED VALUES +C + SMALL=0.005 +C + DO I = KPLP(N) + 1, KMXP(N) + KP = KMX(N) +C + IF(IRHO.NE.0) THEN + CALL DINTERP(RL(KP-5,N),VCL(KP-5,N),5,RHS(I,N),VINT,DVT, + & .TRUE.) + CALL DINTERP(RL(KP-5,N),RHOL(KP-5,N),5,RHS(I,N),RHOINT, + & DVTRHOINT,.TRUE.) + IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN + CHECK='OK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VC ', CHECK + ELSE + CHECK='NOTOK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VC ', CHECK + WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N) + ENDIF +C + IF(DABS(RHOHS(I,N)-RHOINT).LT.DBLE(SMALL)) THEN + CHECK='OK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR RHO ', CHECK + ELSE + CHECK='NOTOK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR DENSITY RHO ', CHECK + WRITE(6,*) I, RHS(I,N), RHOINT, RHOHS(I,N) + ENDIF +C + ELSE +C + CALL DINTERP(RL(KP-5,N),VLMTO(KP-5,N),5,RHS(I,N),VINT,DVT, + & .TRUE.) + IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN + CHECK='OK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VLMTO ', CHECK + ELSE + CHECK='NOTOK' + WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, + & 'FOR VLMTO ', CHECK + WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N) + ENDIF +C + ENDIF +C + ENDDO +C +C + ENDDO +C + 50 CONTINUE +C + CLOSE(2) +C +C write(6,*) npac(22), npac(8), npac(0), npac(-1) + DO 60 I=1,NAT + XV(I) = SNGL(XA(I+1)) - SNGL(XA(2)) + YV(I) = SNGL(YA(I+1)) - SNGL(YA(2)) + ZV(I) = SNGL(ZA(I+1)) - SNGL(ZA(2)) + NSYMBL(I) = NSYMBLA(I+1) + NEQ(I) = NEQA(I+1) +c write(6,*) NEQ(I), NSYMBL(I) + IF(NEQ(I).NE.0) NEQ(I) = NEQ(I) - 1 + NZ(I) = NZEQ(I+1) +C N = NPAC(NZ(I)) + IF(NZ(I).NE.0) THEN +C + N = NPAC(NZ(I)) +C WRITE(6,*) 'N, NZ(I), NPAC(NZ(I))', N, NZ(I), NPAC(NZ(I)) +C + ELSE +C + IF(NSYMBL(I).EQ.'ES') THEN + N=NPAC(0) + ELSE + NES=ICHAR('0')-ICHAR(NSYMBL(I)(2:2)) + N=NPAC(NES) +C WRITE(6,*) ICHAR('0'),ICHAR(NSYMBL(I)(2:2)) +C WRITE(6,*) ' NES = ',NES, ' N = ', N + ENDIF +C + ENDIF + KPLACE(I) = KPLP(N) + KMAX(I) = KMXP(N) + RS(I) = REAL(RSL(N)) + EXFACT(I) = 0.0 +C + IF(NEQ(I).NE.0) GO TO 60 +C + H(I) = REAL(HL(N)) + DO K = 1,10 + ICHG(K,I) = ICHGL(K,N) + ENDDO + DO K = 1, KMAX(I) + R(K,I) = SNGL(RHS(K,N)) + V(2,K,I) = 0.0 + IF(IRHO.NE.0) THEN + V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N)) + RHOTOT(K,I) = SNGL(RHOHS(K,N)) + ELSE + V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N)) + ENDIF + ENDDO + IF(IRHO.NE.0) THEN + VCONS(1) = CMPLX(VCOULINT(1)) + ELSE + VCONS(1) = CMPLX(VCLMTO) + ENDIF + 60 CONTINUE +C +C.....WRITE OUT POTENTIAL AND DENSITY FILES +C + IF (potype.EQ.' lmto') THEN + OPEN (19, FILE = 'div/LMTO.POT', STATUS = 'unknown') + ELSE + OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown') + OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown') + ENDIF +C + INV = 20 + IF (potype.EQ.' lmto') INV = 19 + INRHO= 9 + NST=1 + NC=2 + DO 4401 N=NST,NAT + WRITE(INV,311) NSYMBL(N),NEQ(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N), + 1 XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC + 311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5) + NC=NC+1 + IF(NEQ(N).NE.0) GO TO 4401 + WRITE(INV,308) (ICHG(I,N),I= 1,10),NC + 308 FORMAT(10I5,T76,I5) + NC=NC+1 + WRITE(INV,319) NC,(R(I,N),I=1,5) + 319 FORMAT(T76,I5,T2,1P5E14.7) + NS=N + NC=NC+1 + KX=KMAX(N) + NS = N + DO 142 ISPIN=1,NSPINS + DO 141 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INV,319) NC,(V(1,I,NS),I=K,KCARD) + 141 NC=NC+1 + 142 NS=NS+NDAT + NS=N + IF (potype.NE.' lmto') THEN + DO 555 ISPIN=1,NSPINS + DO 551 K=1,KX,5 + KCARD=MIN0(KX,K+4) + WRITE(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD) + 551 NC=NC+1 + 555 NS=NS+NDAT + ENDIF + 4401 CONTINUE +C + IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS) +C + IF (INV.EQ.20) THEN + WRITE(INV,319) NC, REAL(VCONS(1)) + + WRITE( INRHO,319) NC,(RHOCONI(IS),IS=1,NSPINS) + ENDIF +C + IF(potype.EQ.' lmto') THEN + CLOSE (UNIT=19) + ELSE + CLOSE (UNIT=20) + CLOSE (UNIT=9) + ENDIF +C +C STOP + RETURN + END +C +C +C-------------------------------------------------------------- + + subroutine writewf(lxp) + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV + CHARACTER*8 NSYMBL,NAME0 +c + common /pdq/ p(rd_,f_),ps(n_),dps(n_), + * ramf(n_),pss(6),dpss(6) + complex p,ps,dps,ramf,pss,dpss +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex vcons,v +c + common/funit/idat,iwr,iphas,iedl0,iwf + common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), + $ dxdir,dxexc,nfis,nfis1,nfis2 + real nfis,nfis2,nfis1 + complex dmx,dmx1,qmx,qmx1,dxdir,dxexc +c + nlastl = nstart + lxp +c +c write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf + write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)' + write(iwf,*) e, xe, real(vcon) +c +c write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10) +c + write(iwf,*) + write(iwf,*) ' -- absorber excited regular wf for all l -- ' + write(iwf,*) +c + do 1 i=nstart,nlastl + write(iwf,*) ' l= ', i-1 + do 2 j=1,kmax(nas) + write(iwf,*) r(j,1),p(j,i)/ramf(i) +2 continue +1 continue +c + write(iwf,*) + write(iwf,*) ' -- absorber irregular wf for l less than 6 -- ' + write(iwf,*) ' radial coor --- wf ' + write(iwf,*) +c + do 3 i= 1, 6 + write(iwf,*) ' l= ', i-1 + do 4 j=1,kmax(nas) + write(iwf,*) r(j,1),p(j,i+npss) + 4 continue + 3 continue +c + return + end +c +c +C-------------------------------------------------------------- + + subroutine writeelswf + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, + 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), + 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), + 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE + COMPLEX VCON,XE,EV + CHARACTER*8 NSYMBL,NAME0 +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c +c + common/funit/idat,iwr,iphas,iedl0,iwf +c +c write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf + write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)' + write(iwf,*) e, xe, real(vcon) +c +c write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10) +c + write(iwf,*) + write(iwf,*) ' -- absorber excited regular wf for all l -- ' + write(iwf,*) +c + do i=1,lmxels(1,nas) + write(iwf,*) ' inc l= ', i-1 + do j=1,kmx(nas) + write(iwf,10) rx(j,1),p1(j,i,nas)/ramfsr1(i,nas) + enddo + enddo +c +c + do i=1,lmxels(2,nas) + write(iwf,*) ' sct l= ', i-1 + do j=1,kmx(nas) + write(iwf,10) rx(j,1),p2(j,i,nas)/ramfsr2(i,nas) + enddo + enddo +c +c + do i=1,lmxels(3,nas) + write(iwf,*) ' exc l= ', i-1 + do j=1,kmx(nas) + write(iwf,10) rx(j,1),p3(j,i,nas)/ramfsr3(i,nas) + enddo + enddo +c +c + 10 format(7e15.7) +c + write(iwf,*) + write(iwf,*) ' -- absorber irregular wf for l less than 6 -- ' + write(iwf,*) ' radial coor --- wf ' + write(iwf,*) +c + do 3 i= 1, 6 + write(iwf,*) ' l= ', i-1 + do 4 j=1,kmx(nas) + write(iwf,10) rx(j,1),p3irreg(j,i) + 4 continue + 3 continue +c + return + end +c +c +c********************************************************************** +c + subroutine scfdat (title, ifr, iz, ihole, xion,amass, beta,iprint, + 1 vcoul, srho, dgc0, dpc0, enp, eatom) +c +c single configuration dirac-fock atom code +c +c input: +c title - any name that will be written into output files. +c ifr - specify aadditional output file atom(ifr).dat +c iz - atomic number +c ihole - remove one electron from orbital #ihole. +c complete list is in subroutine getorb. +c xion - ionicity (iz-number of electrons) +c amass - mass of nucleus; 0. - for point nucleus. +c beta - thickness parameter for nuclear charge distribution +c beta=0. for uniform distribution +c iprint - if iprint>0 additional output is written into atom(ifr).dat +c output: +c vcoul - total coulomb potential (hartrees) +c srho - total charge density (bohr**-3) +c dgc0 - upper components of dirac spinors +c dpc0 - lower components of dirac spinors +c enp - energy eigenvalues (hartrees) +c eatom - total atomic energy (hartrees) + +c written by a. ankudinov, univ. of washington +c +c programming language fortran 77 +c +c based on modifications of the code ACRV of J.P. Desclaux +c [Comp Phys Comm. 9, 31 (1975)] and some subroutines from +c the FEFF code, J.J. Rehr, J. Mustre de Leon, S.I. Zabinsky +c and R.C. Albers, [J. Am. Chem. Soc 113,5135(1991) +c +c version 1 (5-22-96) +c +c********************************************************************** + + implicit double precision (a-h,o-z) + parameter ( mp = 251, ms = 30 ) +c +c save central atom dirac components, see comments below. +c + dimension dgc0(mp), dpc0(mp) + dimension vcoul(mp), srho(mp), enp(ms) + + character*(*) title + character*40 ttl + character*512 slog + common /charact/ ttl + + character*30 fname +c +c this programm uses cofcon cofdat dsordf ictime iowrdf +c lagdat messer nucdev ortdat potrdf soldir + common cg(mp,ms),cp(mp,ms),bg(10,ms),bp(10,ms),fl(ms),ibgp +c cg (cp) large (small) components +c bg (bp) development coefficients at the origin of large +c (small) component +c fl power of the first term of development limits. +c ibgp first dimension of the arrays bg and bp +c +c gg,gp are the output from soldir +c + common/comdir/cl,dz,gg(mp),ag(10),gp(mp),ap(10),bid(3*mp+30) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/mulabk/afgk + common/inelma/nem + dimension afgk( 30, 30, 0:3) + common/messag/dlabpr,numerr + character*8 dprlab, dlabpr + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/scrhf1/eps(435),nre(30),ipl + common/snoyau/dvn(251),anoy(10),nuc + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + data dprlab/' scfdat'/ + + +c +c *** copy input parameters to common blocks +c + ttl = title + lttl = istrln(title) + if (lttl.le.0) ttl='atomic data' + nz=iz + dz=nz +c +c *** desclaux standard opinion. be careful when changing. +c + nuc=11 +c +c nuc - number of points inside nucleus (suggested value 11) +c + nes=50 +c +c nes number of attempts in program soldir +c differ from desclaux nes=40 +c + niter=30 +c +c equivalent to desclaux niter=1130 +c niter =1000*n1+100*n2+n3 +c n3 is the number of iterations per orbital +c + testy=1.d-5 +c +c testy precision for the wave functions +c + hx=5.d-2 + dr(1)=exp(-8.8D0)*iz +c +c dr(1)=exp(-8.8) +c hx exponential step +c dr1 first tabulation point multiplied by nz +c desclaux dr1=0.01 correspond to iz=66 +c + teste=5.d-6 + rap(1)=1.d2 + rap(2)=1.d1 +c +c teste precision for the one-electron energies +c rap tests of precision for soldir +c + ido=1 +c +c equivalent to ido=ndep=1 +c calculate initial orbitals using thomas-fermi model ido=1 +c option to read from cards(ido=2) destroyed +c nmax=251 - set in subroutine inmuat +c scc=0.3 - set in subroutine inmuat +c *** end of desclaux standard opinion on parameters +c + if (iprint .ge. 1) then +c +c prepare file for atom output +c + write(fname,14) ifr + 14 format('atom', i2.2, '.dat') + open (unit=16, file=fname, status='unknown') +c call chopen (ios, fname, 'atom') +c call head (16) + write(16,*) ' free atom ', ifr + lttl = istrln(ttl) + if (iprint .ge. 1) write(16,40) ttl(1:lttl) + 40 format (1h1,40x,a) + endif +c +c initialize the rest of the data and calculate initial w.f. +c + jfail = 0 + ibgp = 10 + numerr = 0 + nz = iz + call inmuat (ihole, xion) +c +c iholep is the index for core hole orbital in all arrays +c for 90% of atoms iholep=ihole +c + a = - xion - 1 + call wfirdf ( en, a, nq, kap, nmax, ido, amass, beta) + + j = 1 + ind = 1 + nter = 0 + do 41 i=1, norb + 41 scw(i) = 0.D0 + test1 = testy / rap(1) + test2 = testy / rap(2) + netir = abs(niter) * norb + if (iprint .ge. 1) then + write(16,210) niter, teste, testy + 210 format (5x,'number of iterations',i4,//, + 1 5x,'precision of the energies',1pe9.2,//, + 2 23x,'wave functions ',1pe9.2,/) + write(16,220) idim, dr(1), hx + 220 format (' the integration is made on ', i3, + 1 ' points-the first is equal to ' ,f7.4,/, + 2 ' and the step-size pas = ',f7.4,/) + write(16,230) test1, nes + 230 format ('matching of w.f. with precision', 1pe9.2, + 2 ' in ',i3,' attempts ',/) + if (nuc.gt.1) write(16,250) + 250 format (1h0,30x,'finite nucleus case used'/) + endif +c +c muatco - programm to calculate angular coefficients +c + call muatco + if (numerr .ne. 0) go to 711 +c +c iteration over the number of cycles +c + 101 iort = 0 + nter = nter + 1 + if (niter .ge. 0) go to 105 +c +c orthogonalization by schmidt procedure +c + 104 call ortdat (j) + 105 method = 1 +c +c calculate lagrange parameters +c + if (nre(j).gt.0 .and. ipl.ne.0) call lagdat (j,1) +c +c calculate electron potential +c + call potrdf (j) + e = en(j) + np = idim +c +c resolution of the dirac equation +c + ifail = 0 + ainf = cg(nmax(j),j) + call soldir (en(j), fl(j), bg(1,j), bp(1,j), ainf, + 1 nq(j), kap(j), nmax(j), ifail) + if (ifail .ne. 0 .and. jfail .eq. 0) jfail = j + if (jfail .eq. j .and. ifail .eq.0 ) jfail = 0 + if (numerr.eq.0) go to 111 + if (iort.ne.0 .or. niter.lt.0) go to 711 + iort = 1 + go to 104 + + 111 sce(j) = abs((e-en(j)) / en(j)) +c +c variation of the wave function using two iterations +c + k = nmax(j) + pr = 0.D0 + do 121 i = 1, k + w = cg(i,j) - gg(i) + if (abs(w).le.abs(pr)) go to 115 + pr = w + a = cg(i,j) + b = gg(i) + 115 w = cp(i,j) - gp(i) + if (abs(w).le.abs(pr)) go to 121 + pr = w + a = cp(i,j) + b = gp(i) + 121 continue + write(slog,'(i4,i3,2(1pe11.2),2(1pd16.6),4x,a,i2)') + 1 nter, j, sce(j), pr, a, b, 'method', method + call wlog(slog,0) +c +c acceleration of the convergence +c + b = scc(j) + call cofcon (a, b, pr, scw(j)) + scc(j) = b + do 151 i = 1,k + gg(i) = b*gg(i) + a*cg(i,j) + 151 gp(i) = b*gp(i) + a*cp(i,j) + do 155 i=1,ndor + ag(i) = b*ag(i) + a*bg(i,j) + 155 ap(i) = b*ap(i) + a*bp(i,j) +c +c normalization of the wave function +c + a = dsordf (j,k,0,4,fl(j)) + a = sqrt(a) + do 171 i=1, np + cg(i,j) = gg(i) / a + 171 cp(i,j) = gp(i) / a + do 175 i=1, ndor + bg(i,j) = ag(i) / a + 175 bp(i,j) = ap(i) / a +c +c determination of the next orbital to calculate +c + if (nter.lt.norbsc .or. (ind.lt.0 .and. j.lt.norbsc) ) then + j = j+1 + go to 451 + endif + j = j+1 + pr=0.D0 + do 301 i=1, norbsc + w = abs(scw(i)) + if (w.gt.pr) then + pr = w + j = i + endif + 301 continue + if (j.gt.norbsc) j = 1 + if (pr.gt.testy) go to 421 + pr = 0.D0 + do 321 i=1, norbsc + w = abs(sce(i)) + if (w.gt.pr) then + pr = w + j = i + endif + 321 continue + if (pr.ge.teste) go to 421 + if (ind.lt.0) go to 999 + ind = -1 + j = 1 + go to 451 + + 421 ind = 1 + 451 if (nter.le.netir) go to 101 + numerr = 192011 +c +c **** number of iterations exceeded the limit +c + dlabpr = dprlab + 711 call messer + stop + 999 if (numerr .eq. 0) then + if (jfail.ne.0) then + call wlog( + 1 'failed to match lower component, results are meaningless',1) + stop + endif +c +c tabulation of the results +c + if (iprint .ge. 1) call tabrat + call etotal( kap, xnel, en, iprint, eatom) +c +c return coulomb potential +c + do 800 i=1, idim + 800 srho(i) = 0.0D0 + do 830 j=1, norb + do 830 i=1, nmax(j) + 830 srho(i) = srho(i) + xnel(j) * (cg(i,j)**2 + cp(i,j)**2) + call potslw( vcoul, srho, dr, hx, idim) + do 810 i=1, 251 + 810 vcoul(i) = vcoul(i) - nz/dr(i) +c +c return srho as density instead of 4*pi*density*r**2 +c do 860 i = 1, 251 +c srho(i) = srho(i) / (dr(i)**2) / 4. / pi +c srho(i) = srho(i) / 4. / pi +c 860 continue +c + do 870 ispinr = 1, 30 + do 852 i = 1, 251 + dgc0(i) = cg( i, ispinr) + dpc0(i) = cp( i, ispinr) + 852 continue + enp(ispinr) = en(ispinr) + 870 continue + endif + if (iprint .ge. 1) close(unit=16) + + return + end + double precision function akeato (i,j,k) +c angular coefficient by the direct coulomb integral fk +c for orbitals i and j + + implicit double precision (a-h,o-z) + common/mulabk/afgk + dimension afgk(30,30,0:3) +c +c afgk angular coefficients by integrales fk and gk +c coefficient of integral fk(i;j) is in afgk(min,max) +c and that of integral gk(i;j) is in afgk(max,min) +c max=max(i,j) min=min(i,j) +c + if (i .le. j) then + akeato=afgk(i,j,k/2) + else + akeato=afgk(j,i,k/2) + endif + return + + entry bkeato (i,j,k) +c +c angular coefficient at the exchange coulomb integral gk +c + bkeato=0.0d 00 + if (i .lt. j) then + bkeato=afgk(j,i,k/2) + elseif (i.gt.j) then + bkeato=afgk(i,j,k/2) + endif + return + end + double precision function aprdev (a,b,l) +c +c the result of this function is the coefficient of the term of +c power for the product of two polynomes, whose coefficients are +c in rows a and b +c + implicit double precision (a-h,o-z) + dimension a(10),b(10) + + aprdev=0.0d 00 + do 11 m=1,l + 11 aprdev=aprdev+a(m)*b(l+1-m) + return + end + subroutine bkmrdf (i,j,k) +c +c angular coefficients for the breit term +c i and j are the numbers of orbitals +c k is the value of k in uk(1,2) +c this programm uses cwig3j +c coefficients for magnetic interaction are in cmag +c and those for retarded term are in cret +c the order correspond to -1 0 and +1 +c + implicit double precision (a-h,o-z) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabre/cmag(3),cret(3) + + do 12 l=1,3 + cmag(l)=0.0d 00 + 12 cret(l)=0.0d 00 + ji=2* abs(kap(i))-1 + jj=2* abs(kap(j))-1 + kam=kap(j)-kap(i) + l=k-1 + do 51 m=1,3 + if (l.lt.0) go to 51 + a=cwig3j(ji,jj,l+l,-1,1,2)**2 + if (a.eq.0.0d 00) go to 51 + c=l+l+1 + if (m-2) 14,16,17 + 14 cm=(kam+k)**2 + cz=kam*kam-k*k + cp=(k-kam)**2 + n=k + 15 l1=l+1 + am=(kam-l)*(kam+l1)/c + az=(kam*kam+l*l1)/c + ap=(l+kam)*(kam-l1)/c + d=n*(k+k+1) + go to 31 + + 16 d=k*(k+1) + cm=(kap(i)+kap(j))**2 + cz=cm + cp=cm + go to 41 + + 17 cm=(kam-l)**2 + cz=kam*kam-l*l + cp=(kam+l)**2 + n=l + c=-c + go to 15 + + 31 c= abs(c)*d + if (c.ne.0.0d 00) c=n/c + cret(1)=cret(1)+a*(am-c*cm) + cret(2)=cret(2)+(a+a)*(az-c*cz) + cret(3)=cret(3)+a*(ap-c*cp) + 41 if (d.eq.0.0d 00) go to 51 + a=a/d + cmag(1)=cmag(1)+cm*a + cmag(2)=cmag(2)+cz*(a+a) + cmag(3)=cmag(3)+cp*a + 51 l=l+1 + return + end + subroutine cofcon (a,b,p,q) +c +c acceleration of the convergence in the iterative process +c b is the part of final iteration n is a function of the error (p) +c (p) at iteration n and the error (q) at the iteration n-1. +c if the product p*q is positive b is increased by 0.1 +c zero b is unchanged +c negative b is decreased by 0.1 +c b is between 0.1 and 0.9 +c a = 1. - b +c ** at the end makes q=p +c + implicit double precision (a-h,o-z) + + if (p*q) 11,31,21 + 11 if (b .ge. 0.2D0) b = b - 0.1D0 + go to 31 + + 21 if (b .le. 0.8D0) b = b + 0.1D0 + + 31 a = 1.0D0 - b + q=p + return + end + double precision function cwig3j (j1,j2,j3,m1,m2,ient) +c +c wigner 3j coefficient for integers (ient=1) +c or semiintegers (ient=2) +c other arguments should be multiplied by ient +c + implicit double precision (a-h,o-z) + save + character*512 slog + dimension al(32),m(12) + data ini/1/,idim/31/ +c +c idim-1 is the largest argument of factorial in calculations +c + m3=-m1-m2 + if (ini) 1,21,1 +c +c initialisation of the log's of the factorials +c + 1 ini=0 + al(1)=0.0d 00 + do 11 i=1,idim + b=i + 11 al(i+1)=al(i)+ log(b) + 21 cwig3j=0.0d 00 + if (((ient-1)*(ient-2)).ne.0) go to 101 + ii=ient+ient +c +c test triangular inequalities, parity and maximum values of m +c + if (( abs(m1)+ abs(m2)).eq.0.and.mod(j1+j2+j3,ii).ne.0) go to 99 + m(1)=j1+j2-j3 + m(2)=j2+j3-j1 + m(3)=j3+j1-j2 + m(4)=j1+m1 + m(5)=j1-m1 + m(6)=j2+m2 + m(7)=j2-m2 + m(8)=j3+m3 + m(9)=j3-m3 + m(10)=j1+j2+j3+ient + m(11)=j2-j3-m1 + m(12)=j1-j3+m2 + do 41 i=1,12 + if (i.gt.10) go to 31 + if (m(i).lt.0) go to 99 + 31 if (mod(m(i),ient).ne.0) go to 101 + m(i)=m(i)/ient + if (m(i).gt.idim) go to 101 + 41 continue +c +c calculate 3j coefficient +c + max0= max(m(11),m(12),0)+1 + min0= min(m(1),m(5),m(6))+1 + isig=1 + if (mod(max0-1,2).ne.0) isig=-isig + c=-al(m(10)+1) + do 61 i=1,9 + 61 c=c+al(m(i)+1) + c=c/2.0d 00 + do 71 i=max0,min0 + j=2-i + b=al(i)+al(j+m(1))+al(j+m(5))+al(j+m(6))+al(i-m(11))+al(i-m(12)) + cwig3j=cwig3j+isig* exp(c-b) + 71 isig=-isig + if (mod(j1-j2-m3,ii).ne.0) cwig3j=-cwig3j + 99 return + 101 write(slog,'(a,6i5)') 'error in cwig3j ',j1,j2,j3,m1,m2,ient + call wlog(slog,1) + stop + end + double precision function dentfa (dr,dz,ch) +c +c analitical approximation of potential is created for electrons in +c thomas-fermi model for atom or free ion. dr distance from nucleus +c with charge dz +c ch=ionicity = number of electrons-dz-1 +c + implicit double precision (a-h,o-z) + + dentfa=0.0d 00 + if ((dz+ch).lt.1.0d-04) return + w=dr*(dz+ch)**(1.D0/3.D0) + w=sqrt(w/0.8853D0) + t=w*(0.60112D0*w+1.81061D0)+1.D0 + w=w*(w*(w*(w*(0.04793D0*w+0.21465D0)+0.77112D0)+1.39515D0)+ + 1 1.81061D0)+1D0 + dentfa=(dz+ch)*(1.0d 00-(t/w)**2)/dr + return + end + double precision function dsordf (i,j,n,jnd,a) +c +c * calculation of diff. integrals* +c integration by simpson method of the hg*(r**n) +c hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) if jnd=1 +c hg=expression above multiplied by dg if jnd=-1 +c hg(l)=cg(l,i)*cp(l,j) if jnd=2 +c hg=expression above multiplied by dg if jnd=-2 +c hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j) if jnd=3 +c hg(l)=dg(l)*dg(l)+dp(l)*dp(l) if jnd=4 +c hg is constructed by calling program if jnd>=5 +c cg(l,i) large component of the orbital i +c cp(l,j) small component of the orbital j +c a is such that dg,dp or hg following the case +c behave at the origin as cte*r**a +c the integration is made as far as dr(j) for jnd>3 +c +c the development limits at the origin (used for calculation +c of integral form 0 to dr(1) ) of functions dg,dp and hg are +c supposed to be in blocks ag,ap and chg respectively +c this program utilises aprdev +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) + dimension hg(251),chg(10) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + dimension bgi(10),bgj(10),bpi(10),bpj(10) +c +c construction of the array hg +c + if (jnd.le.3) go to 11 + max0=j + b=a + go to 101 + + 11 max0= min(nmax(i),nmax(j)) + do 15 l= 1,ibgp + bgi(l) = bg(l,i) + bgj(l) = bg(l,j) + bpi(l) = bp(l,i) + 15 bpj(l) = bp(l,j) + if ( abs(jnd)-2) 21,55,101 + 21 do 31 l=1,max0 + 31 hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) + do 45 l=1,ndor + 45 chg(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l) + go to 81 + + 55 do 61 l=1,max0 + 61 hg(l)=cg(l,i)*cp(l,j) + do 71 l=1,ndor + 71 chg(l)=aprdev(bgi,bpj,l) + 81 b=fl(i)+fl(j) + if (jnd.gt.0) go to 301 + + do 85 l=1,max0 + 85 hg(l)=hg(l)*dg(l) + do 87 l=1,ndor + 87 ap(l)=chg(l) + b=b+a + do 95 l=1,ndor + 95 chg(l)=aprdev(ap,ag,l) + go to 301 + + 101 if (jnd-4) 201,111,301 + 111 do 121 l=1,max0 + 121 hg(l)=dg(l)*dg(l)+dp(l)*dp(l) + b=b+b + do 131 l=1,ndor + 131 chg(l)=aprdev(ag,ag,l)+aprdev(ap,ap,l) + go to 301 + + 201 do 221 l=1,max0 + 221 hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j) + b=a+fl(i) + do 241 l=1,ndor + 241 chg(l)=aprdev(bgi,ag,l)+aprdev(bpj,ap,l) +c +c integration of the hg +c + 301 dsordf=0.0d 00 + io=n+1 + do 305 l=1,max0 + 305 hg(l)=hg(l)*(dr(l)**io) + do 311 l=2,max0,2 + 311 dsordf=dsordf+hg(l)+hg(l)+hg(l+1) + dsordf=hx*(dsordf+dsordf+hg(1)-hg(max0))/3.0d 00 +c +c integral from 0 to dr(1) +c + b=b+n + do 331 l=1,ndor + b=b+1.0d 00 + 331 dsordf=dsordf+chg(l)*(dr(1)**b)/b + return + end + subroutine etotal (kap,xnel,en,iprint,eatom) +c +c combined from original subroutines tabfgk,tabbre,tabrat. +c kap quantique number "kappa" +c xnel occupation of orbitales (can be fractional) +c en one-electron energies +c fdrirk function calculating radial integrals rk +c akeato angular coefficient for integrals fk, for the +c integrals fk(i;i) gives angular coefficients multiplied by 2 +c bkeato angular coefficient for integrals gk +c coul ener(1) direct coulomb interaction +c ech ener(2) exchange coulomb interaction +c * average value of the breit hamiltonian * +c fdrocc function of the orbitals' occupations. +c bkmrdf is a programm to calculate angular coefficients +c ema ener(3) magnetic energy +c ere ener(4) retardation term +c sous programmes utilises akeato,bkeato +c fdrocc fdrirk bkmrdf +c + implicit double precision (a-h,o-z) + dimension kap(30),xnel(30),en(30) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + dimension ener(4) + dimension cer(17) + common/tabre/cmag(3),cret(3) + common/inelma/nem + character*4 iner(4) + character*512 slog + data iner/'coul','ech.','mag.','ret.'/ + + do 10 i = 1,4 + 10 ener(i)=0.0d 00 + iv=0 +c +c fk integrales +c + do 40 i=1,norb + l= abs(kap(i))-1 + do 40 j=1,i + a=1.0d 00 + if (j.eq.i) a=a+a + m= abs(kap(j))-1 + kmi=2* min(l,m) + k=0 + 20 iv=iv+1 + cer(iv)=fdrirk(i,i,j,j,k) + ener(1)=ener(1)+cer(iv)*akeato(i,j,k)/a + if (iv.lt.3) go to 30 + iv=0 + 30 k=k+2 + if (k.le.kmi) go to 20 + 40 continue + iv=0 + if (norb.gt.1) then +c +c gk integrales +c + do 70 i=2,norb + i1=i-1 + do 70 j=1,i1 + l= abs(kap(i)) + m= abs(kap(j)) + k= abs(l-m) + if ((kap(i)*kap(j)).lt.0) k=k+1 + kmi=l+m-1 + 50 iv=iv+1 + cer(iv)=fdrirk(i,j,i,j,k) + ener(2) = ener(2) -cer(iv)*bkeato(i,j,k) + if (iv.lt.3) go to 60 + iv=0 + 60 k=k+2 + if (k.le.kmi) go to 50 + 70 continue + endif +c + nem=1 +c +c direct integrales +c + ik=0 + do 140 j=1,norb + jj=2* abs(kap(j))-1 + do 140 i=1,j + ji=2* abs(kap(i))-1 + k=1 + kma= min(ji,jj) + 110 ik=ik+1 + cer(ik)=fdrirk(j,j,i,i,k) + if (i.ne.j) go to 120 + call bkmrdf (j,j,k) + ener(3)=ener(3)+(cmag(1)+cmag(2)+cmag(3))*cer(ik)* + 1 fdmocc(j,j)/2.0d 00 + 120 if (ik.lt.3) go to 130 + ik=0 + 130 k=k+2 + if (k.le.kma) go to 110 + 140 continue + if (norb.gt.1) then +c +c exchange integrales +c + do 201 j=2,norb + lj= abs(kap(j)) + na=-1 + if (kap(j).gt.0) go to 121 + na=-na + lj=lj-1 + 121 jp=j-1 + do 201 l=1,jp + ll= abs(kap(l)) + nb=-1 + if (kap(l).gt.0) go to 131 + nb=-nb + ll=ll-1 + 131 b=fdmocc(j,l) + nm1= abs(lj+na-ll) + nmp1=ll+lj+nb + nmm1=ll+lj+na + np1= abs(ll+nb-lj) + k= min(nm1,np1) + kma=max(nmp1,nmm1) + if (mod(k+ll+lj,2).eq.0) k=k+1 + nb= abs(kap(j))+ abs(kap(l)) + 141 call bkmrdf (j,l,k) + do 151 i=1,3 + 151 cer(i)=0.0d 00 + if (nb.le.k.and.kap(l).lt.0.and.kap(j).gt.0) go to 161 + cer(1)=fdrirk(l,j,l,j,k) + cer(2)=fdrirk(0,0,j,l,k) + 161 if (nb.le.k.and.kap(l).gt.0.and.kap(j).lt.0) go to 171 + cer(3)=fdrirk(j,l,j,l,k) + if (cer(2).ne.0.0d 00) go to 171 + cer(2)=fdrirk(0,0,l,j,k) + 171 do 185 i=1,3 + ener(3) =ener(3) +cmag(i)*cer(i)*b + 185 ener(4) =ener(4) +cret(i)*cer(i)*b + k=k+2 + if (k.le.kma) go to 141 + 201 continue + endif +c +c total energy +c + eatom = -(ener(1)+ener(2))+ener(3)+ener(4) + do 212 j=1,norb + 212 eatom = eatom + en(j)*xnel(j) + if (iprint .ge. 1) write(16,'(a,1pd18.7)') 'etot',eatom + write(slog,'(a,1pd18.7)') 'etot',eatom + call wlog(slog,0) + do 215 i=1,4 + if (iprint .ge. 1) write(16,'(a4,1pd18.7)') iner(i),ener(i) + write(slog,'(a4,1pd18.7)') iner(i),ener(i) + 215 call wlog(slog,0) + return + end +c + double precision function fdmocc (i,j) +c +c product of the occupation numbers of the orbitals i and j +c + implicit double precision (a-h,o-z) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + + if (j.eq.i) then + fdmocc=xnel(i)*(xnel(j)-1) + a=2* abs(kap(i)) + fdmocc=fdmocc*a/(a-1.0D0) + else + fdmocc=xnel(i)*xnel(j) + endif + return + end +c + double precision function fdrirk (i,j,l,m,k) +c +c * calculate radial integrales rk * +c rk = integral of f(r) * uk(r,s) * g(s) +c uk(r,s) = rinf**k / rsup**(k+1) rinf=min(r,s) rsup=max(r,s) +c if nem=0 f(.)=cg(.,i)*cg(.,j)+cp(.,i)*cp(.,j) +c g(.)=cg(.,l)*cg(.,m)+cp(.,l)*cp(.,m) +c if nem non zero f(.)=cg(.,i)*cp(.,j) +c g(.)=cg(.,l)*cp(.,m) +c cg (cp) large (small) componenents of the orbitales +c moreover if nem > or =0 the integration is made from 0 to infinity, +c and otherwise from 0 to r. +c this programm uses yzkrdf and dsordf +c + implicit double precision (a-h,o-z) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) +c +c comdir is used just to exchange variables between dsordf,yzkrdf,fdrirk +c + dimension hg(251) + common/inelma/nem + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + save + + fdrirk=0.0d 00 + if (i.le.0.or.j.le.0) go to 201 + call yzkrdf (i,j,k) + nn= abs(kap(i))+ abs(kap(j)) + nn=max(nn-k,1) + a=k+1 + do 21 n=1,ndor + 21 hg(n)=0.0d 00 + do 31 n=1,ndor + if (nn.gt.ndor) go to 31 + hg(nn)=-ag(n) + 31 nn=nn+1 + do 41 n=1,ndor + 41 ag(n)=hg(n) + ag(1)=ag(1)+ap(1) + + 201 if (l.le.0.or.m.le.0) return + n=-1 + if (nem.ne.0) n=-2 + fdrirk=dsordf(l,m,-1,n,a) + return + end +c + subroutine getorb (iz, ihole, xion, norb, norbco, + 1 iholep, den, nqn, nk, xnel, xnval) +c +c Gets orbital data for chosen element. Input is iz, atomic number +c of desired element, other arguments are output. +c Feel free to change occupation numbers for element of interest. +c ival(i) is necessary only for partly nonlocal exchange model. +c iocc(i) and ival(i) can be fractional +c But you have to keep the sum of iocc(i) equal to nuclear charge. +c Also ival(i) should be equal to iocc(i) or zero. +c Otherwise you have to change this subroutine or contact authors +c for help. +c + implicit double precision (a-h, o-z) +c +c Written by Steven Zabinsky, July 1989 +c modified (20 aug 1989) table increased to at no 97 +c Recipe for final state configuration is changed. Valence +c electron occupations are added. ala 17.1.1996 + +c Table for each element has occupation of the various levels. +c The order of the levels in each array is: + +c element level principal qn (nqn), kappa qn (nk) +c 1 1s 1 -1 +c 2 2s 2 -1 +c 3 2p1/2 2 1 +c 4 2p3/2 2 -2 +c 5 3s 3 -1 +c 6 3p1/2 3 1 +c 7 3p3/2 3 -2 +c 8 3d3/2 3 2 +c 9 3d5/2 3 -3 +c 10 4s 4 -1 +c 11 4p1/2 4 1 +c 12 4p3/2 4 -2 +c 13 4d3/2 4 2 +c 14 4d5/2 4 -3 +c 15 4f5/2 4 3 +c 16 4f7/2 4 -4 +c 17 5s 5 -1 +c 18 5p1/2 5 1 +c 19 5p3/2 5 -2 +c 20 5d3/2 5 2 +c 21 5d5/2 5 -3 +c 22 5f5/2 5 3 +c 23 5f7/2 5 -4 +c 24 6s 6 -1 +c 25 6p1/2 6 1 +c 26 6p3/2 6 -2 +c 27 6d3/2 6 2 +c 28 6d5/2 6 -3 +c 29 7s 7 -1 +c + dimension den(30), nqn(30), nk(30), xnel(30), xnval(30) + dimension kappa (29) + real iocc, ival + dimension iocc (97, 29), ival (97, 29) + dimension nnum (29) + character*512 slog +c +c kappa quantum number for each orbital +c k = - (j + 1/2) if l = j - 1/2 +c k = + (j + 1/2) if l = j + 1/2 +c + data kappa /-1,-1, 1,-2,-1, 1,-2, 2,-3,-1, 1,-2, 2,-3, 3, + 1 -4,-1, 1,-2, 2, -3, 3,-4,-1, 1, -2, 2,-3,-1/ +c +c principal quantum number (energy eigenvalue) +c + data nnum /1,2,2,2,3, 3,3,3,3,4, 4,4,4,4,4, + 1 4,5,5,5,5, 5,5,5,6,6, 6,6,6,7/ +c +c occupation of each level for z = 1, 97 +c + data (iocc( 1,i),i=1,29) /1,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 1,i),i=1,29) /1,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 2,i),i=1,29) /2,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 2,i),i=1,29) /2,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 3,i),i=1,29) /2,1,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 3,i),i=1,29) /0,1,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 4,i),i=1,29) /2,2,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 4,i),i=1,29) /0,2,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 5,i),i=1,29) /2,2,1,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 5,i),i=1,29) /0,2,1,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 6,i),i=1,29) /2,2,2,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 6,i),i=1,29) /0,2,2,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 7,i),i=1,29) /2,2,2,1,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 7,i),i=1,29) /0,2,2,1,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 8,i),i=1,29) /2,2,2,2,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 8,i),i=1,29) /0,2,2,2,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc( 9,i),i=1,29) /2,2,2,3,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival( 9,i),i=1,29) /0,2,2,3,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(10,i),i=1,29) /2,2,2,4,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(10,i),i=1,29) /0,2,2,4,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(11,i),i=1,29) /2,2,2,4,1, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(11,i),i=1,29) /0,0,0,0,1, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(12,i),i=1,29) /2,2,2,4,2, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(12,i),i=1,29) /0,0,0,0,2, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(13,i),i=1,29) /2,2,2,4,2, 1,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(13,i),i=1,29) /0,0,0,0,2, 1,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(14,i),i=1,29) /2,2,2,4,2, 2,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(14,i),i=1,29) /0,0,0,0,2, 2,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(15,i),i=1,29) /2,2,2,4,2, 2,1,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(15,i),i=1,29) /0,0,0,0,2, 2,1,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(16,i),i=1,29) /2,2,2,4,2, 2,2,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(16,i),i=1,29) /0,0,0,0,2, 2,2,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(17,i),i=1,29) /2,2,2,4,2, 2,3,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(17,i),i=1,29) /0,0,0,0,2, 2,3,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(18,i),i=1,29) /2,2,2,4,2, 2,4,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(18,i),i=1,29) /0,0,0,0,2, 2,4,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(19,i),i=1,29) /2,2,2,4,2, 2,4,0,0,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(19,i),i=1,29) /0,0,0,0,0, 0,0,0,0,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(20,i),i=1,29) /2,2,2,4,2, 2,4,0,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(20,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(21,i),i=1,29) /2,2,2,4,2, 2,4,1,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(21,i),i=1,29) /0,0,0,0,0, 0,0,1,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(22,i),i=1,29) /2,2,2,4,2, 2,4,2,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(22,i),i=1,29) /0,0,0,0,0, 0,0,2,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(23,i),i=1,29) /2,2,2,4,2, 2,4,3,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(23,i),i=1,29) /0,0,0,0,0, 0,0,3,0,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(24,i),i=1,29) /2,2,2,4,2, 2,4,4,1,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(24,i),i=1,29) /0,0,0,0,0, 0,0,4,1,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(25,i),i=1,29) /2,2,2,4,2, 2,4,4,1,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(25,i),i=1,29) /0,0,0,0,0, 0,0,4,1,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(26,i),i=1,29) /2,2,2,4,2, 2,4,4,2,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(26,i),i=1,29) /0,0,0,0,0, 0,0,4,2,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(27,i),i=1,29) /2,2,2,4,2, 2,4,4,3,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(27,i),i=1,29) /0,0,0,0,0, 0,0,4,3,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(28,i),i=1,29) /2,2,2,4,2, 2,4,4,4,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(28,i),i=1,29) /0,0,0,0,0, 0,0,4,4,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(29,i),i=1,29) /2,2,2,4,2, 2,4,4,6,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(29,i),i=1,29) /0,0,0,0,0, 0,0,4,6,1, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(30,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(30,i),i=1,29) /0,0,0,0,0, 0,0,4,6,2, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(31,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 1,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(31,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 1,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(32,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(32,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(33,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,1,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(33,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,1,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(34,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,2,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(34,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,2,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(35,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,3,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(35,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,3,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(36,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(36,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,4,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(37,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(37,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(38,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(38,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(39,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,1,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(39,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,1,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(40,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,2,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(40,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,2,0,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(41,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(41,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,0,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(42,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(42,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,1,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(43,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(43,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,1,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(44,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,3,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(44,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,3,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(45,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,4,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(45,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,4,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(46,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(46,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(47,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(47,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, + 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(48,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(48,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, + 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(49,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,1,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(49,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,1,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(50,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,0,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(50,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,0,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(51,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,1,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(51,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,1,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(52,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,2,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(52,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,2,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(53,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,3,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(53,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,3,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(54,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,0, 0,0,0,0,0, 0,0,0,0/ + data (ival(54,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,2,2,4,0, 0,0,0,0,0, 0,0,0,0/ + data (iocc(55,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,0, 0,0,0,1,0, 0,0,0,0/ + data (ival(55,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,1,0, 0,0,0,0/ + data (iocc(56,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(56,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(57,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, + 1 0,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ + data (ival(57,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ + data (iocc(58,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,2, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(58,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,2, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(59,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,3, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(59,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,3, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(60,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,4, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(60,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,4, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(61,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,5, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(61,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,5, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(62,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(62,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(63,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 1,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(63,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 1,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(64,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 1,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ + data (ival(64,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 1,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ + data (iocc(65,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 3,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(65,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 3,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(66,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 4,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(66,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 4,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(67,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 5,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(67,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 5,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(68,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 6,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(68,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 6,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(69,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 7,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(69,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 7,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(70,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ + data (ival(70,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, + 1 8,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ + data (iocc(71,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ + data (ival(71,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ + data (iocc(72,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,2, 0,0,0,2,0, 0,0,0,0/ + data (ival(72,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,2, 0,0,0,2,0, 0,0,0,0/ + data (iocc(73,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,3, 0,0,0,2,0, 0,0,0,0/ + data (ival(73,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,3, 0,0,0,2,0, 0,0,0,0/ + data (iocc(74,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 0,0,0,2,0, 0,0,0,0/ + data (ival(74,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 0,0,0,2,0, 0,0,0,0/ + data (iocc(75,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 1,0,0,2,0, 0,0,0,0/ + data (ival(75,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 1,0,0,2,0, 0,0,0,0/ + data (iocc(76,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 2,0,0,2,0, 0,0,0,0/ + data (ival(76,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 2,0,0,2,0, 0,0,0,0/ + data (iocc(77,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 3,0,0,2,0, 0,0,0,0/ + data (ival(77,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 3,0,0,2,0, 0,0,0,0/ + data (iocc(78,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 5,0,0,1,0, 0,0,0,0/ + data (ival(78,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 5,0,0,1,0, 0,0,0,0/ + data (iocc(79,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,1,0, 0,0,0,0/ + data (ival(79,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 6,0,0,1,0, 0,0,0,0/ + data (iocc(80,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,0, 0,0,0,0/ + data (ival(80,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,4, 6,0,0,2,0, 0,0,0,0/ + data (iocc(81,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,1, 0,0,0,0/ + data (ival(81,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,1, 0,0,0,0/ + data (iocc(82,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 0,0,0,0/ + data (ival(82,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 0,0,0,0/ + data (iocc(83,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 1,0,0,0/ + data (ival(83,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 1,0,0,0/ + data (iocc(84,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 2,0,0,0/ + data (ival(84,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 2,0,0,0/ + data (iocc(85,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 3,0,0,0/ + data (ival(85,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 3,0,0,0/ + data (iocc(86,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,0/ + data (ival(86,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,2,2, 4,0,0,0/ + data (iocc(87,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,1/ + data (ival(87,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,1/ + data (iocc(88,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,2/ + data (ival(88,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,2/ + data (iocc(89,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,1,0,2/ + data (ival(89,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,1,0,2/ + data (iocc(90,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,0,0,2,2, 4,2,0,2/ + data (ival(90,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,0,0,0,0, 0,2,0,2/ + data (iocc(91,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,2,0,2,2, 4,1,0,2/ + data (ival(91,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,2,0,0,0, 0,1,0,2/ + data (iocc(92,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,3,0,2,2, 4,1,0,2/ + data (ival(92,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,3,0,0,0, 0,1,0,2/ + data (iocc(93,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,4,0,2,2, 4,1,0,2/ + data (ival(93,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,4,0,0,0, 0,1,0,2/ + data (iocc(94,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,0,2,2, 4,0,0,2/ + data (ival(94,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,0,0,0, 0,0,0,2/ + data (iocc(95,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,1,2,2, 4,0,0,2/ + data (ival(95,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,1,0,0, 0,0,0,2/ + data (iocc(96,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,2,2,2, 4,0,0,2/ + data (ival(96,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,2,0,0, 0,0,0,2/ + data (iocc(97,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, + 1 8,2,2,4,4, 6,6,3,2,2, 4,0,0,2/ + data (ival(97,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, + 1 0,0,0,0,0, 0,6,3,0,0, 0,0,0,2/ + + if (iz .lt. 1 .or. iz .ge. 97) then + 8 format(' Atomic number ', i5, ' not available.') + write(slog,8) iz + call wlog(slog,1) + stop + endif + + ion = nint(xion) + delion=xion-ion + + + index = iz - ion + ilast = 0 + iscr = 0 + iion = 0 + iholep = ihole +c +c find last occupied orbital (ilast) and iion for delion.ge.0 +c + do 30 i=29,1,-1 + if (iion.eq.0 .and. dble(iocc(index,i)).gt.delion) iion=i + if (ilast.eq.0 .and. iocc(index,i).gt.0) ilast=i + 30 continue +c open(unit=91,file='getorbtuo.dat',status='unknown') +c iz=29 + if (ihole.eq.0) go to 11 + if (ihole.gt.0 .and. iocc(index,ihole) .lt. 1 .or. + 1 (ihole.eq.ilast .and. iocc(index,ihole)-real(delion).lt.1) ) then +c call wlog(' Cannot remove an electron from this level',1) + write(6,*)' Cannot remove an electron from level =', ihole + write(6,*) ' stop in getorb ' + stop 'GETORB-1' + endif + 11 continue +c +c the recipe for final state atomic configuration is changed +c from iz+1 prescription, since sometimes it changed occupation +c numbers in more than two orbitals. This could be consistent +c only with s02=0.0. New recipe remedy this deficiency. +c +c find where to put screening electron +c + index1 = index + 1 + do 10 i = 1, 29 + 10 if (iscr.eq.0 .and. (iocc(index1,i)-iocc(index,i)).gt.0.5) iscr=i +c +c special case of hydrogen like ion +c if (index.eq.1) iscr=2 +c +c find where to add or subtract charge delion (iion). +c if (delion .ge. 0) then +c removal of electron charge +c iion is already found +c + if (delion .lt. 0) then +c +c addition of electron charge +c + iion = iscr +c +c except special cases +c + if (ihole.ne.0 .and. + 1 iocc(index,iscr)+1-real(delion).gt.2*abs(kappa(iscr))) then + iion = ilast + if (ilast.eq.iscr .or. iocc(index,ilast)-real(delion).gt. + 1 2*abs(kappa(ilast)) ) iion = ilast + 1 + endif + endif + + norb = 0 + do 20 i = 1, 29 + if (iocc(index,i).gt.0 .or. (i.eq.iscr .and. ihole.gt.0) + 1 .or. (i.eq.iion .and. iocc(index,i)-real(delion).gt.0)) then + if (i.ne.ihole .or. iocc(index,i).ge.1) then + norb = norb + 1 + nqn(norb) = nnum(i) + nk(norb) = kappa(i) + xnel(norb) = dble(iocc(index,i)) + if (i.eq.ihole) then + xnel(norb) = xnel(norb) - 1 + iholep = norb + endif + if (i.eq.iscr .and. ihole.gt.0) xnel(norb)=xnel(norb)+1 + xnval(norb)= dble(ival(index,i)) + if (i.eq.ihole .and. xnval(norb).ge.1) + 1 xnval(norb) = xnval(norb) - 1 + if (i.eq.iscr .and. ihole.gt.0) + 1 xnval(norb) = xnval(norb) + 1 + if (i.eq.iion) xnel(norb) = xnel(norb) - delion + if (i.eq.iion) xnval(norb) = xnval(norb) - delion + den(norb) = 0.0D0 + endif + endif + 20 continue + norbco = norb +c +c check that all occupation numbers are within limits +c + do 50 i = 1, norb + if ( xnel(i).lt.0 .or. xnel(i).gt.2*abs(nk(i)) .or. + 1 xnval(i).lt.0 .or. xnval(i).gt.2*abs(nk(i)) ) then + write (slog,55) i + 55 format(' error in getorb.f. Check occupation number for ', + 1 i3, '-th orbital. May be a problem with ionicity.') + call wlog(slog,1) + stop + endif + 50 continue +c do 60 i=1,norb +c60 xnval(i) = 0.0d0 +c60 xnval(i) = xnel(i) + + return + end + + subroutine inmuat (ihole, xionin) + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc +c the meaning of common variables is described below + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) +c + dimension xnval(30) +c +c en one-electron energies +c scc factors for acceleration of convergence +c scw precisions of wave functions +c sce precisions of one-electron energies +c nmax number of tabulation points for orbitals +c + common/scrhf1/eps(435),nre(30),ipl +c +c eps non diagonal lagrange parameters +c nre distingue: - the shell is closed (nre <0) +c the shell is open (nre>0) +c - the orbitals in the integral rk if abs(nre) > or =2 +c ipl define the existence of lagrange parameters (ipl>0) +c + common/snoyau/dvn(251),anoy(10),nuc +c +c dvn nuclear potential +c anoy development coefficients at the origin of nuclear potential +c this development is supposed to be written anoy(i)*r**(i-1) +c nuc index of nuclear radius (nuc=1 for point charge) +c + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + data ideps/435/ + + ndor=10 + + + + call getorb( nz, ihole, xionin, norb, norbsc, + 1 iholep, en, nq, kap, xnel, xnval) + xk=0 + do 411 i=1,norb + 411 xk=xk+xnel(i) + if ( abs(nz-xionin-xk) .gt. 0.001D0) then + call wlog('check number of electrons in getorb.f',1) + stop + endif + norbsc=norb +c +c nz atomic number noi ionicity (nz-number of electrons) +c norb number of orbitals +c xnel(i) number of electrons on orbital i. +c first norbsc orbitals will be determined selfconsistently, +c the rest of orbitals are orthogonolized if iorth is non null, +c and their energies are those on cards if iene is non null +c or otherwise are the values obtained from solving dirac equation +c nes number of attempts in program soldir +c nuc number of points inside nucleus (11 by default) +c + do 171 i=1,ideps + 171 eps(i)=0.0d 00 + + idim = 251 + if (mod(idim,2) .eq. 0) idim=idim-1 + + ipl=0 +c +c ipl=0 means no orbitals with the same kappa and no +c orthogonalization needed. Thus it will remain zero only +c for hydrogen atom. +c + do 401 i=1,norb + nre(i)=-1 + llq= abs(kap(i)) + l=llq+llq + if (kap(i).lt.0) llq=llq-1 + if (llq.lt.0.or.llq.ge.nq(i).or.llq.gt.3) then + call wlog('kappa out of range, check getorb.f',1) + stop + endif + nmax(i)=idim + scc(i)=0.3d0 + if (xnel(i) .lt. l) nre(i)=1 + do 385 j=1,i-1 + if (kap(j).ne.kap(i)) go to 385 + if (nre(j).gt.0.or.nre(i).gt.0) ipl=ipl+1 + 385 continue + 401 continue + return + end +c + subroutine intdir(gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0) +c +c solution of the inhomogenios dirac equation +c gg gp initially exchage terms, at the time of return - wave functions +c ag and ap development coefficients of gg and gp +c ggmat gpmat values at the matching point for the inward integration +c en one-electron energy +c fl power of the first development term at the origin +c agi (api) initial values of the first development coefficients +c at the origin of a large (small) component +c ainf initial value for large component at point dr(max0) +c - at the end of tabulation of gg gp +c + implicit double precision (a-h,o-z) + save + common/comdir/cl,dz,bid1(522),dv(251),av(10),bid2(522) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + common/subdir/ell,fk,ccl,imm,nd,node,mat + common/messag/dlabpr,numerr + character*8 dlabpr + dimension gg(251),gp(251),ag(10),ap(10),coc(5),cop(5),dg(5),dp(5) + data cop/2.51d+02,-1.274d+03,2.616d+03,-2.774d+03,1.901d+03/, + 1coc/-1.9d+01,1.06d+02,-2.64d+02,6.46d+02,2.51d+02/, + 2cmixn/4.73d+02/,cmixd/5.02d+02/,hxd/7.2d+02/,npi/5/,icall/0/ +c +c numerical method is a 5-point predictor-corrector method +c predicted value p(n) = y(n-1) + c * somme de i=1,5 cop(i)*y'(n-i) +c corrected value c(n) = y(n-1) + c * somme de i=1,4 coc(i)*y'(n-i) +c + coc(5)*p'(n) +c final value y(n) = cmix*c(n) + (1.-cmix)*p(n) +c cmix=cmixn/cmixd +c + if (icall.eq.0) then + icall=1 + c=cmixn/cmixd + a=1.0d 00-c + cmc=c*coc(5) + f=coc(1) + do 1 j=2,npi + g=coc(j) + coc(j)=c*f+a*cop(j) + 1 f=g + coc(1)=c*cop(1) + endif + c=hx/hxd + ec=en/cl + ag(1)=agi + ap(1)=api + if (imm) 81,15,26 +c +c search for the second sign change point +c + 15 mat=npi + j=1 + 16 mat=mat+2 + if (mat.ge.np) then +c +c i had trouble with screened k-hole for la, for f-electrons. +c below i still define matching point if one electron energy is +c not less than -1ev. ala, january 1995 +c + if (ec .gt. -0.0003D0) then + mat = np - 12 + go to 25 + endif + numerr=56011 +c +c * fail to find matching point +c if you got this error with fractional ionicity, try +c slightly different.(xion=xion+0.01) +c + return + endif + f=dv(mat)+ell/(dr(mat)*dr(mat)) + f=(f-ec)*j + if (f) 25,25,16 + 25 j=-j + if (j.lt.0) go to 16 + if (mat .ge. np-npi) mat=np-12 +c +c initial values for the outward integration +c + 26 do 35 j=2,ndor + k=j-1 + a=fl+fk+k + b=fl-fk+k + ep=a*b+av(1)*av(1) + f=(ec+ccl)*ap(k)+ap(j) + g=ec*ag(k)+ag(j) + do 31 i=1,k + f=f-av(i+1)*ap(j-i) + 31 g=g-av(i+1)*ag(j-i) + + ag(j)=(b*f+av(1)*g)/ep + 35 ap(j)=(av(1)*f-a*g)/ep + do 41 i=1,npi + gg(i)=0.0d 00 + gp(i)=0.0d 00 + dg(i)=0.0d 00 + dp(i)=0.0d 00 + do 41 j=1,ndor + a=fl+j-1 + b=dr(i)**a + a=a*b*c + gg(i)=gg(i)+b*ag(j) + gp(i)=gp(i)+b*ap(j) + dg(i)=dg(i)+a*ag(j) + 41 dp(i)=dp(i)+a*ap(j) + i=npi + k=1 + ggmat=gg(mat) + gpmat=gp(mat) +c +c integration of the inhomogenious system +c + 51 cmcc=cmc*c + + 55 continue + a=gg(i)+dg(1)*cop(1) + b=gp(i)+dp(1)*cop(1) + i=i+k + ep=gp(i) + eg=gg(i) + gg(i)=a-dg(1)*coc(1) + gp(i)=b-dp(1)*coc(1) + do 61 j=2,npi + a=a+dg(j)*cop(j) + b=b+dp(j)*cop(j) + gg(i)=gg(i)+dg(j)*coc(j) + gp(i)=gp(i)+dp(j)*coc(j) + dg(j-1)=dg(j) + 61 dp(j-1)=dp(j) + f=(ec-dv(i))*dr(i) + g=f+ccl*dr(i) + gg(i)=gg(i)+cmcc*(g*b-fk*a+ep) + gp(i)=gp(i)+cmcc*(fk*b-f*a-eg) + dg(npi)=c*(g*gp(i)-fk*gg(i)+ep) + dp(npi)=c*(fk*gp(i)-f*gg(i)-eg) + if (i.ne.mat) go to 55 + + if (k.lt.0) go to 999 + a=ggmat + ggmat=gg(mat) + gg(mat)=a + a=gpmat + gpmat=gp(mat) + gp(mat)=a + if (imm.ne.0) go to 81 +c +c initial values for inward integration +c + a=test1* abs(ggmat) + if (ainf.gt.a) ainf=a + max0=np+2 + 73 a=7.0d+02/cl + 75 max0=max0-2 + if ((max0+1).le.(mat+npi)) then + numerr=138021 +c +c *the last tabulation point is too close to the matching point +c + return + endif + if (((dv(max0)-ec)*dr(max0)*dr(max0)).gt.a) go to 75 + + 81 c=-c + a=- sqrt(-ec*(ccl+ec)) + if ((a*dr(max0)).lt.-1.7d+02) go to 73 + b=a/(ccl+ec) + f=ainf/ exp(a*dr(max0)) + if (f.eq.0.0d 00) f=1.0d 00 + do 91 i=1,npi + j=max0+1-i + gg(j)=f* exp(a*dr(j)) + gp(j)=b*gg(j) + dg(i)=a*dr(j)*gg(j)*c + 91 dp(i)=b*dg(i) + i=max0-npi+1 + k=-1 + go to 51 + + 999 return + end +c + subroutine lagdat (ia,iex) +c +c * non diagonal lagrange parameteres * +c lagrange parameters involving orbital ia if ia is positive +c all lagrange parameters are calculated if ia is negative or zero +c contribution of the exchange terms is omitted if iex=0 +c this program uses akeato(bkeato) fdrirk multrk +c + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1 nq(30),kap(30),nmax(30) + common/scrhf1/eps(435),nre(30),ipl + + i1= max(ia,1) + idep=1 + if (ia.gt.0) go to 15 + 11 idep=i1+1 + 15 ji1=2* abs(kap(i1))-1 + do 201 i2=idep,norbsc + if (i2.eq.i1.or.kap(i2).ne.kap(i1)) go to 201 + if (nre(i1).lt.0.and.nre(i2).lt.0) go to 201 +c +c the following line was included to handle the case of single +c electron in 2 s-shells +c probably need to use schmidt orthogonalization in this case +c + if (xnel(i1).eq.xnel(i2)) go to 201 + d=0.0d 00 + do 101 l=1,norbsc + k=0 + jjl=2* abs(kap(l))-1 + kma= min(ji1,jjl) + 41 a=akeato(l,i1,k)/xnel(i1) + b=a-akeato(l,i2,k)/xnel(i2) + c=b + if (a.ne.0.0d 00) c=c/a + if ( abs(c).lt.1.0d-07) go to 51 + d=d+b*fdrirk(l,l,i1,i2,k) + 51 k=k+2 + if (k.le.kma) go to 41 + if (iex.eq.0) go to 101 + kma=(ji1+jjl)/2 + k= abs(jjl-kma) + if ((kap(i1)*kap(l)).lt.0) k=k+1 + 61 a=bkeato(l,i2,k)/xnel(i2) + b=a-bkeato(l,i1,k)/xnel(i1) + c=b + if (a.ne.0.0d 00) c=c/a + if ( abs(c).lt.1.0d-07) go to 71 + d=d+b*fdrirk(i1,l,i2,l,k) + 71 k=k+2 + if (k.le.kma) go to 61 + 101 continue + i= min(i1,i2) + j= max(i1,i2) + eps(i+((j-1)*(j-2))/2)=d/(xnel(i2)-xnel(i1)) + 201 continue + if (ia.gt.0) go to 999 + i1=i1+1 + if (i1.lt.norbsc) go to 11 + 999 return + end +c + subroutine messer +c +c prints error message on the output device +c + implicit double precision (a-h,o-z) + common/messag/dlabpr,numerr + character*8 dlabpr + character*512 slog + + ilig=numerr/1000 + ier=numerr-1000*ilig + write(slog,'(a,i6,a,i6,a,a8)') 'error number ',ier, + 1 ' detected on a line ',ilig,'in the program',dlabpr + call wlog(slog,1) + return + end +c + subroutine muatco +c +c * angular coefficients * +c sous programmes utilises cwig3j +c + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/mulabk/afgk + dimension afgk(30,30,0:3) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + + do 511 i=1,30 + do 511 j=1,30 + do 511 k=0,3 + 511 afgk(i,j,k)=0.0d 00 + do 701 i=1,norb + li= abs(kap(i))*2-1 + do 701 j=1,i + lj= abs(kap(j))*2-1 + kmax=(li+lj)/2 + kmin= abs(li-lj)/2 + if ((kap(i)*kap(j)).lt.0) kmin=kmin+1 +c +c calculate a_k(i,j) +c + m=0 + if (j.eq.i) m=1 + afgk(j,i,0)=afgk(j,i,0)+xnel(i)*(xnel(j)-m) +c +c calculate b_k(i,j) +c + b=afgk(j,i,0) + if (j.eq.i) then + a=li + b=-b*(a+1.0d 00)/a + kmin = kmin+2 + endif + do 675 k = kmin, kmax,2 + afgk(i,j,k/2)=b*(cwig3j(li,k*2,lj,1,0,2)**2) + 675 continue + 701 continue + return + end +c + subroutine nucdev (a,epai,av,dr,dv,dz,hx,nuc,np,ndor,dr1) +c +c * construction of nuclear potential * +c a atomic mass (negative or null for the point charge) +c epai parameter of the fermi density distribution +c (negative or null for uniform distribution), which is +c cte / (1. + exp((r-rn)/epai) ) +c with nuclear radius rn= 2.2677e-05 * (a**(1/3)) +c av coefficients of the development at the origin of nuclear potential +c dr tabulation points +c dv nuclear potential +c dz nuclear charge +c hx exponential step +c nuc index of the nuclear radius +c np number of tabulation points +c ndor number of the coefficients for development at the origin +c the declared below arguments are saved, dr1 is the first +c + implicit double precision (a-h,o-z) + dimension av(10),dr(251),dv(251),at(251) +c +c calculate radial mesh +c + if (a.le.1.0d-01) then + nuc=1 + else +c dr(nuc)=nuclear radius +c + a=dz*(a**(1.D0/3.D0))*2.2677d-05 + b=a/ exp(hx*(nuc-1)) + if (b.le.dr1) then + dr1=b + else +c +c increase value of nuc +c + b=log(a/dr1)/hx + nuc=3+2*int(b/2.0D0) + if (nuc.ge.np) stop 'dr1 too small' +c +c index of atomic radius larger than dimension of dr +c + dr1=a*exp(-(nuc-1)*hx) + endif + endif + + dr(1)=dr1/dz + do 181 l=2,np + 181 dr(l)=dr(1)* exp(hx*(l-1)) + + if (ndor.lt.5) then +c +c * there should be at least 5 development coefficients +c + call wlog('stopped in programm nucdev, ndor should be > 4.',1) + stop + endif +c +c calculate nuclear potential on calculated radial mesh +c + do 11 i=1,ndor + 11 av(i)=0.0d 00 + if (epai.le.0.0D0) then + do 15 i=1,np + 15 dv(i)=-dz/dr(i) + if (nuc.le.1) then + av(1)=-dz + else + av(2)=-3.0d 00*dz/(dr(nuc)+dr(nuc)) + av(4)=-av(2)/(3.0d 00*dr(nuc)*dr(nuc)) + l=nuc-1 + do 25 i=1,l + 25 dv(i)=av(2)+av(4)*dr(i)*dr(i) + endif + else + b= exp(-dr(nuc)/epai) + b=1.0d 00/(1.0d 00+b) + av(4)=b + av(5)=epai*b*(b-1.0d 00) + if (ndor.le.5) go to 45 + at(1)=1.0d 00 + at(2)=1.0d 00 + nf=1 + do 41 i=6,ndor + n=i-4 + nf=n*nf + dv(1)=n*at(1) + n1=n+1 + dv(n1)=1.0d 00 + do 35 j=2,n + 35 dv(j)=(n-j+2)*at(j-1)+(n-j+1)*at(j) + do 37 j=1,n1 + m=n+1-j + l=1 + if (mod(j,2).eq.0) l=-l + av(i)=av(i)+l*dv(j)*(b**m) + 37 at(j)=dv(j) + 41 av(i)=b*av(i)*(epai**n)/nf + 45 do 47 i=1,np + b=1.0d 00+ exp((dr(i)-dr(nuc))/epai) + if ((b*av(4)).gt.1.0d+15) go to 51 + dv(i)=dr(i)*dr(i)*dr(i)/b + 47 l=i + 51 if (l.ge.(np-1)) l=np-2 + k=l+1 + do 55 i=k,np + 55 dv(i)=0.0d 00 + at(1)=0.0d 00 + at(2)=0.0d 00 + k=2 + do 61 i=4,ndor + k=k+1 + do 58 j=1,2 + 58 at(j)=at(j)+av(i)*(dr(j)**k)/k + av(i)=av(i)/(k*(k-1)) + 61 av(2)=av(2)+av(i)*(dr(1)**k) + a=hx/2.4d+01 + b=a*1.3d+01 + k=l+1 + do 71 i=3,k + 71 at(i)=at(i-1)+b*(dv(i-1)+dv(i))-a*(dv(i-2)+dv(i+1)) + dv(l)=at(l) + do 75 i=k,np + 75 dv(i)=dv(l) + e= exp(hx) + c=1.0d 00/(e*e) + i=l-1 + 83 dv(i)=dv(i+1)/e+b*(at(i+1)/e+at(i))-a*(at(i+2)*c+at(i-1)*e) + i=i-1 + if (i-1) 85,85,83 + 85 dv(1)=dv(3)*c+hx*(at(1)+4.0d 00*at(2)/e+at(3)*c)/3.0d 00 + av(2)=(av(2)+dv(1))/dr(1) + a=-dz/dv(l) + do 95 i=4,ndor + 95 av(i)=-a*av(i) + av(2)=a*av(2) + do 97 i=1,np + 97 dv(i)=a*dv(i)/dr(i) + endif + + return + end +c + subroutine ortdat (ia) +c +c * orthogonalization by the schmidt procedure* +c the ia orbital is orthogonalized toa all orbitals of the same +c symmetry if ia is positive, otherwise all orbitals of the same +c symmetry are orthogonalized +c this program uses dsordf +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) +c dg,ag,dp,ap are used to exchange data only with dsordf + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + + m=norb + l= max(ia,1) + if (ia.gt.0) go to 11 + 5 m=l + l=l+1 + if (l.gt.norb) go to 999 + 11 do 15 i=1,idim + dg(i)=0.0d 00 + 15 dp(i)=0.0d 00 + maxl=nmax(l) + do 21 i=1,maxl + dg(i)=cg(i,l) + 21 dp(i)=cp(i,l) + do 25 i=1,ndor + ag(i)=bg(i,l) + 25 ap(i)=bp(i,l) + do 51 j=1,m + if (j.eq.l.or.kap(j).ne.kap(l)) go to 51 + max0=nmax(j) + a=dsordf (j,j,0,3,fl(l)) + do 41 i=1,max0 + dg(i)=dg(i)-a*cg(i,j) + 41 dp(i)=dp(i)-a*cp(i,j) + do 45 i=1,ndor + ag(i)=ag(i)-a*bg(i,j) + 45 ap(i)=ap(i)-a*bp(i,j) + maxl= max(maxl,max0) + 51 continue + max0= maxl + nmax(l)=max0 + a=dsordf (l,max0,0,4,fl(l)) + a= sqrt(a) + do 71 i=1,max0 + cg(i,l)=dg(i)/a + 71 cp(i,l)=dp(i)/a + do 75 i=1,ndor + bg(i,l)=ag(i)/a + 75 bp(i,l)=ap(i)/a + if (ia.le.0) go to 5 + 999 return + end +c + subroutine potrdf (ia) +c +c this programm uses akeato(bkeato),aprdev,multrk,yzkrdf +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10), + 2 eg(251),ceg(10),ep(251),cep(10) +c dg,dp to get data from yzkrdf, dv,eg,ep -output for soldir + dimension at(251),bt(251) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/scrhf1/eps(435),nre(30),ipl + common/snoyau/dvn(251),anoy(10),nuc + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + dimension bgj(10),bpj(10) + + do 9 i=1,ndor + cep(i)=0.0d 00 + ceg(i)=0.0d 00 + 9 av(i)=anoy(i) + do 11 i=1,idim + at(i)=0.0d 00 + bt(i)=0.0d 00 + ep(i)=0.0d 00 + eg(i)=0.0d 00 + 11 dv(i)=0.0d 00 +c +c coulomb terms +c + jia=2* abs(kap(ia))-1 + k=0 + 21 do 25 i=1,idim + 25 dg(i)=0.0d 00 + do 31 i=1,ndor + 31 ag(i)=0.0d 00 + max0=0 + do 51 j=1,norb + do 33 i = 1,10 + bgj(i) = bg(i,j) + 33 bpj(i) = bp(i,j) + m=2* abs(kap(j))-1 + if (k.gt.m) go to 51 + a=akeato(ia,j,k)/xnel(ia) + if (a.eq.0.0d 00) go to 51 + m=nmax(j) + do 35 i=1,m + 35 dg(i)=dg(i)+a*(cg(i,j)*cg(i,j)+cp(i,j)*cp(i,j)) + n=2* abs(kap(j))-k + l=ndor+2-n + if (l.le.0) go to 51 + do 41 i=1,l + m=n-2+i + 41 ag(m)=ag(m)+a*(aprdev(bgj,bgj,i)+ + 1 aprdev(bpj,bpj,i)) + 51 max0= max(max0,nmax(j)) + call yzkrdf (0,max0,k) + do 61 i=1,ndor + l=k+i+3 + if (l.gt.ndor) go to 61 + av(l)=av(l)-ag(i) + 61 continue + do 81 i=1,idim + 81 dv(i)=dv(i)+dg(i) + k=k+2 + if (k.le.ndor) av(k)=av(k)+ap(1) + if (k.lt.jia) go to 21 +c +c exchange terms +c + if (method.eq.0) go to 411 + do 201 j=1,norb + if (j-ia) 105,201,105 + 105 max0=nmax(j) + jj=2* abs(kap(j))-1 + kma=(jj+jia)/2 + k= abs(jj-kma) + if ((kap(j)*kap(ia)).lt.0) k=k+1 + + 111 a=bkeato(j,ia,k)/xnel(ia) + if (a.eq.0.0d 00) go to 151 + call yzkrdf (j,ia,k) + do 121 i=1,max0 + eg(i)=eg(i)+a*dg(i)*cg(i,j) + 121 ep(i)=ep(i)+a*dg(i)*cp(i,j) + n=k+1+ abs(kap(j))- abs(kap(ia)) + if (n.gt.ndor) go to 141 + do 135 i=n,ndor + ceg(i)=ceg(i)+bg(i+1-n,j)*a*ap(1) + 135 cep(i)=cep(i)+bp(i+1-n,j)*a*ap(1) + 141 i=2* abs(kap(j))+1 + if (i.gt.ndor) go to 151 + do 143 i = 1,10 + bgj(i) = bg(i,j) + 143 bpj(i) = bp(i,j) + do 145 n=i,ndor + ceg(n)=ceg(n)-a*aprdev(ag,bgj,n+1-i) + 145 cep(n)=cep(n)-a*aprdev(ag,bpj,n+1-i) + 151 k=k+2 + if (k.le.kma) go to 111 + 201 continue + 411 if (ipl.eq.0) go to 511 + do 481 j=1,norbsc + if (kap(j).ne.kap(ia).or.j.eq.ia) go to 481 + if (nre(j).lt.0.and.nre(ia).lt.0) go to 481 + m= max(j,ia) + i= min(j,ia)+((m-1)*(m-2))/2 + a=eps(i)*xnel(j) + max0=nmax(j) + do 461 i=1,max0 + at(i)=at(i)+a*cg(i,j) + 461 bt(i)=bt(i)+a*cp(i,j) + do 471 i=1,ndor + ceg(i)=ceg(i)+bg(i,j)*a + 471 cep(i)=cep(i)+bp(i,j)*a + 481 continue +c +c addition of nuclear potential and division of potentials and +c their development limits by speed of light +c + 511 do 527 i=1,ndor + av(i)=av(i)/cl + cep(i)=cep(i)/cl + 527 ceg(i)=ceg(i)/cl + do 531 i=1,idim + dv(i)=(dv(i)/dr(i)+dvn(i))/cl + ep(i)=(ep(i)+bt(i)*dr(i))/cl + 531 eg(i)=(eg(i)+at(i)*dr(i))/cl + return + end +c + subroutine potslw (dv,d,dr,dpas,np) +c +c coulomb potential uses a 4-point integration method +c dv=potential; d=density; dp=bloc de travail; dr=radial mesh +c dpas=exponential step; +c np=number of points +c ********************************************************************** +c + implicit double precision (a-h,o-z) + save + dimension dv(251), d(251), dp(251), dr(251) + das=dpas/24.0D0 + do 10 i=1,np + 10 dv(i)=d(i)*dr(i) + dlo=exp(dpas) + dlo2=dlo*dlo + dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0D0*(dlo-1.0D0)) + dp(1)=dv(1)/3.0D0-dp(2)/dlo2 + dp(2)=dv(2)/3.0D0-dp(2)*dlo2 + j=np-1 + do 20 i=3,j + 20 dp(i)=dp(i-1)+das*(13.0D0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1))) + dp(np)=dp(j) + dv(j)=dp(j) + dv(np)=dp(j) + do 30 i=3,j + k=np+1-i + 30 dv(k)=dv(k+1)/dlo+das*(13.0D0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp + 1 (k-1)*dlo)) + dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0D0*dp(2)/dlo+dp(3)/dlo2)/3.0D0 + do 40 i=1,np + 40 dv(i)=dv(i)/dr(i) + return + end +c + subroutine soldir (en,fl,agi,api,ainf,nq,kap,max0,ifail) +c +c resolution of the dirac equation +c p' - kap*p/r = - ( en/cl-v )*g - eg/r +c g' + kap*g/r = ( 2*cl+en/cl-v )*p + ep/r +c at the origin v approximately is -z/(r*cl) due to the point nucleus +c en one-electron energy in atomic units and negative +c fl power of the first term in development at the origin +c agi (api) initial values of the first development coefficient +c at the origin of the large(small)component +c ainf initial value for the large component at the point dr(max0) +c nq principal quantum number kap quantum number kappa +c max0 the last point of tabulation of the wave function +c this programm uses intdir +c + implicit double precision (a-h,o-z) + save + common/comdir/cl,dz,gg(251),ag(10),gp(251),ap(10),dv(251),av(10), + 2eg(251),ceg(10),ep(251),cep(10) +c +c gg,gp -output, dv,eg,ep - input +c + dimension hg(251),agh(10), + 1hp(251),aph(10),bg(251),bgh(10),bp(251),bph(10) +c +c cl speed of light (approximately 137.037 in atomic units) +c dz nuclear charge +c gg (gp) large (small) component +c hg,hp,bg et bp working space +c dv direct potential (v) eg and ep exchange potentials +c ag,ap,agh,aph,bgh,bph,av,ceg and cep are respectively the +c development coefficients for gg,gp,hg,hp,bg,bp,dv,eg et ep +c + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim +c +c hx exponential step +c dr radial mesh +c test1 precision for the matching the small component if method=1 +c test2 precision for the normalisation if method=2 +c ndor number of terms for the developments at the origin +c np maximum number of the tabulation points +c nes maximum number of attempts to ajust the small component +c method at the initial time distinguish the homoginious (method=0) +c from inhomoginious system. at the end is the index of method used. +c idim dimension of the block dr +c + common/subdir/ell,fk,ccl,imm,nd,node,mat +c +c ell fk*(fk+1)/ccl fk=kap ccl=cl+cl +c imm a flag for the determination of matching point +c nd number of nodes found node number of nodes to be found +c mat index of the matching point +c + common/messag/dlabpr,numerr + character*8 dprlab,dlabpr, drplab +c +c at the time of return numerr should be zero if integration is correct, +c otherwise numerr contains the number of instruction, which +c indicate the sourse and reason for abnornal return. +c + character*512 slog +c + data dprlab/' soldir'/,drplab/' intdir'/ + dlabpr=dprlab + enav=1.0d 00 + ainf= abs(ainf) + ccl=cl+cl + iex=method + if (method.le.0) method=1 +c +c notice that below iex=0,1 and method=1,2 only. +c this was used to simplify block structure of program. ala 11/22/94 +c + fk=kap + if (av(1).lt.0.0d 00.and.kap.gt.0) api=-agi*(fk+fl)/av(1) + if (av(1).lt.0.0d 00.and.kap.lt.0) api=-agi*av(1)/(fk-fl) + ell=fk*(fk+1.0d 00)/ccl + node=nq- abs(kap) + if (kap.lt.0) node=node+1 + emin=0.0D0 + do 91 i=1,np + a=(ell/(dr(i)*dr(i))+dv(i))*cl + if (a.lt.emin) emin=a + 91 continue + if (emin .ge. 0.0D0) then + numerr=75011 +c +c *potential is apparently positive +c + return + endif + if (en.lt.emin) en=emin*0.9d 00 + edep=en + + 101 numerr=0 + test=test1 + if (method.gt.1) test=test2 + einf=1.0d 00 + esup=emin + en=edep + ies=0 + nd=0 + 105 jes=0 + 106 modmat=0 + imm=0 + if ( abs((enav-en)/en).lt.1.0d-01) imm=1 + enav=en +c +c integration of the inhomogenious system +c + 107 do 111 i=1,idim + gg(i)=eg(i) + 111 gp(i)=ep(i) + do 115 i=2,ndor + ag(i)=ceg(i-1) + 115 ap(i)=cep(i-1) + call intdir (gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0) + if (numerr.ne.0) then + dlabpr=drplab + return + endif + if (iex.ne.0) go to 141 +c +c match large component for the homogenios system(method=0) +c + a=ggmat/gg(mat) + do 135 i=mat,max0 + gg(i)=a*gg(i) + 135 gp(i)=a*gp(i) + j=mat + go to 215 +c +c integration of the homogenios system +c + 141 do 151 i=1,idim + hg(i)=0.0d 00 + 151 hp(i)=0.0d 00 + do 155 i=1,ndor + agh(i)=0.0d 00 + 155 aph(i)=0.0d 00 + imm=1 + if (method.eq.1) imm=-1 + call intdir (hg,hp,agh,aph,hgmat,hpmat,en,fl,agi,api,ainf,max0) +c +c match the large component for inhomogenious system(method=1) +c + a=gg(mat)-ggmat + if (method.lt.2) then + b=-a/hg(mat) + else + b=gp(mat)-gpmat + ah=hpmat*hg(mat)-hgmat*hp(mat) + if (ah.eq.0.0d 00) go to 263 + c=(b*hg(mat)-a*hp(mat))/ah + b=(b*hgmat-a*hpmat)/ah + do 165 i=1,ndor + ag(i)=ag(i)+c*agh(i) + 165 ap(i)=ap(i)+c*aph(i) + j=mat-1 + do 168 i=1,j + gg(i)=gg(i)+c*hg(i) + 168 gp(i)=gp(i)+c*hp(i) + endif + do 173 i=mat,max0 + gg(i)=gg(i)+b*hg(i) + 173 gp(i)=gp(i)+b*hp(i) + + if (method.ge.2) then +c +c integration of the system derived from disagreement in energy +c + do 175 i=2,ndor + bgh(i)=ag(i-1)/cl + 175 bph(i)=ap(i-1)/cl + do 177 i=1,max0 + bg(i)=gg(i)*dr(i)/cl + 177 bp(i)=gp(i)*dr(i)/cl + call intdir (bg,bp,bgh,bph,bgmat,bpmat,en,fl,agi,api,ainf,max0) +c +c match both components for inhomogenious system (method=2) +c + f=bg(mat)-bgmat + g=bp(mat)-bpmat + a=(g*hg(mat)-f*hp(mat))/ah + g=(g*hgmat-f*hpmat)/ah + do 181 i=1,j + bg(i)=bg(i)+a*hg(i) + 181 bp(i)=bp(i)+a*hp(i) + do 182 i=1,ndor + bgh(i)=bgh(i)+a*agh(i) + 182 bph(i)=bph(i)+a*aph(i) + do 183 i=mat,max0 + bg(i)=bg(i)+g*hg(i) + 183 bp(i)=bp(i)+g*hp(i) +c +c calculate the norm +c + call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, + 1 gpmat,fl,max0,mat) +c +c correction to the energy (method=2) +c + do 186 i=1,max0 + 186 hg(i)=(gg(i)*bg(i)+gp(i)*bp(i))*dr(i) + ah=0.0d 00 + c=0.0d 00 + do 187 i=2,max0,2 + 187 ah=ah+hg(i)+hg(i)+hg(i+1) + ah=hx*(ah+ah+hg(1)-hg(max0))/3.0d 00+hg(1)/(fl+fl+1.0d 00) + f=(1.0d 00-b)/(ah+ah) + c=1.0d 00-b + do 191 i=1,max0 + gg(i)=gg(i)+f*bg(i) + 191 gp(i)=gp(i)+f*bp(i) + do 195 i=1,ndor + ag(i)=ag(i)+f*bgh(i) + 195 ap(i)=ap(i)+f*bph(i) + endif +c +c search for the maximum of the modulus of large component +c + a=0.0d 00 + bgh(1)=b + bph(1)=ah + do 211 i=1,max0 + g=gg(i)*gg(i) + if (g.le.a) go to 211 + a=g + j=i + 211 continue + if (j.gt.mat .and. modmat.eq.0) then + modmat=1 + mat=j + if (mod(mat,2).eq.0) mat=mat+1 + imm=1 + if (mat.lt.(max0-10)) go to 107 + + mat=max0-12 + j=mat + if (mod(mat,2).eq.0) mat=mat+1 + write(slog,'(a,i4,a,i4)') ' warning mat=',mat,' max0=',max0 + call wlog(slog,1) + endif +c +c this case can happen due to bad starting point in scf procedure. +c ignore this warning unless you are getting it at final norb calls of +c soldir. redirected by ala 11/21/94. +c numerr=220021 +c * impossible matching point +c go to 899 + +c compute number of nodes +c + 215 nd=1 + j= max(j,mat) + do 231 i=2,j + if (gg(i-1).eq.0.0d 00) go to 231 + if ((gg(i)/gg(i-1)).le.0.0d 00) nd=nd+1 + 231 continue + + if (nd-node) 251,305,261 + 251 esup=en + if (einf.lt.0.0d 00) go to 271 + en=en*8.0d-01 + if ( abs(en).gt.test1) go to 285 + numerr=238031 +c *zero energy + go to 899 + + 261 einf=en + if (esup.gt.emin) go to 271 + 263 en=en*1.2d 00 + if (en.gt.emin) go to 285 + numerr=245041 +c +c *energy is lower than the minimum of apparent potential +c + go to 899 + + 271 if ( abs(einf-esup).gt.test1) go to 281 + numerr=249051 +c +c *the upper and lower limits of energy are identical +c + go to 899 + + 281 en=(einf+esup)/2.0d 00 + + 285 jes=jes+1 + if (jes.le.nes) go to 106 +c +c *number of attempts to find good number of nodes is over the limit +c this case can happen due to bad starting point in scf procedure. +c ignore this warning unless you are getting it at final norb calls of +c soldir +c + call wlog('warning jes>nes',1) + ifail=1 +c +c *redirected by ala 11/21/94. +c numerr=255061 +c go to 899 +c +c calculation of the norm +c + 305 call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, + 1 gpmat,fl,max0,mat) + if (method.eq.1) then +c +c correction to the energy (method=1) +c + c=gpmat-gp(mat) + f=gg(mat)*c*cl/b + if (gpmat.ne.0.0d 00) c=c/gpmat + endif + + en=en+f + g= abs(f/(en-f)) + 371 if ((en.ge.0 .or. g.gt.2.0d-01) .or. + 1 (abs(c).gt.test .and. (en.lt.esup.or.en.gt.einf))) then +c +c try smaller step in enrgy under above conditions +c + f=f/2.0d 00 + g=g/2.0d 00 + en=en-f + if (g.gt.test1) go to 371 + numerr=29071 +c +c *zero energy +c + go to 899 + endif + + if ( abs(c).gt.test) then + ies=ies+1 + if (ies.le.nes) go to 105 + ifail=1 + call wlog('warning: iteration stopped because ies=nes',1) +c +c everything is fine unless you are getting this message +c on the latest stage selfconsistent process. +c just stopped trying to match lower component +c because number of trials exceeded limit. +c lines below were commented out. ala 11/18/94 +c + endif +c +c numerr=298081 +c *number of attempts to match the lower component is over the limit +c go to 899 +c +c divide by a square root of the norm, and test the sign of w.f. +c + b= sqrt(b) + c=b + if ((ag(1)*agi).lt.0.0d 00.or.(ap(1)*api).lt.0.0d 00) c=-c + do 711 i=1,ndor + ag(i)=ag(i)/c + 711 ap(i)=ap(i)/c + if ((gg(1)*agi).lt.0.0d 00.or.(gp(1)*api).lt.0.0d 00) b=-b + do 721 i=1,max0 + gg(i)=gg(i)/b + 721 gp(i)=gp(i)/b + if (max0.ge.np) return + j=max0+1 + do 741 i=j,np + gg(i)=0.0d 00 + 741 gp(i)=0.0d 00 +c +c if everything o'k , exit is here. +c + return +c +c abnormal exit is here, if method.ne.1 +c + 899 if (iex.eq.0 .or. method.eq.2) go to 999 + method=method+1 + go to 101 + + 999 return + end +c + subroutine norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, + 1 gpmat,fl,max0,mat) +c +c calculate norm b. this part of original code was used twice, +c causing difficult block structure. so it was rearranged into +c separate subroutine. ala +c + implicit double precision (a-h, o-z) + dimension hp(251),dr(251),gg(251),gp(251),ag(10),ap(10) + + b=0.0d 00 + do 311 i=1,max0 + 311 hp(i)=dr(i)*(gg(i)*gg(i)+gp(i)*gp(i)) + if (method.ne.1) go to 315 + hp(mat)=hp(mat)+dr(mat)*(gpmat**2-gp(mat)**2)/2.0d 00 + 315 do 321 i=2,max0,2 + 321 b=b+hp(i)+hp(i)+hp(i+1) + b=hx*(b+b+hp(1)-hp(max0))/3.0d 00 + do 325 i=1,ndor + g=fl+fl+i + g=(dr(1)**g)/g + do 325 j=1,i + 325 b=b+ag(j)*g*ag(i+1-j)+ap(j)*g*ap(i+1-j) + return + end + +C FUNCTION ISTRLN (STRING) Returns index of last non-blank +C character. Returns zero if string is +C null or all blank. + + FUNCTION ISTRLN (STRING) + CHARACTER*(*) STRING + CHARACTER BLANK, TAB + PARAMETER (BLANK = ' ', TAB = ' ') + +C there is a tab character here ^ + +C -- If null string or blank string, return length zero. + + ISTRLN = 0 + IF (STRING (1:1) .EQ. CHAR(0)) RETURN + IF (STRING .EQ. ' ') RETURN + +C -- Find rightmost non-blank character. + + ILEN = LEN (STRING) + DO 20 I = ILEN, 1, -1 + IF (STRING(I:I).NE.BLANK .AND. STRING(I:I).NE.TAB) GOTO 30 + 20 CONTINUE + 30 ISTRLN = I + + RETURN + END + + subroutine tabrat +c +c tabulation of the results +c do identifications of orbitals +c nmax number of tabulation points for wave function +c this programm uses dsordf +c + implicit double precision (a-h,o-z) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common /charact/ ttl + character*40 ttl + character*2 titre(30) + character*2 ttire(9) + dimension at(8),mbi(8) + parameter (zero=0) + data ttire /'s ', 'p*', 'p ', 'd*', 'd ', 'f*', 'f ','g*', 'g '/ +c + do 110 i=1,norb + if (kap(i) .gt. 0) then + j=2*kap(i) + else + j=-2*kap(i)-1 + endif + titre(i)=ttire(j) + 110 continue +c +c tabulation of number of points and of average values of +c r**n (n=6,4,2,1,-1,-2,-3) +c + do 201 i=2,8 + 201 mbi(i)=8-i-i/3-i/4+i/8 + lttl = istrln(ttl) + write(16,11) ttl(1:lttl) + 11 format (10x,a) + write(16,*) + 1'number of electrons nel and average values of r**n in a.u.' + write(16,2061) (mbi(k),k=2,8) + 2061 format (4x,'nel',' n=',7(i2,8x)) + do 251 i=1,norb + llq= abs(kap(i))-1 + j=8 + if (llq.le.0) j=7 + do 241 k=2,j + 241 at(k)=dsordf(i,i,mbi(k),1, zero) + 251 write(16,2071) nq(i),titre(i),xnel(i),(at(k),k=2,j) + 2071 format(i2,a2,f7.3,7(1pe10.3)) +c +c overlap integrals +c + if (norb.le.1) return + write(16,11) ttl(1:lttl) + write(16,321) + 321 format(10x,'overlap integrals') + do 351 i=1,norb-1 + do 331 j=i+1,norb + if (kap(j).ne.kap(i)) go to 331 + at(1)=dsordf(i,j,0,1, zero) + write(16,2091) nq(i),titre(i),nq(j),titre(j),at(1) + 331 continue + 351 continue + 2091 format (4x,i3,a2,i3,a2,f14.7) + return + end +c + subroutine wfirdf (en,ch,nq,kap,nmax,ido,amass,beta) +c +c calculate initial orbiatls from integration of dirac equation +c cg (cp) large (small) radial components +c bg (bp) development coefficients at the origin of cg (cp) +c en one-electron energies +c fl power of the first term of development at the origin +c ch ionicity (nuclear charge - number of electrons) +c nq principal quantum number +c kap quantum number "kappa" +c nmax number of tabulation points for the orbitals +c ibgp first dimension of the arrays bg and bp +c this programmes utilises nucdev,dentfa,soldir et messer +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + dimension en(30),nq(30),kap(30),nmax(30) + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10), + 1dv(251),av(10),eg(251),ceg(10),ep(251),cep(10) + common/itescf/testy,rap(2),teste,nz,norb,norbsc + common/inelma/nem + common/messag/dlabpr,numerr + character*8 dlabpr + character*512 slog + common/snoyau/dvn(251),anoy(10),nuc + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim +c +c speed of light in atomic units +c + cl=1.370373d+02 +c +c make r-mesh and calculate nuclear potential +c hx exponential step +c dr1 first tabulation point multiplied by nz +c + dr1=dr(1) + call nucdev (amass, beta,anoy,dr,dvn,dz,hx,nuc,idim,ndor,dr1) +c +c notice that here nuc=1, +c unless you specified nonzero nuclear mass in nucdev.f +c + a=(dz/cl)**2 + if (nuc.gt.1) a=0.0d 00 + do 11 j=1,norb + b=kap(j)*kap(j)-a + 11 fl(j)= sqrt(b) +c +c calculate potential from thomas-fermi model +c + do 21 i=1,idim + 21 dv(i)=(dentfa(dr(i),dz,ch)+dvn(i))/cl + if (numerr.ne.0) return + do 51 i=1,idim + eg(i)=0.0d 00 + 51 ep(i)=0.0d 00 + do 61 i=1,ibgp + ceg(i)=0.0d 00 + cep(i)=0.0d 00 + 61 av(i)=anoy(i)/cl + av(2)=av(2)+dentfa(dr(nuc),dz,ch)/cl + test1=testy/rap(1) + b=test1 +c +c resolution of the dirac equation to get initial orbitals +c + if (ido.ne.1) then + call wlog('only option ido=1 left',1) + ido = 1 + endif +c +c here was a piece to read orbitals from cards +c + do 281 j=1,norb + bg(1,j)=1.0d 00 + i=nq(j)- abs(kap(j)) + if (kap(j).lt.0) i=i-1 + if (mod(i,2).eq.0) bg(1,j)=-bg(1,j) + if (kap(j).lt.0) go to 201 + bp(1,j)=bg(1,j)*cl*(kap(j)+fl(j))/dz + if (nuc.gt.1) bg(1,j)=0.0d 00 + go to 211 + + 201 bp(1,j)=bg(1,j)*dz/(cl*(kap(j)-fl(j))) + if (nuc.gt.1) bp(1,j)=0.0d 00 + 211 np=idim + en(j)=-dz*dz/nq(j)*nq(j) + method=0 + call soldir + 1 (en(j),fl(j),bg(1,j),bp(1,j),b,nq(j),kap(j),nmax(j),0) + + if (numerr.eq.0) go to 251 + call messer + write(slog,'(a,2i3)') + 1 'soldir failed in wfirdf for orbital nq,kappa ',nq(j),kap(j) + call wlog(slog,1) + go to 281 + + 251 do 261 i=1,ibgp + bg(i,j)=ag(i) + 261 bp(i,j)=ap(i) + do 271 i=1,np + cg(i,j)=dg(i) + 271 cp(i,j)=dp(i) + 281 continue + nem=0 + return + end +c + subroutine wlog (string,iprint) + character*(*) string +c +c This output routine is used to replace the PRINT statement +c for output that "goes to the terminal", or to the log file. +c If you use a window based system, you can modify this routine +c to handle the running output elegantly. +c Handle carriage control in the string you pass to wlog. +c +c The log file is also written here, hard coded here. +c +c The log file is unit 11. The log file is opened in the +c main program, program feff. +c +c make sure not to write trailing blanks +c + + 10 format (a) + + il = istrln (string) + if (il .eq. 0) then + if(iprint.eq.1) print 10 + write(11,10) + else + if(iprint.eq.1) print 10, string(1:il) + write(11,10) string(1:il) + endif + return + end +c + subroutine yzkrdf (i,j,k) +c +c * calculate function yk * +c yk = r * integral of f(s)*uk(r,s) +c uk(r,s) = rinf**k/rsup**(k+1) rinf=min(r,s) rsup=max(r,s) +c f(s)=cg(s,i)*cg(s,j)+cp(s,i)*cp(s,j) if nem=0 +c f(s)=cg(s,i)*cp(s,j) if nem is non zero +c f(s) is constructed by the calling programm if i < or =0 +c in the last case a function f (lies in the block dg) is supposedly +c tabulated untill point dr(j), and its' devlopment coefficients +c at the origin are in ag and the power in r of the first term is k+2 + +c the output functions yk and zk are in the blocks dp and dg. +c at the origin yk = cte * r**(k+1) - developement limit, +c cte lies in ap(1) and development coefficients in ag. +c this programm uses aprdev and yzkteg +c + implicit double precision (a-h,o-z) + common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp + common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) + dimension chg(10) + common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), + 1nq(30),kap(30),nmax(30) + common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim + common/inelma/nem + dimension bgi(10),bgj(10),bpi(10),bpj(10) +c + if (i.le.0) go to 51 +c +c construction of the function f +c + do 5 l= 1,ibgp + bgi(l) = bg(l,i) + bgj(l) = bg(l,j) + bpi(l) = bp(l,i) + 5 bpj(l) = bp(l,j) + id= min(nmax(i),nmax(j)) + ap(1)=fl(i)+fl(j) + if (nem.ne.0) go to 31 + do 11 l=1,id + 11 dg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) + do 21 l=1,ndor + 21 ag(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l) + go to 55 + + 31 do 35 l=1,id + 35 dg(l)=cg(l,i)*cp(l,j) + do 41 l=1,ndor + 41 ag(l)=aprdev(bgi,bpj,l) + go to 55 +c + 51 ap(1)=k+2 + id=j + 55 call yzkteg (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim) + return + end +c + subroutine yzkteg (f,af,g,ag,dr,ap,h,k,nd,np,idim) +c +c calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to +c infinity of f(u) * u**(-k-1) +c zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k + +c at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1) +c dr tabulation points h exponential step +c np number of tabulation points for f +c idim dimension of the blocks f,g and dr + +c at the origin yk=cte*r**(k+1)-developement limit +c the constant for yk lies in ap +c output functions yk and zk lie in f and g, and their +c development coefficients at the origin in af and ag. + +c integration from point to point by a 4 points method. +c integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24 +c + implicit double precision (a-h,o-z) + dimension f(251),af(10),g(251),ag(10),dr(251) +c +c initialisation and development coefficients of yk +c + np= min(np,idim-2) + b=ap + ap=0.0d 00 + g(1)=0.0d 00 + g(2)=0.0d 00 + do 15 i=1,nd + b=b+1.0d 00 + ag(i)=af(i)/(b+k) + if (af(i).ne.0.0d 00) then + c=dr(1)**b + g(1)=g(1)+ag(i)*c + g(2)=g(2)+ag(i)*(dr(2)**b) + af(i)=(k+k+1)*ag(i)/(b-k-1) + ap=ap+af(i)*c + endif + 15 continue + do 21 i=1,np + 21 f(i)=f(i)*dr(i) + np1=np+1 + f(np1)=0.0d 00 + f(np1+1)=0.0d 00 +c +c calcualation of zk +c + eh= exp(h) + e=eh**(-k) + b=h/2.4d+01 + c=1.3d+01*b + ee=e*e*b + b=b/e + do 51 i=3,np1 + 51 g(i)=g(i-1)*e+(c*(f(i)+f(i-1)*e)-(f(i-2)*ee+f(i+1)*b)) +c +c calcualation of yk +c + f(np)=g(np) + do 61 i=np1,idim + 61 f(i)=f(i-1)*e + i=k+k+1 + b=i*b*eh + ee=i*ee/(eh*eh) + e=e/eh + c=i*c + do 71 i=np-1,2,-1 + 71 f(i)=f(i+1)*e+(c*(g(i)+g(i+1)*e)-(g(i+2)*ee+g(i-1)*b)) + ee=e*e + c=8.0d 00*c/1.3d+01 + f(1)=f(3)*ee+c*(g(3)*ee+4.0d 00*e*g(2)+g(1)) + ap=(ap+f(1))/(dr(1)**(k+1)) + return + end +c + subroutine llmesh +c + include 'msxas3.inc' +c include 'msxasc3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $ n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), + $ ichg(10,d_),kplace(at_),kmax(at_) + complex v,vcons +c + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMMON /LLM/ ALPHA, BETA +c + character*8 name0 ,nsymbl !added 29/3/2013 +c + common /param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + + complex vcon,xe,ev +c + logical do_r_in +c +c-------------------------------------------------------- +c +c write(69,*) ' in sub cont_sub nat = ', nat +C +C CONSTRUCT LINEAR-LOG MESH +C + DO_R_IN = .FALSE. +C + DO N = 1, NDAT +C + ZAT = FLOAT(NZ(N)) + IF(ZAT.EQ.0.0) THEN + X0 = 9.0 +C X0 = 10.0 + ELSE + X0 = 9.0 + LOG(ZAT) +C X0 = 10.0 + LOG(ZAT) + ENDIF + RKMX = R(KMAX(N),N) + DPAS = 0.1/RKMX +! IF(DPAS.GT.0.03) DPAS = 0.03 + IF(DPAS.GT.0.02) DPAS = 0.02 + ALPHA = 0.5 + BETA = 1.0 + RHO_1 = -BETA*X0 + R_SUB = RS(N) + XMAX = ALPHA*R_SUB + BETA*LOG(R_SUB) + KMX(N) = NINT ( (XMAX + X0 + DPAS) / DPAS ) + IF(KMX(N).GT.RDX_) THEN + WRITE(6,*) + & 'INCREASE PARAMETER RDX_. IT SHOULD BE AT LEAST ', KMX(N) + CALL EXIT + ENDIF + NR = KMX(N) + KPLX(N) = KMX(N)-3 +C +C CHECK IN LLMESH +c write(6,'(2i5,4e15.6)') n,kmx(n),rkmx,r_sub,xmax,rho_1 +c flush(6) +C + CALL LINLOGMESH ( I_END, HX(N), X(1,N), RX(1,N), DO_R_IN, + & KMX(N), KPLX(N), NR, RHO_1, R_SUB, R_IN, + & ALPHA, BETA ) +c +c if(n.eq.ndat) then + +c if(n.eq.ndat) write(6,*) (x(i,n), rx(i,n), i=1,kmx(n)) +c endif +C +c print *, ' inside llmesh loop ', kmx(n) +c do i = 1, kmx(n) +c write(69,*) x(i,n), rx(i,n) +c print *, x(i,n), rx(i,n) +c enddo +c + ENDDO +c +c---------------------------------------------------------- +c + return + end +c + subroutine linlogmesh ( i_end, drho, rho, r_real, do_r_in, + & kmax, kplace, nr, rho_1, r_sub, r_in, + & alpha, beta ) +! +! Set up log + linear radial mesh. +! +! rho = alpha * r_real + beta * log ( r_real ) +! +! rho_i = rho_{i-1} + drho +! +! +! i_end : point at inscribed sphere, for outersphere not used always 0. +! drho : constant step in loglinear space +! rho : log + linear mesh with constant step. +! r_real : real radial mesh correponding to the step of loglinear mesh +! do_r_in : option for outer sphere +! kmax : three points after kplace +! kplace : point on the bounding sphere where the Wronskian is estimated. +! nr : number of radial mesh points +! rho_1 : the first point in loglinear space +! r_sub : radius of bounding sphere in loglinear space, r_sub => rho(kplace) +! r_in : +! alpha : parameter for linear part +! beta : parameter for log part + +c implicit double precision (a-h,o-z) + +!...input +! logical, intent ( in ) :: do_r_in +! integer, intent ( in ) :: nr, kmax, kplace +! real ( kind = double ), intent ( in ) :: rho_1, r_sub, r_in, alpha, beta + +!...output +! integer, intent ( out ) :: i_end +! real ( kind = double ), intent ( out ) :: drho +! real ( kind = double ), intent ( out ), dimension ( : ) :: rho, r_real + +!...local +! logical :: check +! integer :: i, k +! real ( kind = double ) :: rn, rhon, epsilon +c + dimension rho(kmax), r_real(kmax) +c + logical do_r_in, check + + myrank = 0 + dzero = 0.0 + check = .false. +c check = .true. + + rho ( kplace ) = alpha * r_sub + beta * log ( r_sub ) + + rho ( 1 ) = rho_1 + drho = ( rho ( kplace ) - rho ( 1 ) ) / real ( kmax - 4 ) + + rho ( kmax ) = rho ( kplace ) + 3.00 * drho +! +! write(6,*) rho(1), rho(kmax), drho +! write(6,*) ' ** ' + +! if ( myrank .eq. 0 ) then +! write ( unit = 6, fmt = * ) " alpha =", alpha, " beta ", beta +! write ( unit = 6, fmt = * ) "rho_1 =", rho ( 1 ), & +! & " rho ( kplace ) =", rho ( kplace ), " rho ( kmax ) = ", rho ( kmax ) +! write ( unit = 6, fmt = * ) "drho =", drho, " nr =", nr +! end if + +! + do i = 2, nr + + rho ( i ) = rho ( i - 1 ) + drho + + end do +! +!.....Solve non-linear equation by Newton method +! + rhon = rho ( kplace ) + r_real ( kplace ) = r_sub +! rn = ( rhon - beta * log ( rhon ) ) / alpha ! correction 2nd April 2013 + rn = ( rhon - beta * log ( r_sub ) ) / alpha +! + do i = kplace - 1, 1, - 1 + + k = 0 +! + do +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn + + end if +! +! MPI + +! + if ( rn .eq. dzero ) then +! +! MPI +! + if ( myrank .eq. 0 ) then + + write ( unit = 6, fmt = * ) "Error occurred at radialmesh!", + & "rn = 0" + + end if +! +! MPI +! + stop + + end if +! + + epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / + & ( alpha * rn + beta ) +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn, epsilon + + end if +! +! MPI +! + + rn = rn * ( 1.00 - epsilon ) +! + if ( rn .lt. 0.0 ) then + + rn = r_real ( i + 1 ) * 0.100 ** k + k = k + 1 + + end if +! +! + if ( abs ( epsilon ) .le. 1.0e-6 ) then + + exit + + end if +! + end do +! + r_real ( i ) = rn + +! write(6,*) i, r_real ( i ) + + end do +! + + rhon = rho ( kplace ) +! rn = ( rhon - beta * log ( rhon ) ) / alpha ! correction 2nd April 2013 + rn = ( rhon - beta * log ( r_sub ) ) / alpha + +! + do i = kmax - 2, nr + + k = 0 +! + do +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn + + end if +! +! MPI +! + + epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / + & ( alpha * rn + beta ) +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 98, fmt = * ) i, rn, epsilon + + end if +! +! MPI +! + rn = rn * ( 1.00 - epsilon ) +! + if ( rn .lt. 0.0 ) then + + rn = r_real ( i - 1 ) * 10.00 ** k + k = k + 1 + + end if +! + if ( abs ( epsilon ) .le. 1.0e-6 ) then + + exit + + end if +! + end do +! + r_real ( i ) = rn + + end do +! +! MPI +! + if ( check .and. myrank .eq. 0 ) then + + write ( unit = 99, fmt = * ) '# i rho r rho ( r )', + & ' dr' + i = 1 + write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i, rho ( i ), + & r_real ( i ), + & alpha * r_real ( i ) + beta * log ( r_real ( i ) ) +! + do i = 2, nr + + write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i,rho ( i ), + & r_real ( i ), + & alpha * r_real ( i ) + beta * log ( r_real ( i ) ), + & r_real ( i ) - r_real ( i - 1 ) + + end do +! + end if +! +! MPI +! + if ( .not. do_r_in ) then +! if ( do_r_in ) then + + i = 1 +! + do +! + if ( r_real ( i ) > r_in ) then + + exit + + end if +! + i = i + 1 + + end do +! + i_end = i + + else + + i_end = 0 + + end if +! + +! if ( myrank .eq. 0 ) then + +! write ( unit = 6, fmt = * ) +! write ( unit = 6, fmt = "( a7, i5, a20, f12.7 )" ) & +! & "kplace = ", kplace, ", r_real ( kplace ) = ", r_real ( kplace ) +! write ( unit = 6, fmt = "( a7, i5, a20, f12.7, a10, f12.7 )" ) & +! & "kmax = ", kmax, ", r_real ( kmax ) = ", r_real ( kmax ), & +! & ", r_sub = ", r_sub +! write ( unit = 6, fmt = * ) +! write ( unit = 6, fmt = * ) "**** r_in = r_real (",i_end,")= ", & +! & r_real ( i_end ) + +! end if + + end subroutine linlogmesh +C +C + SUBROUTINE VREL +C + include 'msxas3.inc' + + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c +C + COMMON /FCNR/KXE,H(D_),VCONS(2), + 1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS,V +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,xe,ev + character*8 nsymbl,name0 +c + + COMPLEX ZTMP(0:RD_), ZX, DZX, D2ZX + REAL*4 RTMP(0:RD_) +C + DATA FSC,FSCS4 /7.29735E-3,1.331283E-5/ +C +C INTERPOLATE POTENTIAL ON THE LOG-LINEAR MESH +C AND ADD RELATIVISTIC CORRECTIONS, INCLUDING SPIN-ORBIT INTERACTION +C +C WRITE(7,*) ' I RX(I), VX(I), VXSR(I), VXSO(I), BX(I) ' +C + RTMP(0) = 0.0 +C + DO N = 1, NDAT +C + ZAT = FLOAT(NZ(N)) + ZTMP(0) = CMPLX(2.0*ZAT,0.0) +C + DO I = 1, KMAX(N) + RTMP(I) = R(I,N) + ENDDO +C + NS = N + DO IS=1,NSPINS + DO I = 1, KMAX(N) + ZTMP(I) = -V(I,NS) * RTMP(I) +C WRITE(6,*) N, IS, I, RTMP(I), ZTMP(I) + ENDDO + +C + DO I=1,KMX(N) +C +C FIND NEAREST POINTS - INITIALIZE HUNTING PARAMETER (SUBROUTINE NEAREST) +C + JLO=1 + CALL NEAREST1(RTMP(0), KMAX(N)+1, RX(I,N), + & IP1, IP2, IP3, JLO) + IP1 = IP1 - 1 + IP2 = IP2 - 1 + IP3 = IP3 - 1 +C +C INTERPOLATE ZR(I) AND RHOTOT(I) +C + CALL CINTERP_QUAD( RTMP(IP1),ZTMP(IP1), + & RTMP(IP2),ZTMP(IP2), + & RTMP(IP3),ZTMP(IP3), + & RX(I,N),ZX,DZX,D2ZX ) + VX(I,NS) = -ZX/RX(I,N) + BX(I,NS) = FSCS4/(1.0 + FSCS4*(E - VX(I,NS))) + DVX(I,NS) = -(DZX/RX(I,N) - ZX/RX(I,N)**2) + VXR(I,NS) = VX(I,NS) - FSCS4*(E - VX(I,NS))**2 + + & 0.5*BX(I,NS)*( -D2ZX/RX(I,N) + + & 1.5*BX(I,NS)*(DVX(I,NS))**2 ) + VXSO(I,NS) = BX(I,NS)*DVX(I,NS)/RX(I,N) +C WRITE(15,1) I, RX(I,N), VX(I,NS), VXR(I,NS), +C & VXSO(I,NS), BX(I,NS) +1 FORMAT(I5,9E15.6) + ENDDO + NS=NS+NDAT + ENDDO +C + ENDDO +C + RETURN +C + END +C +C + SUBROUTINE NEAREST1(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3, + & JLO) +C +C FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X +C AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3 +C This subroutine was taken from Numerical Recipes, +C W. H. Press, B. F. Flanney, S. A. Teukolsky and W. T. +C Vetterling, page 91. Originally called HUNT +C IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C COMMON/MESH_PARAM/JLO +C + DIMENSION XX(*) + LOGICAL ASCND + ASCND=XX(N).GT.XX(1) +C +C EXTRAPOLATE BELOW LOWEST POINT +C + IF(X.LE.XX(1))THEN + I_POINT_1=1 + I_POINT_2=2 + I_POINT_3=3 + RETURN + END IF +C +C EXTRAPOLATE BEYOND HIGHEST POINT +C + IF(X.GE.XX(N))THEN + I_POINT_1=N-2 + I_POINT_2=N-1 + I_POINT_3=N + RETURN + END IF + IF(JLO.LE.0.OR.JLO.GT.N)THEN + JLO=0 + JHI=N+1 + GO TO 3 + ENDIF + INC=1 + IF(X.GE.XX(JLO).EQV.ASCND)THEN +1 JHI=JLO+INC + IF(JHI.GT.N)THEN + JHI=N+1 + ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN + JLO=JHI + INC=INC+INC + GO TO 1 + ENDIF + ELSE + JHI=JLO +2 JLO=JHI-INC + IF(JLO.LT.1)THEN + JLO=0 + ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN + JHI=JLO + INC=INC+INC + GO TO 2 + ENDIF + ENDIF +3 IF(JHI-JLO.EQ.1)THEN + IF((JLO+1).EQ.N)THEN + I_POINT_1=JLO-1 + I_POINT_2=JLO + I_POINT_3=JLO+1 + ELSE + I_POINT_1=JLO + I_POINT_2=JLO+1 + I_POINT_3=JLO+2 + END IF + RETURN + END IF + JM=(JHI+JLO)/2 + IF(X.GT.XX(JM).EQV.ASCND)THEN + JLO=JM + ELSE + JHI=JM + ENDIF + GO TO 3 + END +C +C + SUBROUTINE CINTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4,DY4,D2Y4) +C +C INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2) +C TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT +C PARAMETERS. THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C +C + COMPLEX Y1, Y2, Y3, Y4, DY4, D2Y4 + COMPLEX TOP, A, B, C +C + TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1) + BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1) + B = TOP/BOTTOM + A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1) + C = Y3 - A*X3*X3 - B*X3 + Y4 = A*X4*X4 + B*X4 + C + DY4 = 2.0*A*X4 + B + D2Y4 = 2.0*A +C + RETURN + END +C +C + subroutine smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax, + & ramfnr,ramfsr,ramfsop,ramfsoa) +c + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +C + COMMON/BESSEL/SBF(LTOT_),DSBF(LTOT_),SHF(LTOT_),DSHF(LTOT_) + COMPLEX*16 SBF,DSBF,SHF,DSHF + COMPLEX*16 SBFX(LTOT_),DSBFX(LTOT_),SHFX(LTOT_),DSHFX(LTOT_) +C + COMPLEX*16 Y0(0:LMAX_), Y1(0:LMAX_) + DOUBLE PRECISION RX1, RX2, EXPR +C + COMMON /FCNR/KXE, H(D_),VCONS(2), + 1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_) + COMPLEX VCONS,V +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C + COMPLEX VXP(RDX_), VXA(RDX_), BD(RDX_) +C + COMPLEX PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), PAX(RDX_,F_) + COMPLEX PSX(N_), DPSX(N_), STMAT, RAMFX(N_) + COMPLEX PS0(N_), DPS0(N_), STMAT0, RAMF0(N_) + COMPLEX PS1(N_), DPS1(N_), STMAT1, RAMF1(N_) + COMPLEX PS2(N_), DPS2(N_), STMAT2, RAMF2(N_) + COMPLEX RAMF00, RAMF01, RAMF02 +C + COMPLEX PKMX, PKMX1 +C + COMMON /LLM/ ALPHA, BETA +c + common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, + 1 imvhl,nedhlp +c + complex pss(6),dpss(6), + & ramfnr(n_), ramfsr(n_), ramfsop(n_), ramfsoa(n_) +c + character*8 name0 ,nsymbl !added 29/3/2013 + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe +c + common /seculrx/ atmnr(n_), atmsr(n_), atmsop(n_), atmsoa(n_) + complex atmnr, atmsr, atmsop, atmsoa +c + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda +c + common/auger/calctype,expmode,edge1,edge2 + character*3 calctype, expmode + character*2 edge1,edge2 +c + complex csqrt,arg,arg1 + COMPLEX ONEC +c + character*2 relc +c + data zero,one,two/0.0,1.0,2.0/ + data pi/3.14159265358979/,srt2/1.414213562/ +c + data fsc,fscs4 /7.29735e-3,1.331283e-5/ +c +c.....Define bd for non relativistic calculation +c + do i = 1, rdx_ + bd(i) = cmplx(fscs4,0.0) + enddo + +C + onec = (1.0,0.0) + if(e.eq.0.0) e = 1.0e-8 + ns=(nns-1)*ndat +C + do 5 j=1,ndim + atmnr(j)=(0.00,0.00) + atmsr(j)=(0.00,0.00) + atmsop(j)=(0.00,0.00) + 5 atmsoa(j)=(0.00,0.00) +c +c write(70,*) ' non relativistic stmat and phase shifts ' +c write(80,*) ' scalar relativistic stmat and phase shifts ' +c write(90,*) ' spin-orbit stmat and phase shifts ' +c +c calculate t-matrix elements: +c stmat: inverse t-m elements (atomic spheres) +c ramf: for normalization of ps(k) functions +c +c write(19,18) e, xe + write(81,*) ' e, vcon, xe, relc =', e, real(vcon), + & real(xe), relc +c write(84,*) ' e, vcon, xe =', e, vcon, xe +c 18 FORMAT(' E =', F10.5,5X,' XE =',2F10.5,' GAMMA =',F10.5) +c + do 60 na=1,nuatom + write(35,77) na + write(70,77) na + write(80,77) na + write(90,77) na + ns=ns+1 + 25 nt0a=n0(na) + ntxa=nt0a+nterms(na)-1 + if (na.eq.nas) then + nstart=nt0a + nlast=ntxa + endif + l=-1 + nlat=-1 + arg=xe*rs(na) + ml=lmaxn(na)+1 + if (ml.lt.3) ml = 3 + call csbf(arg,xe,ml,sbf,dsbf) + call cshf2(arg,xe,ml,shf,dshf) + npabs = 0 +C + 43 do 45 nn=nt0a,ntxa + + l=ln(nn) + nlat=nlat+1 + npabs=npabs+1 + if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss + if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45 + np=npabs +C +c if(relc.eq.'nr') then +c + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + y0(l) = dcmplx(rx1**(l+1),0.d0) + y1(l) = dcmplx(rx2**(l+1),0.d0) +c + call pgenll1m(l, e, hx(na), rx(1,na), vx(1,ns), bd, + & kmx(na), kplx(na), rs(na), px(1,np), psx(nn), + & dpsx(nn), ramf00, stmat, y0(l),y1(l)) +c + atmnr(nn)=stmat + ramfx(nn)=ramf00 + ramfnr(nn) = ramf00 + + write(70,1000) xe/0.52917715, stmat + if(relc.eq.'nr') write(35,1000) xe/0.52917715, stmat +c definition of stmat as exp(-i*delta)*sin(delta) + phase=sign(-1.,real(stmat))* + 1 asin(sqrt(abs(aimag(stmat)))) + if(phase.lt.0.0) phase=phase+3.1415926 + write(71,1001)e,xe,na,nlat,stmat,phase + 1001 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3, + & 2x,2e12.6,f10.5,2x,2e12.6,f10.5) + 1000 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6,5x,e12.6,5x,e12.6) +c 1000 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9,5x,f12.9,5x,f12.9) + +c +c elseif(relc.eq.'sr') then +c + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + expr = 0.5d0 + sqrt( dfloat(l*(l+1)) +1 - dble(fsc*z(na))**2 ) + y0(l) = dcmplx(rx1**expr,0.d0) + y1(l) = dcmplx(rx2**expr,0.d0) + call pgenll1m(l, e, hx(na), rx(1,na), vxr(1,ns), bx(1,ns), + & kmx(na), kplx(na), rs(na), px0(1,np), ps0(nn), + & dps0(nn), ramf00, stmat0, y0(l),y1(l)) +c + if(calctype.eq.'els'.or.calctype.eq.'e2e') then + do k = 1, kmx(na) + if(nks.eq.1) p1(k,l+1,na) = px0(k,np) !npabs = np + if(nks.eq.2) p2(k,l+1,na) = px0(k,np) + if(nks.eq.3) p3(k,l+1,na) = px0(k,np) + enddo + if(nks.eq.1) ramfsr1(l+1,na) = ramf00 + if(nks.eq.2) ramfsr2(l+1,na) = ramf00 + if(nks.eq.3) ramfsr3(l+1,na) = ramf00 + endif +c + atmsr(nn)=stmat0 + ramfsr(nn)=ramf00 + + write(80,1000) xe/0.52917715, stmat0 + if(relc.eq.'sr') write(35,1000) xe/0.52917715, stmat0 +C +c definition of stmat as exp(-i*delta)*sin(delta) +C + phase=sign(-1.,real(stmat0))* + 1 asin(sqrt(abs(aimag(stmat0)))) + if(phase.lt.0.0) phase=phase+3.1415926 + write(81,1001)e,xe,na,nlat,stmat,phase +c +c elseif(relc.eq.'so') then +c + ilm = 2 + if(l.eq.0) ilm = 1 + do il = 1, ilm +c + if(il.eq.1) then + do i = 1, kmx(na) + vxp(i) = vxr(i,ns) + float(l)*vxso(i,ns) + enddo + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + expr = 0.5d0 + sqrt( dfloat(l+1)**2 -dble(fsc*z(na))**2 ) + y0(l) = dcmplx(rx1**expr,0.d0) + y1(l) = dcmplx(rx2**expr,0.d0) + call pgenll1m(l, e, hx(na), rx(1,na), vxp, bx(1,ns), + & kmx(na), kplx(na), rs(na), ppx(1,np), + & ps1(nn), dps1(nn), ramf01, stmat1, + & y0(l),y1(l)) + if(na.eq.nas) + & write(81,1) 'rp', na, l, real(stmat1), 1.0/stmat1, + & real(ramf01), e + else + do i = 1, kmx(na) + vxa(i) = vxr(i,ns) - float(l+1)*vxso(i,ns) + enddo + rx1 = dble(rx(1,na)) + rx2 = dble(rx(2,na)) + expr = 0.5d0 + sqrt( dfloat(l)**2 - dble(fsc*z(na))**2 ) + if(l.eq.0) expr = 0.5d0 +sqrt( 1.0d0 -dble(fsc*z(na))**2) + y0(l) = dcmplx(rx1**expr,0.d0) + y1(l) = dcmplx(rx2**expr,0.d0) + call pgenll1m(l, e, hx(na), rx(1,na), vxa, bx(1,ns), + & kmx(na), kplx(na), rs(na), pax(1,np), + & ps2(nn), dps2(nn), ramf02, stmat2, + & y0(l),y1(l)) +c + endif +c + enddo +c +c + atmsop(nn)=stmat1 + ramfsop(nn)=ramf01 + atmsoa(nn)=stmat2 + ramfsoa(nn)=ramf02 + + write(90,1000) xe/0.52917715, stmat1, stmat2 + if(relc.eq.'so') write(35,1000) xe/0.52917715, stmat1, stmat2 +C +c definition of stmat as exp(-i*delta)*sin(delta) +C + phase1=sign(-1.,real(stmat1))* + 1 asin(sqrt(abs(aimag(stmat1)))) + phase2=sign(-1.,real(stmat2))* + 1 asin(sqrt(abs(aimag(stmat2)))) + if(phase.lt.0.0) phase=phase+3.1415926 + write(91,1001)e,xe,na,nlat,stmat1,phase1,stmat2,phase2 +c + +c endif +1 format(a3,2i5,10e13.5) +30 format(5i3,8e13.5) +c +c + 45 continue + 60 continue +c + 77 FORMAT('-------------------------- ATOM ',I3, + 1 ' -----------------------') +c +c +c calculate singular solution inside muffin tin sphere for the absorbing +c atom, matching to shf in interstitial region +c + if(calctype.eq.'els'.and.nks.eq.3) + & write(6,*)' store irregular solution' + 90 nl=0 + lmsing=5 + mout=4 + nst=n0(nas) + nlst=n0(nas)+nterms(nas)-1 +c if(nks.eq.3) write(6,*)' nst =',nst,' nlst =',nlst + l=-1 + ml=lmaxn(nas)+1 + if (ml.lt.3) ml = 3 + kpp = kmx(nas) -2 + arg=xe*rx(kpp,nas) + call cshf2(arg,xe,ml,sbfx,dsbfx) + arg1=xe*rx(kpp-1,nas) + call cshf2(arg1,xe,ml,shfx,dshfx) +c + do n=nst,nlst + l=ln(n) + if(l.gt.lmsing) cycle + nl=nl+1 + np=npss+nl + np1=nl +c + pkmx = cmplx(sbfx(l+1))*arg/pi + pkmx1 = cmplx(shfx(l+1))*arg1/pi +c + call pgenll2( l, e, hx(nas), rx(1,nas), vx(1,nas), bd, + & kpp, px(1,np), pkmx, pkmx1 ) + + call pgenll2( l, e, hx(nas), rx(1,nas), vxr(1,nas), + & bx(1,nas), kpp, px0(1,np), pkmx, pkmx1 ) + + ilm = 2 + if(l.eq.0) ilm = 1 +c + do i = 1, kmx(nas) + vxp(i) = vxr(i,nas) + float(l)*vxso(i,nas) + vxa(i) = vxr(i,nas) - float(l+1)*vxso(i,nas) + enddo +c + do il = 1, ilm + if(il.eq.1) + & call pgenll2( l, e, hx(nas), rx(1,nas), vxp, + & bx(1,nas), kpp, ppx(1,np), pkmx, pkmx1 ) + if(il.eq.2) + & call pgenll2( l, e, hx(nas), rx(1,nas), vxa, + & bx(1,nas), kpp, pax(1,np), pkmx, pkmx1 ) + enddo +c + if(calctype.eq.'els') then + if(nks.eq.2) then + do k = 1, kmx(nas) + p2irreg(k,l+1) = px0(k,np) +c write(6,*) l, rx(k,nas), px0(k,np) + enddo + elseif(nks.eq.3) then + do k = 1, kmx(nas) + p3irreg(k,l+1) = px0(k,np) +c write(6,*) l, rx(k,nas), px0(k,np) + enddo + endif + endif +c + enddo +c +c + return +c + end +c +c + + subroutine pgenll1m(l, en, h, rx, v, b, kmax, kplx, rs, + & p, ps, dps, ramf, stmat, y0, y1 ) +c +c + include 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf +c + common/param/eftr,gamma,vcon,xe,ev,e,iout + complex vcon,xe,ev +c + common /llm/ alpha, beta +c + complex v(kmax), p(kmax), b(kmax), ps, dps, ramff, ramf, stmat, x + complex*16 y0, y1, pd(kmax) +c + dimension rx(kmax) +c + double precision dfl, a, hd, hsq12, rxi, den, arb2, + & alphad, betad, rlv, amv + complex*16 dvi +c + complex*16 um(0:kmax), vm(0:kmax), + & am(0:kmax), bm(0:kmax) +c +c + data pi/3.141592653589793d0/, fsc/7.29735E-3/ +c +c calculate coefficients um(m) and vm(m). +c inv = .true. : y0 first starting point; y1 last starting point +c inv = .false. : y0, y1 first two starting points at rx(1) and rx(2) +c In this particular case um=/0. +c + + vm(1) = (0.d0,0.d0) + um(1) = (1.d0,0.d0) + am(0) = (0.d0,0.d0) + bm(0) = (0.d0,0.d0) +c + alphad = dble(alpha) + betad = dble(beta) + den = dble(en) + dfl = dble(float(l)) + a = (dfl + 1)*dfl + hd = dble(h) + hsq12 = hd*hd/12.d0 +c + do i = 1, kmax + rxi = dble(rx(i)) + arb2 = (alphad*rxi + betad)**2 + dvi = dcmplx(v(i)) + am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a - + & betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 + bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) + enddo + + do i = 2, kmax-1 + vm(i) = am(i+1) / ( bm(i) - am(i-1)*vm(i-1) ) + enddo + + do i = 2, kmax + um(i) = um(i-1)*am(i-1) / ( bm(i) - am(i-1)*vm(i-1) ) + enddo +c + pd(1) = y0 * sqrt( alphad + betad/dble(rx(1)) ) + pd(2) = y1 * sqrt( alphad + betad/dble(rx(2)) ) + do i = 2, kmax - 1 + pd(i+1) = (pd(i) - um(i)*pd(1))/vm(i) + enddo +c + do i = 1, kmax + pd(i) = pd(i)*sqrt(dble(rx(i))/(alphad*dble(rx(i))+betad) ) * + & dble(fsc)/2.0D0 /sqrt(dcmplx(b(i)))/ dble(rx(i)) + p(i) = cmplx(pd(i)) + enddo +c + kplx3 = kplx - 3 + call interp(rx(kplx3),p(kplx3),7,rs,ps,dps,.true.) +c + x=dps/ps + ramff=cmplx(sbf(l+1))*x-cmplx(dsbf(l+1)) +c stmat=(shf(l+1)*x-dshf(l+1))/ramff + stmat=ramff/(cmplx(shf(l+1))*x-cmplx(dshf(l+1))) + ramf=ramff*ps*rs*rs*pi + ramf=ramf*xe/pi +c +c + return + end +c +c + subroutine pgenll2( l, en, h, rx, v, b, kmax, p, pkmx, pkmx1 ) +c +c This subroutine for inward integration toward the origin +c + common /llm/ alpha, beta +c + complex v(kmax), p(kmax), b(kmax), pkmx, pkmx1 + dimension rx(kmax) +c + double precision dfl, a, hd, hsq12, rxi, den, arb2, + & alphad, betad +c + complex*16 um(0:kmax), vm(0:kmax), am(0:kmax), bm(0:kmax) + complex*16 dvi, dnm +c + data pi/3.14159265/, fsc/7.29735E-3/ +c +c calculate coefficients um(m) and vm(m). +c + + vm(kmax) = (0.d0,0.d0) + um(kmax) = dcmplx(pkmx*sqrt( alpha + beta/rx(kmax) )) + + alphad = dble(alpha) + betad = dble(beta) + den = dble(en) + dfl = dble(float(l)) + a = (dfl + 1)*dfl + hd = dble(h) + hsq12 = hd*hd/12.d0 +c + do i = 1, kmax + rxi = dble(rx(i)) + arb2 = (alphad*rxi + betad)**2 + dvi = dcmplx(v(i)) + am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a - + & betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 + bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) + enddo + + do i = kmax-1, 2, -1 + dnm = ( bm(i) - am(i+1)*vm(i+1) ) + vm(i) = am(i-1) / dnm + um(i) = am(i+1) * um(i+1) / dnm +c write(6,*) vm(i), um(i) + enddo + + + p(kmax) = pkmx * sqrt( alpha + beta/rx(kmax) ) + p(kmax-1) = pkmx1 * sqrt( alpha + beta/rx(kmax-1) ) + + do i = kmax-1, 2, -1 + p(i-1) = ( p(i) - cmplx(um(i))) / cmplx(vm(i)) + enddo + + do i = 1, kmax + p(i) = p(i) * sqrt( rx(i)/(alpha*rx(i) + beta) ) * + & fsc/2.0 /sqrt(b(i))/ rx(i) + enddo + + return + end +c +C + subroutine get_edge_gap(iz,ihole,i_radial,xion,eatom) +c +c + implicit real*8(a-h,o-z) +c +c + parameter ( mp = 251, ms = 30 ) +c + character*40 title +c + common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy +c + dimension dum1(mp), dum2(mp) + dimension vcoul(mp), rho0(mp), enp(ms) +c + title = ' ' +c + ifr=1 + iprint=0 +C + amass=0.0d0 + beta=0.0d0 +c + call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, + 1 vcoul, rho0, dum1, dum2, enp, eatom) +c + return + end +C +C + subroutine calc_edge(cip) + implicit real*8 (a-h,o-z) + real*4 cip +c + include 'msxas3.inc' + include 'msxasc3.inc' +c + dimension etot(2) +c +c.....Find out ionization potential for chosen edge +c + xion=0.0d0 !corrected 23 June 2017 + iz = nz(1) + ihole1 = 0 +c + if(edge.eq.'k ') ihole2 = 1 + if(edge.eq.'l1') ihole2 = 2 + if(edge.eq.'l2') ihole2 = 3 + if(edge.eq.'l3') ihole2 = 4 + if(edge.eq.'m1') ihole2 = 5 + if(edge.eq.'m2') ihole2 = 6 + if(edge.eq.'m3') ihole2 = 7 + if(edge.eq.'m4') ihole2 = 8 + if(edge.eq.'m5') ihole2 = 9 + if(edge.eq.'n2') ihole2 = 11 + if(edge.eq.'n3') ihole2 = 12 + if(edge.eq.'n4') ihole2 = 13 + if(edge.eq.'n5') ihole2 = 14 + if(edge.eq.'n6') ihole2 = 15 + if(edge.eq.'n7') ihole2 = 16 +c + write(6,*) ' ---' + do i = 1, 2 +c + ityhole = ihole1 +c if(i.eq.2) ityhole = ihole2 ----- corrected 23th June 2017 + if(i.eq.2) then + ityhole = ihole2 + xion = 1.0d0 + endif +c + if(i.eq.1) write(6,*) ' total energy for atom in ground state ' + if(i.eq.2) write(6,*) ' total energy for atom with a hole in ', + & edge, ' edge' +c + + call get_edge_gap(iz,ityhole,ityhole,xion,etot(i)) +c + enddo +c + cip = real(etot(2) - etot(1))*2.0 + cip = sign(cip,1.0) + write(6,*) ' calculated ionization energy for edge ', edge, + & ' = ', cip*13.6, ' eV' +c +c.....Find out energy distance between edges and construct two edge +c dipole cross section +c + xion=1.0d0 +c + if(edge.eq.'k '.or.edge.eq.'l1'.or.edge.eq.'m1'.or.edge.eq.'n1') + & go to 15 + if(edge.eq.'l2'.or.edge.eq.'l3') then + ihole1 = 3 + ihole2 = 4 + else if(edge.eq.'m2'.or.edge.eq.'m3') then + ihole1 = 6 + ihole2 = 7 + else if(edge.eq.'m4'.or.edge.eq.'m5') then + ihole1 = 8 + ihole2 = 9 + else if(edge.eq.'n2'.or.edge.eq.'n3') then + ihole1 = 11 + ihole2 = 12 + else if(edge.eq.'n4'.or.edge.eq.'n5') then + ihole1 = 13 + ihole2 = 14 + else if(edge.eq.'n6'.or.edge.eq.'n7') then + ihole1 = 15 + ihole2 = 16 + endif +c + do i = 1, 2 + + ityhole = ihole1 + if(i.eq.2) ityhole = ihole2 +c + call get_edge_gap(iz,ityhole,ityhole,xion,etot(i)) +c + enddo +c + detot = (etot(1) - etot(2))*2.0d0 + detot = sign(detot,1.0d0) + if(edge.eq.'l2'.or.edge.eq.'l3') then + write(6,*) ' energy distance between edges l2 and l3 = ', + & real( etot(1) - etot(2) )* 27.2, 'eV' + elseif(edge.eq.'m2'.or.edge.eq.'m3') then + write(6,*) ' energy distance between edges m2 and m3 = ', + & real( etot(1) - etot(2) )* 27.2, 'eV' + elseif(edge.eq.'m4'.or.edge.eq.'m5') then + write(6,*) ' energy distance between edges m4 and m5 = ', + & real( etot(1) - etot(2) )* 27.2, 'eV' + endif +c +15 continue +c + write(6,*) ' ---' +c + end +C +C + SUBROUTINE RADIALX(NE,RELC,EIKAPPR) + INCLUDE 'msxas3.inc' + integer at_,d_,rd_,ltot_,sd_ + parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, + $n_=ltot_*ua_,rd_=440,sd_=ua_-1) +C +c.....this subroutine calculates the radial matrix elements d(i) +c.....(i=1,2) for lfin=l0i-1 (i=1) and lfin=l0i+1 (i=2) both for +c.....the regular (dmxx) and irregular solution (dmxx1) using a +c.....linear-log mesh +c + common/mtxele/ nstart,nlast +c + common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), + & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), + & dxxdir,dxxexc + complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, + & dxxdir,dxxexc +c + common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, + 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), + 3 lmaxx(at_),nz(at_),nsymbl(at_), + 4 neq(at_),name0,cip,emax,emin,de + complex vcon,ev,xe + character*8 nsymbl,name0 +c + common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) + complex*16 sbf,dsbf,shf,dshf +C + COMMON /LLM/ ALPHA, BETA +C + COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), + & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), + & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) + COMPLEX VX, VXR, DVX, BX, VXSO +C +C COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_) +C COMPLEX PX,DPX,PSX,DPSX,RAMFX +c + COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), + & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), + & RAMFSOA(N_) + COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA +c +C + COMMON/PDQIX/RPIX(RDX_), FNISX + COMPLEX RPIX +C + common /state/ natom(n_),ln(n_),nleq(at_), + 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), + 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) +C +c ######### common pottype modified to consider also the Auger calcu +c + common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, + * i_absorber_hole2,i_norman,i_alpha, + 1 i_outer_sphere,i_exc_pot,i_mode +c + common/auger/calctype,expmode,edge1,edge2 +c + common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), + & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), + & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), + & ramfsr2(npss,nef_),ramfsr3(npss,nef_), + & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) + complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg + real*4 einc,esct,scangl,qt,lambda + complex qtc, arg, ydf, scprod +c + character*3 calctype, expmode, eikappr + character*2 edge1,edge2 +C + common /lparam/lmax2(nat_),l0i +c + DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_) + COMPLEX RID,CRI,CRI1,DX,DX1,SMX0,SMX1 +C + CHARACTER*2 RELC +C +C +c*************************************************************************** +c note that here rpix(k) = r**3*pi(k). +c wf rpix(k) is already normalized +c (see subroutine corewf) +c*************************************************************************** +c + pi = 3.1415926 +c + id = 1 + nq = nas + kx = kmx(nq) - 3 + dh = hx(nq) +c + write(6,*)' check orthogonality between core and continuum', + & ' state' + np = l0i + 1 + do k = 1, kx + if(relc.eq.'nr') + & rid(k)=rpix(k)*px(k,np+1)/(alpha*rx(k,nq) + beta) + if(relc.eq.'sr') + & rid(k)=rpix(k)*px0(k,np+1)/(alpha*rx(k,nq) + beta) + enddo + call defint1(rid,dh,kx,scprod,id) + write(6,*)' scalar product between core and continuum', + & ' state =', scprod/ramfsr(nstart+np) !*sqrt(xe/pi) + write(6,*) ' sqrt(xe/pi) =', sqrt(xe/pi) +c + if((calctype.eq.'els'.or.calctype.eq.'e2e') + & .and.eikappr.eq.'yes') then + ydf=(0.0,0.0) + qtc = cmplx(qt,0.0) + ml=lmxne(nq,ne)+1 + if (ml.lt.3) ml = 3 + do np = 0, ml-1 + do k = 1, kx + arg=qtc*rx(k,nq) + call csbf(arg,ydf,ml,sbf,dsbf) + if(relc.eq.'nr') + & rid(k)=rpix(k)*px(k,np+1)*cmplx(sbf(np+1))/ + 1 (alpha*rx(k,nq) + beta) + if(relc.eq.'sr') + & rid(k)=rpix(k)*px0(k,np+1)*cmplx(sbf(np+1))/ + 1 (alpha*rx(k,nq) + beta) + enddo +c call defint1(rid,dh,kx,eelsme(np+1),id) +c eelsme(np+1) = (eelsme(np+1)/ramfsr(nstart+np))**2*xe/pi +c write(6,*) 'l =',np,'eelsme =', eelsme(np+1) +c write(6,*) 'l =',np,'sqrt(eelsme) =', sqrt(eelsme(np+1)) + enddo +c + endif +c +c 21 if(calctype.eq.'xpd'.or.eikappr.eq.' no') then + 21 if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. + & calctype.eq.'rex'.or.eikappr.eq.' no') then +c + do 100 i=1,2 + dmxx(i)=(0.,0.) + dmxx1(i)=(0.,0.) + if((l0i.eq.0).and.(i.eq.1))goto 100 + np = l0i + (-1)**i +C + if(relc.eq.'nr') then +c + DO 116 K=1,KX + 116 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXX(I) = (CRI(KX)/RAMFNR(NSTART+NP))**2*(L0I-1+I) +c dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i) + DO 117 K=1,KX + 117 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 118 K=1,KX + 118 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 119 K=1,KX + 119 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFNR(NSTART+NP) +c dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np) +c + else if(relc.eq.'sr') then + DO K=1,KX + RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXX(I) = (CRI(KX)/RAMFSR(NSTART+NP))**2*(L0I-1+I) + DO 120 K=1,KX + 120 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 121 K=1,KX + 121 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 122 K=1,KX + 122 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSR(NSTART+NP) +c + else if(relc.eq.'so') then + DO K=1,KX + RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXX(I) = (CRI(KX)/RAMFSOP(NSTART+NP))**2*(L0I-1+I) + DO 123 K=1,KX + 123 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 124 K=1,KX + 124 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 125 K=1,KX + 125 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSOP(NSTART+NP) +C + DO K=1,KX + RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + DMXXA(I) = (CRI(KX)/RAMFSOA(NSTART+NP))**2*(L0I-1+I) + DO 126 K=1,KX + 126 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 127 K=1,KX + 127 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,DX,ID) + DO 128 K=1,KX + 128 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,DX1,ID) + DMXXA1(I) = (DX + DX1)*(L0I-1+I)/RAMFSOA(NSTART+NP) +c + endif + + 100 continue +C +c write(6,*) ' radialx matrix elements from shell li = ', l0i +c write(6,*) (real(dmxx(l)),aimag(dmxx(l)),l=1,2) +c write(6,*) (real(dmxx1(l)),aimag(dmxx1(l)),l=1,2) +C +C.....CALCULATE RADIAL QUADRUPOLAR TRANSITION MATRIX ELEMENT +C + DO K = 1, KX + RPIX(K) = RPIX(K) * RX(K,NQ) + ENDDO +C + M = 0 + DO 200 I=-2,2,2 + M = M + 1 + QMXX(M)=(0.,0.) + QMXX1(M)=(0.,0.) + LF = L0I + I + IF(LF.LE.0) GO TO 200 + NP = L0I + I +C + if(relc.eq.'nr') then +c + DO 216 K=1,KX + 216 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXX(M) = (CRI(KX)/RAMFNR(NSTART+NP))**2 +c dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i) + DO 217 K=1,KX + 217 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 218 K=1,KX + 218 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 219 K=1,KX + 219 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + QMXX1(M) = (SMX0 + SMX1)/RAMFNR(NSTART+NP) +c dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np) +c + else if(relc.eq.'sr') then + DO K=1,KX + RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXX(M) = (CRI(KX)/RAMFSR(NSTART+NP))**2 + DO 220 K=1,KX + 220 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 221 K=1,KX + 221 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 222 K=1,KX + 222 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + QMXX1(M) = (SMX0 + SMX1)/RAMFSR(NSTART+NP) +c + else if(relc.eq.'so') then + DO K=1,KX + RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXX(M) = (CRI(KX)/RAMFSOP(NSTART+NP))**2 + DO 223 K=1,KX + 223 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 224 K=1,KX + 224 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,SMX0,ID) + DO 225 K=1,KX + 225 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,SMX1,ID) + QMXX1(M) = (SMX0 + SMX1)/RAMFSOP(NSTART+NP) +C + DO K=1,KX + RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + ENDDO + CALL INTEGRCM(RID,DH,KX,CRI,ID) + QMXXA(M) = (CRI(KX)/RAMFSOA(NSTART+NP))**2 + DO 226 K=1,KX + 226 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL INTEGRCM(RID,DH,KX,CRI1,ID) + DO 227 K=1,KX + 227 RID(K)=RID(K)*CRI(K) + CALL DEFINT1(RID,DH,KX,DX,ID) + DO 228 K=1,KX + 228 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))* + & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) + CALL DEFINT1(RID,DH,KX,DX1,ID) + QMXXA1(M) = (DX + DX1)/RAMFSOA(NSTART+NP) +c + endif +C + 200 CONTINUE +C +C.....RESET RPI(K) TO INITIAL VALUE +C + DO K = 1, KX + RPIX(K) = RPIX(K) / RX(K,NQ) + ENDDO +C + else !PUT AUGER PART HERE +C + endif +C + RETURN + END +C +C + SUBROUTINE OSBF(X,Y,MAX,SBF,DSBF) +C REAL*8 SBFK,SBF1,SBF2,XF1,PSUM + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR +C FIRST DERIVATIVES WITH RESPECT TO R. X=ARGUMENT= Y*R. +C IF Y=0, NO DERIVATIVES ARE CALCULATED. MAX MUST BE AT LEAST 3. +C OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS. MSBF - MODI- +C FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS; +C MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS +C + DIMENSION SBF(MAX), DSBF(MAX) + LOGICAL ORD + ORD=.TRUE. + GO TO 1 + ENTRY MSBF(X,Y,MAX,SBF,DSBF) + ORD=.FALSE. +1 IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 + IF( ABS(X).LT.0.50D0 ) GO TO 18 +C +C BESSEL FUNCTIONS BY DOWNWARD RECURSION +C + SBF2=0.0D0 + SBF1=1.0D-25 + IF( ABS(X).LT.2.0D0) SBF1=1.0D-38 + JMIN=10+X + KMAX=MAX+JMIN-1 + K=MAX + XF1=2*KMAX+1 + IF (ORD) GO TO 11 + DO 10 J=1,KMAX + SBFK=XF1*SBF1/X+SBF2 + SBF2=SBF1 + SBF1=SBFK + IF (J.LT.JMIN) GO TO 10 + SBF(K)=SBFK + K=K-1 +10 XF1=XF1-2.0D0 + RAT=SINH(X)/(X*SBF(1)) + DSBF1=SBF2*RAT + GO TO 16 +11 CONTINUE + DO 12 J=1,KMAX + SBFK=XF1*SBF1/X-SBF2 + SBF2=SBF1 + SBF1=SBFK + XF1=XF1-2.0D0 + IF (J.LT.JMIN) GO TO 12 + SBF(K)=SBFK + K=K-1 +12 CONTINUE + 15 RAT=SIN(X)/(X*SBF(1)) + DSBF1=-SBF2*RAT + 16 DO 17 K=1,MAX + 17 SBF(K)=RAT*SBF(K) + GO TO 26 +C +C SMALL ARGUMENTS +C + 18 Z=X*X*0.50D0 + IF(ORD) Z=-Z + A=1.0D0 + MMX=MAX + IF (MAX.EQ.1.AND.Y.NE.0.0D0) MMX=2 + DO 30 J=1,MMX + SBFJ=A + B=A + DO 31 I=1,20 + B=B*Z/(I*(2*(J+1)-1)) + SBFJ=SBFJ+B + IF ( ABS(B).LE.1.0D-07* ABS(SBFJ )) GO TO 29 + 31 CONTINUE +29 IF (J.EQ.2) DSBF1=SBFJ + IF (J.LE.MAX) SBF(J)=SBFJ + 30 A=A*X/ DFLOAT(2*J+1) + IF (ORD) DSBF1=-DSBF1 + GO TO 26 + ENTRY OSNF(X,Y,MAX,SBF,DSBF) + ORD=.TRUE. + SBF2=-COS(X)/X + IF (MAX.EQ.1 .AND. Y.EQ.0.0D0) GO TO 2 + SBF1=(SBF2-SIN(X))/X + DSBF1=-SBF1 + GO TO 2 + ENTRY MSNF(X,Y,MAX,SBF,DSBF) + ORD=.FALSE. + SBF2=COSH(X)/X + IF (MAX.EQ.1 .AND. Y.EQ.0.0D0) GO TO 2 + SBF1=(SINH(X)-SBF2)/X + DSBF1= SBF1 + GO TO 2 + ENTRY MSHF(X,Y,MAX,SBF,DSBF) + ORD=.FALSE. + SBF2=EXP(-X)/X + SBF1=-SBF2/X-SBF2 + DSBF1= SBF1 +2 SBF(1)=SBF2 + IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 + IF (MAX.EQ.1) GO TO 26 + SBF(2)=SBF1 + IF (MAX.EQ.2) GO TO 26 + XF1=3.0D0 + IF (ORD) GO TO 21 + DO 8 I=3,MAX + SBFK=SBF2-XF1*SBF1/X + SBF(I)=SBFK + SBF2=SBF1 + SBF1=SBFK +8 XF1=XF1+2.0D0 + GO TO 26 +21 DO 22 I=3,MAX + SBFK=XF1*SBF1/X-SBF2 + SBF(I)=SBFK + SBF2=SBF1 + SBF1=SBFK +22 XF1=XF1+2.0D0 +26 IF (Y.EQ.0.0D0) RETURN + DSBF(1)=Y*DSBF1 + IF (MAX.EQ.1) RETURN + DO 9 I=2,MAX + 9 DSBF(I)=Y*(SBF(I-1)- DFLOAT(I)*SBF(I)/X) + RETURN +99 WRITE(6,100) MAX +100 FORMAT (' SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8) + + STOP 2013 +C + END +C + diff --git a/src/msspec/spec/__init__.py b/src/msspec/spec/__init__.py new file mode 100644 index 0000000..e69de29 diff --git a/src/msspec/spec/fortran/Makefile b/src/msspec/spec/fortran/Makefile new file mode 100644 index 0000000..98dfc69 --- /dev/null +++ b/src/msspec/spec/fortran/Makefile @@ -0,0 +1,37 @@ +COMP=gfortran + +objects_src := dim_mod.f modules.f allocation.f spec.f +objects := $(patsubst %.f,%.o, $(objects_src)) + +OPTS := -g -Wall -Wextra -Warray-temporaries -Wconversion -fbacktrace -ffree-line-length-0 -fcheck=all -ffpe-trap=zero,overflow,underflow -finit-real=nan + +EXE=prog + + +.PHONY: clean pybinding + +pybinding: libspec.so + +libspec.so: $(objects) main.f + @echo "building Python binding..." + @f2py3 -I. $(objects) -c -m libspec main.f + #f2py3 -I. $(objects) --debug-capi --debug -c -m libspec main.f + @cp libspec.cpython*.so ../ + @mv libspec.cpython*.so libspec.so + +exe: $(objects) prog.f + @$(COMP) -c main.f + @$(COMP) -c prog.f + @$(COMP) -o $(EXE) $(objects) main.o prog.o + + +$(objects): $(objects_src) + @echo "compiling subroutines and functions..." + #$(COMP) -cpp -fPIC -O2 -ffast-math -mcmodel=large -fdefault-real-4 -c $^ + @$(COMP) $(OPTS) -fPIC -mcmodel=large -c $^ + +clean: + @echo "cleaning..." + @rm -rf *.so *.o *.mod $(EXE) + @rm -rf ../*.so + diff --git a/src/msspec/spec/fortran/allocation.f b/src/msspec/spec/fortran/allocation.f new file mode 100644 index 0000000..29657a9 --- /dev/null +++ b/src/msspec/spec/fortran/allocation.f @@ -0,0 +1,189 @@ + SUBROUTINE 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_) + USE DIM_MOD + USE ADSORB_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE CLUSLIM_MOD + USE COOR_MOD + USE DEBWAL_MOD + USE INDAT_MOD + USE INIT_A_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE INIT_M_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE LIMAMA_MOD + USE LPMOY_MOD + USE MASSAT_MOD + USE MILLER_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TL_AED_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE XMRHO_MOD + USE CRANGL_MOD + USE VECSYS_MOD + USE VIBRAT_MOD + USE COEFRLM_MOD + USE EXPROT_MOD + USE EXPFAC_MOD + USE LOGAMAD_MOD + USE EXPFAC2_MOD + USE FACTSQ_MOD + USE ALGORITHM_MOD + USE EXAFS_MOD + USE HEADER_MOD + USE MOYEN_MOD + USE VALIN_AV_MOD + USE VALFIN_MOD + USE VALEX_A_MOD + USE AMPLI_MOD + USE CONVACC_MOD + USE CONVTYP_MOD + USE C_G_MOD + USE C_G_A_MOD + USE C_G_M_MOD + USE DEXPFAC2_MOD + USE DFACTSQ_MOD + USE EIGEN_MOD + USE FDIF_MOD + USE FIXSCAN_MOD + USE FIXSCAN_A_MOD + USE LINLBD_MOD + USE MOYEN_A_MOD + USE OUTFILES_MOD + USE RA_MOD + USE SPECTRUM_MOD + USE DIRECT_MOD + USE DIRECT_A_MOD + USE PATH_MOD + USE ROT_MOD + USE TESTPA_MOD + USE TESTPB_MOD + USE TLDW_MOD + USE VARIA_MOD + USE LBD_MOD + USE SCATMAT_MOD + USE EXTREM_MOD + USE PRINTP_MOD + IMPLICIT INTEGER (A-Z) + NATP_M = NATP_M_ + NATCLU_M = NATCLU_M_ + NAT_EQ_M = NAT_EQ_M_ + N_CL_L_M = N_CL_L_M_ + NE_M = NE_M_ + NL_M = NL_M_ + LI_M = LI_M_ + NEMET_M = NEMET_M_ + NO_ST_M = NO_ST_M_ + NDIF_M = NDIF_M_ + NSO_M = NSO_M_ + NTEMP_M = NTEMP_M_ + NODES_EX_M = NODES_EX_M_ + NSPIN_M = NSPIN_M_ + NTH_M = NTH_M_ + NPH_M = NPH_M_ + NDIM_M = NDIM_M_ + N_TILT_M = N_TILT_M_ + N_ORD_M = N_ORD_M_ + NPATH_M = NPATH_M_ + NGR_M = NGR_M_ + CALL INIT_DIM() + CALL ALLOC_ADSORB() + CALL ALLOC_APPROX() + CALL ALLOC_ATOMS() + CALL ALLOC_AUGER() + CALL ALLOC_BASES() + CALL ALLOC_CLUSLIM() + CALL ALLOC_COOR() + CALL ALLOC_DEBWAL() + CALL ALLOC_INDAT() + CALL ALLOC_INIT_A() + CALL ALLOC_INIT_L() + CALL ALLOC_INIT_J() + CALL ALLOC_INIT_M() + CALL ALLOC_INFILES() + CALL ALLOC_INUNITS() + CALL ALLOC_LIMAMA() + CALL ALLOC_LPMOY() + CALL ALLOC_MASSAT() + CALL ALLOC_MILLER() + CALL ALLOC_OUTUNITS() + CALL ALLOC_PARCAL() + CALL ALLOC_PARCAL_A() + CALL ALLOC_RELADS() + CALL ALLOC_RELAX() + CALL ALLOC_RESEAU() + CALL ALLOC_SPIN() + CALL ALLOC_TESTS() + CALL ALLOC_TRANS() + CALL ALLOC_TL_AED() + CALL ALLOC_TYPCAL() + CALL ALLOC_TYPCAL_A() + CALL ALLOC_TYPEM() + CALL ALLOC_TYPEXP() + CALL ALLOC_VALIN() + CALL ALLOC_XMRHO() + CALL ALLOC_CRANGL() + CALL ALLOC_VECSYS() + CALL ALLOC_VIBRAT() + CALL ALLOC_COEFRLM() + CALL ALLOC_EXPROT() + CALL ALLOC_EXPFAC() + CALL ALLOC_LOGAMAD() + CALL ALLOC_EXPFAC2() + CALL ALLOC_FACTSQ() + CALL ALLOC_ALGORITHM() + CALL ALLOC_EXAFS() + CALL ALLOC_HEADER() + CALL ALLOC_MOYEN() + CALL ALLOC_VALIN_AV() + CALL ALLOC_VALFIN() + CALL ALLOC_VALEX_A() + CALL ALLOC_AMPLI() + CALL ALLOC_CONVACC() + CALL ALLOC_CONVTYP() + CALL ALLOC_C_G() + CALL ALLOC_C_G_A() + CALL ALLOC_C_G_M() + CALL ALLOC_DEXPFAC2() + CALL ALLOC_DFACTSQ() + CALL ALLOC_EIGEN() + CALL ALLOC_FDIF() + CALL ALLOC_FIXSCAN() + CALL ALLOC_FIXSCAN_A() + CALL ALLOC_LINLBD() + CALL ALLOC_MOYEN_A() + CALL ALLOC_OUTFILES() + CALL ALLOC_RA() + CALL ALLOC_SPECTRUM() + CALL ALLOC_DIRECT() + CALL ALLOC_DIRECT_A() + CALL ALLOC_PATH() + CALL ALLOC_ROT() + CALL ALLOC_TESTPA() + CALL ALLOC_TESTPB() + CALL ALLOC_TLDW() + CALL ALLOC_VARIA() + CALL ALLOC_LBD() + CALL ALLOC_SCATMAT() + CALL ALLOC_EXTREM() + CALL ALLOC_PRINTP() + END SUBROUTINE ALLOCATION \ No newline at end of file diff --git a/src/msspec/spec/fortran/dim_mod.f b/src/msspec/spec/fortran/dim_mod.f new file mode 100644 index 0000000..97f43bf --- /dev/null +++ b/src/msspec/spec/fortran/dim_mod.f @@ -0,0 +1,60 @@ + MODULE DIM_MOD + IMPLICIT NONE + INTEGER NATP_M, NATCLU_M, NAT_EQ_M, N_CL_L_M + INTEGER NE_M, NL_M + INTEGER LI_M, NEMET_M + INTEGER NO_ST_M + INTEGER NDIF_M + INTEGER NSO_M + INTEGER NTEMP_M + INTEGER NODES_EX_M +C + INTEGER NSPIN_M +C + INTEGER NTH_M, NPH_M + INTEGER NDIM_M + INTEGER N_TILT_M + INTEGER N_ORD_M +C + INTEGER NGR_M + INTEGER NPATH_M + +C =============================================================== + INTEGER NLP_M, NLA_M + INTEGER N_MU_M, N_NU_M + INTEGER NATM + INTEGER LINMAX, LINMAXA + INTEGER LINFMAX + INTEGER NLAMBDA_M + INTEGER NSPIN2_M + INTEGER NT_M + INTEGER NCG_M + INTEGER N_BESS, N_GAUNT +C =============================================================== + CONTAINS + SUBROUTINE INIT_DIM() + NLP_M=NL_M + NLA_M=NL_M + + N_MU_M=NO_ST_M + N_NU_M=NO_ST_M/2 + + NATM=NATP_M+3 + + LINMAX=NLP_M*NLP_M + LINMAXA=NLA_M*NLA_M + + LINFMAX=(LI_M+2)*(LI_M+2) + + NLAMBDA_M=(NO_ST_M+2)*(NO_ST_M+1)/2 + + NSPIN2_M=3*NSPIN_M-2 + + NT_M=(NL_M-1)*(1+(NSPIN_M-1)*NL_M) + + NCG_M=4*LI_M+2 + + N_BESS=100*NL_M + N_GAUNT=5*NL_M + END SUBROUTINE INIT_DIM + END MODULE DIM_MOD diff --git a/src/msspec/spec/fortran/main.f b/src/msspec/spec/fortran/main.f new file mode 100644 index 0000000..9925513 --- /dev/null +++ b/src/msspec/spec/fortran/main.f @@ -0,0 +1,21 @@ + SUBROUTINE RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_, + & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_, + & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_, + & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_) + + USE DIM_MOD + IMPLICIT INTEGER (A-Z) +CF2PY INTEGER, INTENT(IN,COPY) :: NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_ + + CALL ALLOCATION(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_, + & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_, + & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_, + & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_) + + CALL DO_MAIN() + PRINT *, "BEFORE END IN SPEC" + + END SUBROUTINE RUN diff --git a/src/msspec/spec/fortran/modules.f b/src/msspec/spec/fortran/modules.f new file mode 100644 index 0000000..e778ee7 --- /dev/null +++ b/src/msspec/spec/fortran/modules.f @@ -0,0 +1,1150 @@ +C======================================================================= + MODULE ADSORB_MOD + IMPLICIT NONE + INTEGER :: IADS + INTEGER :: NATA + INTEGER :: NADS1 + INTEGER :: NADS2 + INTEGER :: NADS3 + REAL, ALLOCATABLE, DIMENSION(:,:) :: ADS + INTEGER :: NCOUCH + CONTAINS + SUBROUTINE ALLOC_ADSORB() + USE DIM_MOD + ALLOCATE(ADS(3,900)) + END SUBROUTINE ALLOC_ADSORB + END MODULE ADSORB_MOD + +C======================================================================= + MODULE APPROX_MOD + IMPLICIT NONE + INTEGER :: NDIF + INTEGER :: NO + INTEGER :: ISPHER + INTEGER :: IFWD + INTEGER :: NTHOUT + REAL, ALLOCATABLE, DIMENSION(:) :: RTHFWD + INTEGER, ALLOCATABLE, DIMENSION(:) :: IBWD + REAL, ALLOCATABLE, DIMENSION(:) :: RTHBWD + INTEGER :: IPW + INTEGER :: NCUT + REAL :: PCTINT + INTEGER :: IPP + INTEGER :: ISPEED + INTEGER :: IATTS + INTEGER :: ILENGTH + REAL :: RLENGTH + CONTAINS + SUBROUTINE ALLOC_APPROX() + USE DIM_MOD + ALLOCATE(RTHFWD(NATP_M)) + ALLOCATE(IBWD(NATP_M)) + ALLOCATE(RTHBWD(NATP_M)) + END SUBROUTINE ALLOC_APPROX + END MODULE APPROX_MOD + +C======================================================================= + MODULE ATOMS_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: VALZ + REAL :: VALZ_MAX + INTEGER, ALLOCATABLE, DIMENSION(:) :: NZAT + INTEGER :: I_GR + INTEGER :: I_INV + CHARACTER*2, ALLOCATABLE, DIMENSION(:) :: CHEM + CONTAINS + SUBROUTINE ALLOC_ATOMS() + USE DIM_MOD + ALLOCATE(VALZ(NATCLU_M)) + ALLOCATE(NZAT(NATCLU_M)) + ALLOCATE(CHEM(NATCLU_M)) + END SUBROUTINE ALLOC_ATOMS + END MODULE ATOMS_MOD + +C======================================================================= + MODULE AUGER_MOD + IMPLICIT NONE + INTEGER, ALLOCATABLE, DIMENSION(:) :: NLIN_A + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: L_BOUNDS + CHARACTER*6 :: AUGER + CONTAINS + SUBROUTINE ALLOC_AUGER() + USE DIM_MOD + ALLOCATE(NLIN_A(0:20)) + ALLOCATE(L_BOUNDS(0:20,2)) + END SUBROUTINE ALLOC_AUGER + END MODULE AUGER_MOD + +C======================================================================= + MODULE BASES_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: ATBAS + REAL, ALLOCATABLE, DIMENSION(:) :: VECBAS + CONTAINS + SUBROUTINE ALLOC_BASES() + USE DIM_MOD + ALLOCATE(ATBAS(3*NATP_M)) + ALLOCATE(VECBAS(9)) + END SUBROUTINE ALLOC_BASES + END MODULE BASES_MOD + +C======================================================================= + MODULE CLUSLIM_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: X_MAX + REAL, ALLOCATABLE, DIMENSION(:) :: X_MIN + REAL, ALLOCATABLE, DIMENSION(:) :: Y_MAX + REAL, ALLOCATABLE, DIMENSION(:) :: Y_MIN + REAL, ALLOCATABLE, DIMENSION(:) :: VAL + INTEGER :: NPLAN + CONTAINS + SUBROUTINE ALLOC_CLUSLIM() + USE DIM_MOD + ALLOCATE(X_MAX(NATCLU_M)) + ALLOCATE(X_MIN(NATCLU_M)) + ALLOCATE(Y_MAX(NATCLU_M)) + ALLOCATE(Y_MIN(NATCLU_M)) + ALLOCATE(VAL(NATCLU_M)) + END SUBROUTINE ALLOC_CLUSLIM + END MODULE CLUSLIM_MOD + +C======================================================================= + MODULE COOR_MOD + IMPLICIT NONE + INTEGER :: NATCLU + INTEGER :: N_PROT + INTEGER, ALLOCATABLE, DIMENSION(:) :: NATYP + INTEGER, ALLOCATABLE, DIMENSION(:) :: NCHTYP + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NCORR + INTEGER, ALLOCATABLE, DIMENSION(:) :: INEW_AT + REAL, ALLOCATABLE, DIMENSION(:,:) :: SYM_AT + CONTAINS + SUBROUTINE ALLOC_COOR() + USE DIM_MOD + ALLOCATE(NATYP(NATM)) + ALLOCATE(NCHTYP(NATP_M)) + ALLOCATE(NCORR(NAT_EQ_M,NATP_M)) + ALLOCATE(INEW_AT(NATCLU_M)) + ALLOCATE(SYM_AT(3,NATCLU_M)) + END SUBROUTINE ALLOC_COOR + END MODULE COOR_MOD + +C======================================================================= + MODULE DEBWAL_MOD + IMPLICIT NONE + INTEGER :: IDCM + INTEGER :: IDWSPH + REAL :: TD + REAL :: QD + REAL :: TEMP + REAL :: RSJ + REAL, ALLOCATABLE, DIMENSION(:) :: UJ2 + CONTAINS + SUBROUTINE ALLOC_DEBWAL() + USE DIM_MOD + ALLOCATE(UJ2(NATM)) + END SUBROUTINE ALLOC_DEBWAL + END MODULE DEBWAL_MOD + +C======================================================================= + MODULE INDAT_MOD + IMPLICIT NONE + CHARACTER*24, ALLOCATABLE, DIMENSION(:) :: INDATA + CONTAINS + SUBROUTINE ALLOC_INDAT() + USE DIM_MOD + ALLOCATE(INDATA(100)) + END SUBROUTINE ALLOC_INDAT + END MODULE INDAT_MOD + +C======================================================================= + MODULE INIT_A_MOD + IMPLICIT NONE + INTEGER :: LI_C + INTEGER :: LI_I + INTEGER :: LI_A + CONTAINS + SUBROUTINE ALLOC_INIT_A() + USE DIM_MOD + END SUBROUTINE ALLOC_INIT_A + END MODULE INIT_A_MOD + +C======================================================================= + MODULE INIT_L_MOD + IMPLICIT NONE + INTEGER :: LI + INTEGER :: INITL + INTEGER :: NNL + INTEGER :: LF1 + INTEGER :: LF2 + INTEGER :: ISTEP_LF + CONTAINS + SUBROUTINE ALLOC_INIT_L() + USE DIM_MOD + END SUBROUTINE ALLOC_INIT_L + END MODULE INIT_L_MOD + +C======================================================================= + MODULE INIT_J_MOD + IMPLICIT NONE + INTEGER :: JF1 + INTEGER :: JF2 + INTEGER :: I_SO + CHARACTER*3 :: S_O + CONTAINS + SUBROUTINE ALLOC_INIT_J() + USE DIM_MOD + END SUBROUTINE ALLOC_INIT_J + END MODULE INIT_J_MOD + +C======================================================================= + MODULE INIT_M_MOD + IMPLICIT NONE + INTEGER :: I_SHELL + INTEGER :: I_MULT + INTEGER :: L_MUL + INTEGER :: J_MUL + INTEGER :: S_MUL + CHARACTER*3 :: MULTIPLET + CONTAINS + SUBROUTINE ALLOC_INIT_M() + USE DIM_MOD + END SUBROUTINE ALLOC_INIT_M + END MODULE INIT_M_MOD + +C======================================================================= + MODULE INFILES_MOD + IMPLICIT NONE + CHARACTER*24 :: INFILE1 + CHARACTER*24 :: INFILE2 + CHARACTER*24 :: INFILE3 + CHARACTER*24 :: INFILE4 + CHARACTER*24 :: INFILE5 + CHARACTER*24 :: INFILE6 + CHARACTER*24 :: INFILE7 + CHARACTER*24 :: INFILE8 + CHARACTER*24 :: INFILE9 + CONTAINS + SUBROUTINE ALLOC_INFILES() + USE DIM_MOD + END SUBROUTINE ALLOC_INFILES + END MODULE INFILES_MOD + +C======================================================================= + MODULE INUNITS_MOD + IMPLICIT NONE + INTEGER :: IUI1 + INTEGER :: IUI2 + INTEGER :: IUI3 + INTEGER :: IUI4 + INTEGER :: IUI5 + INTEGER :: IUI6 + INTEGER :: IUI7 + INTEGER :: IUI8 + INTEGER :: IUI9 + CONTAINS + SUBROUTINE ALLOC_INUNITS() + USE DIM_MOD + END SUBROUTINE ALLOC_INUNITS + END MODULE INUNITS_MOD + +C======================================================================= + MODULE LIMAMA_MOD + IMPLICIT NONE + INTEGER :: NIV + REAL :: COUPUR + CONTAINS + SUBROUTINE ALLOC_LIMAMA() + USE DIM_MOD + END SUBROUTINE ALLOC_LIMAMA + END MODULE LIMAMA_MOD + +C======================================================================= + MODULE LPMOY_MOD + IMPLICIT NONE + INTEGER :: ILPM + INTEGER :: NZA + REAL :: XMTA + REAL :: RHOTA + REAL :: XLPM0 + CONTAINS + SUBROUTINE ALLOC_LPMOY() + USE DIM_MOD + END SUBROUTINE ALLOC_LPMOY + END MODULE LPMOY_MOD + +C======================================================================= + MODULE MASSAT_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: XMT + CONTAINS + SUBROUTINE ALLOC_MASSAT() + USE DIM_MOD + ALLOCATE(XMT(NATM)) + END SUBROUTINE ALLOC_MASSAT + END MODULE MASSAT_MOD + +C======================================================================= + MODULE MILLER_MOD + IMPLICIT NONE + INTEGER :: IH + INTEGER :: IK + INTEGER :: II + INTEGER :: IL + INTEGER :: IVG0 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IVN + CONTAINS + SUBROUTINE ALLOC_MILLER() + USE DIM_MOD + ALLOCATE(IVN(3)) + END SUBROUTINE ALLOC_MILLER + END MODULE MILLER_MOD + +C======================================================================= + MODULE OUTUNITS_MOD + IMPLICIT NONE + INTEGER :: IUO1 + INTEGER :: IUO2 + INTEGER :: IUO3 + INTEGER :: IUO4 + INTEGER :: IUSCR + INTEGER :: IUSCR2 + CONTAINS + SUBROUTINE ALLOC_OUTUNITS() + USE DIM_MOD + END SUBROUTINE ALLOC_OUTUNITS + END MODULE OUTUNITS_MOD + +C======================================================================= + MODULE PARCAL_MOD + IMPLICIT NONE + INTEGER :: NPHI + INTEGER :: NE + INTEGER :: NTHETA + INTEGER :: NFTHET + INTEGER :: NEPS + CONTAINS + SUBROUTINE ALLOC_PARCAL() + USE DIM_MOD + END SUBROUTINE ALLOC_PARCAL + END MODULE PARCAL_MOD + +C======================================================================= + MODULE PARCAL_A_MOD + IMPLICIT NONE + INTEGER :: NPHI_A + INTEGER :: NE_A + INTEGER :: NTHETA_A + INTEGER :: NFTHET_A + CONTAINS + SUBROUTINE ALLOC_PARCAL_A() + USE DIM_MOD + END SUBROUTINE ALLOC_PARCAL_A + END MODULE PARCAL_A_MOD + +C======================================================================= + MODULE RELADS_MOD + IMPLICIT NONE + INTEGER :: NRELA + REAL, ALLOCATABLE, DIMENSION(:) :: PCRELA + CONTAINS + SUBROUTINE ALLOC_RELADS() + USE DIM_MOD + ALLOCATE(PCRELA(3)) + END SUBROUTINE ALLOC_RELADS + END MODULE RELADS_MOD + +C======================================================================= + MODULE RELAX_MOD + IMPLICIT NONE + INTEGER :: IREL + INTEGER :: NREL + REAL, ALLOCATABLE, DIMENSION(:) :: PCREL + REAL :: OMEGA1 + REAL :: OMEGA2 + CONTAINS + SUBROUTINE ALLOC_RELAX() + USE DIM_MOD + ALLOCATE(PCREL(10)) + END SUBROUTINE ALLOC_RELAX + END MODULE RELAX_MOD + +C======================================================================= + MODULE RESEAU_MOD + IMPLICIT NONE + INTEGER :: NCRIST + INTEGER :: NCENTR + INTEGER :: IBAS + INTEGER :: NAT + REAL :: A + REAL :: BSURA + REAL :: CSURA + CHARACTER*3 :: UNIT + CONTAINS + SUBROUTINE ALLOC_RESEAU() + USE DIM_MOD + END SUBROUTINE ALLOC_RESEAU + END MODULE RESEAU_MOD + +C======================================================================= + MODULE SPIN_MOD + IMPLICIT NONE + INTEGER :: ISPIN + INTEGER :: IDICHR + INTEGER :: NSPIN + INTEGER :: NSPIN2 + INTEGER :: ISFLIP + INTEGER :: IR_DIA + INTEGER :: NSTEP + CONTAINS + SUBROUTINE ALLOC_SPIN() + USE DIM_MOD + END SUBROUTINE ALLOC_SPIN + END MODULE SPIN_MOD + +C======================================================================= + MODULE TESTS_MOD + IMPLICIT NONE + INTEGER :: ITEST + INTEGER :: IPRINT + INTEGER :: ISORT1 + INTEGER :: NPATHP + INTEGER :: ISOM + CONTAINS + SUBROUTINE ALLOC_TESTS() + USE DIM_MOD + END SUBROUTINE ALLOC_TESTS + END MODULE TESTS_MOD + +C======================================================================= + MODULE TRANS_MOD + IMPLICIT NONE + COMPLEX, ALLOCATABLE, DIMENSION(:,:,:,:) :: DLT + COMPLEX, ALLOCATABLE, DIMENSION(:,:,:,:) :: TL + COMPLEX, ALLOCATABLE, DIMENSION(:) :: VK + REAL, ALLOCATABLE, DIMENSION(:) :: VK2 + INTEGER :: IPOTC + INTEGER :: ITL + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: LMAX + CONTAINS + SUBROUTINE ALLOC_TRANS() + USE DIM_MOD + ALLOCATE(DLT(NE_M,NATM,0:18,2)) + ALLOCATE(TL(0:NT_M,4,NATM,NE_M)) + ALLOCATE(VK(NE_M)) + ALLOCATE(VK2(NE_M)) + ALLOCATE(LMAX(NATM,NE_M)) + END SUBROUTINE ALLOC_TRANS + END MODULE TRANS_MOD + +C======================================================================= + MODULE TL_AED_MOD + IMPLICIT NONE + COMPLEX, ALLOCATABLE, DIMENSION(:,:,:,:) :: DLT_A + COMPLEX, ALLOCATABLE, DIMENSION(:,:,:,:) :: TL_A + COMPLEX, ALLOCATABLE, DIMENSION(:) :: VK_A + REAL, ALLOCATABLE, DIMENSION(:) :: VK2_A + INTEGER :: IPOTC_A + INTEGER :: ITL_A + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: LMAX_A + CONTAINS + SUBROUTINE ALLOC_TL_AED() + USE DIM_MOD + ALLOCATE(DLT_A(NE_M,NATM,0:18,2)) + ALLOCATE(TL_A(0:NT_M,4,NATM,NE_M)) + ALLOCATE(VK_A(NE_M)) + ALLOCATE(VK2_A(NE_M)) + ALLOCATE(LMAX_A(NATM,NE_M)) + END SUBROUTINE ALLOC_TL_AED + END MODULE TL_AED_MOD + +C======================================================================= + MODULE TYPCAL_MOD + IMPLICIT NONE + INTEGER :: IPHI + INTEGER :: IE + INTEGER :: ITHETA + INTEGER :: IFTHET + INTEGER :: IMOD + INTEGER :: IPOL + INTEGER :: I_CP + INTEGER :: I_EXT + INTEGER :: I_TEST + CONTAINS + SUBROUTINE ALLOC_TYPCAL() + USE DIM_MOD + END SUBROUTINE ALLOC_TYPCAL + END MODULE TYPCAL_MOD + +C======================================================================= + MODULE TYPCAL_A_MOD + IMPLICIT NONE + INTEGER :: IPHI_A + INTEGER :: IE_A + INTEGER :: ITHETA_A + INTEGER :: IFTHET_A + INTEGER :: IMOD_A + INTEGER :: I_CP_A + INTEGER :: I_EXT_A + INTEGER :: I_TEST_A + CONTAINS + SUBROUTINE ALLOC_TYPCAL_A() + USE DIM_MOD + END SUBROUTINE ALLOC_TYPCAL_A + END MODULE TYPCAL_A_MOD + +C======================================================================= + MODULE TYPEM_MOD + IMPLICIT NONE + INTEGER :: NEMET + INTEGER :: IESURF + INTEGER, ALLOCATABLE, DIMENSION(:) :: IEMET + CONTAINS + SUBROUTINE ALLOC_TYPEM() + USE DIM_MOD + ALLOCATE(IEMET(NEMET_M)) + END SUBROUTINE ALLOC_TYPEM + END MODULE TYPEM_MOD + +C======================================================================= + MODULE TYPEXP_MOD + IMPLICIT NONE + CHARACTER*3 :: SPECTRO + CHARACTER*7 :: INTERACT + CHARACTER*3 :: STEREO + CONTAINS + SUBROUTINE ALLOC_TYPEXP() + USE DIM_MOD + END SUBROUTINE ALLOC_TYPEXP + END MODULE TYPEXP_MOD + +C======================================================================= + MODULE VALIN_MOD + IMPLICIT NONE + REAL :: PHI0 + REAL :: E0 + REAL :: THETA0 + REAL :: THLUM + REAL :: PHILUM + REAL :: ELUM + REAL :: VINT + INTEGER, ALLOCATABLE, DIMENSION(:) :: NONVOL + CONTAINS + SUBROUTINE ALLOC_VALIN() + USE DIM_MOD + ALLOCATE(NONVOL(100)) + END SUBROUTINE ALLOC_VALIN + END MODULE VALIN_MOD + +C======================================================================= + MODULE XMRHO_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: XMAT + REAL, ALLOCATABLE, DIMENSION(:) :: RHOAT + CONTAINS + SUBROUTINE ALLOC_XMRHO() + USE DIM_MOD + ALLOCATE(XMAT(0:99)) + ALLOCATE(RHOAT(0:99)) + END SUBROUTINE ALLOC_XMRHO + END MODULE XMRHO_MOD + +C======================================================================= + MODULE CRANGL_MOD + IMPLICIT NONE + REAL :: ALPHAD + REAL :: BETAD + REAL :: GAMMAD + CONTAINS + SUBROUTINE ALLOC_CRANGL() + USE DIM_MOD + END SUBROUTINE ALLOC_CRANGL + END MODULE CRANGL_MOD + +C======================================================================= + MODULE VECSYS_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: ASYS + REAL, ALLOCATABLE, DIMENSION(:) :: BSYS + REAL, ALLOCATABLE, DIMENSION(:) :: CSYS + CONTAINS + SUBROUTINE ALLOC_VECSYS() + USE DIM_MOD + ALLOCATE(ASYS(3)) + ALLOCATE(BSYS(3)) + ALLOCATE(CSYS(3)) + END SUBROUTINE ALLOC_VECSYS + END MODULE VECSYS_MOD + +C======================================================================= + MODULE VIBRAT_MOD + IMPLICIT NONE + INTEGER, ALLOCATABLE, DIMENSION(:) :: I_FREE + CONTAINS + SUBROUTINE ALLOC_VIBRAT() + USE DIM_MOD + ALLOCATE(I_FREE(NATP_M)) + END SUBROUTINE ALLOC_VIBRAT + END MODULE VIBRAT_MOD + +C======================================================================= + MODULE COEFRLM_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: CF + CONTAINS + SUBROUTINE ALLOC_COEFRLM() + USE DIM_MOD + ALLOCATE(CF(0:2*NL_M-2,0:2*NL_M-2,0:2*NL_M-2)) + END SUBROUTINE ALLOC_COEFRLM + END MODULE COEFRLM_MOD + +C======================================================================= + MODULE EXPROT_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:) :: EXPR + CONTAINS + SUBROUTINE ALLOC_EXPROT() + USE DIM_MOD + ALLOCATE(EXPR(0:2*NL_M-2,0:2*NL_M-2)) + END SUBROUTINE ALLOC_EXPROT + END MODULE EXPROT_MOD + +C======================================================================= + MODULE EXPFAC_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:) :: EXPF + CONTAINS + SUBROUTINE ALLOC_EXPFAC() + USE DIM_MOD + ALLOCATE(EXPF(0:2*NL_M-2,0:2*NL_M-2)) + END SUBROUTINE ALLOC_EXPFAC + END MODULE EXPFAC_MOD + +C======================================================================= + MODULE LOGAMAD_MOD + IMPLICIT NONE + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: GLD + CONTAINS + SUBROUTINE ALLOC_LOGAMAD() + USE DIM_MOD + ALLOCATE(GLD(0:N_GAUNT,2)) + END SUBROUTINE ALLOC_LOGAMAD + END MODULE LOGAMAD_MOD + +C======================================================================= + MODULE EXPFAC2_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:) :: EXPF2 + CONTAINS + SUBROUTINE ALLOC_EXPFAC2() + USE DIM_MOD + ALLOCATE(EXPF2(0:2*NL_M-2,0:2*NL_M-2)) + END SUBROUTINE ALLOC_EXPFAC2 + END MODULE EXPFAC2_MOD + +C======================================================================= + MODULE FACTSQ_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: FSQ + CONTAINS + SUBROUTINE ALLOC_FACTSQ() + USE DIM_MOD + ALLOCATE(FSQ(0:2*NL_M-2)) + END SUBROUTINE ALLOC_FACTSQ + END MODULE FACTSQ_MOD + +C======================================================================= + MODULE ALGORITHM_MOD + IMPLICIT NONE + CHARACTER*2 :: ALGO1 + CHARACTER*2 :: ALGO2 + CHARACTER*2 :: ALGO3 + CHARACTER*2 :: ALGO4 + CONTAINS + SUBROUTINE ALLOC_ALGORITHM() + USE DIM_MOD + END SUBROUTINE ALLOC_ALGORITHM + END MODULE ALGORITHM_MOD + +C======================================================================= + MODULE EXAFS_MOD + IMPLICIT NONE + INTEGER :: NE_X + REAL :: EK_INI + REAL :: EK_FIN + REAL :: EPH_INI + CONTAINS + SUBROUTINE ALLOC_EXAFS() + USE DIM_MOD + END SUBROUTINE ALLOC_EXAFS + END MODULE EXAFS_MOD + +C======================================================================= + MODULE HEADER_MOD + IMPLICIT NONE + INTEGER :: NI + CHARACTER*1 :: NLI + CHARACTER*6 :: AUGER + CHARACTER*1 :: EDGE + INTEGER :: NEDGE + CONTAINS + SUBROUTINE ALLOC_HEADER() + USE DIM_MOD + END SUBROUTINE ALLOC_HEADER + END MODULE HEADER_MOD + +C======================================================================= + MODULE MOYEN_MOD + IMPLICIT NONE + INTEGER :: IMOY + INTEGER :: NDIR + REAL :: ACCEPT + INTEGER :: ICHKDIR + CONTAINS + SUBROUTINE ALLOC_MOYEN() + USE DIM_MOD + END SUBROUTINE ALLOC_MOYEN + END MODULE MOYEN_MOD + +C======================================================================= + MODULE VALIN_AV_MOD + IMPLICIT NONE + INTEGER :: I_SET + REAL, ALLOCATABLE, DIMENSION(:) :: TH_0 + REAL, ALLOCATABLE, DIMENSION(:) :: PH_0 + CONTAINS + SUBROUTINE ALLOC_VALIN_AV() + USE DIM_MOD + ALLOCATE(TH_0(NTH_M)) + ALLOCATE(PH_0(NPH_M)) + END SUBROUTINE ALLOC_VALIN_AV + END MODULE VALIN_AV_MOD + +C======================================================================= + MODULE VALFIN_MOD + IMPLICIT NONE + REAL :: PHI1 + REAL :: EFIN + REAL :: THETA1 + CONTAINS + SUBROUTINE ALLOC_VALFIN() + USE DIM_MOD + END SUBROUTINE ALLOC_VALFIN + END MODULE VALFIN_MOD + +C======================================================================= + MODULE VALEX_A_MOD + IMPLICIT NONE + REAL :: PHI0_A + REAL :: THETA0_A + REAL :: PHI1_A + REAL :: THETA1_A + CONTAINS + SUBROUTINE ALLOC_VALEX_A() + USE DIM_MOD + END SUBROUTINE ALLOC_VALEX_A + END MODULE VALEX_A_MOD + +C======================================================================= + MODULE AMPLI_MOD + IMPLICIT NONE + INTEGER :: I_AMP + CONTAINS + SUBROUTINE ALLOC_AMPLI() + USE DIM_MOD + END SUBROUTINE ALLOC_AMPLI + END MODULE AMPLI_MOD + +C======================================================================= + MODULE CONVACC_MOD + IMPLICIT NONE + COMPLEX*16 :: ALPHA + COMPLEX*16 :: BETA + INTEGER :: I_XN + INTEGER :: I_VA + INTEGER :: I_GN + INTEGER :: I_WN + INTEGER :: LEVIN + CONTAINS + SUBROUTINE ALLOC_CONVACC() + USE DIM_MOD + END SUBROUTINE ALLOC_CONVACC + END MODULE CONVACC_MOD + +C======================================================================= + MODULE CONVTYP_MOD + IMPLICIT NONE + REAL*8 :: SHIFT + REAL*8 :: ACC + REAL*8 :: EXPO + INTEGER :: I_PWM + INTEGER :: I_ACC + INTEGER :: N_ONE + INTEGER :: N_MAX + INTEGER :: N_ITER + INTEGER :: N_TABLE + CHARACTER*4 :: METHOD + CONTAINS + SUBROUTINE ALLOC_CONVTYP() + USE DIM_MOD + END SUBROUTINE ALLOC_CONVTYP + END MODULE CONVTYP_MOD + +C======================================================================= + MODULE C_G_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: CG + CONTAINS + SUBROUTINE ALLOC_C_G() + USE DIM_MOD + ALLOCATE(CG(-LI_M:LI_M+1,2,2)) + END SUBROUTINE ALLOC_C_G + END MODULE C_G_MOD + +C======================================================================= + MODULE C_G_A_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: CGA + CONTAINS + SUBROUTINE ALLOC_C_G_A() + USE DIM_MOD + ALLOCATE(CGA(0:NCG_M,-NCG_M:NCG_M,0:NCG_M,-NCG_M:NCG_M,0:2*NCG + &_M)) + END SUBROUTINE ALLOC_C_G_A + END MODULE C_G_A_MOD + +C======================================================================= + MODULE C_G_M_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: CG_S + CONTAINS + SUBROUTINE ALLOC_C_G_M() + USE DIM_MOD + ALLOCATE(CG_S(2,2,2)) + END SUBROUTINE ALLOC_C_G_M + END MODULE C_G_M_MOD + +C======================================================================= + MODULE DEXPFAC2_MOD + IMPLICIT NONE + REAL*8, ALLOCATABLE, DIMENSION(:,:) :: DEXPF2 + CONTAINS + SUBROUTINE ALLOC_DEXPFAC2() + USE DIM_MOD + ALLOCATE(DEXPF2(0:2*NL_M-2,0:2*NL_M-2)) + END SUBROUTINE ALLOC_DEXPFAC2 + END MODULE DEXPFAC2_MOD + +C======================================================================= + MODULE DFACTSQ_MOD + IMPLICIT NONE + REAL*8, ALLOCATABLE, DIMENSION(:) :: DFSQ + CONTAINS + SUBROUTINE ALLOC_DFACTSQ() + USE DIM_MOD + ALLOCATE(DFSQ(0:2*NL_M-2)) + END SUBROUTINE ALLOC_DFACTSQ + END MODULE DFACTSQ_MOD + +C======================================================================= + MODULE EIGEN_MOD + IMPLICIT NONE + INTEGER :: NE_EIG + REAL :: E0_EIG + REAL :: EFIN_EIG + INTEGER :: I_VIB + INTEGER :: I_MFP + CONTAINS + SUBROUTINE ALLOC_EIGEN() + USE DIM_MOD + END SUBROUTINE ALLOC_EIGEN + END MODULE EIGEN_MOD + +C======================================================================= + MODULE FDIF_MOD + IMPLICIT NONE + REAL :: R1 + REAL :: R2 + CONTAINS + SUBROUTINE ALLOC_FDIF() + USE DIM_MOD + END SUBROUTINE ALLOC_FDIF + END MODULE FDIF_MOD + +C======================================================================= + MODULE FIXSCAN_MOD + IMPLICIT NONE + INTEGER :: N_FIXED + INTEGER :: N_SCAN + INTEGER :: IPH_1 + REAL :: FIX0 + REAL :: FIX1 + REAL :: SCAN0 + REAL :: SCAN1 + CONTAINS + SUBROUTINE ALLOC_FIXSCAN() + USE DIM_MOD + END SUBROUTINE ALLOC_FIXSCAN + END MODULE FIXSCAN_MOD + +C======================================================================= + MODULE FIXSCAN_A_MOD + IMPLICIT NONE + INTEGER :: N_FIXED_A + INTEGER :: N_SCAN_A + INTEGER :: IPH_1_A + REAL :: FIX0_A + REAL :: FIX1_A + REAL :: SCAN0_A + REAL :: SCAN1_A + CONTAINS + SUBROUTINE ALLOC_FIXSCAN_A() + USE DIM_MOD + END SUBROUTINE ALLOC_FIXSCAN_A + END MODULE FIXSCAN_A_MOD + +C======================================================================= + MODULE LINLBD_MOD + IMPLICIT NONE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: LBD + INTEGER :: LBDMAX + INTEGER, ALLOCATABLE, DIMENSION(:) :: NUMAX + CONTAINS + SUBROUTINE ALLOC_LINLBD() + USE DIM_MOD + ALLOCATE(LBD(-N_MU_M:N_MU_M,0:N_NU_M)) + ALLOCATE(NUMAX(NATP_M)) + END SUBROUTINE ALLOC_LINLBD + END MODULE LINLBD_MOD + +C======================================================================= + MODULE MOYEN_A_MOD + IMPLICIT NONE + INTEGER :: IMOY_A + INTEGER :: NDIR_A + REAL :: ACCEPT_A + INTEGER :: ICHKDIR_A + CONTAINS + SUBROUTINE ALLOC_MOYEN_A() + USE DIM_MOD + END SUBROUTINE ALLOC_MOYEN_A + END MODULE MOYEN_A_MOD + +C======================================================================= + MODULE OUTFILES_MOD + IMPLICIT NONE + CHARACTER*24 :: OUTFILE1 + CHARACTER*24 :: OUTFILE2 + CHARACTER*24 :: OUTFILE3 + CHARACTER*24 :: OUTFILE4 + CONTAINS + SUBROUTINE ALLOC_OUTFILES() + USE DIM_MOD + END SUBROUTINE ALLOC_OUTFILES + END MODULE OUTFILES_MOD + +C======================================================================= + MODULE RA_MOD + IMPLICIT NONE + INTEGER :: I_NO + INTEGER :: I_RA + INTEGER, ALLOCATABLE, DIMENSION(:) :: N_RA + CONTAINS + SUBROUTINE ALLOC_RA() + USE DIM_MOD + ALLOCATE(N_RA(NATP_M)) + END SUBROUTINE ALLOC_RA + END MODULE RA_MOD + +C======================================================================= + MODULE SPECTRUM_MOD + IMPLICIT NONE + INTEGER, ALLOCATABLE, DIMENSION(:) :: I_SPECTRUM + CONTAINS + SUBROUTINE ALLOC_SPECTRUM() + USE DIM_MOD + ALLOCATE(I_SPECTRUM(NE_M)) + END SUBROUTINE ALLOC_SPECTRUM + END MODULE SPECTRUM_MOD + +C======================================================================= + MODULE DIRECT_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:) :: DIRANA + REAL, ALLOCATABLE, DIMENSION(:,:) :: ANADIR + REAL :: RTHEXT + REAL :: RPHI + REAL, ALLOCATABLE, DIMENSION(:) :: THETAR + REAL, ALLOCATABLE, DIMENSION(:) :: PHIR + CONTAINS + SUBROUTINE ALLOC_DIRECT() + USE DIM_MOD + ALLOCATE(DIRANA(3,49)) + ALLOCATE(ANADIR(3,49)) + ALLOCATE(THETAR(49)) + ALLOCATE(PHIR(49)) + END SUBROUTINE ALLOC_DIRECT + END MODULE DIRECT_MOD + +C======================================================================= + MODULE DIRECT_A_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:) :: DIRANA_A + REAL, ALLOCATABLE, DIMENSION(:,:) :: ANADIR_A + REAL :: RTHEXT_A + REAL :: RPHI_A + REAL, ALLOCATABLE, DIMENSION(:) :: THETAR_A + REAL, ALLOCATABLE, DIMENSION(:) :: PHIR_A + CONTAINS + SUBROUTINE ALLOC_DIRECT_A() + USE DIM_MOD + ALLOCATE(DIRANA_A(3,49)) + ALLOCATE(ANADIR_A(3,49)) + ALLOCATE(THETAR_A(49)) + ALLOCATE(PHIR_A(49)) + END SUBROUTINE ALLOC_DIRECT_A + END MODULE DIRECT_A_MOD + +C======================================================================= + MODULE PATH_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: NPATH + REAL, ALLOCATABLE, DIMENSION(:) :: NPATH2 + INTEGER :: NTHOF + REAL, ALLOCATABLE, DIMENSION(:) :: NPMA + REAL, ALLOCATABLE, DIMENSION(:) :: NPMI + CONTAINS + SUBROUTINE ALLOC_PATH() + USE DIM_MOD + ALLOCATE(NPATH(0:NDIF_M)) + ALLOCATE(NPATH2(0:NDIF_M)) + ALLOCATE(NPMA(0:NDIF_M)) + ALLOCATE(NPMI(0:NDIF_M)) + END SUBROUTINE ALLOC_PATH + END MODULE PATH_MOD + +C======================================================================= + MODULE ROT_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: RLM01 + CONTAINS + SUBROUTINE ALLOC_ROT() + USE DIM_MOD + ALLOCATE(RLM01(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)) + END SUBROUTINE ALLOC_ROT + END MODULE ROT_MOD + +C======================================================================= + MODULE TESTPA_MOD + IMPLICIT NONE + INTEGER, ALLOCATABLE, DIMENSION(:) :: IT + INTEGER, ALLOCATABLE, DIMENSION(:) :: IN + INTEGER :: IJ + CONTAINS + SUBROUTINE ALLOC_TESTPA() + USE DIM_MOD + ALLOCATE(IT(0:NDIF_M)) + ALLOCATE(IN(0:NDIF_M)) + END SUBROUTINE ALLOC_TESTPA + END MODULE TESTPA_MOD + +C======================================================================= + MODULE TESTPB_MOD + IMPLICIT NONE + COMPLEX :: RHO01 + REAL :: TH01 + REAL :: PHI01 + CONTAINS + SUBROUTINE ALLOC_TESTPB() + USE DIM_MOD + END SUBROUTINE ALLOC_TESTPB + END MODULE TESTPB_MOD + +C======================================================================= + MODULE TLDW_MOD + IMPLICIT NONE + COMPLEX, ALLOCATABLE, DIMENSION(:,:,:,:) :: TLT + CONTAINS + SUBROUTINE ALLOC_TLDW() + USE DIM_MOD + ALLOCATE(TLT(0:NT_M,4,NATM,NE_M)) + END SUBROUTINE ALLOC_TLDW + END MODULE TLDW_MOD + +C======================================================================= + MODULE VARIA_MOD + IMPLICIT NONE + COMPLEX, ALLOCATABLE, DIMENSION(:) :: CEX + COMPLEX, ALLOCATABLE, DIMENSION(:) :: CEXDW + REAL, ALLOCATABLE, DIMENSION(:) :: DW + CONTAINS + SUBROUTINE ALLOC_VARIA() + USE DIM_MOD + ALLOCATE(CEX(0:NDIF_M)) + ALLOCATE(CEXDW(0:NDIF_M)) + ALLOCATE(DW(0:NDIF_M)) + END SUBROUTINE ALLOC_VARIA + END MODULE VARIA_MOD + +C======================================================================= + MODULE LBD_MOD + IMPLICIT NONE + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: LBDM + CONTAINS + SUBROUTINE ALLOC_LBD() + USE DIM_MOD + INTEGER I,J + ALLOCATE(LBDM(2,NDIF_M)) + DO I=1,NDIF_M + DO J=1,2 + LBDM(J,I) = 0 + ENDDO + ENDDO + END SUBROUTINE ALLOC_LBD + END MODULE LBD_MOD + +C======================================================================= + MODULE SCATMAT_MOD + IMPLICIT NONE + COMPLEX, ALLOCATABLE, DIMENSION(:,:,:,:) :: F21 + CONTAINS + SUBROUTINE ALLOC_SCATMAT() + USE DIM_MOD + ALLOCATE(F21(NSPIN2_M,NLAMBDA_M,NLAMBDA_M,NDIF_M)) + END SUBROUTINE ALLOC_SCATMAT + END MODULE SCATMAT_MOD + +C======================================================================= + MODULE EXTREM_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: FMIN + REAL, ALLOCATABLE, DIMENSION(:) :: FMAX + INTEGER :: IREF + CONTAINS + SUBROUTINE ALLOC_EXTREM() + USE DIM_MOD + ALLOCATE(FMIN(0:NDIF_M)) + ALLOCATE(FMAX(0:NDIF_M)) + END SUBROUTINE ALLOC_EXTREM + END MODULE EXTREM_MOD + +C======================================================================= + MODULE PRINTP_MOD + IMPLICIT NONE + REAL, ALLOCATABLE, DIMENSION(:) :: FMN + REAL, ALLOCATABLE, DIMENSION(:) :: PATH + REAL, ALLOCATABLE, DIMENSION(:) :: DMN + INTEGER, ALLOCATABLE, DIMENSION(:) :: JON + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JPON + CONTAINS + SUBROUTINE ALLOC_PRINTP() + USE DIM_MOD + INTEGER I,J + ALLOCATE(FMN(NPATH_M)) + ALLOCATE(PATH(NPATH_M)) + ALLOCATE(DMN(NPATH_M)) + ALLOCATE(JON(NPATH_M)) + ALLOCATE(JPON(NPATH_M,NDIF_M)) + END SUBROUTINE ALLOC_PRINTP + END MODULE PRINTP_MOD + diff --git a/src/msspec/spec/fortran/prog.f b/src/msspec/spec/fortran/prog.f new file mode 100644 index 0000000..0a2de49 --- /dev/null +++ b/src/msspec/spec/fortran/prog.f @@ -0,0 +1,13 @@ + PROGRAM MAIN + IMPLICIT INTEGER (A-Z) + + READ *, 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 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_) + END PROGRAM MAIN diff --git a/src/msspec/spec/fortran/spec.f b/src/msspec/spec/fortran/spec.f new file mode 100644 index 0000000..932d9e0 --- /dev/null +++ b/src/msspec/spec/fortran/spec.f @@ -0,0 +1,13297 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * PHOTOELECTRON DIFFRACTION CODE * * +C * * BASED ON SERIES EXPANSION * * +C * * * * +C * ******************************************************** * +C ************************************************************ +C +C +C +C +C Written by D. Sebilleau, Groupe Theorie, +C Departement Materiaux-Nanosciences, +C Institut de Physique de Rennes, +C UMR CNRS-Universite 6251, +C Universite de Rennes-1, +C 35042 Rennes-Cedex, +C France +C +C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada +C +C----------------------------------------------------------------------- +C +C As a general rule in this code, although there might be a few +C exceptions (...), a variable whose name starts with a 'I' is a +C switch, with a 'J' is a loop index and with a 'N' is a number. +C +C The main subroutines are : +C +C * PHDDIF : computes the photoelectron diffraction +C formula +C +C * LEDDIF : computes the low-energy electron +C diffraction formula +C +C * XASDIF : computes the EXAFS or XANES formula +C depending on the energy +C +C * AEDDIF : computes the Auger electron diffraction +C formula +C +C * FINDPATHS : generates the multiple scattering +C paths the electron will follow +C +C * PATHOP : calculates the contribution of a given +C path to the scattering path operator +C +C * MATDIF : computes the Rehr-Albers scattering +C matrices +C +C A subroutine called NAME_A is the Auger equivalent of subroutine +C NAME. The essentail difference between NAME and NAME_A is that +C they do not contain the same arrays. +C +C Always remember, when changing the input data file, to keep the +C format. The rule here is that the last digit of any integer or +C character data must correspond to the tab (+) while for real data, +C the tab precedes the point. +C +C Do not forget, before submitting a calculation, to check the +C consistency of the input data with the corresponding maximal +C values in the include file. +C +C----------------------------------------------------------------------- +C +C Please report any bug or problem to me at : +C +C didier.sebilleau@univ-rennes1.fr +C +C +C +C Last modified : 10 Jan 2016 +C +C======================================================================= +C + SUBROUTINE DO_MAIN() +C +C This routine reads the various input files and calls the subroutine +C performing the requested calculation +C + USE DIM_MOD +C + USE ADSORB_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE CLUSLIM_MOD + USE COOR_MOD + USE DEBWAL_MOD + USE INDAT_MOD + USE INIT_A_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE INIT_M_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE LIMAMA_MOD + USE LPMOY_MOD + USE MASSAT_MOD + USE MILLER_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TL_AED_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE XMRHO_MOD +C + DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3) + DIMENSION ROT(3,3),EMET(3) + DIMENSION VAL2(NATCLU_M) + DIMENSION IRE(NATCLU_M,2) + DIMENSION REL(NATCLU_M),RHOT(NATM) + DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M) + DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM) + DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M) + DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M) + DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM) +C + COMPLEX TLSTAR + COMPLEX RHOR(NE_M,NATM,0:18,5,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHOR5STAR +C + INTEGER INV(2) +C + CHARACTER RIEN + CHARACTER*1 B + CHARACTER*2 R +C +C +C +C +C +C + CHARACTER*30 TUNIT,DUMMY +C + DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/ + DATA INV /0,0/ +C + LE_MAX=0 +C +C! READ(*,776) NFICHLEC +C! READ(*,776) ICOM +C! DO JF=1,NFICHLEC +C! READ(*,777) INDATA(JF) +C! ENDDO +C +C.......... Loop on the data files .......... +C + NFICHLEC=1 + ICOM = 5 + DO JFICH=1,NFICHLEC +C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD') + OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD') + CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*5 + &20,*540,*550,*570,*580,*590,*630) +C +C.......... Atomic case index .......... +C + I_AT=0 + IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1 + IF(SPECTRO.EQ.'APC') THEN + IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1 + ENDIF +C + IF(IBAS.EQ.1) THEN + IF(ITEST.EQ.0) THEN + NEQ=(2*NIV+1)**3 + ELSE + NEQ=(2*NIV+3)**3 + ENDIF + IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518 + ENDIF +C + IF(SPECTRO.EQ.'APC') THEN + N_EL=2 + ELSE + N_EL=1 + ENDIF + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN + IF(I_MULT.EQ.0) THEN + LE_MIN=ABS(LI_C-ABS(LI_I-LI_A)) + LE_MAX=LI_C+LI_A+LI_I + ELSE + LE_MIN=ABS(LI_C-L_MUL) + LE_MAX=LI_C+L_MUL + ENDIF + ENDIF +C +C.......... Test of the dimensions against the input values .......... +C + IF(NO.GT.NO_ST_M) GOTO 600 + IF(LE_MAX.GT.LI_M) GOTO 620 +C + OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD') + OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD') + IF(INTERACT.EQ.'DIPCOUL') THEN + OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD') + OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD') + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (dipolar excitation or no excitation case) .......... +C + IF(INTERACT.NE.'COULOMB') THEN + IF(SPECTRO.EQ.'APC') WRITE(IUO1,418) + READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE + IF(ISPIN.EQ.0) THEN + IF(NAT1.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1 + ENDIF + ENDIF + IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IUI2,530) E_MIN,E_MAX,DE + ENDIF + IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN + NLG=INT(NAT1-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1 + READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX. Waiting for a version of PHAGEN +C with LMAX dependent on the energy +C + DO JE=1,NE + DO JAT=1,NAT1 + LMAX(JAT,JE)=LMAX(JAT,1) + ENDDO + ENDDO +C + NL1=1 + DO JAT=1,NAT1 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + ENDIF + IF(ITL.EQ.0) READ(IUI3,101) NATR,NER + IF(ISPIN.EQ.1) THEN + READ(IUI3,106) L_IN,NATR,NER + IF(LI.NE.L_IN) GOTO 606 + ENDIF + NAT2=NAT+NATA + IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180 + IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL.EQ.0) THEN + DO JAT=1,NAT2 + IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + ENDIF + DO JE=1,NE + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121 + READ(IUI3,103) ENERGIE + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + 121 CONTINUE + DO L=0,LMAX(JAT,JE) + READ(IUI2,7) VK(JE),TL(L,1,JAT,JE) + TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,1.)*TL(L,1, + &JAT,JE)) + ENDDO + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5 + DO LL=1,18 + READ(IUI3,104) RH1,RH2,DEF1,DEF2 + RHOR(JE,JAT,LL,1,1)=CMPLX(RH1) + RHOR(JE,JAT,LL,2,1)=CMPLX(RH2) + DLT(JE,JAT,LL,1)=CMPLX(DEF1) + DLT(JE,JAT,LL,2)=CMPLX(DEF2) + ENDDO + 5 CONTINUE + ENDDO + ENDDO + ELSE +C +C.......... TL and RHOR calculated by PHAGEN .......... +C + DO JE=1,NE + NLG=INT(NAT2-0.0001)/4 +1 + IF(NE.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2 + READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL) + ENDDO + NL1=1 + DO JAT=1,NAT2 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + DO JAT=1,NAT2 + READ(IUI2,*) DUMMY + DO L=0,LMAX(JAT,JE) + IF(LMAX_MODE.EQ.0) THEN + READ(IUI2,9) VK(JE),TLSTAR + ELSE + READ(IUI2,9) VK(JE),TLSTAR + ENDIF + TL(L,1,JAT,JE)=CONJG(TLSTAR) + VK(JE)=CONJG(VK(JE)) + ENDDO + ENDDO +C + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333 + IF(JE.EQ.1) THEN + DO JDUM=1,7 + READ(IUI3,102) RIEN + ENDDO + ENDIF +C +C Reading or regular (RHOR) and irregular (RHOI) radial integrals +C +C 1-2 : dipole terms +C 3-5 : quadrupole terms +C + DO JEMET=1,NEMET +C + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHO + &R5STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + RHOR(JE,JM,NNL,3,1)=CONJG(RHOR3STAR) + RHOR(JE,JM,NNL,4,1)=CONJG(RHOR4STAR) + RHOR(JE,JM,NNL,5,1)=CONJG(RHOR5STAR) +C + ENDDO +C + 333 VK(JE)=VK(JE)*A + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDDO + ENDIF +C + CLOSE(IUI2) + CLOSE(IUI3) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN + CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL) + ENDIF + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (Coulomb excitation case) .......... +C + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN + IERR=0 + IF(INTERACT.EQ.'COULOMB') THEN + IRD1=IUI2 + IRD2=IUI3 + ELSEIF(INTERACT.EQ.'DIPCOUL') THEN + IRD1=IUI7 + IRD2=IUI8 + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,419) + READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A + IF(ISPIN.EQ.0) THEN + IF(NAT1_A.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1_A + ENDIF + ENDIF + IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A + ENDIF + IF(ITL_A.EQ.1) THEN + READ(IRD2,107) LI_C2,LI_I2,LI_A2 + READ(IRD2,117) LE_MIN1,N_CHANNEL + LE_MAX1=LE_MIN1+N_CHANNEL-1 + IF(I_TEST_A.NE.1) THEN + IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO 610 + ELSE + LI_C2=0 + LI_I2=1 + LI_A2=0 + LE_MIN1=1 + N_CHANNEL=1 + ENDIF + ENDIF + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN + NLG=INT(NAT1_A-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1_A + READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX_A. Waiting for a version of PHAGEN +C with LMAX_A dependent on the energy +C + DO JE=1,NE1_A + DO JAT=1,NAT1_A + LMAX_A(JAT,JE)=LMAX_A(JAT,1) + ENDDO + ENDDO +C + NL1_A=1 + DO JAT=1,NAT1_A + NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1) + ENDDO + IF(NL1_A.GT.NL_M) GOTO 184 + ENDIF + IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A + IF(ISPIN.EQ.1) THEN + READ(IRD2,106) L_IN_A,NATR_A,NER_A + IF(LI_C.NE.L_IN_A) GOTO 606 + ENDIF + NAT2_A=NAT+NATA + NAT2=NAT2_A + IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180 + IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) GOTO + &182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL_A.EQ.0) THEN + CONTINUE + ELSE +C +C.......... TL_A and RHOR_A calculated by PHAGEN .......... +C + DO JE=1,NE_A + NLG=INT(NAT2_A-0.0001)/4 +1 + IF(NE_A.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2_A + READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL) + ENDDO + DO JAT=1,NAT2_A + READ(IRD1,*) DUMMY + DO L=0,LMAX_A(JAT,JE) + IF(LMAX_MODE_A.EQ.0) THEN + READ(IRD1,9) VK_A(JE),TLSTAR + ELSE + READ(IRD1,7) VK_A(JE),TLSTAR + ENDIF + TL_A(L,1,JAT,JE)=CONJG(TLSTAR) + VK_A(JE)=CONJG(VK_A(JE)) + ENDDO + ENDDO +C + IF(IFTHET_A.EQ.1) GOTO 331 + DO LE=LE_MIN,LE_MAX + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IRD2,109) L_E,LB_MIN,LB_MAX + IF(I_TEST_A.EQ.1) THEN + L_E=1 + LB_MIN=0 + LB_MAX=1 + ENDIF + IF(LE.NE.L_E) IERR=1 + L_BOUNDS(L_E,1)=LB_MIN + L_BOUNDS(L_E,2)=LB_MAX + DO LB=LB_MIN,LB_MAX + READ(IRD2,108) L_A,RAD_D,RAD_E + RHOR_A(LE,JM,L_A,1,1)=RAD_D + RHOR_A(LE,JM,L_A,2,1)=RAD_E + IF(I_TEST_A.EQ.1) THEN + IF(LB.EQ.LB_MIN) THEN + RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0) + ELSEIF(LB.EQ.LB_MAX) THEN + RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + 331 VK_A(JE)=VK_A(JE)*A + VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE)) + ENDDO + ENDIF +C + CLOSE(IRD1) + CLOSE(IRD2) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN + CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL) + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,420) +C + ENDIF +C +C.......... Check of the consistency of the two TL and radial .......... +C.......... matrix elements for APECS .......... +C + IF(SPECTRO.EQ.'APC') THEN +C + I_TL_FILE=0 + I_RD_FILE=0 +C + IF(NAT1.NE.NAT1_A) I_TL_FILE=1 + IF(NE1.NE.NE1_A) I_TL_FILE=1 + IF(ITL.NE.ITL_A) I_TL_FILE=1 + IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1 +C + IF(LI_C.NE.LI_C2) I_RD_FILE=1 + IF(LI_I.NE.LI_I2) I_RD_FILE=1 + IF(LI_A.NE.LI_A2) I_RD_FILE=1 +C + IF(I_TL_FILE.EQ.1) GOTO 608 + IF(I_RD_FILE.EQ.1) GOTO 610 + IF(IERR.EQ.1) GOTO 610 +C + ENDIF +C +C.......... Calculation of the scattering factor (only) .......... +C + IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8 + IF(IFTHET.EQ.1) THEN + CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE) + ELSEIF(IFTHET_A.EQ.1) THEN +c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A) + ENDIF + WRITE(IUO1,57) + STOP +C + 8 IF(IBAS.EQ.0) THEN +C +C............... Reading of an external cluster ............... +C +C +C Cluster originating from CLUSTER_NEW.F : IPHA=0 +C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems) +C Other cluster : the first line must be text; then +C free format : Atomic number,X,Y,Z,number +C of the corresponding prototypical atom ; +C All atoms corresponding to the same +C prototypical atom must follow each other. +C Moreover, the blocks of equivalent atoms +C must be ordered by increasing number of +C prototypical atom. +C + VALZ_MIN=1000.0 + VALZ_MAX=-1000.0 +C + OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD') + READ(IUI4,778,ERR=892) IPHA + GOTO 893 + 892 IPHA=3 + IF(UNIT.EQ.'ANG') THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + ELSEIF(UNIT.EQ.'LPU') THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(UNIT.EQ.'ATU') THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + ELSE + GOTO 890 + ENDIF + 893 NATCLU=0 + DO JAT=1,NAT2 + NATYP(JAT)=0 + ENDDO + IF(IPHA.EQ.0) THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(IPHA.EQ.1) THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + IEMET(1)=1 + ELSEIF(IPHA.EQ.2) THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + IEMET(1)=1 + ENDIF + IF(IPRINT.EQ.2) THEN + IF(I_AT.NE.1) THEN + WRITE(IUO1,558) IUI4,TUNIT + IF(IPHA.EQ.3) WRITE(IUO1,549) + ENDIF + ENDIF + JATM=0 + DO JLINE=1,10000 + IF(IPHA.EQ.0) THEN + READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.1) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.2) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.3) THEN + READ(IUI4,*,END=780) NN,X,Y,Z,JAT + ENDIF + JATM=MAX0(JAT,JATM) + NATCLU=NATCLU+1 + IF(IPHA.NE.3) THEN + CHEM(JAT)=R + ELSE + CHEM(JAT)='XX' + ENDIF + NZAT(JAT)=NN + NATYP(JAT)=NATYP(JAT)+1 + COORD(1,NATCLU)=X*CUNIT + COORD(2,NATCLU)=Y*CUNIT + COORD(3,NATCLU)=Z*CUNIT + VALZ(NATCLU)=Z*CUNIT + IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,NATCLU),COORD + &(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT) + ENDIF + ENDDO + 780 NBZ=NATCLU + IF(JATM.NE.NAT) GOTO 514 + CLOSE(IUI4) +C + IF(NATCLU.GT.NATCLU_M) GOTO 510 + DO JA1=1,NATCLU + DO JA2=1,NATCLU + DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(COORD(2 + &,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**2) + IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO 895 + ENDDO + ENDDO +C + D_UP=VALZ_MAX-VALZ(1) + D_DO=VALZ(1)-VALZ_MIN + IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN + I_INV=1 + ELSE + I_INV=0 + ENDIF + ELSE +C +C............... Construction of an internal cluster ............... +C + CALL BASE + CALL ROTBAS(ROT) + IF(IVG0.EQ.2) THEN + NMAX=NIV+1 + ELSE + NMAX=(2*NIV+1)**3 + ENDIF + IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN + WRITE(IUO1,37) + WRITE(IUO1,38) NIV + DO NUM=1,NMAX + CALL NUMAT(NUM,NIV,IA,IB,IC) + WRITE(IUO1,17) NUM,IA,IB,IC + ENDDO + WRITE(IUO1,39) + ENDIF + CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,NBZ,N + &AT2,NCOUCH,NMAX) + IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN + CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,NCOUCH) + & + IF(IREL.EQ.1) THEN + DO JP=1,NPLAN + VAL(JP)=VAL2(JP) + ENDDO + ENDIF + ENDIF + ENDIF +C +C Storage of the extremal values of x and y for each plane. They define +C the exterior of the cluster when a new cluster has to be build to +C support a point-group +C + IF(I_GR.GE.1) THEN + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + WRITE(IUO1,29) K,VAL(K) + X_MAX(K)=0. + X_MIN(K)=0. + Y_MAX(K)=0. + Y_MIN(K)=0. + ENDDO + ENDIF + DO JAT=1,NATCLU + X=COORD(1,JAT) + Y=COORD(2,JAT) + Z=COORD(3,JAT) + DO JPLAN=1,NPLAN + IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN + X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN)) + X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN)) + Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN)) + Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN)) + ENDIF + ENDDO + ENDDO + ENDIF +C +C Instead of the symmetrization of the cluster (this version only) +C + N_PROT=NAT + NAT_ST=0 + DO JTYP=1,JATM + NB_AT=NATYP(JTYP) + IF(NB_AT.GT.NAT_EQ_M) GOTO 614 + DO JA=1,NB_AT + NAT_ST=NAT_ST+1 + NCORR(JA,JTYP)=NAT_ST + ENDDO + ENDDO + DO JC=1,3 + DO JA=1,NATCLU + SYM_AT(JC,JA)=COORD(JC,JA) + ENDDO + ENDDO +C +C Checking surface-like atoms for mean square displacements +C calculations +C + CALL CHECK_VIB(NAT2) +C +C.......... Set up of the variables used for an internal .......... +C.......... calculation of the mean free path and/or of .......... +C.......... the mean square displacements .......... +C + IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN + DO JTYP=1,NAT2 + XMT(JTYP)=XMAT(NZAT(JTYP)) + RHOT(JTYP)=RHOAT(NZAT(JTYP)) + ENDDO + XMTA=XMT(1) + RHOTA=RHOT(1) + NZA=NZAT(1) + ENDIF + IF(IDCM.GT.0) THEN + CALL CHNOT(3,VECBAS,VEC) + DO J=1,3 + VB1(J)=VEC(J,1) + VB2(J)=VEC(J,2) + VB3(J)=VEC(J,3) + ENDDO + CPR=1. + CALL PRVECT(VB2,VB3,VBS,CPR) + VM=PRSCAL(VB1,VBS) + QD=(6.*PI*PI*NAT/VM)**(1./3.) + ENDIF +C +C.......... Writing of the contents of the cluster, .......... +C.......... of the position of the different planes .......... +C.......... and of their respective absorbers in .......... +C.......... the control file IUO1 .......... +C + IF(I_AT.EQ.1) GOTO 153 + IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN + WRITE(IUO1,40) + NCA=0 + DO J=1,NAT + DO I=1,NMAX + NCA=NCA+1 + WRITE(IUO1,20) J,I + WRITE(IUO1,21) (ATOME(L,NCA),L=1,3) + K=IRE(NCA,1) + IF(K.EQ.0) THEN + WRITE(IUO1,22) + ELSE + WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2) + ENDIF + ENDDO + ENDDO + WRITE(IUO1,41) + ENDIF + IF(IBAS.EQ.1) THEN + WRITE(IUO1,24) + NATCLU=0 + DO I=1,NAT + NN=NATYP(I) + NATCLU=NATCLU+NATYP(I) + WRITE(IUO1,26) NN,I + ENDDO + IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3 + WRITE(IUO1,782) NATCLU + IF(NATCLU.GT.NATCLU_M) GOTO 516 + IF(IPRINT.EQ.3) WRITE(IUO1,559) + IF(IPRINT.EQ.3) THEN + NBTA=0 + DO JT=1,NAT2 + NBJT=NATYP(JT) + DO JN=1,NBJT + NBTA=NBTA+1 + WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),COORD(3,N + &BTA),JT,JN,CHEM(JT) + ENDDO + ENDDO + ENDIF + ENDIF + 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN + CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) + ENDIF + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) + ENDDO + ENDIF +C + IF(I_AT.EQ.0) WRITE(IUO1,30) + IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,31) (IEMET(J),J=1,NEMET) + ENDIF + ZEM=1.E+20 + DO L=1,NPLAN + Z=VAL(L) + DO JEMED=1,NEMET + CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93) + IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET(3) + IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3) + GO TO 33 + 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM + 33 CONTINUE + ENDDO + ENDDO +C +C.......... Loop on the electrons involved in the .......... +C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... +C.......... LEED or AED and N_EL = 2 for APC .......... +C + DO J_EL=1,N_EL +C +C.......... Writing the information on the spectroscopies .......... +C.......... in the control file IUO1 .......... +C + IF(SPECTRO.EQ.'XAS') GOTO 566 + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,236) + ELSE + WRITE(IUO1,248) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,245) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF +C +C---------- Photoelectron diffraction case (PHD) ---------- +C + IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,35) + ELSE + WRITE(IUO1,246) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,44) + IF(IE.EQ.1) WRITE(IUO1,58) + IF(INITL.EQ.0) WRITE(IUO1,118) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + WRITE(IUO1,418) + WRITE(IUO1,18) + ENDIF + IF(J_EL.EQ.2) GOTO 222 + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + IF(INITL.NE.0) THEN + WRITE(IUO1,337) + WRITE(IUO1,91) + IF(IPOL.EQ.0) THEN + WRITE(IUO1,88) + ELSEIF(ABS(IPOL).EQ.1) THEN + WRITE(IUO1,87) + ELSEIF(IPOL.EQ.2) THEN + WRITE(IUO1,89) + ENDIF + WRITE(IUO1,91) + IF(IDICHR.GT.0) THEN + WRITE(IUO1,338) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,90) + WRITE(IUO1,43) THLUM,PHILUM + IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF + ENDIF +C + IF(INITL.EQ.2) THEN + WRITE(IUO1,79) LI,LI-1,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,1,1),RHOR(JE,JTE + &,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1),DLT(JE,JTE,N + &NL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.-1) THEN + WRITE(IUO1,82) LI,LI-1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,1,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,1) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.1) THEN + WRITE(IUO1,82) LI,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + 222 CONTINUE + ENDIF +C +C---------- LEED case (LED) ---------- +C + IF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,252) + ELSE + WRITE(IUO1,258) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,254) + IF(IE.EQ.1) WRITE(IUO1,256) + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,260) + WRITE(IUO1,261) THLUM,PHILUM + IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF +C +C---------- Auger diffraction case (AED) ---------- +C + IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,235) + ELSE + WRITE(IUO1,247) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,244) + IF(I_TEST_A.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN + WRITE(IUO1,419) + WRITE(IUO1,18) + ENDIF + IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC_A.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,95) AUGER + CALL AUGER_MULT + IF(I_MULT.EQ.0) THEN + WRITE(IUO1,154) + ELSE + WRITE(IUO1,155) MULTIPLET + ENDIF +C + DO JEM=1,NEMET + JTE=IEMET(JEM) + WRITE(IUO1,112) JTE + DO LE=LE_MIN,LE_MAX + WRITE(IUO1,119) LE + LA_MIN=L_BOUNDS(LE,1) + LA_MAX=L_BOUNDS(LE,2) + DO LA=LA_MIN,LA_MAX + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,115) LA,RHOR_A(LE,JTE,LA,1,1),RHOR_A(LE + &,JTE,LA,2,1) + ENDIF + ENDDO + ENDDO + ENDDO +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF + ENDIF +C +C.......... Check of the dimensioning of the treatment routine .......... +C + CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,NPH + &I_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C.......... Call of the subroutine performing either .......... +C.......... the PhD, LEED, AED, EXAFS or APECS calculation .......... +C + 566 IF(ISPIN.EQ.0) THEN + IF(SPECTRO.EQ.'PHD') THEN + CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,NATC + &LU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'LED') THEN +c CALL LEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'AED') THEN +c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, +c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) + ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'APC') THEN +c IF(J_EL.EQ.1) THEN +c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(J_EL.EQ.2) THEN +c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, +c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) +c ENDIF + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF(SPECTRO.EQ.'PHD') THEN +c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(SPECTRO.EQ.'AED') THEN +c CALL AEDDIF_SP +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_SP +c ENDIF + continue + ENDIF +C +C.......... End of the MS calculation : .......... +C.......... direct exit or treatment of the results .......... +C +C +C.......... End of the loop on the electrons .......... +C + ENDDO +C + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,52) + ELSE + WRITE(IUO1,249) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,49) + IF(IE.EQ.1) WRITE(IUO1,59) + ELSEIF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,253) + ELSE + WRITE(IUO1,259) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,255) + IF(IE.EQ.1) WRITE(IUO1,257) + ELSEIF(SPECTRO.EQ.'XAS') THEN + WRITE(IUO1,51) + ELSEIF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,237) + ELSE + WRITE(IUO1,250) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,238) + ELSEIF(SPECTRO.EQ.'APC') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,239) + ELSE + WRITE(IUO1,251) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,240) + ENDIF +C + CLOSE(ICOM) + IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN + WRITE(IUO1,562) + ENDIF + IF(ISOM.EQ.0) CLOSE(IUO2) + IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1) +C +C.......... End of the loop on the data files .......... +C + ENDDO +C + IF(ISOM.NE.0) THEN + JFF=1 + IF(ISPIN.EQ.0) THEN + IF(SPECTRO.NE.'XAS') THEN + CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP) + ELSE +c CALL TREAT_XAS(ISOM,NFICHLEC,NP) + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP) +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP) +c ENDIF + continue + ENDIF + ENDIF +C + IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) +C STOP + GOTO 999 +C + 1 WRITE(IUO1,60) + STOP + 2 WRITE(IUO1,61) + STOP + 55 WRITE(IUO1,65) + STOP + 56 WRITE(IUO1,64) + STOP + 74 WRITE(IUO1,75) + STOP + 99 WRITE(IUO1,100) + STOP + 180 WRITE(IUO1,181) + STOP + 182 WRITE(IUO1,183) + STOP + 184 WRITE(IUO1,185) + STOP + 504 WRITE(IUO1,505) + STOP + 510 WRITE(IUO1,511) IUI4 + STOP + 514 WRITE(IUO1,515) + STOP + 516 WRITE(IUO1,517) + STOP + 518 WRITE(IUO1,519) + WRITE(IUO1,889) + STOP + 520 WRITE(IUO1,521) + STOP + 540 WRITE(IUO1,541) + STOP + 550 WRITE(IUO1,551) + STOP + 570 WRITE(IUO1,571) + STOP + 580 WRITE(IUO1,581) + STOP + 590 WRITE(IUO1,591) + STOP + 600 WRITE(IUO1,601) + STOP + 602 WRITE(IUO1,603) + STOP + 604 WRITE(IUO1,605) + STOP + 606 WRITE(IUO1,607) + STOP + 608 WRITE(IUO1,609) + STOP + 610 WRITE(IUO1,611) + STOP + 614 WRITE(IUO1,615) NB_AT + STOP + 620 WRITE(IUO1,621) LE_MAX + STOP + 630 WRITE(IUO1,631) + STOP + 890 WRITE(IUO1,891) + STOP + 895 WRITE(IUO1,896) JA1,JA2 +C + 3 FORMAT(5(5X,I4)) + 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) + 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',': + &(',I3,',',I3,',',I3,')') + 18 FORMAT(' ',/) + 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5) + 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,', + &',F7.3,')') + 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER') + 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,' + &,',F7.3,')',5X,'NEW NUMBER : ',I4) + 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/) + 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2) + 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3) + 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/) + 31 FORMAT(38X,10(I2,3X),//) + 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS P + &OSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL PHOTO + &ELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', 'OF THE EX + &AFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE A + &TOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + &'++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', ' CONTENTS OF THE RE + &DUCED CLUSTER ======================',///) + 41 FORMAT(///,'====================================================', + &'============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,' + &DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR PHOTOELECTR + &ON DIFFRACTION CALCULATION #####', '#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE SURF + &ACE)') + 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON DIFFRA + &CTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', 'EXAFS CALCU + &LATION ##########') + 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON DI + &FFRACTION CALCULATION #####','#####') + 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE') + 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE STRUCTURE + & OSCILLATIONS CALCULATION #####', '#####',/////) + 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE OSCILLATI + &ONS CALCULATION #####','#####') + 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M) + &- CHECK THE DIMENSIONING >>>>>>>>>>') + 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', ' + & >>>>>>>>>>') + 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ','CLUST + &ER HAS NOT CONVERGED YET >>>>>>>>>>') + 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ', + &'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>') + 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ', + & 'IN MAIN ET READ_DATA >>>>>>>>>>') + 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ', + & I1,',',I1,/) + 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',A3 + &,')',//) + 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)') + 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1) + 83 FORMAT(//,32X,'(SPHERICAL WAVES)') + 84 FORMAT(//,34X,'(PLANE WAVES)') + 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)') + 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)') + 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +') + 88 FORMAT(24X,'+ NON POLARIZED LIGHT +') + 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +') + 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/) + 91 FORMAT(24X,'+',35X,'+') + 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++') + 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS PR + &ESENT IN THIS PLANE') + 95 FORMAT(////,31X,'AUGER LINE :',A6,//) + 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')') + & + 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',I1, + &')') + 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE',' >> + &>>>>>>>>') + 101 FORMAT(24X,I3,24X,I3) + 102 FORMAT(A1) + 103 FORMAT(31X,F7.2) + 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5) + 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,E1 + &2.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) + 106 FORMAT(12X,I3,12X,I3,12X,I3) + 107 FORMAT(5X,I2,5X,I2,5X,I2) + 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 109 FORMAT(5X,I2,12X,I2,11X,I2) + 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,' + & :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//) + 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,' + &: (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')') + 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,' + &: ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)',/, + &8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//) + 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ', + * 'TYPE ',I2,' : (',F8.5,',',F8.5,')') + 114 FORMAT(/) + 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.5 + &,')') + 117 FORMAT(12X,I2,5X,I2) + 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/) + 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE INTEGRAL' + &) + 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ','I + &NVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ','INVER + &SION)') + 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4) + 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,' + &',/,' ') + 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ','LINE' + &,' ',/,' ',/,' ') + 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A + &ND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A + &ND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ','FILE + & >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX ELEME + &NTS TAKEN INTO ACCOUNT <-----',///) + 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL AUGER + & DIFFRACTION CALCULATION #####', '#####',/////) + 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL APECS + & DIFFRACTION CALCULATION #####', '#####',/////) + 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER DIFFR + &ACTION CALCULATION #####', '#####',/////) + 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER DIFFRACT + &ION CALCULATION #####', '#####',/////) + 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS DIFFR + &ACTION CALCULATION #####', '#####',/////) + 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS DIFFRACT + &ION CALCULATION #####', '#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER DI + &FFRACTION CALCULATION #####', '#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS DI + &FFRACTION CALCULATION #####', '#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE PHOT + &OELECTRON DIFFRACTION CALCULATION ','##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE AUGE + &R DIFFRACTION CALCULATION ', '##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE APEC + &S DIFFRACTION CALCULATION ', '##########',/////) + 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON D + &IFFRACTION CALCULATION #####','#####') + 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER DIFF + &RACTION CALCULATION #####', '#####',/////) + 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS DIFF + &RACTION CALCULATION #####', '#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL LEED + &CALCULATION #####', '#####',/////) + 253 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL LEED CALCUL + &ATION #####', '#####',/////) + 254 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR LEED CAL + &CULATION #####', '#####',/////) + 255 FORMAT(/////,6X,'########## END ', 'OF THE POLAR LEED CALCULATI + &ON #####', '#####',/////) + 256 FORMAT(/////,5X,'########## BEGINNING ', 'OF THE ENERGY LEED CA + &LCULATION #####', '#####',/////) + 257 FORMAT(/////,5X,'########## END ', 'OF THE ENERGY LEED CALCULAT + &ION #####', '#####',/////) + 258 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE LEED + & CALCULATION ', '##########',/////) + 259 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE LEED CALCULATIO + &N #####','#####') + 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/) + 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ',F6.2,' DE + &GREES') + 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +') + 335 FORMAT(24X,'+ STANDARD +') + 336 FORMAT(24X,'+ SPIN-POLARIZED +') + 337 FORMAT(24X,'+ WITH +') + 338 FORMAT(24X,'+ IN DICHROIC MODE +') + 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +') + 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','----- + &-------------------') + 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','----- + &-------------------') + 420 FORMAT(///,9X,'----------------------------------------------','-- + &--------------------') + 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(', + &F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')') + 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.5 + &,',',F8.5,')') + 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE DIME + &NSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ','CONSIS + &TENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' >>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ','N + &AT IN THE DATA AND CLUSTER FILES >>>>>>>>>>') + 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ',' + &IBWD >>>>>>>>>>') + 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT',' CONSIS + &TENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE >>>>>>>>>> + &') + 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH', + &' THE VALUE OF LI >>>>>>>>>>') + 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4) + 535 FORMAT(29X,F8.5,1X,F8.5) + 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ','CORR + &ESPOND TO NAT >>>>>>>>>>') + 543 FORMAT(5X,F12.9,5X,F12.9) + 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM' + &,/) + 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ','CORRES + &POND TO NAT >>>>>>>>>>') + 555 FORMAT(4(7X,I2)) + 556 FORMAT(28X,4(I2,5X)) + 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,A2) + & + 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' : + &',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,'A + &TOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' N + &o ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL A + &TOMS : ',//) + 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM : + & ',//) + 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',13X + &,'oooooooooooooooo',///) + 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/) + 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ','CORR + &ESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD A + &ND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT CON + &SISTENT WITH THE INPUT DATA FILE >>>>>>>>>>') + 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ','> + &>>>>>>>>>',//) + 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ', + &'.inc FILE >>>>>>>>>>',//) + 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ','>>>> + &>>>>>>',//) + 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ', + &'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS FILE + & >>>>>>>>>>',//) + 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ','>>> + &>>>>>>>',//) + 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ','ELECTR + &ON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',17X,'WITH T + &HE INPUT DATA FILE ',16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ','TH + &E DIMENSIONNING FILE >>>>>>>>>>',//) + 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ',' + &THE DIMENSIONNING FILE >>>>>>>>>>',//) + 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ','THE + &DIMENSIONNING FILE >>>>>>>>>>',//) + 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE IDE + &NTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH ELECTRONS IN + & CLUSTER ROTATION MODE',' >>>>>>>>>>',//) + 776 FORMAT(I2) + 777 FORMAT(A24) + 778 FORMAT(30X,I1) + 779 FORMAT(11X,A2,5X,I2,3F10.4,I5) + 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,' ATOMS + &') + 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M >> + &>>>>>>>>') + 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''','UNIT + &S >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' AT + &OMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' ARE + & IDENTICAL >>>>>>>>>>') +C + 999 END +C +C======================================================================= +C + SUBROUTINE AMAS(NIV,ATOME,COORD,VALZ,ISURF,COUPUR,ROT,IRE,NATYP,NB + &Z,NAT2,NCOUCH,NMAX) +C +C This routine generates a cluster from the knowledge of its +C lattice vectors +C + USE DIM_MOD +C + USE ADSORB_MOD , NCOUCH1 => NCOUCH + USE BASES_MOD + USE MILLER_MOD , IM1 => IH, IM2 => IK, IM3 => II, IM4 => IL + USE OUTUNITS_MOD + USE RESEAU_MOD +C + DIMENSION VALZ(NATCLU_M) + DIMENSION ROT(3,3),IRE(NATCLU_M,2),NATYP(NATM),ITA(NATCLU_M) + DIMENSION ATOME(3,NATCLU_M),ATRSU(3,NATCLU_M),COORD(3,NATCLU_M) + DIMENSION ROTINV(3,3),XINIT(3,1),XFIN(3,1) +C +C +C + NCOUCH=0 + WRITE(IUO1,10) ISURF + 10 FORMAT(//,18X,'ATOM (0,0,0) ON THE SURFACE PLANE IS OF TYPE ',I2) + NBZ=0 + CALL INVMAT(ROT,ROTINV) + IF(IVG0.EQ.0) THEN + CALL CHBASE(NATP_M,ATBAS) + ENDIF + NB1=0 + NB2=0 + DO NTYP=1,NAT + NBAT=0 + DO NUM=1,NMAX + NB1=NB1+1 + IRE(NB1,1)=0 + IRE(NB1,2)=0 + IF(IVG0.LE.1) THEN + CALL NUMAT(NUM,NIV,IA,IB,IC) + ELSE + BSURA=1. + CSURA=1. + ENDIF + IF(IVG0.LE.1) THEN + XA=FLOAT(IA) + XB=FLOAT(IB) + XC=FLOAT(IC) + ELSEIF(IVG0.EQ.2) THEN + XA=FLOAT(NUM-1) + XB=FLOAT(NUM-1) + XC=FLOAT(NUM-1) + ENDIF + IF(IVG0.EQ.1) THEN + IF(IVN(1).EQ.0) THEN + ITA(NUM)=IA + ELSEIF(IVN(2).EQ.0) THEN + ITA(NUM)=IB + ELSEIF(IVN(3).EQ.0) THEN + ITA(NUM)=IC + ENDIF + IF((ITA(NUM).EQ.ITA(NUM-1)).AND.(NUM.GT.1)) GOTO 30 + ENDIF + DO J=1,3 + K=J+3*(NTYP-1) + O=ATBAS(K) + ATOME(J,NB1)=O+XA*VECBAS(J)+XB*VECBAS(J+3)+XC*VECBAS(J+6) + ENDDO + DO I=1,3 + M=I+3*(ISURF-1) + XINIT(I,1)=ATOME(I,NB1)-ATBAS(M) + ENDDO + CALL MULMAT(ROTINV,3,3,XINIT,3,1,XFIN) + DO I=1,3 + ATRSU(I,NB1)=XFIN(I,1) + ENDDO + CALL TEST1(COUPUR,NB1,NB2,ATRSU,COORD,VALZ,NBAT,IRE,NBZ) + 30 CONTINUE + ENDDO + NATYP(NTYP)=NBAT + ENDDO + IF(IADS.GE.1) THEN + N0=NBZ + DO JADS=1,NADS1 + NB1=NB1+1 + DO I=1,3 + COORD(I,NB1)=ADS(I,JADS) + ENDDO + N1=0 + DO N=1,N0 + D=ABS(COORD(3,NB1)-VALZ(N)) + IF(D.LT.0.0001) N1=N1+1 + ENDDO + IF(N1.EQ.0) THEN + N0=N0+1 + VALZ(N0)=COORD(3,NB1) + ENDIF + ENDDO + NANEW1=NADS1+NADS2 + NATYP(NAT+1)=NADS1 + IF(NANEW1.EQ.NADS1) GOTO 99 + DO JADS=NADS1+1,NANEW1 + NB1=NB1+1 + DO I=1,3 + COORD(I,NB1)=ADS(I,JADS) + ENDDO + N1=0 + DO N=1,N0 + D=ABS(COORD(3,NB1)-VALZ(N)) + IF(D.LT.0.0001) N1=N1+1 + ENDDO + IF(N1.EQ.0) THEN + N0=N0+1 + VALZ(N0)=COORD(3,NB1) + ENDIF + ENDDO + NATYP(NAT+2)=NADS2 + NANEW2=NANEW1+NADS3 + IF(NANEW2.EQ.NANEW1) GOTO 99 + DO JADS=NANEW1+1,NANEW2 + NB1=NB1+1 + DO I=1,3 + COORD(I,NB1)=ADS(I,JADS) + ENDDO + N1=0 + DO N=1,N0 + D=ABS(COORD(3,NB1)-VALZ(N)) + IF(D.LT.0.0001) N1=N1+1 + ENDDO + IF(N1.EQ.0) THEN + N0=N0+1 + VALZ(N0)=COORD(3,NB1) + ENDIF + ENDDO + NATYP(NAT+3)=NADS3 + 99 CONTINUE + NCOUCH=N0-NBZ + NBZ=N0 + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE BASE +C +C This routine generates the lattice basis vectors for a given Bravais +C lattice NCRIST centered according to NCENTR +C + USE DIM_MOD + USE BASES_MOD + USE CRANGL_MOD + USE OUTUNITS_MOD + USE RESEAU_MOD + USE VECSYS_MOD +C + CHARACTER*15 BRAV(8),CENT(7) + CHARACTER*31 RESEAU +C +C + DIMENSION CUB(9),MNC(9),TCN(9),TRG(9),HEX(9) +C +C +C + DATA CUB /1.,0.,0., 0.,1.,0., 0.,0.,1./ + DATA MNC /1.,0.,1., 0.,1.,0., 0.,0.,1./ + DATA TCN /1.,0.,1., 1.,1.,1., 0.,0.,1./ + DATA TRG /0.,1.,1., -0.866025,-0.5,1., 0.866025,-0.5,1./ + DATA HEX /1.,0.,0., -0.5,0.866025,0., 0.,0.,1./ + DATA PIS180 /0.017453/ + DATA BRAV /' CUBIQUE',' TETRAGONAL',' ORTHORHOMBIQUE',' + & MONOCLINIQUE',' TRICLINIQUE',' TRIGONAL',' HEXAGO + &NAL',' EXTERNE'/ + DATA CENT /' ','CENTRE',' FACES CENTREES','(RHOMBOEDRIQUE)',' FACE + & A CENTREE',' FACE B CENTREE',' FACE C CENTREE'/ +C + ALPHAR=ALPHAD*PIS180 + BETAR=BETAD*PIS180 + GAMMAR=GAMMAD*PIS180 + NAT3=NAT*3 + GO TO (1,1,1,2,3,4,5,6) NCRIST +C + 1 DO I=1,9 + VECBAS(I)=CUB(I) + ENDDO + IF(NCRIST.NE.1) THEN + VECBAS(9)=CSURA + IF(NCRIST.EQ.3) THEN + VECBAS(5)=BSURA + ENDIF + ENDIF + GO TO 6 +C + 2 DO I=1,9 + VECBAS(I)=MNC(I) + ENDDO + VECBAS(1)=SIN(BETAR) + VECBAS(3)=COS(BETAR) + VECBAS(5)=BSURA + VECBAS(9)=CSURA + GO TO 6 +C + 3 DO I=1,9 + VECBAS(I)=TCN(I) + ENDDO + VECBAS(1)=SIN(BETAR) + VECBAS(3)=COS(BETAR) + A2Y=(COS(GAMMAR)-COS(ALPHAR)*COS(BETAR))/SIN(BETAR) + VECBAS(4)=BSURA*A2Y + VECBAS(5)=BSURA*SQRT(SIN(ALPHAR)*SIN(ALPHAR)-A2Y*A2Y) + VECBAS(6)=BSURA*COS(ALPHAR) + VECBAS(9)=CSURA + GO TO 6 +C + 4 IF(((NCENTR.EQ.4).AND.(CSURA.NE.1.)).OR.(NCENTR.EQ.1)) GO TO 5 + ETA=-2.*SIN(ALPHAR/2.)/SQRT(3.) + DZETA=SQRT(1.-ETA*ETA) + DO I=1,3 + J=I+2*(I-1) + J1=J+1 + J2=J+2 + VECBAS(J)=TRG(J)*ETA + VECBAS(J1)=TRG(J1)*ETA + VECBAS(J2)=TRG(J2)*DZETA + ENDDO + GO TO 6 +C + 5 DO I=1,9 + VECBAS(I)=HEX(I) + ENDDO + VECBAS(9)=CSURA +C + 6 DO I=1,3 + ASYS(I)=VECBAS(I) + BSYS(I)=VECBAS(I+3) + CSYS(I)=VECBAS(I+6) + ENDDO + DCA=ABS(CSURA-1.) + IF((NCRIST.EQ.6).AND.(DCA.LT.0.0001)) GO TO 8 + IF(NCRIST.EQ.8) GO TO 8 + IF(NCENTR.GT.1) THEN + CALL CENTRE(VECBAS) + IF(NCENTR.EQ.4) THEN + DO I=1,9 + VECBAS(I)=VECBAS(I)*SQRT((1.-CSURA*CSURA)*3.) + ENDDO + DO I=1,3 + ASYS(I)=VECBAS(I) + BSYS(I)=VECBAS(I+3) + CSYS(I)=VECBAS(I+6) + ENDDO + ENDIF + ENDIF +C + 8 RESEAU=BRAV(NCRIST)//' '//CENT(NCENTR) + WRITE(IUO1,80) RESEAU,NAT + WRITE(IUO1,81) (VECBAS(I),I=1,9) + WRITE(IUO1,82) + WRITE(IUO1,83) (ATBAS(I),I=1,NAT3) +C + 80 FORMAT(////,10X,'RESEAU CRISTALLIN DE TYPE : ',A29,/,16X, + * 'CONTENANT',I3,' ATOMES DANS LA MAILLE ELEMENTAIRE',//) + 81 FORMAT(28X,'VECTEURS GENERATEURS :',//,26X,'A1 = (',F6.3,',', + *F6.3,',',F6.3,')',/,26X,'A2 = (',F6.3,',',F6.3,',',F6.3,')',/, + *26X,'A3 = (',F6.3,',',F6.3,',',F6.3,')') + 82 FORMAT(/,21X,'POSITIONS DES ATOMES DANS LA MAILLE :',/) + 83 FORMAT(29X,'(',F6.3,',',F6.3,',',F6.3,')') +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE CENTRE(VECBAS) +C +C This routine modifies the Bravais lattice basis vectors according to +C the way the lattice is centered +C + USE RESEAU_MOD +C + DIMENSION VECBAS(9),V1(9) +C +C +C + DO I=1,9 + V1(I)=VECBAS(I) + ENDDO + N1=NCENTR-1 + GO TO (2,3,4,5,6,7) N1 +C + 2 DO I=1,3 + VECBAS(I)=-0.5*V1(I)+0.5*V1(I+3)+0.5*V1(I+6) + VECBAS(I+3)=0.5*V1(I)-0.5*V1(I+3)+0.5*V1(I+6) + VECBAS(I+6)=0.5*V1(I)+0.5*V1(I+3)-0.5*V1(I+6) + ENDDO + GO TO 8 +C + 3 DO I=1,3 + VECBAS(I)=0.5*(V1(I+3)+V1(I+6)) + VECBAS(I+3)=0.5*(V1(I)+V1(I+6)) + VECBAS(I+6)=0.5*(V1(I)+V1(I+3)) + ENDDO + GO TO 8 +C + 4 DO I=1,3 + VECBAS(I)=(2./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6) + VECBAS(I+3)=(-1./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6) + VECBAS(I+6)=(-1./3.)*V1(I)-(2./3.)*V1(I+3)+(1./3.)*V1(I+6) + ENDDO + DO I=1,3 + VECBAS(3*I)=VECBAS(3*I)*SQRT(3./(1.-CSURA*CSURA)) + ENDDO + GO TO 8 +C + 5 DO I=1,3 + VECBAS(I+6)=0.5*(V1(I+3)+V1(I+6)) + ENDDO + GO TO 8 +C + 6 DO I=1,3 + VECBAS(I+6)=0.5*(V1(I)+V1(I+6)) + ENDDO + GO TO 8 +C + 7 DO I=1,3 + VECBAS(I+3)=0.5*(V1(I)+V1(I+3)) + ENDDO +C + 8 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE CHBASE(NAT,ATBAS) +C + USE VECSYS_MOD +C + DIMENSION ATBAS(3*NAT),BASVEC(3,3),BAS1(1,3),BAS2(1,3) +C + DO J=1,3 + BASVEC(1,J)=ASYS(J) + BASVEC(2,J)=BSYS(J) + BASVEC(3,J)=CSYS(J) + ENDDO +C + DO JAT=1,NAT + DO J=1,3 + K=J+3*(JAT-1) + BAS1(1,J)=ATBAS(K) + ENDDO + CALL MULMAT(BAS1,1,3,BASVEC,3,3,BAS2) + DO J=1,3 + K=J+3*(JAT-1) + ATBAS(K)=BAS2(1,J) + ENDDO + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE CHNOT(NVEC,VEC1,VEC2) +C +C This routine linearizes the storage of a two index array +C + DIMENSION VEC1(3*NVEC),VEC2(3,NVEC) +C + DO J=1,NVEC + DO I=1,3 + VEC2(I,J)=VEC1(I+3*(J-1)) + ENDDO + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE INVMAT(B,BINV) +C + USE OUTUNITS_MOD + DIMENSION B(3,3),BINV(3,3) +C +C + A1=B(1,1)*B(2,2)*B(3,3) + A2=B(2,1)*B(3,2)*B(1,3) + A3=B(3,1)*B(1,2)*B(2,3) + A4=B(1,1)*B(3,2)*B(2,3) + A5=B(2,1)*B(1,2)*B(3,3) + A6=B(3,1)*B(2,2)*B(1,3) + DET=A1+A2+A3-A4-A5-A6 +C + IF(ABS(DET).LT.0.0001) GO TO 10 +C + DO I=1,3 + DO J=1,3 + DO K=1,3 + L=(I-J)*(I-K)*(J-K) + IF(L.NE.0) THEN + XNUM1=B(J,J)*B(K,K)-B(J,K)*B(K,J) + XNUM2=B(I,K)*B(K,J)-B(K,K)*B(I,J) + BINV(I,I)=XNUM1/DET + BINV(I,J)=XNUM2/DET + ENDIF + ENDDO + ENDDO + ENDDO + GO TO 50 +C + 10 WRITE(IUO1,60) +C + 60 FORMAT(5X,'NON INVERTIBLE MATRIX') +C + 50 CONTINUE +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE MULMAT(A1,IL1,IC1,A2,IL2,IC2,A3) +C +C This routine performs the matrix multiplication of A1(IL1,IC1) by +C A2(IL2,IC2) with the result stored in A3(IL1,IC2) +C + USE OUTUNITS_MOD + DIMENSION A1(IL1,IC1),A2(IL2,IC2),A3(IL1,IC2) +C +C + IF(IC1.NE.IL2) THEN + WRITE(IUO1,10) + ELSE + DO I=1,IL1 + DO J=1,IC2 + A3(I,J)=0. + DO K=1,IC1 + A3(I,J)=A3(I,J)+A1(I,K)*A2(K,J) + ENDDO + ENDDO + ENDDO + ENDIF +C + 10 FORMAT(5X,'THESE MATRICES CANNOT BE MULTIPLIED') +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE NUMAT(NUM,NIVA,IL,IM,IN) +C + USE OUTUNITS_MOD + DIMENSION I(100) +C +C + L=2*NIVA+1 + IF(L.GT.100) THEN + WRITE(IUO1,5) + STOP + ENDIF + L1=NIVA+1 +C + DO K=1,L + IF(K.LE.L1) THEN + I(K)=K-1 + ELSE + I(K)=L1-K + ENDIF + ENDDO +C + Q1=FLOAT(NUM)/FLOAT(L*L) + JR1=NUM-L*L*INT(Q1+0.0001) + JS1=INT(Q1+0.9999) + Q2=FLOAT(JR1)/FLOAT(L) + JS2=INT(Q2+0.9999) + IF(JR1.EQ.0) JS2=L + Q3=FLOAT(NUM)/FLOAT(L) + JR3=INT(Q3+0.0001) + JS3=NUM-L*JR3 + IF(JS3.EQ.0) JS3=L + IL=I(JS1) + IM=I(JS2) + IN=I(JS3) +C + 5 FORMAT(///,'<<<<<<<<<< INCREASE THE SIZE OF I IN',' THE NUMAT SU + &BROUTINE >>>>>>>>>>') +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE RELA(NINI,NFIN,NAT,VALINI,VALFIN,VALFIN2,COORD,NTYP,REL + &,L) +C + USE DIM_MOD +C + USE ADSORB_MOD , I1 => IADS, N1 => NADS1, N2 => NADS2, N3 => NADS3 + & + USE OUTUNITS_MOD + USE RELADS_MOD + USE RELAX_MOD +C + DIMENSION VALINI(NATCLU_M),VALFIN(NATCLU_M),REL(NATCLU_M) + DIMENSION NTYP(NATM),COORD(3,NATCLU_M),LSP(2),DZA(2),DZB(2) + DIMENSION DYA(2),DYB(2),VALFIN2(NATCLU_M),KZ(1000) +C + DATA SMALL /0.0001/ +C + IF((IREL.EQ.1).OR.((IREL.EQ.0).AND.(NRELA.GT.0))) THEN +C + CALL ORDRE(NINI,VALINI,NFIN,VALFIN) + WRITE(IUO1,70) NFIN + DO JPLAN=1,NFIN + IF(JPLAN.LE.NRELA) THEN + X1=1. + X2=0. + PCADS=PCRELA(JPLAN) + ELSEIF((JPLAN.GT.NRELA).AND.(JPLAN.LE.L)) THEN + X1=0. + X2=0. + ELSE + X1=0. + X2=1. + PCSUBS=PCREL(JPLAN-L) + ENDIF + REL(JPLAN)=0. + IF(JPLAN.GT.NREL+L) GO TO 20 + IF(JPLAN.EQ.NFIN) GO TO 20 + DPLAN=VALFIN(JPLAN)-VALFIN(JPLAN+1) + REL(JPLAN)=DPLAN*(X1*PCADS+X2*PCSUBS)/100. + 20 DREL=VALFIN(JPLAN)+REL(JPLAN) + WRITE(IUO1,30) JPLAN,VALFIN(JPLAN),DREL + ENDDO +C + NBR=0 + DO JTYP=1,NAT + NBAT=NTYP(JTYP) + DO NUM=1,NBAT + NBR=NBR+1 + DO JPLAN=1,NFIN + DIF=ABS(COORD(3,NBR)-VALFIN(JPLAN)) + IF(DIF.LT.SMALL) THEN + COORD(3,NBR)=COORD(3,NBR)+REL(JPLAN) + ENDIF + ENDDO + ENDDO + ENDDO +C + DO JPLAN=1,NFIN + VALFIN(JPLAN)=VALFIN(JPLAN)+REL(JPLAN) + ENDDO +C + ELSEIF(IREL.GE.2) THEN +C + IP=0 + LSP(2)=0 + OMEGA=OMEGA1 + 97 XN1=1. + XN2=0. + IP=IP+1 + CALL ORDRE(NINI,VALINI,NFIN,VALFIN) + ZP=VALFIN(IP) + CALL RZB110(OMEGA,DY1,DY2,DZ1,DZ2) + DZA(IP)=DZ1 + DZB(IP)=DZ2 + DYA(IP)=DY1 + DYB(IP)=DY2 + IF(ABS(OMEGA).LT.SMALL) THEN + LSP(IP)=1 + ELSE + LSP(IP)=2 + ENDIF + IF(LSP(IP).EQ.1) GOTO 95 + NBR=0 +C + DO JTYP=1,NAT-NATA + NBAT=NTYP(JTYP) + XN1=XN1+1.-FLOAT(JTYP) + XN2=XN2-1.+FLOAT(JTYP) + DO JNUM=1,NBAT + NBR=NBR+1 + ZAT=COORD(3,NBR)-ZP + IF(ABS(ZAT).LT.SMALL) THEN + YAT=COORD(2,NBR) + COORD(2,NBR)=YAT-XN1*DYA(IP)-XN2*DYB(IP) + COORD(3,NBR)=ZAT+ZP+XN1*DZA(IP)+XN2*DZB(IP) + ENDIF + ENDDO + ENDDO +C + 95 OMEGA=OMEGA2 + IF((IREL.EQ.3).AND.(IP.EQ.1)) GOTO 97 + LS=0 + DO I=1,IP + LS=LS+LSP(I) + ENDDO + NBZ1=NFIN+LS-IP + DO K=1,IP + IF(LSP(K).EQ.2) THEN + IF((K.EQ.2).AND.(LS.EQ.3)) THEN + KN=K-1 + ELSE + KN=K + ENDIF + VALINI(NBZ1-KN+1)=VALFIN(L+K)+DZB(K) + REL(NBZ1-KN+1)=DZB(K) + ELSE + VALINI(NBZ1-K+1)=VALFIN(L+K) + REL(NBZ1-K+1)=0. + ENDIF + ENDDO +C + IL=0 + IR=0 + DO J=1,NFIN + IS=0 + IF(J.LE.NRELA) THEN + X1=1. + X2=0. + X3=0. + PCADS=PCRELA(J) + IS=1 + ELSEIF((J.GT.NRELA).AND.(J.LE.L)) THEN + X1=0. + X2=0. + X3=0. + ELSEIF((J.GT.L).AND.(J.LE.(L+IP))) THEN + IR=IR+1 + IF(LSP(IR).EQ.1) THEN + IF((IR.EQ.1).AND.(LSP(2).EQ.2)) GOTO 31 + X1=0. + X2=1. + X3=0. + LT=MAX0(LSP(1),LSP(2))-1 + PCSUBS=PCREL(J-L-LT) + IL=1 + IS=1 + 31 CONTINUE + ELSE + X1=0. + X2=0. + X3=1. + ENDIF + ELSEIF((J.GT.(L+IP)).AND.(J.LE.(L+IP+NREL))) THEN + X1=0. + X2=1. + X3=0. + LT=MAX0(LSP(1),LSP(2))+IP-1 + PCSUBS=PCREL(J-L-LT+IL+1) + IS=1 + ELSE + X1=0. + X2=0. + X3=0. + ENDIF + DPLAN=VALFIN(J)-VALFIN(J+1) + REL(J)=X3*DZA(IR)+DPLAN*(X1*PCADS+X2*PCSUBS)/100. + VALINI(J)=VALFIN(J)+REL(J) + IF(IS.EQ.1) THEN + NBR=0 + DO JTYP=1,NAT + NBAT=NTYP(JTYP) + DO NUM=1,NBAT + NBR=NBR+1 + DIF=ABS(COORD(3,NBR)-VALFIN(J)) + IF(DIF.LT.SMALL) THEN + COORD(3,NBR)=VALINI(J) + ENDIF + ENDDO + ENDDO + ENDIF + ENDDO +C + CALL ORDRE(NBZ1,VALINI,NFIN,VALFIN2) + WRITE(IUO1,65) NFIN + KZ(1)=0 + KZ(2)=LSP(1) + KZ(3)=MAX0(LSP(1),LSP(2)) + DO KK=4,NFIN + KZ(KK)=LS + ENDDO + DO JPLAN=1,NFIN + IF(JPLAN.LE.L) THEN + WRITE(IUO1,55) JPLAN,VALFIN(JPLAN),VALFIN2(JPLAN) + VALINI(JPLAN)=VALFIN(JPLAN) + ELSEIF((JPLAN.GT.L).AND.(JPLAN.LE.(L+LS))) THEN + K=KZ(JPLAN-L) - INT((JPLAN-L)/2) + IPLAN=JPLAN-K + WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN) + VALINI(JPLAN)=VALFIN(IPLAN) + ELSEIF(JPLAN.GT.(L+LS)) THEN + IPLAN=JPLAN-LS+IP + WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN) + VALINI(JPLAN)=VALFIN(IPLAN) + ENDIF + ENDDO + ENDIF +C + 30 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3, + * ' BEFORE RELAXATION AND : ',F6.3,' AFTER') + 55 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3, + * ' BEFORE RELAXATION AND : ',F6.3,' AFTER') + 65 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ') + 70 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ') +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE ROTBAS(ROT) +C +C This routine calculates the basis vectors related to a surface +C characterized by its Miller indices (IH,IK,II,IL) +C + USE MILLER_MOD + USE OUTUNITS_MOD + USE RESEAU_MOD + USE VECSYS_MOD , A1 => ASYS, A2 => BSYS, A3 => CSYS +C + DIMENSION ROT(3,3),VECT(3,3),A1STAR(3),A2STAR(3),A3STAR(3),B1(3) + DIMENSION VECT1(3),XNORM(3),CHBASE(3,3),VECT2(3,3) +C +C +C + DATA PI /3.141593/ +C + IF((NCRIST.EQ.8).AND.(IVG0.GE.1)) GOTO 7 + XH=FLOAT(IH) + XK=FLOAT(IK) + XI=FLOAT(II) + XL=FLOAT(IL) + XI1=-XH-XK + II1=INT(XI1) + IF((NCRIST.EQ.7).AND.(XI.NE.XI1)) WRITE(IUO1,5) IH,IK,II1,IL + 5 FORMAT(5X,'THE SURFACE INDICES ARE NOT CORRECT,',/,5X, 'FOR THE RE + &ST OF THE CALCULATION, THEY ARE TAKEN AS ','(',I2,1X,I2,1X,I2,1X,I + &2,')') + CPR=1. + CALL PRVECT(A2,A3,B1,CPR) + OMEGA=PRSCAL(A1,B1)/(2.*PI) + CALL PRVECT(A2,A3,A1STAR,OMEGA) + CALL PRVECT(A3,A1,A2STAR,OMEGA) + CALL PRVECT(A1,A2,A3STAR,OMEGA) + DO 10 I=1,3 + VECT1(I)=XH*A1STAR(I)+XK*A2STAR(I)+XL*A3STAR(I) + 10 CONTINUE + DO 15 I=1,3 + ROT(I,3)=VECT1(I)/SQRT(PRSCAL(VECT1,VECT1)) + 15 CONTINUE + DO 20 I=1,3 + CHBASE(I,1)=A1(I) + CHBASE(I,2)=A2(I) + CHBASE(I,3)=A3(I) + DO 25 J=1,3 + VECT(I,J)=0. + 25 CONTINUE + 20 CONTINUE + XHKL=XH*XK*XL + XHK=XH*XK + XHL=XH*XL + XKL=XK*XL + IF(XHKL.NE.0.) THEN + VECT(1,1)=-1./XH + VECT(2,1)=1./XK + VECT(1,2)=-1./XH + VECT(3,2)=1./XL + VECT(2,3)=-1./XK + VECT(3,3)=1./XL + ELSEIF(XHK.NE.0.) THEN + VECT(1,1)=-1./XH + VECT(2,1)=1./XK + ELSEIF(XHL.NE.0.) THEN + VECT(1,2)=-1./XH + VECT(3,2)=1./XL + ELSEIF(XKL.NE.0.) THEN + VECT(2,3)=-1./XK + VECT(3,3)=1./XL + ELSEIF(XH.NE.0.) THEN + VECT(2,2)=1./XH + ELSEIF(XK.NE.0.) THEN + VECT(3,3)=1./XK + ELSEIF(XL.NE.0.) THEN + VECT(1,1)=1./XL + ENDIF + CALL MULMAT(CHBASE,3,3,VECT,3,3,VECT2) + DO 35 I=1,3 + XNORM(I)=SQRT(VECT2(1,I)**2+VECT2(2,I)**2+VECT2(3,I)**2) + 35 CONTINUE + XMIN=AMIN1(XNORM(1),XNORM(2),XNORM(3)) + XMAX=AMAX1(XNORM(1),XNORM(2),XNORM(3)) + DO 40 I=1,3 + IF(XHKL.NE.0.) THEN + IF(ABS(XMIN-XNORM(I)).LT.0.0001) THEN + DO 45 J=1,3 + ROT(J,1)=VECT2(J,I)/XNORM(I) + 45 CONTINUE + ENDIF + ELSE + IF(ABS(XMAX-XNORM(I)).LT.0.0001) THEN + DO 50 J=1,3 + ROT(J,1)=VECT2(J,I)/XNORM(I) + 50 CONTINUE + ENDIF + ENDIF + 40 CONTINUE + ROT(1,2)=ROT(2,3)*ROT(3,1)-ROT(3,3)*ROT(2,1) + ROT(2,2)=ROT(3,3)*ROT(1,1)-ROT(3,1)*ROT(1,3) + ROT(3,2)=ROT(1,3)*ROT(2,1)-ROT(2,3)*ROT(1,1) + IF(NCRIST.EQ.7) THEN + WRITE(IUO1,85) IH,IK,II1,IL + ELSE + WRITE(IUO1,80) IH,IK,IL + ENDIF + WRITE(IUO1,65) ROT(1,1),ROT(2,1),ROT(3,1) + WRITE(IUO1,70) ROT(1,2),ROT(2,2),ROT(3,2) + WRITE(IUO1,75) ROT(1,3),ROT(2,3),ROT(3,3) + GOTO 37 + 7 DO 17 I=1,3 + DO 27 J=1,3 + ROT(I,J)=0. + IF(I.EQ.J) ROT(I,J)=1. + 27 CONTINUE + 17 CONTINUE + IF(IVG0.EQ.1) WRITE(IUO1,48) + IF(IVG0.EQ.2) WRITE(IUO1,47) + 47 FORMAT(//,25X,'LINEAR CHAIN STUDY ') + 48 FORMAT(//,35X,'PLANE STUDY') + 65 FORMAT(26X,'ISURF = (',F6.3,',',F6.3,',',F6.3,')') + 70 FORMAT(26X,'JSURF = (',F6.3,',',F6.3,',',F6.3,')') + 75 FORMAT(26X,'KSURF = (',F6.3,',',F6.3,',',F6.3,')') + 80 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X, + *I2,') :',/) + 85 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X, + *I2,1X,I2,') :',/) +C + 37 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE RZB110(OMEGA,DY1,DY2,DZ1,DZ2) +C + A1=COS(OMEGA) + ALPHA=SIN(OMEGA) + BETA=A1-3. + GAMMA=SQRT(3.)*(5./3.-A1) + DELTA=SQRT(SQRT(3.)*(1./3.+A1)/GAMMA) + CSA=SQRT(3.)*(-BETA-ALPHA*DELTA)/6. + SNA=SQRT(1.-CSA*CSA) + CSB=-SQRT(3.)*BETA/3. -CSA + SNB=-SQRT(3.)*ALPHA/3. +SNA + DY1=(SQRT(3.)*CSB-1.)/4. + DY2=(1.-SQRT(3.)*CSA)/4. + DZ1=(SQRT(3.)*SNB-SQRT(2.))/4. + DZ2=(SQRT(3.)*SNA-SQRT(2.))/4. +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE TEST1(COUPUR,NB1,NB2,ATOME,COORD,VAL,NBAT,IRE,NBZ) +C + USE DIM_MOD +C + DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M),VAL(NATCLU_M) + DIMENSION IRE(NATCLU_M,2) +C + DIST2=0. + DO 10 I=1,3 + DIST2=DIST2+ATOME(I,NB1)*ATOME(I,NB1) + 10 CONTINUE + DIST=SQRT(DIST2) + V=0.0001 + IF((ATOME(3,NB1).LE.V).AND.(DIST.LE.COUPUR)) THEN + NBAT=NBAT+1 + NB2=NB2+1 + IRE(NB1,1)=NB2 + IRE(NB1,2)=NBAT + DO 20 I=1,3 + COORD(I,NB2)=ATOME(I,NB1) + 20 CONTINUE + IF(NBZ.EQ.0) THEN + NBZ=NBZ+1 + VAL(NBZ)=COORD(3,NB2) + ELSE + N1=0 + DO N=1,NBZ + D=ABS(COORD(3,NB2)-VAL(N)) + IF(D.LT.0.0001) N1=N1+1 + ENDDO + IF(N1.EQ.0) THEN + NBZ=NBZ+1 + VAL(NBZ)=COORD(3,NB2) + ENDIF + ENDIF + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE TEST(NIV,ROT,NATYP,NBZ,NAT2,ISURF,COUP,*) +C + USE DIM_MOD +C + DIMENSION ATOME1(3,NATCLU_M),COORD1(3,NATCLU_M) + DIMENSION IRE1(NATCLU_M,2),NATYP(NATM) + DIMENSION NATYP1(NATM),VALZ1(NATCLU_M),ROT(3,3) +C + NMAX1=(2*NIV+3)**3 + NV1=NIV+1 + CALL AMAS(NV1,ATOME1,COORD1,VALZ1,ISURF,COUP,ROT,IRE1,NATYP1,NBZ,N + &AT2,NCOUCH,NMAX1) + DO 10 I=1,NAT2 + IF(NATYP(I).NE.NATYP1(I)) RETURN 1 + 10 CONTINUE +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE ARCSIN(U,CST,RANGLE) +C +C For a given complex number U, this subroutine calculates its phase +C Warning : it is implicitely assumed that U = sin(theta) exp(i*phi) +C with theta > or = to 0 which is always the case when theta is obtained +C from the coordinates of a given vector r by the ACOS intrinsic function. +C +C When sin(theta) = 0, then phi = 0 if cos(theta) = 1 and pi if +C cos(theta) = -1. Cos(theta) is the variable CST. +C + COMPLEX U,CANGLE +C + IF(CABS(U).LT.0.0001) THEN + IF(CST.GT.0.) THEN + RANGLE=0. + ELSEIF(CST.LT.0.) THEN + RANGLE=3.141593 + ENDIF + ELSE + CANGLE=(0.,-1.)*CLOG(U/CABS(U)) + RANGLE=REAL(CANGLE) + ENDIF + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE ATDATA +C +C This routine contains the atomic mass and the density of all the +C elements,and the equivalence between their atomic number and +C chemical symbol. +C +C Value Z = 0 added for empty spheres. The values entered in this +C case are arbitrary and set to the corresponding Z = 1 value +C divided by 1836 (the ratio of the mass of the proton and electron). +C +C Last modified : 25 Apr 2013 +C + USE XMRHO_MOD , XM_AT => XMAT, RHO_AT => RHOAT + REAL XMAT(0:99),RHOAT(0:99) +C +C + DATA XMAT/0.00055,1.00794,4.00260,6.941,9.01218,10.81,12.011,14.00 + &67,15.9994,18.998403,20.179,22.98977,24.305,26.98154,28.0855,30.97 + &376,32.06,35.453,39.948,39.0983,40.08,44.9559,47.88,50.9415,51.996 + &,54.9380,55.847,58.9332,58.69,63.546,65.38,69.72,72.59,74.9216,78. + &96,79.904,83.80,85.4678,87.62,88.9059,91.22,92.9064,95.94,98.,101. + &07,102.9055,106.42,107.8682,112.41,114.82,118.69,121.75,127.60,126 + &.9045,131.29,132.9054,137.33,138.9055,140.12,140.9077,144.24,145., + & + * 150.36,151.96,157.25,158.9254,162.50,164.9304, + * 167.26,168.9342,173.04,174.967,178.49,180.9479, + * 183.85,186.207,190.2,192.22,195.08,196.9665, + * 200.59,204.383,207.2,208.9804,209.,210.,222., + * 223.,226.0254,227.0278,232.0381,231.0359, + * 238.0289,237.0482,244.,243.,247.,247.,251.,252./ +C + DATA RHOAT/0.0007,0.0708,0.122,0.533,1.845,2.34,2.26,0.81,1.14,1.1 + &08,1.207,0.969,1.735,2.6941,2.32,1.82,2.07,1.56,1.40,0.860,1.55,2. + &980,4.53,6.10,7.18,7.43,7.860,8.9,8.876,8.94,7.112,5.877,5.307,5.7 + &2,4.78,3.11,2.6,1.529,2.54,4.456,6.494,8.55,10.20,11.48,12.39,12.3 + &9,12.00,10.48,8.63,7.30,7.30,6.679,6.23,4.92,3.52,1.870,3.5,6.127, + &6.637,6.761,6.994,7.20,7.51,5.228,7.8772,8.214,8.525,8.769,9.039,9 + &.294,6.953,9.811,13.29,16.624,19.3,20.98,22.53,22.39,21.41,18.85,1 + &3.522,11.83,11.33, + * 9.730,9.30,0.0,4.4,0.0,5.,10.05,11.70,15.34, + * 18.92,20.21,19.80,13.64,13.49,14.,0.0,0.0/ +C + DO J=0,99 + XM_AT(J)=XMAT(J) + RHO_AT(J)=RHOAT(J) + ENDDO +C + END +C +C======================================================================= +C + SUBROUTINE AUGER_MULT +C +C This subroutine computes all the possible multiplets that are +C contained in a given Auger transition line. It assumes that +C the atom has closed shells only. +C +C Last modified : 9 March 2006 +C + USE INIT_A_MOD , LI => LI_C, L2 => LI_I, L1 => LI_A + USE OUTUNITS_MOD +C + CHARACTER*1 SC(0:1),LC(0:6),JC(0:7) + CHARACTER*3 MULTIPLET(112) +C + DATA SC /'1','3'/ + DATA LC /'S','P','D','F','G','H','I'/ + DATA JC /'0','1','2','3','4','5','6','7'/ +C + WRITE(IUO1,10) + N_MULT=0 + DO NS=0,1 + DO L=ABS(L1-L2),L1+L2 + DO J=ABS(L-NS),L+NS + N_MULT=N_MULT+1 + MULTIPLET(N_MULT)=SC(NS)//LC(L)//JC(J) + WRITE(IUO1,20) MULTIPLET(N_MULT) + ENDDO + ENDDO + ENDDO +C + 10 FORMAT(///,26X,'THE POSSIBLE MULTIPLETS ARE :',/,' ') + 20 FORMAT(58X,A3) +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE BESPHE(NL,IBES,X1,FL) +C +C This routine computes the spherical Bessel functions for +C a real argument X1. +C +C IBES=1 : Bessel function +C IBES=2 : Neumann function +C IBES=3 : Hankel function of the first kind +C IBES=4 : Hankel function of the second kind +C IBES=5 : Modified Bessel function +C IBES=6 : Modified Neumann function +C IBES=7 : Modified Hankel function +C +C Last modified : 8 Nov 2006 +C +C + USE DIM_MOD + USE OUTUNITS_MOD +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2 + COMPLEX*16 ZERO,CNORM +C + DOUBLE PRECISION SCALN(0:N_BESS) +C + REAL X1 +C +C + ECH=37.D0 + COMP=1.D37 + COMM=1.D-37 + X=DBLE(X1) + NX=INT(X1) + NREC=5*MAX0(NL-1,NX) + IF(NREC.GT.N_BESS) GOTO 16 + ITEST=0 + ZERO=(0.D0,0.D0) + UN=(1.D0,0.D0) + C1=UN + I=(0.D0,1.D0) + C2=I + DEB=1.D0 + IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN + IBES1=1 + IF(IBES.EQ.4) C2=-I + ELSEIF(IBES.EQ.7) THEN + IBES1=5 + C2=-UN + ELSE + IBES1=IBES + ENDIF +C +C Case where the argument is zero +C + IF(DABS(X).LT.0.000001D0) THEN + IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN + FL(0)=UN + DO 10 L=1,NL-1 + FL(L)=ZERO + 10 CONTINUE + ITEST=1 + ELSE + ITEST=-1 + ENDIF + ENDIF + IF(ITEST) 11,12,13 + 11 WRITE(IUO1,14) + STOP + 16 WRITE(IUO1,17) NREC + STOP + 15 IBES1=IBES1+1 +C +C Initial values +C + 12 A=-1.D0 + B=1.D0 + IF(IBES1.EQ.1) THEN + FL(0)=UN*DSIN(X)/X + FLNN(NREC)=ZERO + SCALN(NREC)=0.D0 + FLNN(NREC-1)=UN*DEB + SCALN(NREC-1)=0.D0 + ELSEIF(IBES1.EQ.2) THEN + GL(0)=-UN*DCOS(X)/X + GL(1)=GL(0)/X -DSIN(X)/X + ELSEIF(IBES1.EQ.5) THEN + A=1.D0 + B=-1.D0 + FL(0)=UN*DSINH(X)/X + FLNN(NREC)=ZERO + SCALN(NREC)=0.D0 + FLNN(NREC-1)=UN*DEB + SCALN(NREC-1)=0.D0 + ELSEIF(IBES1.EQ.6) THEN + A=1.D0 + B=-1.D0 + GL(0)=UN*DCOSH(X)/X + GL(1)=(DSINH(X)-GL(0))/X + ENDIF +C +C Downward reccurence for the spherical Bessel function +C + IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN + DO 30 L=NREC-1,1,-1 + ECHEL=0.D0 + SCALN(L-1)=SCALN(L) + REN=DEXP(SCALN(L)-SCALN(L+1)) + FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X) + IF(CDABS(FLNN(L-1)).GT.COMP) THEN + ECHEL=-ECH + ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN + ECHEL=ECH + ENDIF + IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1) + FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL) + 30 CONTINUE + CNORM=FL(0)/FLNN(0) + DO 40 L=1,NL-1 + FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L)) + 40 CONTINUE + ELSE +C +C Upward recurrence for the spherical Neumann function +C + DO 20 L=1,NL-1 + IF(IBES.EQ.7) C1=(-UN)**(L+2) + GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X + IF(IBES1.NE.IBES) THEN +C +C Calculation of the spherical Hankel function +C + FL(L+1)=C1*(FL(L+1)+C2*GL(L+1)) + ELSE + FL(L+1)=GL(L+1) + ENDIF + 20 CONTINUE + IF(IBES1.EQ.IBES) THEN + FL(0)=GL(0) + FL(1)=GL(1) + ELSE + FL(0)=C1*(FL(0)+C2*GL(0)) + FL(1)=C1*(FL(1)+C2*GL(1)) + ENDIF + IBES1=IBES + ENDIF + IF(IBES.NE.IBES1) GOTO 15 +C + 13 RETURN +C + 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION + &S IS NUL >>>>>>>>>>') + 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR + &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL + &D BE AT LEAST : ',I5,' >>>>>>>>>>') +C + END +C +C======================================================================= +C + SUBROUTINE BESPHE2(NL,IBES,X,FL) +C +C This routine computes the spherical Bessel functions for +C a real argument X1. +C +C IBES=1 : Bessel function +C IBES=2 : Neumann function +C IBES=3 : Hankel function of the first kind +C IBES=4 : Hankel function of the second kind +C IBES=5 : Modified Bessel function +C IBES=6 : Modified Neumann function +C IBES=7 : Modified Hankel function +C +C Last modified : 8 Nov 2006 +C +C + USE DIM_MOD + USE OUTUNITS_MOD +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2 + COMPLEX*16 ZERO,CNORM +C + DOUBLE PRECISION SCALN(0:N_BESS) +C +C + ECH=37.D0 + COMP=1.D37 + COMM=1.D-37 + NX=INT(X) + NREC=5*MAX0(NL-1,NX) + IF(NREC.GT.N_BESS) GOTO 16 + ITEST=0 + ZERO=(0.D0,0.D0) + UN=(1.D0,0.D0) + C1=UN + I=(0.D0,1.D0) + C2=I + DEB=1.D0 + IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN + IBES1=1 + IF(IBES.EQ.4) C2=-I + ELSEIF(IBES.EQ.7) THEN + IBES1=5 + C2=-UN + ELSE + IBES1=IBES + ENDIF +C +C Case where the argument is zero +C + IF(DABS(X).LT.0.000001D0) THEN + IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN + FL(0)=UN + DO 10 L=1,NL-1 + FL(L)=ZERO + 10 CONTINUE + ITEST=1 + ELSE + ITEST=-1 + ENDIF + ENDIF + IF(ITEST) 11,12,13 + 11 WRITE(IUO1,14) + STOP + 16 WRITE(IUO1,17) NREC + STOP + 15 IBES1=IBES1+1 +C +C Initial values +C + 12 A=-1.D0 + B=1.D0 + IF(IBES1.EQ.1) THEN + FL(0)=UN*DSIN(X)/X + FLNN(NREC)=ZERO + SCALN(NREC)=0.D0 + FLNN(NREC-1)=UN*DEB + SCALN(NREC-1)=0.D0 + ELSEIF(IBES1.EQ.2) THEN + GL(0)=-UN*DCOS(X)/X + GL(1)=GL(0)/X -DSIN(X)/X + ELSEIF(IBES1.EQ.5) THEN + A=1.D0 + B=-1.D0 + FL(0)=UN*DSINH(X)/X + FLNN(NREC)=ZERO + SCALN(NREC)=0.D0 + FLNN(NREC-1)=UN*DEB + SCALN(NREC-1)=0.D0 + ELSEIF(IBES1.EQ.6) THEN + A=1.D0 + B=-1.D0 + GL(0)=UN*DCOSH(X)/X + GL(1)=(DSINH(X)-GL(0))/X + ENDIF +C +C Downward reccurence for the spherical Bessel function +C + IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN + DO 30 L=NREC-1,1,-1 + ECHEL=0.D0 + SCALN(L-1)=SCALN(L) + REN=DEXP(SCALN(L)-SCALN(L+1)) + FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X) + IF(CDABS(FLNN(L-1)).GT.COMP) THEN + ECHEL=-ECH + ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN + ECHEL=ECH + ENDIF + IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1) + FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL) + 30 CONTINUE + CNORM=FL(0)/FLNN(0) + DO 40 L=1,NL-1 + FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L)) + 40 CONTINUE + ELSE +C +C Upward recurrence for the spherical Neumann function +C + DO 20 L=1,NL-1 + IF(IBES.EQ.7) C1=(-UN)**(L+2) + GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X + IF(IBES1.NE.IBES) THEN +C +C Calculation of the spherical Hankel function +C + FL(L+1)=C1*(FL(L+1)+C2*GL(L+1)) + ELSE + FL(L+1)=GL(L+1) + ENDIF + 20 CONTINUE + IF(IBES1.EQ.IBES) THEN + FL(0)=GL(0) + FL(1)=GL(1) + ELSE + FL(0)=C1*(FL(0)+C2*GL(0)) + FL(1)=C1*(FL(1)+C2*GL(1)) + ENDIF + IBES1=IBES + ENDIF + IF(IBES.NE.IBES1) GOTO 15 +C + 13 RETURN +C + 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION + &S IS NUL >>>>>>>>>>') + 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR + &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL + &D BE AT LEAST : ',I5,' >>>>>>>>>>') +C + END +C +C======================================================================= +C + SUBROUTINE CHECK_VIB(NAT2) +C +C This subroutines checks the geometrical environment of each atom +C to identify those which can move "freely" in one direction, in +C order to see whether the mean square displacement in this +C direction is of bulk type or surface type +C +C An atom is considered to move freely in one direction if no other +C atom is present in the tetragonal cell of height ALENGTH * A +C and base edge 2 * A, whose base is centered on the atom considered +C +C Only prototypical atoms are considered as all equivalent atoms are +C in the same geometrical environment +C +C Surface-like atoms are then identified as having I_FREE = 1 +C +C Last modified : 24 Apr 2013 +C + USE DIM_MOD +C + USE COOR_MOD , COORD => SYM_AT + USE OUTUNITS_MOD + USE VIBRAT_MOD +C + INTEGER NSUR(NATP_M) +C + DATA SMALL /0.0001/ +C + ALENGTH=4. +C +C.................... Checking the z direction .................... +C + WRITE(IUO1,11) + N_SUR=0 +C +C Loop on the prototypical atoms +C + DO JTYP=1,N_PROT +C + I_FREE(JTYP)=0 + JAT0=NCORR(1,JTYP) + XA=COORD(1,JAT0) + YA=COORD(2,JAT0) + ZA=COORD(3,JAT0) +C +C Loop on the surrounding atoms +C + I_ACC=0 +C + DO JAT=1,NAT2 +C + IF(JAT.EQ.JAT0) GOTO 10 +C + X=COORD(1,JAT) + Y=COORD(2,JAT) + Z=COORD(3,JAT) +C +C Considering only atoms with Z > ZA +C + IF(Z.LT.(ZA+SMALL)) GOTO 10 +C +C Lateral and vertical distances between the two atoms +C + D_LAT=(X-XA)*(X-XA)+(Y-YA)*(Y-YA) + D_VER=(Z-ZA)*(Z-ZA) +C + IF(D_VER.LT.(ALENGTH+SMALL)) THEN + IF(D_LAT.LT.(1.+SMALL)) THEN + I_ACC=I_ACC+1 + ENDIF + ENDIF +C + IF(I_ACC.GE.1) GOTO 10 +C + 10 CONTINUE +C + ENDDO +C + IF(I_ACC.EQ.0) THEN + I_FREE(JTYP)=1 + N_SUR=N_SUR+1 + NSUR(N_SUR)=JTYP + ENDIF +C + ENDDO +C + WRITE(IUO1,12) (NSUR(J),J=1,N_SUR) +C + 11 FORMAT(//,18X,'SURFACE-LIKE ATOMS FOR MSD CALCULATIONS: ',/) + 12 FORMAT(20X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5) +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE DJMN(RBETA,R,LMAX) +C +C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to +C order LMAX, following Messiah's convention. +C They are stored as R(M2,M1,L). +C +C Last modified : 20 Oct 2006 +C + USE DIM_MOD +C + USE COEFRLM_MOD + USE EXPROT_MOD +C + INTEGER EPS0 +C + DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + DATA SMALL,SQR2 /0.001,1.4142136/ +C + C=COS(RBETA)*0.5 + S=SIN(RBETA)*0.5 + CC=C+C + CMUL=-1. + IF(ABS(S).LT.SMALL) THEN + IF(C.GT.0.) EPS0=1 + IF(C.LT.0.) EPS0=-1 + DO L=0,LMAX + DO M1=-L,L + DO M2=-L,L + IF(M1.NE.M2*EPS0) THEN + R(M2,M1,L)=0. + ELSE + IF(EPS0.EQ.1) THEN + R(M2,M1,L)=1. + ELSE + IF(MOD(L+M1,2).EQ.0) THEN + R(M2,M1,L)=1. + ELSE + R(M2,M1,L)=-1. + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ELSE + S1=S*SQR2 + C1=0.5+C + R(0,0,0)=1.0 + R(-1,-1,1)=C1 + R(0,-1,1)=S1 + R(1,-1,1)=1.-C1 + R(-1,0,1)=-S1 + R(0,0,1)=CC + R(1,0,1)=S1 + R(-1,1,1)=1.-C1 + R(0,1,1)=-S1 + R(1,1,1)=C1 +C + PRODL=-S + COEF=-S/C1 + CL=-1. + DO L=2,LMAX + CL=-CL + L1=L-1 + FLL1=CC*FLOAT(L+L1) + FLL2=1./(FLOAT(L*L1)*CC) + PRODL=-PRODL*S +C +C Case M = 0 +C + R_1=EXPR(0,L)*PRODL + R(-L,0,L)=R_1 +C + R(L,0,L)=R_1*CL + R(0,-L,L)=R_1*CL +C + R(0,L,L)=R_1 +C + CM2=CL + DO M2=-L1,-1 + CM2=CM2*CMUL + CF1=CF(L1,0,-M2)/FLL1 + CF2=FLL1/CF(L,0,-M2) + IF(-M2.LT.L1) THEN + R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1) + ELSE + R_A=CF2*R(M2,0,L1) + ENDIF +C + R(M2,0,L)=R_A +C + R(-M2,0,L)=R_A*CM2 + R(0,M2,L)=R_A*CM2 +C + R(0,-M2,L)=R_A +C + ENDDO +C + R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0 + &,0) +C +C Case M > 0 +C + PRODM=1. + CM=CL + FLLM=0. + DO M=1,L1 + CM=-CM + PRODM=PRODM*COEF + FLLM=FLLM+FLL2 +C + R_1=EXPR(M,L)*PRODL*PRODM + R_2=R_1/(PRODM*PRODM) +C + R(-L,M,L)=R_1 + R(-L,-M,L)=R_2 +C + R(L,-M,L)=R_1*CM + R(M,-L,L)=R_1*CM + R(L,M,L)=R_2*CM + R(-M,-L,L)=R_2*CM +C + R(-M,L,L)=R_1 + R(M,L,L)=R_2 +C + CM2=CM + DO M2=-L1,-M + CM2=-CM2 + D0=FLOAT(M2)*FLLM + CF1=CF(L1,M,-M2)/FLL1 + CF2=FLL1/CF(L,M,-M2) + IF((M.LT.L1).AND.(-M2.LT.L1)) THEN + R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1) + R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1) + ELSE + R_A=CF2*(1.-D0)*R(M2,M,L1) + R_B=CF2*(1.+D0)*R(M2,-M,L1) + ENDIF +C + R(M2,M,L)=R_A + R(M2,-M,L)=R_B +C + R(-M2,-M,L)=R_A*CM2 + R(M,M2,L)=R_A*CM2 + R(-M,M2,L)=R_B*CM2 + R(-M2,M,L)=R_B*CM2 +C + R(-M,-M2,L)=R_A + R(M,-M2,L)=R_B +C + ENDDO + ENDDO +C + PRODM=PRODM*COEF + R_1=PRODL*PRODM + R_2=PRODL/PRODM + R(-L,L,L)=R_1 + R(L,-L,L)=R_1 + R(L,L,L)=R_2 + R(-L,-L,L)=R_2 +C + ENDDO + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE DJMN2(RBETA,R,LMAX,ISWITCH) +C +C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to +C order LMAX, following Messiah's convention. +C They are stored as R(M2,M1,L) and multiplied (ISWITCH=1) or divided +C by EXPF. +C +C Last modified : 20 Oct 2006 +C + USE DIM_MOD +C + USE COEFRLM_MOD + USE EXPFAC_MOD + USE EXPROT_MOD +C + INTEGER EPS0 +C + DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + DATA SMALL,SQR2 /0.001,1.4142136/ +C + C=COS(RBETA)*0.5 + S=SIN(RBETA)*0.5 + CC=C+C + CMUL=-1. + IF(ABS(S).LT.SMALL) THEN + IF(C.GT.0.) EPS0=1 + IF(C.LT.0.) EPS0=-1 + DO L=0,LMAX + DO M1=-L,L + DO M2=-L,L + IF(M1.NE.M2*EPS0) THEN + R(M2,M1,L)=0. + ELSE + IF(EPS0.EQ.1) THEN + R(M2,M1,L)=1. + ELSE + IF(MOD(L+M1,2).EQ.0) THEN + R(M2,M1,L)=1. + ELSE + R(M2,M1,L)=-1. + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ELSE + S1=S*SQR2 + C1=0.5+C + R(0,0,0)=1.0 + R(-1,-1,1)=C1 + R(0,-1,1)=S1 + R(1,-1,1)=1.-C1 + R(-1,0,1)=-S1 + R(0,0,1)=CC + R(1,0,1)=S1 + R(-1,1,1)=1.-C1 + R(0,1,1)=-S1 + R(1,1,1)=C1 +C + PRODL=-S + COEF=-S/C1 + CL=-1. + DO L=2,LMAX + CL=-CL + L1=L-1 + FLL1=CC*FLOAT(L+L1) + FLL2=1./(FLOAT(L*L1)*CC) + PRODL=-PRODL*S +C +C Case M = 0 +C + R_1=EXPR(0,L)*PRODL + R(-L,0,L)=R_1 +C + R(L,0,L)=R_1*CL + R(0,-L,L)=R_1*CL +C + R(0,L,L)=R_1 +C + CM2=CL + DO M2=-L1,-1 + CM2=CM2*CMUL + CF1=CF(L1,0,-M2)/FLL1 + CF2=FLL1/CF(L,0,-M2) + IF(-M2.LT.L1) THEN + R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1) + ELSE + R_A=CF2*R(M2,0,L1) + ENDIF +C + R(M2,0,L)=R_A +C + R(-M2,0,L)=R_A*CM2 + R(0,M2,L)=R_A*CM2 +C + R(0,-M2,L)=R_A +C + ENDDO +C + R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0 + &,0) +C +C Case M > 0 +C + PRODM=1. + CM=CL + FLLM=0. + DO M=1,L1 + CM=-CM + PRODM=PRODM*COEF + FLLM=FLLM+FLL2 +C + R_1=EXPR(M,L)*PRODL*PRODM + R_2=R_1/(PRODM*PRODM) +C + R(-L,M,L)=R_1 + R(-L,-M,L)=R_2 +C + R(L,-M,L)=R_1*CM + R(M,-L,L)=R_1*CM + R(L,M,L)=R_2*CM + R(-M,-L,L)=R_2*CM +C + R(-M,L,L)=R_1 + R(M,L,L)=R_2 +C + CM2=CM + DO M2=-L1,-M + CM2=-CM2 + D0=FLOAT(M2)*FLLM + CF1=CF(L1,M,-M2)/FLL1 + CF2=FLL1/CF(L,M,-M2) + IF((M.LT.L1).AND.(-M2.LT.L1)) THEN + R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1) + R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1) + ELSE + R_A=CF2*(1.-D0)*R(M2,M,L1) + R_B=CF2*(1.+D0)*R(M2,-M,L1) + ENDIF +C + R(M2,M,L)=R_A + R(M2,-M,L)=R_B +C + R(-M2,-M,L)=R_A*CM2 + R(M,M2,L)=R_A*CM2 + R(-M,M2,L)=R_B*CM2 + R(-M2,M,L)=R_B*CM2 +C + R(-M,-M2,L)=R_A + R(M,-M2,L)=R_B +C + ENDDO + ENDDO +C + PRODM=PRODM*COEF + R_1=PRODL*PRODM + R_2=PRODL/PRODM + R(-L,L,L)=R_1 + R(L,-L,L)=R_1 + R(L,L,L)=R_2 + R(-L,-L,L)=R_2 +C + ENDDO + ENDIF +C + IF(ISWITCH.EQ.1) THEN + DO L=0,LMAX + DO M1=-L,L + DO M2=-L,L + R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)*EXPF(ABS(M2),L) + ENDDO + ENDDO + ENDDO + ELSEIF(ISWITCH.EQ.2) THEN + DO L=0,LMAX + DO M1=-L,L + DO M2=-L,L + R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)/EXPF(ABS(M2),L) + ENDDO + ENDDO + ENDDO + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE EMETT(JEM,IEMET,Z,COORD,NATYP,EMET,NM,JNEM,*) +C +C This routine looks for the position of an absorber of type IEMET(JEM) +C situated in the plane at Z. The result is stored in EMET(3) +C + USE DIM_MOD +C + DIMENSION IEMET(NEMET_M) + DIMENSION EMET(3),DIST(NATCLU_M),COORD(3,NATCLU_M),NATYP(NATM) +C + KEMET=0 + JNT=0 + IEM=IEMET(JEM) + IF(IEM.GT.1) THEN + DO JTP=1,IEM-1 + JNT=JNT+NATYP(JTP) + ENDDO + ENDIF + NB=NATYP(IEM) + XMIN=1000000. +C + DO J=1,NB + JN=J+JNT + DELTAZ=ABS(COORD(3,JN)-Z) + IF(DELTAZ.LT.0.0001) THEN + XX=COORD(1,JN) + XY=COORD(2,JN) + XZ=COORD(3,JN) + DIST(J)=SQRT(XX*XX+XY*XY+XZ*XZ) + IF(DIST(J).LT.XMIN) THEN + XMIN=DIST(J) + NM=IEM + JNEM=J + DO I=1,3 + EMET(I)=COORD(I,JN) + ENDDO + ENDIF + KEMET=KEMET+1 + ENDIF + ENDDO +C + IF(KEMET.EQ.0) THEN + NM=IEM + RETURN 1 + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE EULER(RTHETA1,RPHI1,RTHETA2,RPHI2,RALPHA,RBETA,RGAMMA,I + &ROT) +C +C This routine calculates the Euler angles RALPHA,RBETA,RGAMMA corresponding +C to the rotation r1(RTHETA1,RPHI1) ----> r2(RTHETA2,RPHI2) +C +C IROT=1 : r ---> z represented by (0,RTHETA,PI-RPHI) +C IROT=0 : r ---> z represented by (0,-RTHETA,-RPHI) +C +C + COMPLEX U1,U2 +C + DATA PI /3.141593/ +C + IF(IROT.EQ.1) THEN + EPS=1 + ELSE + EPS=-1 + ENDIF + DPHI=RPHI2-RPHI1 + A1=SIN(RTHETA1)*COS(RTHETA2) + A2=COS(RTHETA1)*SIN(RTHETA2) + A3=COS(RTHETA1)*COS(RTHETA2) + A4=SIN(RTHETA1)*SIN(RTHETA2) + U1=A1-A2*COS(DPHI)-(0.,1.)*SIN(RTHETA2)*SIN(DPHI) + U2=A1*COS(DPHI)-A2+(0.,1.)*SIN(RTHETA1)*SIN(DPHI) + U3=A3+A4*COS(DPHI) + IF(U3.GT.1.) U3=1. + IF(U3.LT.-1.) U3=-1. + RBETA=ACOS(U3) + IF(ABS(SIN(RBETA)).GT.0.0001) THEN + U1=EPS*U1/SIN(RBETA) + U2=EPS*U2/SIN(RBETA) + CALL ARCSIN(U1,U3,RALPHA) + CALL ARCSIN(U2,U3,RGAMMA) + ELSE + RALPHA=0. + IF(ABS(U3-1.0).LT.0.0001) THEN + RGAMMA=0. + ELSE + RGAMMA=PI + ENDIF + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE GAUNT(L2,M2,L1,M1,GNT) +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 Last modified : 8 Dec 2008 +C +C + USE DIM_MOD + USE LOGAMAD_MOD +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + REAL GNT(0:N_GAUNT) +C + DOUBLE PRECISION F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT) + DOUBLE PRECISION A1(0:N_GAUNT),B(0:N_GAUNT) +C +C + DATA PI4/12.566370614359D0/ +C + L12=L1+L2 + K12=L1-L2 +C + DO J=1,N_GAUNT + GNT(J)=0. + ENDDO +C + IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10 +C + M3=M1-M2 + LM1=L1+M1 + LM2=L2+M2 + KM1=L1-M1 + KM2=L2-M2 +C + IF(MOD(M1,2).EQ.0) THEN + COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) + ELSE + COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) + ENDIF +C + F(L12+1)=0.D0 + G(L12+1)=0.D0 + A(L12+1)=0.D0 + A1(L12+1)=0.D0 + D1=GLD(2*L2+1,1)-GLD(2*L12+2,1) + D2=GLD(2*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 + D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,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 + A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3))) + B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1) + &)) + A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12))) +C + IF(ABS(M3).LE.L12) THEN + GNT(L12)=SNGL(COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1))) + ELSE + GNT(L12)=0. + ENDIF +C + JMIN=MAX0(ABS(K12),ABS(M3)) +C + DO J=L12-1,JMIN,-1 + J1=J+1 + J2=J+2 + A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL + &OAT(J*J-M3*M3)) + B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1))) + A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J) + &)) + F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1)) + G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1)) + GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1)) +C + IF(ABS(M3).LE.J) THEN + GNT(J)=SNGL(GND) + ELSE + GNT(J)=0. + ENDIF +C + ENDDO +C + 10 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE GAUNT2(L2,M2,L1,M1,GNT) +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 Last modified : 8 Dec 2008 +C This is the double precision version +C +C +C + USE DIM_MOD + USE LOGAMAD_MOD +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + REAL*8 F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT),A1(0:N_GAUNT) + REAL*8 B(0:N_GAUNT),GNT(0:N_GAUNT) +C +C + DATA PI4/12.566370614359D0/ +C + L12=L1+L2 + K12=L1-L2 +C + DO J=1,N_GAUNT + GNT(J)=0.D0 + ENDDO +C + IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10 +C + M3=M1-M2 + LM1=L1+M1 + LM2=L2+M2 + KM1=L1-M1 + KM2=L2-M2 +C + IF(MOD(M1,2).EQ.0) THEN + COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) + ELSE + COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) + ENDIF +C + F(L12+1)=0.D0 + G(L12+1)=0.D0 + A(L12+1)=0.D0 + A1(L12+1)=0.D0 + D1=GLD(2*L2+1,1)-GLD(2*L12+2,1) + D2=GLD(2*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 + D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,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 + A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3))) + B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1) + &)) + A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12))) +C + IF(ABS(M3).LE.L12) THEN + GNT(L12)=COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1)) + ELSE + GNT(L12)=0.D0 + ENDIF +C + JMIN=MAX0(ABS(K12),ABS(M3)) +C + DO J=L12-1,JMIN,-1 + J1=J+1 + J2=J+2 + A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL + &OAT(J*J-M3*M3)) + B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1))) + A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J) + &)) + F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1)) + G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1)) + GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1)) +C + IF(ABS(M3).LE.J) THEN + GNT(J)=GND + ELSE + GNT(J)=0.D0 + ENDIF +C + ENDDO +C + 10 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE HARSPH(NL,THETA,PHI,YLM,NC) +C +C This routine computes the complex spherical harmonics using Condon and +C Shortley phase convention. +C + USE DIM_MOD +C + USE EXPFAC2_MOD + USE FACTSQ_MOD +C + COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C +C + DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ + DATA PI,SMALL /3.141593,0.0001/ +C + X=COS(THETA) + IF(ABS(X).LT.SMALL) X=0.0 + IF(ABS(X+1.).LT.SMALL) X=-1.0 + IF(ABS(X-1.).LT.SMALL) X=1.0 +C + YLM(0,0)=CMPLX(SQ4PI_INV) + YLM(1,0)=X*SQR3_INV + DO L=2,NC + Y=1./FLOAT(L) + YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) + &-1.5))*YLM(L-2,0) + ENDDO +C + C2=-1. + IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN + C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) + ELSE + C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) + ENDIF +C + C1=1. + COEF=(1.,0.) + DO M=1,NC + C1=C1*C2 + COEF=COEF*C + YMM=SQ4PI_INV*COEF*FSQ(M) + YLM(M,M)=YMM + YLM(M,-M)=C1*CONJG(YMM) + YMMP=X*SQRT(FLOAT(M+M+3))*YMM + YLM(M+1,M)=YMMP + YLM(M+1,-M)=C1*CONJG(YMMP) + IF(M.LT.NC-1) THEN + DO L=M+2,NC + YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2( + &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M)) + YLM(L,-M)=C1*CONJG(YLM(L,M)) + ENDDO + ENDIF + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE HARSPH2(NL,THETA,PHI,YLM,NC) +C +C This routine computes the complex spherical harmonics using Condon and +C Shortley phase convention. This version for m=0 only +C + USE DIM_MOD +C + USE EXPFAC2_MOD + USE FACTSQ_MOD +C + COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C +C + DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ + DATA PI,SMALL /3.141593,0.0001/ +C + X=COS(THETA) + IF(ABS(X).LT.SMALL) X=0.0 + IF(ABS(X+1.).LT.SMALL) X=-1.0 + IF(ABS(X-1.).LT.SMALL) X=1.0 +C + YLM(0,0)=CMPLX(SQ4PI_INV) + YLM(1,0)=X*SQR3_INV + DO L=2,NC + Y=1./FLOAT(L) + YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) + &-1.5))*YLM(L-2,0) + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE HARSPH3(NL,THETA,PHI,YLM2,NC) +C +C This routine computes the complex spherical harmonics using Condon and +C Shortley phase convention. +C + USE DIM_MOD +C + USE EXPFAC2_MOD + USE FACTSQ_MOD +C + COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C + COMPLEX YLM2(LINMAX) +C + DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ + DATA PI,SMALL /3.141593,0.0001/ +C + X=COS(THETA) + IF(ABS(X).LT.SMALL) X=0.0 + IF(ABS(X+1.).LT.SMALL) X=-1.0 + IF(ABS(X-1.).LT.SMALL) X=1.0 +C + YLM(0,0)=CMPLX(SQ4PI_INV) + YLM(1,0)=X*SQR3_INV + DO L=2,NC + Y=1./FLOAT(L) + YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) + &-1.5))*YLM(L-2,0) + ENDDO +C + C2=-1. + IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN + C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) + ELSE + C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) + ENDIF +C + C1=1. + COEF=(1.,0.) + DO M=1,NC + C1=C1*C2 + COEF=COEF*C + YMM=SQ4PI_INV*COEF*FSQ(M) + YLM(M,M)=YMM + YLM(M,-M)=C1*CONJG(YMM) + YMMP=X*SQRT(FLOAT(M+M+3))*YMM + YLM(M+1,M)=YMMP + YLM(M+1,-M)=C1*CONJG(YMMP) + IF(M.LT.NC-1) THEN + DO L=M+2,NC + YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2( + &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M)) + YLM(L,-M)=C1*CONJG(YLM(L,M)) + ENDDO + ENDIF + ENDDO +C + DO L=0,NC + IL=L*L+L+1 + DO M=-L,L + IND=IL+M + YLM2(IND)=YLM(L,M) + ENDDO + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE HEADERS(IUO2) +C +C This subroutine writes headers containing the main parameters +C of the calculation in the result file. The number of +C lines written depends of the spectroscopy +C +C Last modified : 31 Jan 2013 +C + USE DIM_MOD +C + USE ALGORITHM_MOD + USE APPROX_MOD + USE EXAFS_MOD + USE HEADER_MOD + USE INFILES_MOD + USE INIT_A_MOD + USE INIT_J_MOD + USE INIT_L_MOD + USE INIT_M_MOD + USE MOYEN_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE VALIN_AV_MOD + USE VALFIN_MOD + USE VALEX_A_MOD +C +C +C +C +C +C +C +C +C +C +C + WRITE(IUO2,1) + WRITE(IUO2,2) +C +C Input files section: +C +C Checking the size of filenames +C + N_CHAR1=0 + DO J_CHAR=1,24 + IF(INFILE1(J_CHAR:J_CHAR).EQ.' ') GOTO 500 + N_CHAR1=N_CHAR1+1 + ENDDO + 500 CONTINUE +C + N_CHAR2=0 + DO J_CHAR=1,24 + IF(INFILE2(J_CHAR:J_CHAR).EQ.' ') GOTO 501 + N_CHAR2=N_CHAR2+1 + ENDDO + 501 CONTINUE +C + N_CHAR3=0 + DO J_CHAR=1,24 + IF(INFILE3(J_CHAR:J_CHAR).EQ.' ') GOTO 502 + N_CHAR3=N_CHAR3+1 + ENDDO + 502 CONTINUE +C + N_CHAR4=0 + DO J_CHAR=1,24 + IF(INFILE4(J_CHAR:J_CHAR).EQ.' ') GOTO 503 + N_CHAR4=N_CHAR4+1 + ENDDO + 503 CONTINUE +C + WRITE(IUO2,3) INFILE1(6:N_CHAR1) + WRITE(IUO2,4) INFILE2(4:N_CHAR2) + IF(INTERACT.NE.'NOINTER') THEN + WRITE(IUO2,5) INFILE3(5:N_CHAR3) + ENDIF + WRITE(IUO2,6) INFILE4(6:N_CHAR4) + WRITE(IUO2,2) +C +C Type of calculation +C + WRITE(IUO2,2) +C + IF(SPECTRO.EQ.'PHD') THEN + WRITE(IUO2,11) SPECTRO,ALGO1 + IF(ALGO1.EQ.'SE') THEN + WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH + ELSEIF(ALGO1.EQ.'CE') THEN + WRITE(IUO2,13) NDIF + ENDIF + WRITE(IUO2,14) VINT + ELSEIF(SPECTRO.EQ.'XAS') THEN + WRITE(IUO2,11) SPECTRO,ALGO1 + IF(ALGO1.EQ.'SE') THEN + WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH + ELSEIF(ALGO1.EQ.'CE') THEN + WRITE(IUO2,13) NDIF + ENDIF + WRITE(IUO2,14) VINT + ELSEIF(SPECTRO.EQ.'LED') THEN + WRITE(IUO2,11) SPECTRO,ALGO1 + IF(ALGO1.EQ.'SE') THEN + WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH + ELSEIF(ALGO1.EQ.'CE') THEN + WRITE(IUO2,13) NDIF + ENDIF + WRITE(IUO2,14) VINT + ELSEIF(SPECTRO.EQ.'AED') THEN + WRITE(IUO2,11) SPECTRO,ALGO2 + IF(ALGO1.EQ.'SE') THEN + WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH + ELSEIF(ALGO1.EQ.'CE') THEN + WRITE(IUO2,13) NDIF + ENDIF + WRITE(IUO2,14) VINT + ELSEIF(SPECTRO.EQ.'APC') THEN + WRITE(IUO2,15) SPECTRO,ALGO1,ALGO2 + WRITE(IUO2,14) VINT + ELSEIF(SPECTRO.EQ.'EIG') THEN + WRITE(IUO2,11) SPECTRO,ALGO1 + ELSEIF(SPECTRO.EQ.'RES') THEN + CONTINUE + ELSEIF(SPECTRO.EQ.'ELS') THEN + CONTINUE + ENDIF +C + WRITE(IUO2,2) +C +C Initial state parameters +C + IF(SPECTRO.EQ.'PHD') THEN + WRITE(IUO2,21) NI,NLI,S_O,INITL + ELSEIF(SPECTRO.EQ.'XAS') THEN + WRITE(IUO2,22) EDGE,NEDGE,INITL + ELSEIF(SPECTRO.EQ.'LED') THEN + CONTINUE + ELSEIF(SPECTRO.EQ.'AED') THEN + WRITE(IUO2,24) AUGER,MULTIPLET + ELSEIF(SPECTRO.EQ.'APC') THEN + WRITE(IUO2,21) NI,NLI,S_O,INITL + WRITE(IUO2,24) AUGER,MULTIPLET + ELSEIF(SPECTRO.EQ.'RES') THEN + CONTINUE + ELSEIF(SPECTRO.EQ.'ELS') THEN + CONTINUE + ENDIF +C + WRITE(IUO2,2) +C +C Angular and energy parameters +C + IF(SPECTRO.EQ.'PHD') THEN + WRITE(IUO2,35) + WRITE(IUO2,34) THLUM,PHILUM,ELUM + WRITE(IUO2,2) + WRITE(IUO2,36) + WRITE(IUO2,31) THETA0,THETA1 + WRITE(IUO2,32) PHI0,PHI1 + WRITE(IUO2,33) E0,EFIN + ELSEIF(SPECTRO.EQ.'XAS') THEN + WRITE(IUO2,35) + WRITE(IUO2,33) EK_INI,EK_FIN + WRITE(IUO2,34) THLUM,PHILUM,ELUM + ELSEIF(SPECTRO.EQ.'LED') THEN + WRITE(IUO2,35) + WRITE(IUO2,31) THLUM,PHILUM + WRITE(IUO2,2) + WRITE(IUO2,36) + WRITE(IUO2,31) THETA0,THETA1 + WRITE(IUO2,32) PHI0,PHI1 + WRITE(IUO2,2) + WRITE(IUO2,33) E0,EFIN + ELSEIF(SPECTRO.EQ.'AED') THEN + WRITE(IUO2,36) + WRITE(IUO2,31) THETA0_A,THETA1_A + WRITE(IUO2,32) PHI0_A,PHI1_A + ELSEIF(SPECTRO.EQ.'APC') THEN + WRITE(IUO2,35) + WRITE(IUO2,34) THLUM,PHILUM,ELUM + WRITE(IUO2,2) + WRITE(IUO2,37) + WRITE(IUO2,31) THETA0,THETA1 + WRITE(IUO2,32) PHI0,PHI1 + WRITE(IUO2,33) E0,EFIN + WRITE(IUO2,2) + WRITE(IUO2,38) + WRITE(IUO2,31) THETA0_A,THETA1_A + WRITE(IUO2,32) PHI0_A,PHI1_A + ELSEIF(SPECTRO.EQ.'EIG') THEN + WRITE(IUO2,33) EK_INI,EK_FIN + ELSEIF(SPECTRO.EQ.'RES') THEN + CONTINUE + ELSEIF(SPECTRO.EQ.'ELS') THEN + CONTINUE + ENDIF +C +C End of headers +C + WRITE(IUO2,2) + WRITE(IUO2,1) + WRITE(IUO2,39) +C +C Formats +C + 1 FORMAT('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',' + &!!!!!!!!!!!!!!!!') + 2 FORMAT('!',69X,'!') + 3 FORMAT('!',10X,'data file : ',A19,20X,'!') + 4 FORMAT('!',10X,'t-matrix file : ',A17,20X,'!') + 5 FORMAT('!',10X,'rad integral file: ',A20,20X,'!') + 6 FORMAT('!',10X,'cluster file : ',A19,20X,'!') +C + 11 FORMAT('!',10X,'spectroscopy : ',A3,8X,'algorithm : ',A2, + &10X,'!') + 12 FORMAT('!',15X,'NO = ',I1,' NDIF = ',I2,' IFWD = ',I1,' IPW = ' + &,I1,' ILENGTH = ',I1,5X,'!') + 13 FORMAT('!',15X,'NDIF = ',I2,45X,'!') + 14 FORMAT('!',10X,'inner potential : ',F6.2,' eV',28X,'!') + 15 FORMAT('!',10X,'spectroscopy: ',A3,10X,'algorithm (photo): ',A2,11 + &X,'!',/,'!',37X,'algorithm (auger): ',A2, 11X,'!') +C + 21 FORMAT('!',10X,'initial state : ',I1,A1,1X,A3,' selection rules + &:',' INITL = ',I2,6X,'!') + 22 FORMAT('!',10X,'initial state : ',A1,I1,2X,' selection rules:', + &' INITL = ',I2,8X,'!') + 24 FORMAT('!',10X,'initial state : ',A6,2X,' multiplet: ',A3,17X,' + &!') +C + 31 FORMAT('!',10X,'THETA_INI: ',F8.2,6X,'THETA_FIN: ',F8.2,15X,'!') + 32 FORMAT('!',10X,'PHI_INI : ',F8.2,6X,'PHI_FIN : ',F8.2,15X,'!') + 33 FORMAT('!',10X,'E_INI : ',F8.2,' eV',3X,'E_FIN : ',F8.2,' eV + &',12X,'!') + 34 FORMAT('!',10X,'THETA_LUM: ',F8.2,2X,'PHI_LUM: ',F8.2,2X,'E_LUM: ' + &,F8.2,' eV !') + 35 FORMAT('!',10X,'incoming beam : ',40X,'!') + 36 FORMAT('!',10X,'outgoing beam : ',40X,'!') + 37 FORMAT('!',10X,'photoelectron beam:',40X,'!') + 38 FORMAT('!',10X,'auger beam :',40X,'!') + 39 FORMAT(71X) +C + RETURN +C + END +C +C======================================================================= +C + INTEGER FUNCTION IG(J) +C +C This function is returns the value 1 if J is an integer +C and 2 if it is a half-integer +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C + REAL*8 J,JJ +C + DATA SMALL /0.0001D0/ +C + JJ=ABS(J+J) +C + LL=INT(JJ+SMALL) +C + IF(MOD(LL,2).EQ.0) THEN + IG=1 + ELSE + IG=2 + ENDIF +C + END +C +C======================================================================= +C + SUBROUTINE LOCATE(XX,N,X,J) +C +C +C This subroutine is taken from the book : +C "Numerical Recipes : The Art of Scientific +C Computing" par W.H. PRESS, B.P. FLANNERY, +C S.A. TEUKOLSKY et W.T. VETTERLING +C (Cambridge University Press 1992) +C +C It performs a search in an ordered table using a bisection method. +C Given a monotonic array XX(1:N) and a value X, it returns J such +C that X is between XX(J) and XX(J+1). +C + INTEGER J,N + INTEGER JL,JM,JU +C + REAL X,XX(N) +C + JL=0 + JU=N+1 + 10 IF(JU-JL.GT.1)THEN + JM=(JU+JL)/2 + IF((XX(N).GT.XX(1)).EQV.(X.GT.XX(JM)))THEN + JL=JM + ELSE + JU=JM + ENDIF + GOTO 10 + ENDIF + J=JL +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE LPM(E,XLPM,*) +C +C This routine generates the electron mean free path +C +C ILPM=-1: XLPM is set to 1.E+30 +C ILPM=0 : XLPM is the value given in the input data file +C ILPM=1 : XLPM computed from Tokutaka et al, Surf. Sci. 149,349 (1985) +C ILPM=2 : XLPM computed from the Seah and Dench expression +C +C Last modified : 15 Sep 2009 +C + USE LPMOY_MOD , NZ => NZA, XMAT => XMTA, RHO => RHOTA + USE OUTUNITS_MOD + USE TESTS_MOD + USE VALIN_MOD +C + E=E+VINT +C + IF(ILPM.EQ.-1) THEN + XLPM=1.E+30 + ELSEIF(ILPM.EQ.0) THEN + XLPM=XLPM0 + ELSEIF(ILPM.EQ.1) THEN + Q=FLOAT(NZ)*RHO/XMAT + CSTE1=ALOG(Q/4.50)/(ALOG(7.74/4.50)) + CSTE2=ALOG(Q/3.32)/(ALOG(7.74/3.32)) + CSTE3=ALOG(Q/3.32)/(ALOG(4.50/3.32)) + A1=0.7271+0.2595*ALOG(E) + A2=-3.2563+0.9395*ALOG(E) + A3=-2.5716+0.8226*ALOG(E) + IF(E.GE.350.) GO TO 10 + XLN=CSTE1*(0.0107-0.0083*ALOG(E))+A1 + GO TO 20 + 10 IF((NZ.GE.24).AND.(NZ.LE.74)) GO TO 30 + XLN=CSTE2*(1.6551-0.2890*ALOG(E))+A2 + GO TO 20 + 30 IF(NZ.GE.42) GO TO 40 + XLN=CSTE3*(0.6847-0.1169*ALOG(E))+A2 + GO TO 20 + 40 XLN=CSTE1*(0.9704-0.1721*ALOG(E))+A3 + 20 XLPM=EXP(XLN) + ELSEIF(ILPM.EQ.2) THEN + XLPM=1430./(E**2)+0.54*SQRT(E) + ELSE + RETURN 1 + ENDIF +C + E=E-VINT + IF(IPRINT.GT.0) WRITE(IUO1,80) E,XLPM +C + 80 FORMAT(/////,2X,'========= E = ',F7.2,' eV',5X,'MEAN',' FREE PATH + & = ',F6.3,' ANGSTROEMS ','=========') +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE N_J(J1,MJ1,J2,MJ2,MJ6,NJ,I_INT,N_IN) +C +C This subroutine calculates Wigner's 3j and 6j coefficients +C using a downward recursion scheme due to Schulten and Gordon. +C The 3j are defined as (J1 J2 J) where in fact L1=MJ1, etc are +C (L1 L2 L) +C azimuthal quantum numbers, and the 6j as {J1 J2 J} where now +C {L1 L2 L} +C J1, L1, etc are the same kind of orbital quantum numbers. +C The result is stored as NJ(J). +C +C The parameter N allows to choose between 3j and 6j calculation, and +C Clebsch-Gordan. It can take the values : +C +C N = 2 ----> Clebsch-Gordan +C N = 3 ----> Wigner's 3j +C N = 6 ----> Wigner's 6j +C +C The Clebsch-Gordan coefficients are related to Wigner's 3j through : +C +C CG(J1,M1,J2,M2|J,MJ) = ( J1 J2 J )*sqrt(2*J+1)*(-1)**(J1-J2+MJ) +C ( M1 M2 -MJ ) +C I_INT is a flag that returns 1 if the index J of the nj symbol +C is integer and 0 if it is a half integer. +C +C Note : For 3j, MJ6 is ignored while for 6j, we have : +C +C J1=J1 MJ1=L1 J2=J2 MJ2=L2 MJ6=L +C +C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975) +C +C Last modified : 8 Dec 2008 ----> D. Sebilleau +C +C + USE DIM_MOD + USE LOGAMAD_MOD +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + REAL*4 NJ(0:N_GAUNT) +C + REAL*8 J1,J2,J,MJ1,MJ2,MJ,JP1,JP2 + REAL*8 F(0:N_GAUNT),A(0:N_GAUNT),B(0:N_GAUNT) + REAL*8 JL12,JK12,MJ6,SIG + REAL*8 JJ1,JJ2,JL1,JL2,JL3,JJ12,JJ_MIN,JJ_MAX +C +C + DATA SMALL /0.0001D0/ +C + IS=0 +C + IF(N_IN.EQ.2) THEN + N_OU=3 + I_CG=1 + ELSE + N_OU=N_IN + I_CG=0 + ENDIF +C + IF(N_OU.EQ.3) THEN +C +C------------------------------ 3j case --------------------------------- +C +C +C Test to check if J1 and J2 are integer or semi-integer +C +C Integer : IG=1 +C Half-integer : IG=2 +C +C Each angular momentum J is represented by the integer index L and +C the corresponding MJ by M +C + L1=INT(J1+SMALL) + L2=INT(J2+SMALL) + M1=INT(MJ1+SIGN(SMALL,MJ1)) + M2=INT(MJ2+SIGN(SMALL,MJ2)) + DIF1=J1-DFLOAT(L1) + DIF2=J2-DFLOAT(L2) +C +C IGx is a flag telling the code which case of Gamma function to use : +C +C IGx = 1 : integer case +C IGx = 2 : half-integer case +C + IF(ABS(DIF1).LT.SMALL) THEN + IG1=1 + ELSE + IG1=2 + ENDIF + IF(ABS(DIF2).LT.SMALL) THEN + IG2=1 + ELSE + IG2=2 + ENDIF + IF(IG1.EQ.IG2) THEN + IGG=1 + IF(IG1.EQ.2) IS=1 + ELSE + IGG=2 + ENDIF +C +C Here, we assume that (J1,J2) are both either integer or half-integer +C If J is integer, the corresponding index is L = j (for loops or storage) +C while if J is an half-integer, this index is L= j - 1/2 = int(j) +C +C Integer indices are used for loops and for storage while true values +C are used for the initial values. When J1 and J2 are both half-integers, +C the values of J are integer and L should be increased by 1 +C + JL12=J1+J2 + JK12=J1-J2 +C + L12=INT(JL12 + SIGN(SMALL,JL12)) + K12=INT(JK12 + SIGN(SMALL,JK12)) +C + LM1=INT(J1+MJ1 + SIGN(SMALL,J1+MJ1)) + LM2=INT(J2+MJ2 + SIGN(SMALL,J2+MJ2)) + KM1=INT(J1-MJ1 + SIGN(SMALL,J1-MJ1)) + KM2=INT(J2-MJ2 + SIGN(SMALL,J2-MJ2)) +C + MJ=-MJ1-MJ2 +C + M=INT(MJ+SIGN(SMALL,MJ)) + L12M=INT(JL12+MJ+SIGN(SMALL,JL12+MJ)) + K12M=INT(JL12-MJ+SIGN(SMALL,JL12-MJ)) + L1_2=INT(J1+J1+SIGN(SMALL,J1)) + L2_2=INT(J2+J2+SIGN(SMALL,J2)) + L12_2=INT(JL12+JL12+SIGN(SMALL,JL12)) +C + IF(IG(JL12).EQ.1) THEN + I_INT=1 + ELSE + I_INT=0 + ENDIF +C +C Initialisation of the 3j symbol NJ(J) = (J1 J2 J) +C (MJ1 MJ2 MJ) +C + DO L=0,L12 + NJ(L)=0. + ENDDO +C + IF((ABS(MJ1).GT.J1).OR.(ABS(MJ2).GT.J2)) GOTO 10 +C +C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward +C recursion scheme. This scheme writes as +C +C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0 +C + F(L12+1)=0.D0 + A(L12+1)=0.D0 + D1=GLD(L2_2+1,1)-GLD(L12_2+2,1) + D2=GLD(L1_2+1,1)-GLD(LM2+1,1) + D3=GLD(L12M+1,1)-GLD(KM2+1,1) + D4=GLD(K12M+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1) +C + N12=INT(JK12-MJ + SIGN(SMALL,JK12-MJ)) +C + IF(I_CG.EQ.1) THEN + IF(MOD(N12,2).EQ.0) THEN + SIG=1.D0 + ELSE + SIG=-1.D0 + ENDIF + ENDIF +C + IF(MOD(N12,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(J1*J2*(1.D0+2.D0*JL12)*(JL12*JL12-MJ*MJ)) + B(L12)=-(2.D0*JL12+1.D0)*((J1*J1-J2*J2+JK12)*MJ-JL12*(JL12+1.D0) + &*(MJ2-MJ1)) +C + IF(ABS(M).LE.L12) THEN + IF(I_CG.EQ.0) THEN + NJ(L12)=SNGL(F(L12)) + ELSE + NJ(L12)=SNGL(F(L12)*SIG*DSQRT(JL12+JL12+1.D0)) + ENDIF + ELSE + NJ(L12)=0. + ENDIF +C + LMIN=MAX0(ABS(K12),ABS(M)) +C +C Downward recursion for NJ(J) +C + DO L=L12-1,LMIN,-1 + LP1=L+1 + LP2=L+2 +C +C Value of the angular momentum J corresponding to the loop index L +C + IF(IGG.EQ.1) THEN + J=DFLOAT(L) + JP1=DFLOAT(LP1) + JP2=DFLOAT(LP2) + ELSE + J=DFLOAT(L) + 0.5D0 + JP1=DFLOAT(LP1) + 0.5D0 + JP2=DFLOAT(LP2) + 0.5D0 + ENDIF +C + A(L)=DSQRT((J*J-JK12*JK12)*((JL12+1.D0)*(JL12+1.D0)-J*J)*(J*J- + &MJ*MJ)) + B(L)=-(2.D0*J+1.D0)*(J1*(J1+1.D0)*MJ-J2*(J2+1.D0)*MJ-J*JP1*(MJ + &2-MJ1)) + F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1)) +C + IF(ABS(MJ).LE.J) THEN + IF(I_CG.EQ.0) THEN + NJ(L)=SNGL(F(L)) + ELSE + NJ(L)=SNGL(F(L)*SIG*DSQRT(J+J+1.D0)) + ENDIF + ELSE + NJ(L)=0. + ENDIF +C + ENDDO +C + 10 CONTINUE +C + ELSEIF(N_OU.EQ.6) THEN +C +C------------------------------ 6j case --------------------------------- +C +C Change of notation for greater readability ---> NJ(JJ) +C +C True angular momentum value : begins with a J (JJn,JLn) +C Corresponding integer storage and loop index : begins by L (LJn,LLn) +C + JJ1=J1 + JJ2=J2 + JL1=MJ1 + JL2=MJ2 + JL3=MJ6 +C + LJ1=INT(JJ1+SIGN(SMALL,JJ1)) + LJ2=INT(JJ2+SIGN(SMALL,JJ2)) + LL1=INT(JL1+SIGN(SMALL,JL1)) + LL2=INT(JL2+SIGN(SMALL,JL2)) + LL3=INT(JL3+SIGN(SMALL,JL3)) +C + JJ12=JJ1-JJ2 + JL12=JL1-JL2 +C + LJ12=INT(JJ12+SIGN(SMALL,JJ12)) + LL12=INT(JL12+SIGN(SMALL,JL12)) +C + JJ_MIN=MAX(ABS(LJ12),ABS(LL12)) + JJ_MAX=MIN(JJ1+JJ2,JL1+JL2) + LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN)) + LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX)) +C +C Initialisation of the 6j symbol NJ(J) = {J1 J2 J } +C {L1 L2 L3} +C + DO L=0,LJJ_MAX + NJ(L)=0. + ENDDO +C +C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward +C recursion scheme. This scheme writes as +C +C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0 +C +C There are two possible initial values as max(|J1-J2|,|L1-L2|) <= J <= +C min(J1+J2,L1+L2) : +C +C {J1 J2 L1+L2} and {J1 J2 J1+J2} = {L1 L2 J1+J2} +C {L1 L2 L3 } {L1 L2 L3 } {J1 J2 L3 } +C +C They can be calculated from equation (6.3.1) of Edmonds page 97 +C + F(LJJ_MAX+1)=0.D0 + A(LJJ_MAX+1)=0.D0 +C + IF(ABS(JJ_MAX-JL1-JL2).LT.SMALL) THEN + F(LJJ_MAX)=SIXJ_IN(JJ1,JJ2,JL1,JL2,JL3) + ELSE + F(LJJ_MAX)=SIXJ_IN(JL1,JL2,JJ1,JJ2,JL3) + ENDIF + NJ(LJJ_MAX)=SNGL(F(LJJ_MAX)) +C + A(LJJ_MAX)=SQRT((JJ_MAX*JJ_MAX-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1. + &D0)*(JJ1+JJ2+1.D0)-JJ_MAX*JJ_MAX)*(JJ_MAX*JJ_MAX-(JL1-JL2)*(JL1-JL + &2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)-JJ_MAX*JJ_MAX)) + B(LJJ_MAX)=(JJ_MAX+JJ_MAX+1.D0)*(JJ_MAX*(JJ_MAX+1.D0)*(-JJ_MAX*( + &JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1*(JL1+1.D0)*(JJ_MAX + &*(JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(JJ_M + &AX*(JJ_MAX+1.D0)-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(JJ_MAX+JJ_MAX)*(J + &J_MAX+1.D0)*JL3*(JL3+1.D0)) +C + IF(IG(JJ_MAX).EQ.1) THEN + I_INT=1 + ELSE + I_INT=0 + ENDIF +C +C Downward recurrence relation +C + DO L=LJJ_MAX-1,LJJ_MIN,-1 + LP1=L+1 + LP2=L+2 +C +C Value of the angular momentum J corresponding to the loop index L +C + IF(IG(JJ_MAX).EQ.1) THEN + J=DFLOAT(L) + JP1=DFLOAT(LP1) + JP2=DFLOAT(LP2) + ELSE + J=DFLOAT(L) + 0.5D0 + JP1=DFLOAT(LP1) + 0.5D0 + JP2=DFLOAT(LP2) + 0.5D0 + ENDIF +C + A(L)=SQRT((J*J-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.D0)*(JJ1+JJ2+1 + &.D0)-J*J)*(J*J-(JL1-JL2)*(JL1-JL2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0) + &-J*J)) + B(L)=(J+J+1)*(J*JP1*(-J*JP1+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1 + &*(JL1+1.D0)*(J*JP1+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*( + &J*JP1-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(J+J)*JP1*JL3*(JL3+1.D0)) +C + F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1)) + NJ(L)=SNGL(F(L)) +C + ENDDO +C + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE ORDRE2(NINI,VALINI,NFIN,VALFIN) +C +C Given a set of **integer** numbers VALINI, this routine orders them +C and suppresses the values appearing more than once. The remaining +C values are stored in VALFIN. +C +C VALINI(K+1).GT.VALINI(K) : decreasing order +C VALINI(K+1).LT.VALINI(K) : increasing order +C +C +C + INTEGER VALINI(NINI),VALFIN(NINI),R1 +C + LOGICAL BUBBLE +C + DO J=1,NINI-1 + K=J + BUBBLE=.TRUE. +150 IF(K.GE.1.AND.BUBBLE) THEN + IF(VALINI(K+1).LT.VALINI(K)) THEN + R1=VALINI(K) + VALINI(K)=VALINI(K+1) + VALINI(K+1)=R1 + ELSE + BUBBLE=.FALSE. + ENDIF + K=K-1 + GOTO 150 + ENDIF + ENDDO +C + JFIN=1 + VALFIN(1)=VALINI(1) + DO J=1,NINI-1 + IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.0) THEN + JFIN=JFIN+1 + VALFIN(JFIN)=VALINI(J+1) + ENDIF + ENDDO + NFIN=JFIN +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE ORDRE(NINI,VALINI,NFIN,VALFIN) +C +C Given a set of **real** numbers VALINI, this routine orders them and +C suppresses the values appearing more than once. The remaining +C values are stored in VALFIN. +C +C VALINI(K+1).GT.VALINI(K) : decreasing order +C VALINI(K+1).LT.VALINI(K) : increasing order +C +C + DIMENSION VALINI(NINI),VALFIN(NINI) +C + LOGICAL BUBBLE +C + DATA SMALL /0.00001/ +C + DO J=1,NINI-1 + K=J + BUBBLE=.TRUE. +150 IF(K.GE.1.AND.BUBBLE) THEN + IF(VALINI(K+1).GT.VALINI(K)) THEN + R1=VALINI(K) + VALINI(K)=VALINI(K+1) + VALINI(K+1)=R1 + ELSE + BUBBLE=.FALSE. + END IF + K=K-1 + GOTO 150 + ENDIF + ENDDO +C + JFIN=1 + VALFIN(1)=VALINI(1) + DO J=1,NINI-1 + IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN + JFIN=JFIN+1 + VALFIN(JFIN)=VALINI(J+1) + ENDIF + ENDDO + NFIN=JFIN +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE PLM(X,PLMM,NC) +C +C This routine computes the Legendre functions. It is a modified version +C of that written by W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY and +C W.T. VETTERLING in "Numerical Recipes : The Art of Scientific +C Computing" (Cambridge University Press 1992). +C + DIMENSION PLMM(0:100,0:100) +C + PLMM(0,0)=1. + PLMM(1,0)=X + DO L=2,NC + PLMM(L,0)=(X*(L+L-1)*PLMM(L-1,0)-(L-1)*PLMM(L-2,0))/L + ENDDO +C + DO M=1,NC + PMM=1. + FACT=1. + SOMX2=SQRT(1.-X*X) + FACT=1. + DO I=1,M + PMM=-PMM*FACT*SOMX2 + FACT=FACT+2. + ENDDO + PMMP1=X*FACT*PMM + PLMM(M,M)=PMM + PLMM(M+1,M)=PMMP1 + IF(M.LT.NC-1) THEN + DO L=M+2,NC + PLL=(X*(L+L-1)*PMMP1-(L+M-1)*PMM)/(L-M) + PMM=PMMP1 + PMMP1=PLL + PLMM(L,M)=PLL + ENDDO + ENDIF + ENDDO +C + RETURN +C + END +C +C============================================================================= +C + SUBROUTINE POLHAN(ISPHER,NO,NC,RHO,HLM) +C +C This routine calculates a function HLM(L,M), related to the the Hankel +C polynomials and their derivatives with respect to z=1/ikr, +C necessary for the Rehr-Albers expansion of the propagator. +C + USE DIM_MOD +C + COMPLEX HLM(0:NO_ST_M,0:NL_M-1),RHO,Z,ONEC +C + ONEC=(1.,0.) +C + IF(ISPHER.GE.1) THEN + Z=(0.,-1.)/RHO +C +C Case M = 0 +C + HLM(0,0)=ONEC + HLM(0,1)=ONEC-Z + DO L=2,NC + HLM(0,L)=HLM(0,L-2)-FLOAT(L+L-1)*Z*HLM(0,L-1) + ENDDO +C +C Case M > 0 +C + IF(NO.GE.1) THEN + DO M=1,NO + HLM(M,M)=-Z*HLM(M-1,M-1)*FLOAT(M+M-1) + HLM(M,M+1)=HLM(M,M)*FLOAT(M+M+1)*(ONEC-Z*FLOAT(M+1)) + DO L=M+2,NC + HLM(M,L)=HLM(M,L-2)-FLOAT(L+L-1)*Z*(HLM(M,L-1)+HLM(M-1,L-1 + &)) + ENDDO + ENDDO + ENDIF + ELSE + DO M=0,NO + DO L=M,NC + HLM(M,L)=ONEC + ENDDO + ENDDO + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE POLLEG(NC,X,PL) +C +C This routine computes the Legendre polynomials up to order NC-1 +C + DIMENSION PL(0:100) +C + PL(0)=1. + PL(1)=X + DO 10 L=2,NC-1 + L1=L-1 + L2=L-2 + L3=2*L-1 + PL(L)=(X*FLOAT(L3)*PL(L1)-FLOAT(L1)*PL(L2))/FLOAT(L) + 10 CONTINUE +C + RETURN +C + END +C +C======================================================================= +C + FUNCTION PRSCAL(A1,A2) +C +C This function computes the dot product of the two vectors A1 and A2 +C + DIMENSION A1(3),A2(3) +C + PRSCAL=A1(1)*A2(1)+A1(2)*A2(2)+A1(3)*A2(3) +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE PRVECT(A1,A2,A3,C) +C +C This function computes the vector product of the two vectors A1 and A2. +C The result is A3; C is a scaling factor +C + DIMENSION A1(3),A2(3),A3(3) +C + A3(1)=(A1(2)*A2(3)-A1(3)*A2(2))/C + A3(2)=(A1(3)*A2(1)-A1(1)*A2(3))/C + A3(3)=(A1(1)*A2(2)-A1(2)*A2(1))/C +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*,*,*,*,*,*,*,*,*,* + &,*,*,*) +C +C This subroutine reads the input data from unit ICOM and writes +C them in the control file IUO1. Then, it stores the data in +C the various COMMON blocks +C +C Last modified : 26 Apr 2013 +C + USE DIM_MOD +C + USE ADSORB_MOD + USE AMPLI_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE COEFRLM_MOD + USE CONVACC_MOD + USE CONVTYP_MOD + USE C_G_MOD + USE C_G_A_MOD + USE C_G_M_MOD + USE CRANGL_MOD + USE DEBWAL_MOD , T => TEMP + USE DEXPFAC2_MOD + USE DFACTSQ_MOD + USE EIGEN_MOD + USE EXAFS_MOD + USE EXPFAC_MOD + USE EXPFAC2_MOD + USE EXPROT_MOD + USE FACTSQ_MOD + USE FDIF_MOD + USE FIXSCAN_MOD + USE FIXSCAN_A_MOD + USE HEADER_MOD , AUGER1 => AUGER + USE INDAT_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE INIT_A_MOD + USE INIT_J_MOD + USE INIT_L_MOD + USE INIT_M_MOD + USE LIMAMA_MOD + USE LINLBD_MOD + USE LOGAMAD_MOD + USE LPMOY_MOD , XM => XMTA, RH => RHOTA + USE MILLER_MOD + USE MOYEN_MOD + USE MOYEN_A_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RA_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPECTRUM_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE VALIN_AV_MOD + USE VALFIN_MOD + USE VALEX_A_MOD + USE XMRHO_MOD +C +C +C +C + REAL*8 J1,J2,MJ1,MJ2,MJ3,JJ,DXDEN,DEXPF + REAL*8 JJ_MIN,JJ_MAX,JJ12,JL12,SMALL,SQPI +C + REAL TEXTE1(10),TEXTE2(10),TEXTE3(10) + REAL TEXTE4(10),TEXTE5(10),TEXTE6(10) + REAL TEXTE6B(10),TEXTE7(10) + REAL THFWD(NATP_M),THBWD(NATP_M),GLG(0:N_GAUNT),NJ(0:N_GAUNT) + REAL ALPHAR,BETAR,RACC +C +C +C + DOUBLE PRECISION FACT1L,FACT2L +C +C +C +C +C + CHARACTER*7 TESLEC,RIEN +C +C + CHARACTER*3 CODRES(8),CODCTR(7),CRIST,CENTR,UNLENGTH +C +C + CHARACTER*1 EDGE_C,EDGE_I,EDGE_A,MULT + DATA CODRES/'CUB','TET','ORB','MNC','TCN','TRG','HEX','EXT'/ + DATA CODCTR/'P','I','F','R','A','B','C'/ + DATA PIS180,BOHR/0.017453,0.529177/ + DATA SQPI,SMALL /1.772453850906D0,1.D-6/ +C + I_EXT=0 + I_EXT_A=0 + IVG0=0 + IRET=0 + NCRIST=0 + NCENTR=0 + I_SO=0 + DO I=1,10 + PCREL(I)=0. + ENDDO + STEREO=' NO' +C +C +C.......... Reading of the input data in unit ICOM .......... +C +C + READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE1 + READ(ICOM,1) RIEN + READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE2 + READ(ICOM,1) RIEN +C + READ(ICOM,3) CRIST,CENTR,IBAS,NAT + READ(ICOM,4) A,BSURA,CSURA,UNIT +C + IF(IBAS.EQ.0) THEN + DO JLINE=1,100 + READ(ICOM,5) TESLEC + IF(TESLEC.EQ.'SPECTRO') THEN + BACKSPACE ICOM + BACKSPACE ICOM + BACKSPACE ICOM + GOTO 600 + ENDIF + ENDDO + ENDIF +C + READ(ICOM,6) ALPHAD,BETAD,GAMMAD + READ(ICOM,7) IH,IK,II,IL + READ(ICOM,8) NIV,COUPUR,ITEST,IESURF + IF(NAT.GT.1) THEN + DO I=1,NAT + J=3*(I-1) + READ(ICOM,9) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(I) + ENDDO + ELSE + READ(ICOM,9) X1,Y1,Z1,CHEM(1),NZA + ENDIF +C + READ(ICOM,5) TESLEC + IF(TESLEC.EQ.'VECBAS ') THEN + BACKSPACE ICOM + ELSE + IRET=10 + GOTO 605 + ENDIF +C + DO I=1,8 + IF(CRIST.EQ.CODRES(I)) NCRIST=I + IF(I.NE.8) THEN + IF(CENTR.EQ.CODCTR(I)) NCENTR=I + ENDIF + ENDDO + IF((NCRIST.EQ.0).OR.(NCENTR.EQ.0)) THEN + IRET=1 + GOTO 605 + ENDIF +C + IF(NCRIST.EQ.8) THEN + DO I=1,3 + J=3*(I-1) + IVN(I)=1 + READ(ICOM,9) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J) + IF(ABS(VECBAS(1+J)).LT.0.0001) THEN + IF(ABS(VECBAS(2+J)).LT.0.0001) THEN + IF(ABS(VECBAS(3+J)).LT.0.0001) THEN + IVG0=IVG0+1 + IVN(I)=0 + ENDIF + ENDIF + ENDIF + ENDDO + ELSE + READ(ICOM,9) X3,Y3,Z3 + READ(ICOM,9) X4,Y4,Z4 + READ(ICOM,9) X5,Y5,Z5 + ENDIF + READ(ICOM,10) IREL,NREL,(PCREL(I),I=1,2) + IF(IREL.EQ.1) THEN + IF(NREL.GT.2) THEN + NLIGNE=INT(FLOAT(NREL-2)/4.)+1 + DO J=1,NLIGNE + READ(ICOM,11) (PCREL(I),I=1,4) + ENDDO + ENDIF + IF(NREL.GT.10) THEN + IRET=4 + GOTO 605 + ENDIF + ELSEIF(IREL.EQ.0) THEN + NREL=0 + ENDIF + IF(NREL.EQ.0) THEN + DO JREL=1,10 + PCREL(JREL)=0. + ENDDO + ENDIF + READ(ICOM,12) OMEGAD1,OMEGAD2,IADS +C + READ(ICOM,1) RIEN + 600 READ(ICOM,2) TEXTE3 + READ(ICOM,1) RIEN +C + READ(ICOM,13) SPECTRO,ISPIN,IDICHR,IPOL + READ(ICOM,44) I_AMP +C + IF(SPECTRO.EQ.'PHD') THEN + INTERACT='DIPOLAR' + ELSEIF(SPECTRO.EQ.'LED') THEN + INTERACT='NOINTER' + ELSEIF(SPECTRO.EQ.'XAS') THEN + INTERACT='DIPOLAR' + ELSEIF(SPECTRO.EQ.'AED') THEN + INTERACT='COULOMB' + ELSEIF(SPECTRO.EQ.'APC') THEN + INTERACT='DIPCOUL' + ELSEIF(SPECTRO.EQ.'EIG') THEN + INTERACT='DIPOLAR' + ENDIF +C + IF((IPOL.EQ.0).AND.(IDICHR.GT.0)) THEN + PRINT 513 + STOP + ENDIF + IF((IDICHR.EQ.2).AND.(ISPIN.EQ.0)) THEN + PRINT 514 + STOP + ENDIF +C + IF(ISPIN.EQ.0) THEN + NSPIN2=1 + NSPIN=1 + ELSEIF(ISPIN.EQ.1) THEN + NSPIN2=4 + NSPIN=2 + ENDIF +C + IF(SPECTRO.EQ.'LED') THEN + DO JLINE=1,10 + READ(ICOM,1) RIEN + ENDDO + GOTO 607 + ELSEIF(SPECTRO.EQ.'XAS') THEN + IF(IDICHR.GT.1) THEN + PRINT 512 + STOP + ENDIF + DO JLINE=1,19 + READ(ICOM,1) RIEN + ENDDO + GOTO 602 + ELSEIF(SPECTRO.EQ.'AED') THEN + DO JLINE=1,24 + READ(ICOM,1) RIEN + ENDDO + GOTO 603 + ELSEIF(SPECTRO.EQ.'EIG') THEN + DO JLINE=1,34 + READ(ICOM,1) RIEN + ENDDO + GOTO 608 + ENDIF +C + IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN + READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE4 + READ(ICOM,1) RIEN +C + READ(ICOM,20) NI,NLI,S_O,INITL,I_SO +C + IF((NLI.EQ.'s').OR.(NLI.EQ.'S')) THEN + LI=0 + ELSEIF((NLI.EQ.'p').OR.(NLI.EQ.'P')) THEN + LI=1 + ELSEIF((NLI.EQ.'d').OR.(NLI.EQ.'D')) THEN + LI=2 + ELSEIF((NLI.EQ.'f').OR.(NLI.EQ.'F')) THEN + LI=3 + ELSEIF((NLI.EQ.'g').OR.(NLI.EQ.'G')) THEN + LI=4 + ELSE + IRET=5 + GOTO 605 + ENDIF + IF(LI.GT.LI_M) THEN + IRET=6 + GOTO 605 + ENDIF + IF(I_SO.EQ.0) THEN + S_O=' ' + ELSEIF(I_SO.EQ.1) THEN + IF(S_O.EQ.'1/2') THEN + IF(LI.GT.1) IRET=7 + ELSEIF(S_O.EQ.'3/2') THEN + IF((LI.LT.1).OR.(LI.GT.2)) IRET=7 + ELSEIF(S_O.EQ.'5/2') THEN + IF((LI.LT.2).OR.(LI.GT.3)) IRET=7 + ELSEIF(S_O.EQ.'7/2') THEN + IF((LI.LT.3).OR.(LI.GT.4)) IRET=7 + ELSEIF(S_O.EQ.'9/2') THEN + IF(LI.NE.4) IRET=7 + ENDIF + ELSEIF(I_SO.EQ.2) THEN + S_O=' ' + ENDIF +C + READ(ICOM,14) IPHI,ITHETA,IE,IFTHET + READ(ICOM,15) NPHI,NTHETA,NE,NFTHET + READ(ICOM,16) PHI0,THETA0,E0,R1 + READ(ICOM,16) PHI1,THETA1,EFIN,R2 + READ(ICOM,17) THLUM,PHILUM,ELUM + READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR +C + DO JLINE=1,9 + READ(ICOM,1) RIEN + ENDDO + ENDIF +C + 607 IF(SPECTRO.EQ.'LED') THEN + READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE4 + READ(ICOM,1) RIEN +C + READ(ICOM,14) IPHI,ITHETA,IE,IFTHET + READ(ICOM,15) NPHI,NTHETA,NE,NFTHET + READ(ICOM,16) PHI0,THETA0,E0,R1 + READ(ICOM,16) PHI1,THETA1,EFIN,R2 + READ(ICOM,17) TH_INI,PHI_INI + READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR +C + THLUM=TH_INI + PHILUM=PHI_INI + ELUM=0. + IDICHR=0 + INITL=0 + ENDIF +C + IF(SPECTRO.NE.'XAS') THEN + IF(IPHI.EQ.-1) THEN + IPHI=1 + I_EXT=0 + ICHKDIR=0 + STEREO='YES' + IF(ABS(PHI1-PHI0).LT.0.0001) THEN + PHI0=0. + PHI1=360. + NPHI=361 + ENDIF + IF(ABS(THETA1-THETA0).LT.0.0001) THEN + THETA0=0. + THETA1=88. + NTHETA=89 + ENDIF + ELSEIF(IPHI.EQ.2) THEN + IPHI=1 + I_EXT=1 + ELSEIF(IPHI.EQ.3) THEN + IPHI=1 + I_EXT=-1 + ELSEIF(ITHETA.EQ.2) THEN + ITHETA=1 + I_EXT=1 + ELSEIF(ITHETA.EQ.3) THEN + ITHETA=1 + I_EXT=-1 + ELSEIF(IE.EQ.2) THEN + IE=1 + I_EXT=1 + ELSEIF(IE.EQ.3) THEN + IE=1 + I_EXT=-1 + ELSEIF(IE.EQ.4) THEN + IF(SPECTRO.EQ.'PHD') THEN + IE=1 + I_EXT=2 + IMOD=0 + ELSE + IE=1 + I_EXT=1 + ENDIF + ENDIF + ENDIF +C + ICALC=IPHI*IE+IPHI*ITHETA+IE*ITHETA + IF((ICALC.NE.0).AND.(IFTHET.EQ.0)) IRET=3 +C +C When the direction of the analyzer might be experimentally +C inaccurate, the calculation will be done for nine +C direction across the one given in the data file +C with an increment of one degree. +C + IF(ICHKDIR.EQ.1) THEN + IF((ITHETA.EQ.1).AND.(IPHI.EQ.0)) THEN + NPHI=9 + PHI0=PHI0-4. + PHI1=PHI0+8. + ELSEIF((IPHI.EQ.1).AND.(ITHETA.EQ.0)) THEN + NTHETA=9 + THETA0=THETA0-4. + THETA1=THETA0+8. + ENDIF + ENDIF +C +C Initialization of the values for the scanned angle and the "fixed" one +C + IF(IPHI.EQ.1) THEN + N_FIXED=NTHETA + N_SCAN=NPHI + FIX0=THETA0 + FIX1=THETA1 + SCAN0=PHI0 + SCAN1=PHI1 + IPH_1=0 + ELSEIF(ITHETA.EQ.1) THEN + N_FIXED=NPHI + N_SCAN=NTHETA + FIX0=PHI0 + FIX1=PHI1 + SCAN0=THETA0 + SCAN1=THETA1 + IPH_1=1 + ELSEIF(IE.EQ.1) THEN + IF(NTHETA.GE.NPHI) THEN + N_FIXED=NPHI + N_SCAN=NTHETA + FIX0=PHI0 + FIX1=PHI1 + SCAN0=THETA0 + SCAN1=THETA1 + IPH_1=1 + ELSE + N_FIXED=NTHETA + N_SCAN=NPHI + FIX0=THETA0 + FIX1=THETA1 + SCAN0=PHI0 + SCAN1=PHI1 + IPH_1=0 + ENDIF + ENDIF +C + 602 IF(SPECTRO.EQ.'XAS') THEN + READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE5 + READ(ICOM,1) RIEN +C + READ(ICOM,39) EDGE,NEDGE,INITL,THLUM,PHILUM + READ(ICOM,19) NE_X,EK_INI,EK_FIN,EPH_INI +C + LI=NEDGE/2 + IF(NEDGE.GT.1) I_SO=2 + IF(EDGE.EQ.'K') THEN + NI=1 + ELSEIF(EDGE.EQ.'L') THEN + NI=2 + ELSEIF(EDGE.EQ.'M') THEN + NI=3 + ELSEIF(EDGE.EQ.'N') THEN + NI=4 + ELSEIF(EDGE.EQ.'O') THEN + NI=5 + ELSEIF(EDGE.EQ.'P') THEN + NI=6 + ENDIF + ELSE + DO JLINE=1,5 + READ(ICOM,1) RIEN + ENDDO + ENDIF +C + 603 IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN +C + READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE6 + READ(ICOM,1) RIEN +C + READ(ICOM,40) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A + READ(ICOM,42) I_MULT,IM1,MULT,IM2 + READ(ICOM,14) IPHI_A,ITHETA_A,IFTHET_A,I_INT + READ(ICOM,15) NPHI_A,NTHETA_A,NFTHET_A + READ(ICOM,41) PHI0_A,THETA0_A,R1_A + READ(ICOM,41) PHI1_A,THETA1_A,R2_A + READ(ICOM,18) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A +C + LI_C=NEDGE_C/2 + LI_I=NEDGE_I/2 + LI_A=NEDGE_A/2 +C + IF((EDGE_I.EQ.EDGE_A).AND.(LI_I.EQ.LI_A)) THEN + I_SHELL=1 + ELSE + I_SHELL=0 + ENDIF +C + IE_A=0 + NE_A=1 + I_CP_A=0 +C + IF(EDGE_C.EQ.'K') THEN + AUGER=' '//EDGE_C//EDGE_I//CHAR(48+NEDGE_I)//EDGE_A//CHAR(48+N + &EDGE_A) + ELSE + AUGER=EDGE_C//CHAR(48+NEDGE_C)//EDGE_I//CHAR(48+NEDGE_I)//EDGE + &_A//CHAR(48+NEDGE_A) + ENDIF + AUGER1=AUGER +C + IF(IPHI_A.EQ.-1) THEN + IPHI_A=1 + I_EXT_A=0 + ICHKDIR_A=0 + STEREO='YES' + IF(ABS(PHI1_A-PHI0_A).LT.0.0001) THEN + PHI0_A=0. + PHI1_A=360. + NPHI_A=361 + ENDIF + IF(ABS(THETA1_A-THETA0_A).LT.0.0001) THEN + THETA0_A=0. + THETA1_A=88. + NTHETA_A=89 + ENDIF + ELSEIF(IPHI_A.EQ.2) THEN + IPHI_A=1 + I_EXT_A=1 + ELSEIF(IPHI_A.EQ.3) THEN + IPHI_A=1 + I_EXT_A=-1 + ELSEIF(ITHETA_A.EQ.2) THEN + ITHETA_A=1 + I_EXT_A=1 + ELSEIF(ITHETA_A.EQ.3) THEN + ITHETA_A=1 + I_EXT_A=-1 + ENDIF +C +C Check for the consistency of the data for the two electrons in +C APECS, in particular when the sample is rotated (IMOD=1) +C + IF(SPECTRO.EQ.'APC') THEN + IF((LI_C.NE.LI).OR.(IMOD_A.NE.IMOD)) THEN + IRET=11 + GOTO 605 + ENDIF + DTH=THETA1-THETA0 + DTH_A=THETA1_A-THETA0_A + DPH=PHI1-PHI0 + DPH_A=PHI1_A-PHI0_A + IF((IMOD_A.EQ.1).AND.(IPHI_A.NE.IPHI)) IRET=13 + IF((IMOD_A.EQ.1).AND.(ITHETA_A.NE.ITHETA)) IRET=13 + IF((IMOD_A.EQ.1).AND.(NPHI_A.NE.NPHI)) IRET=13 + IF((IMOD_A.EQ.1).AND.(NTHETA_A.NE.NTHETA)) IRET=13 + IF((IMOD_A.EQ.1).AND.(DTH_A.NE.DTH)) IRET=13 + IF((IMOD_A.EQ.1).AND.(DPH_A.NE.DPH)) IRET=13 + ENDIF +C +C When the direction of the analyzer might be experimentally +C inaccurate, the calculation will be done for nine +C direction across the one given in the data file +C with an increment of one degree. +C + IF(ICHKDIR_A.EQ.1) THEN + IF((ITHETA_A.EQ.1).AND.(IPHI_A.EQ.0)) THEN + NPHI_A=9 + PHI0_A=PHI0_A-4. + PHI1_A=PHI0_A+8. + ELSEIF((IPHI_A.EQ.1).AND.(ITHETA_A.EQ.0)) THEN + NTHETA_A=9 + THETA0_A=THETA0_A-4. + THETA1_A=THETA0_A+8. + ENDIF + ENDIF +C +C Initialization of the values for the scanned angle and the "fixed" one +C + IF(IPHI_A.EQ.1) THEN + N_FIXED_A=NTHETA_A + N_SCAN_A=NPHI_A + FIX0_A=THETA0_A + FIX1_A=THETA1_A + SCAN0_A=PHI0_A + SCAN1_A=PHI1_A + IPH_1_A=0 + ELSEIF(ITHETA_A.EQ.1) THEN + N_FIXED_A=NPHI_A + N_SCAN_A=NTHETA_A + FIX0_A=PHI0_A + FIX1_A=PHI1_A + SCAN0_A=THETA0_A + SCAN1_A=THETA1_A + IPH_1_A=1 + ENDIF +C + ELSE + DO JLINE=1,10 + READ(ICOM,1) RIEN + ENDDO + ENDIF +C + IF(SPECTRO.EQ.'XAS') THEN + I_CP=1 + NE=NE_X + ELSE + I_CP=0 + ENDIF +C + 608 IF(SPECTRO.EQ.'EIG') THEN +C + READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE6B + READ(ICOM,1) RIEN +C + READ(ICOM,43) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP +C + NE=NE_EIG + N_LINE_E=INT((FLOAT(NE_EIG)-0.0001)/4.)+1 + N_LAST=4-(4*N_LINE_E-NE_EIG) +C + IF(N_LINE_E.GT.1) THEN + DO JLINE=1,N_LINE_E-1 + J=(JLINE-1)*4 + READ(ICOM,7) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3 + &),I_SPECTRUM(J+4) + ENDDO + ENDIF +C + J=4*(N_LINE_E-1) +C + READ(ICOM,7) (I_SPECTRUM(J+K), K=1,N_LAST) +C + READ(ICOM,46) I_PWM,METHOD,RACC,EXPO + READ(ICOM,47) N_MAX,N_ITER,N_TABLE,SHIFT + READ(ICOM,48) I_XN,I_VA,I_GN,I_WN + READ(ICOM,49) LEVIN,ALPHAR,BETAR +C + ACC=DBLE(RACC) + IF(ABS(I_PWM).LE.2) THEN + I_ACC=0 + N_ITER=N_MAX + ELSEIF(I_PWM.EQ.3) THEN + I_ACC=1 + N_ITER=N_MAX + ELSEIF(I_PWM.EQ.-3) THEN + I_ACC=-1 + N_ITER=N_MAX + ELSEIF(I_PWM.EQ.4) THEN + I_ACC=2 + ELSEIF(I_PWM.EQ.-4) THEN + I_ACC=-2 + ENDIF + IF(N_MAX.LT.N_ITER) N_ITER=N_MAX +C + ALPHA=DCMPLX(ALPHAR) + BETA=DCMPLX(BETAR) +C +C + ELSE + DO JLINE=1,9 + READ(ICOM,1) RIEN + ENDDO +C + ENDIF +C + 609 READ(ICOM,1) RIEN + READ(ICOM,2) TEXTE7 + READ(ICOM,1) RIEN +C + READ(ICOM,21) NO,NDIF,ISPHER,I_GR +C + IF(ISPHER.EQ.0) THEN + IDWSPH=0 + NO=0 + ENDIF + IF(NO.LT.0) NO=8 + NUMAX(1)=NO/2 +C + READ(ICOM,22) ISFLIP,IR_DIA,ITRTL,I_TEST +C + IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) I_TEST_A=I_TEST + IF(I_TEST.EQ.1) THEN + IF(INTERACT.EQ.'DIPOLAR') THEN + INITL=1 + LI=0 + IPOL=1 + ELSEIF(INTERACT.EQ.'COULOMB') THEN + LI_C=0 + LI_I=0 + ENDIF + ENDIF +C + READ(ICOM,23) NEMET +C + BACKSPACE ICOM + NLG=INT((NEMET-0.0001)/3) +1 + DO N=1,NLG + NRL=3*N + JD=3*(N-1)+1 + IF(N.EQ.NLG) NRL=NEMET + READ(ICOM,24) NEMO,(IEMET(J), J=JD, NRL) + IF(N.EQ.1) NEMET1=NEMO + ENDDO +C + READ(ICOM,25) ISOM,NONVOL(JFICH),NPATHP,VINT +C + IF(I_TEST.EQ.2) THEN + IF(ABS(IPOL).EQ.1) THEN + THLUM=-90. + PHILUM=0. + ELSEIF(ABS(IPOL).EQ.2) THEN + THLUM=0. + PHILUM=0. + ENDIF + IMOD=0 + VINT=0. + A=1. + ENDIF +C + IF((NFICHLEC.EQ.1).OR.(IBAS.EQ.1)) ISOM=0 +C + READ(ICOM,26) IFWD,NTHOUT,I_NO,I_RA +C + IF(NTHOUT.EQ.NDIF-1) IFWD=0 +C + IF(I_RA.EQ.1) NO=0 + DO JAT=1,NAT + READ(ICOM,27) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT) + IF(I_RA.EQ.0) THEN + N_RA(JAT)=NO + NUMAX(JAT)=NO/2 + ELSEIF(I_RA.EQ.1) THEN + NUMAX(JAT)=N_RA(JAT)/2 + NO=MAX(N_RA(JAT),NO) + ENDIF + ENDDO +C + READ(ICOM,5) TESLEC + IF(TESLEC.EQ.'IPW,NCU') THEN + BACKSPACE ICOM + ELSE + IRET=8 + GOTO 605 + ENDIF +C + READ(ICOM,28) IPW,NCUT,PCTINT,IPP + READ(ICOM,29) ILENGTH,RLENGTH,UNLENGTH + READ(ICOM,30) IDWSPH,ISPEED,IATTS,IPRINT +C + IF(IDWSPH.EQ.0) ISPEED=1 +C + READ(ICOM,31) IDCM,TD,T,RSJ + READ(ICOM,32) ILPM,XLPM0 +C + IF((IDCM.GE.1).OR.(ILPM.EQ.1)) THEN + CALL ATDATA + ENDIF + NLEC=INT((NAT-0.0001)/4)+1 +C + DO I=1,NLEC + NDEB=4*(I-1) + 1 + NFIN=MIN0(4*I,NAT) + READ(ICOM,33) (UJ2(J),J=NDEB,NFIN) + ENDDO +C + DO JLINE=1,5 + READ(ICOM,1) RIEN + ENDDO + READ(ICOM,5) TESLEC + IF(TESLEC.EQ.'DATA FI') THEN + BACKSPACE ICOM + ELSE + IRET=9 + GOTO 605 + ENDIF +C + READ(ICOM,34) INFILE1,IUI1 + READ(ICOM,34) INFILE2,IUI2 + READ(ICOM,34) INFILE3,IUI3 + READ(ICOM,34) INFILE4,IUI4 + READ(ICOM,34) INFILE5,IUI5 + READ(ICOM,34) INFILE6,IUI6 +C + IF(SPECTRO.NE.'APC') THEN + DO JLINE=1,9 + READ(ICOM,1) RIEN + ENDDO + ELSE + DO JLINE=1,6 + READ(ICOM,1) RIEN + ENDDO + READ(ICOM,34) INFILE7,IUI7 + READ(ICOM,34) INFILE8,IUI8 + READ(ICOM,34) INFILE9,IUI9 + ENDIF +C +C Set up of the switch controlling external +C reading of the detector directions and +C averaging over them for an undetected electron +C + IF(SPECTRO.EQ.'APC') THEN + IF((I_EXT.EQ.-1).OR.(I_EXT_A.EQ.-1)) THEN + IF(I_EXT*I_EXT_A.EQ.0) THEN + WRITE(IUO1,523) + I_EXT=-1 + I_EXT_A=-1 + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI6,713) IDIR,NSET + READ(IUI9,713) IDIR_A,NSET_A + IF(IDIR.EQ.2) THEN + IF(NSET.NE.NSET_A) WRITE(IUO1,524) NSET,NSET_A + STOP + ENDIF + ENDIF + ENDIF + IF(I_INT.EQ.1) THEN + I_EXT=2 + ELSEIF(I_INT.EQ.2) THEN + I_EXT_A=2 + ELSEIF(I_INT.EQ.3) THEN + I_EXT=2 + I_EXT_A=2 + ENDIF + ENDIF +C + IF(I_EXT.EQ.-1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,701) IDIR,I_SET,N_POINTS + READ(IUI6,702) I_PH,N_FIXED,N_SCAN + DO JS=1,I_SET + READ(IUI6,703) TH_0(JS),PH_0(JS) + ENDDO + CLOSE(IUI6) + IF(IDIR.NE.2) IRET=12 + IF(I_PH.NE.IPH_1) IPH_1=I_PH + IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN + IF(I_PH.EQ.0) THEN + NTHETA=N_FIXED + NPHI=N_SCAN + ELSE + NTHETA=N_SCAN + NPHI=N_FIXED + ENDIF + ICHKDIR=2 + ENDIF + ENDIF + IF(I_EXT.GE.1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,701) IDIR,I_SET,N_POINTS + CLOSE(IUI6) + IF((IDIR.NE.1).AND.(I_EXT.EQ.2)) IRET=12 + N_FIXED=N_POINTS + N_SCAN=1 + NTHETA=N_POINTS + NPHI=1 + ENDIF + IF(I_EXT_A.GE.1) THEN + IF(SPECTRO.EQ.'APC') THEN + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A + CLOSE(IUI9) + ELSE + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A + CLOSE(IUI6) + ENDIF + IF((IDIR_A.NE.1).AND.(I_EXT_A.EQ.2)) IRET=12 + N_FIXED_A=N_POINTS_A + N_SCAN_A=1 + NTHETA_A=N_POINTS_A + NPHI_A=1 + ENDIF +C + IF(I_EXT_A.EQ.-1) THEN + IF(SPECTRO.EQ.'APC') THEN + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A + READ(IUI9,702) I_PH_A,N_FIXED_A,N_SCAN_A + CLOSE(IUI9) + ELSE + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A + READ(IUI6,702) I_PH_A,N_FIXED_A,N_SCAN_A + CLOSE(IUI6) + ENDIF + IF(IDIR_A.NE.2) IRET=12 + IF(I_PH_A.EQ.0) THEN + NTHETA_A=N_FIXED_A + NPHI_A=N_SCAN_A + ELSE + NTHETA_A=N_SCAN_A + NPHI_A=N_FIXED_A + ENDIF + ICHKDIR_A=2 + ENDIF +C + DO JLINE=1,5 + READ(ICOM,1) RIEN + ENDDO +C + READ(ICOM,34) OUTFILE1,IUO1 + READ(ICOM,34) OUTFILE2,IUO2 + READ(ICOM,34) OUTFILE3,IUO3 + READ(ICOM,34) OUTFILE4,IUO4 +C + IUSCR=MAX0(ICOM,IUI2,IUI3,IUI4,IUI5,IUI6,IUI7,IUI8,IUI9,IUO1,IUO2, + &IUO3,IUO4)+1 + IUSCR2=IUSCR+1 +C + IF(IADS.GE.1) THEN + OPEN(UNIT=IUI5, FILE=INFILE5, STATUS='OLD') + READ(IUI5,1) RIEN + READ(IUI5,12) NATA,NADS1,NADS2,NADS3 + IF(NATA.EQ.1) THEN + NADS2=0 + NADS3=0 + ELSEIF(NATA.EQ.2) THEN + NADS3=0 + ENDIF + READ(IUI5,35) (NZAT(I),I=NAT+1,NAT+NATA) + READ(IUI5,36) (CHEM(I),I=NAT+1,NAT+NATA) + READ(IUI5,37) (UJ2(NAT+J),J=1,NATA) + READ(IUI5,38) NRELA,(PCRELA(I),I=1,NRELA) + IF(NRELA.EQ.0) THEN + DO JRELA=1,3 + PCRELA(JRELA)=0. + ENDDO + ENDIF + NADS=NADS1+NADS2+NADS3 + DO JADS=1,NADS + READ(IUI5,9) (ADS(I,JADS),I=1,3) + ENDDO + CLOSE(IUI5) + ELSE + NATA=0 + NRELA=0 + ENDIF +C + GOTO 601 +C + 605 REWIND ICOM + DO JLINE=1,500 + READ(ICOM,5) TESLEC + IF(TESLEC.EQ.'CONTROL') THEN + BACKSPACE ICOM + READ(ICOM,34) OUTFILE1,IUO1 + GOTO 601 + ENDIF + ENDDO +C + 601 IF((JFICH.EQ.1).OR.(ISOM.EQ.0)) THEN +c LINE REMOVED BY PYMSSPEC + ENDIF + IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN + WRITE(IUO1,105) INDATA(JFICH) + ENDIF +C + IF(IRET.EQ.1) RETURN 1 + IF(IRET.EQ.3) RETURN 3 + IF(IRET.EQ.4) RETURN 4 + IF(IRET.EQ.5) RETURN 5 + IF(IRET.EQ.6) RETURN 6 + IF(IRET.EQ.7) RETURN 7 + IF(IRET.EQ.8) RETURN 8 + IF(IRET.EQ.9) RETURN 9 + IF(IRET.EQ.10) RETURN 10 + IF(IRET.EQ.11) RETURN 11 + IF(IRET.EQ.12) RETURN 12 + IF(IRET.EQ.13) RETURN 13 +C +C +C.......... Writing of the input data in unit IUO1 .......... +C +C + WRITE(IUO1,100) + WRITE(IUO1,101) + WRITE(IUO1,101) + WRITE(IUO1,102) TEXTE1 + WRITE(IUO1,101) + WRITE(IUO1,101) + WRITE(IUO1,203) +C + IF(I_TEST.NE.2) THEN + WRITE(IUO1,201) TEXTE2 + ELSE + IF(ABS(IPOL).EQ.1) THEN + WRITE(IUO1,525) + ELSEIF(ABS(IPOL).EQ.2) THEN + WRITE(IUO1,526) + ENDIF + ENDIF +C + IF(NAT.GT.NATP_M) RETURN 2 + IF(NE.GT.NE_M) RETURN 2 + IF(NEMET.GT.NEMET_M) RETURN 2 +C + IF(I_TEST.EQ.2) GOTO 606 + IF(IBAS.EQ.0) THEN + WRITE(IUO1,204) A,IBAS + GOTO 604 + ENDIF + WRITE(IUO1,103) CRIST,CENTR,IBAS,NAT + IF(NCRIST.EQ.1) THEN + BSURA=1. + CSURA=1. + WRITE(IUO1,304) A + ELSEIF((NCRIST.EQ.2).OR.(NCRIST.EQ.7).OR.(NCRIST.EQ.6)) THEN + BSURA=1. + WRITE(IUO1,404) A,CSURA + IF((NCRIST.EQ.6).AND.(CSURA.EQ.1.)) THEN + WRITE(IUO1,206) ALPHAD + ELSEIF(NCRIST.EQ.4) THEN + WRITE(IUO1,306) BETAD + ENDIF + ELSEIF((NCRIST.EQ.3).OR.(NCRIST.EQ.5).OR.(NCRIST.EQ.8)) THEN + WRITE(IUO1,104) A,BSURA,CSURA + IF(NCRIST.NE.3) THEN + WRITE(IUO1,106) ALPHAD,BETAD,GAMMAD + ENDIF + ENDIF + IF(NCRIST.EQ.7) THEN + WRITE(IUO1,107) IH,IK,II,IL + ELSE + WRITE(IUO1,207) IH,IK,IL + ENDIF + WRITE(IUO1,108) NIV,COUPUR,ITEST,IESURF + IF(NAT.GT.1) THEN + DO I=1,NAT + J=3*(I-1) + WRITE(IUO1,109) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT( + &I) + ENDDO + ENDIF + IF(NCRIST.EQ.8) THEN + DO I=1,3 + J=3*(I-1) + WRITE(IUO1,209) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J) + ENDDO + ENDIF + IF(IREL.GE.1) THEN + WRITE(IUO1,110) IREL,NREL,(PCREL(I),I=1,2) + IF(NREL.GT.2) THEN + NLIGNE=INT(FLOAT(NREL-2)/4.)+1 + DO J=1,NLIGNE + WRITE(IUO1,210) (PCREL(I),I=1,4) + ENDDO + ENDIF + IF(NREL.GT.10) RETURN 4 + WRITE(IUO1,112) OMEGAD1,OMEGAD2,IADS + ENDIF + IF((IREL.EQ.0).AND.(IADS.EQ.1)) WRITE(IUO1,212) IADS + IF(IADS.GE.1) THEN + WRITE(IUO1,501) + DO JADS=1,NADS + IF(JADS.LE.NADS1) THEN + IF(JADS.EQ.1) WRITE(IUO1,303) NAT+1 + WRITE(IUO1,309) (ADS(I,JADS),I=1,3) + ELSEIF((JADS.GT.NADS1).AND.(JADS.LE.(NADS1+NADS2))) THEN + IF(JADS.EQ.(NADS1+1)) WRITE(IUO1,303) NAT+2 + WRITE(IUO1,309) (ADS(I,JADS),I=1,3) + ELSEIF(JADS.GT.(NADS1+NADS2)) THEN + IF(JADS.EQ.(NADS2+1)) WRITE(IUO1,303) NAT+3 + WRITE(IUO1,309) (ADS(I,JADS),I=1,3) + ENDIF + ENDDO + ENDIF + IF((IREL.GT.0).OR.(NRELA.GT.0)) WRITE(IUO1,502) + IF(NRELA.GT.0) THEN + WRITE(IUO1,311) (PCRELA(I),I=1,NRELA) + ENDIF + 604 IF(IREL.GT.0) THEN + WRITE(IUO1,211) (PCREL(I),I=1,NREL) + ENDIF +C + 606 IF(SPECTRO.EQ.'APC') WRITE(IUO1,517) +C + IF(SPECTRO.EQ.'PHD') THEN +C + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,503) + ELSE + WRITE(IUO1,527) + ENDIF + ENDIF + IF(IE.EQ.1) WRITE(IUO1,504) + IF(ITHETA.EQ.1) WRITE(IUO1,505) + IF(IFTHET.EQ.1) WRITE(IUO1,506) + IF(I_AMP.EQ.1) WRITE(IUO1,534) +C + WRITE(IUO1,201) TEXTE4 + WRITE(IUO1,113) ISPIN,IDICHR,IPOL + WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO + WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET + WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET +C + IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN + IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN + WRITE(IUO1,508) + STOP + ENDIF + IF(ABS(THLUM).GT.90.0) THEN + WRITE(IUO1,509) + STOP + ENDIF + ENDIF +C + WRITE(IUO1,116) PHI0,THETA0,E0,R1 + WRITE(IUO1,216) PHI1,THETA1,EFIN,R2 + WRITE(IUO1,117) THLUM,PHILUM,ELUM + WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR +C + IF(IMOY.GT.3) IMOY=3 + IF(IMOY.LT.0) IMOY=0 + IF(IMOY.EQ.0) NDIR=1 + IF(IMOY.EQ.1) NDIR=5 + IF(IMOY.EQ.2) NDIR=13 + IF(IMOY.EQ.3) NDIR=49 + IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1 +C + ELSEIF(SPECTRO.EQ.'LED') THEN +C + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,529) + ELSE + WRITE(IUO1,530) + ENDIF + ENDIF + IF(IE.EQ.1) WRITE(IUO1,531) + IF(ITHETA.EQ.1) WRITE(IUO1,532) + IF(IFTHET.EQ.1) WRITE(IUO1,506) + IF(I_AMP.EQ.1) WRITE(IUO1,534) +C + WRITE(IUO1,201) TEXTE4 + WRITE(IUO1,141) ISPIN + WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET + WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET +C + IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN + IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN + WRITE(IUO1,508) + STOP + ENDIF + ENDIF +C + WRITE(IUO1,116) PHI0,THETA0,E0,R1 + WRITE(IUO1,216) PHI1,THETA1,EFIN,R2 + WRITE(IUO1,142) TH_INI,PHI_INI + WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR +C + IF(IMOY.GT.3) IMOY=3 + IF(IMOY.LT.0) IMOY=0 + IF(IMOY.EQ.0) NDIR=1 + IF(IMOY.EQ.1) NDIR=5 + IF(IMOY.EQ.2) NDIR=13 + IF(IMOY.EQ.3) NDIR=49 +C + ELSEIF(SPECTRO.EQ.'XAS') THEN +C + WRITE(IUO1,507) + IF(I_AMP.EQ.1) WRITE(IUO1,534) + WRITE(IUO1,201) TEXTE5 + WRITE(IUO1,113) ISPIN,IDICHR,IPOL + WRITE(IUO1,134) EDGE,NEDGE,INITL,THLUM,PHILUM + WRITE(IUO1,119) NE_X,EK_INI,EK_FIN,EPH_INI +C + ELSEIF(SPECTRO.EQ.'AED') THEN +C + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,515) + ELSE + WRITE(IUO1,528) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,516) + IF(I_AMP.EQ.1) WRITE(IUO1,534) + WRITE(IUO1,201) TEXTE6 + WRITE(IUO1,113) ISPIN,IDICHR,IPOL + WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A + WRITE(IUO1,140) I_MULT,IM1,MULT,IM2 + WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT + WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A + WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A + WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A + WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A +C + IF(IMOY_A.GT.3) IMOY_A=3 + IF(IMOY_A.LT.0) IMOY_A=0 + IF(IMOY_A.EQ.0) NDIR_A=1 + IF(IMOY_A.EQ.1) NDIR_A=5 + IF(IMOY_A.EQ.2) NDIR_A=13 + IF(IMOY_A.EQ.3) NDIR_A=49 +C + ELSEIF(SPECTRO.EQ.'APC') THEN +C + WRITE(IUO1,518) + IF(IPHI.EQ.1) WRITE(IUO1,503) + IF(ITHETA.EQ.1) WRITE(IUO1,505) + IF(IFTHET.EQ.1) WRITE(IUO1,506) + IF(I_AMP.EQ.1) WRITE(IUO1,534) +C + WRITE(IUO1,201) TEXTE4 + WRITE(IUO1,113) ISPIN,IDICHR,IPOL + WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO + WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET + WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET +C + IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN + IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN + WRITE(IUO1,508) + STOP + ENDIF + IF(ABS(THLUM).GT.90.0) THEN + WRITE(IUO1,509) + STOP + ENDIF + ENDIF +C + WRITE(IUO1,116) PHI0,THETA0,E0,R1 + WRITE(IUO1,216) PHI1,THETA1,EFIN,R2 + WRITE(IUO1,117) THLUM,PHILUM,ELUM + WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR +C + IF(IMOY.GT.3) IMOY=3 + IF(IMOY.LT.0) IMOY=0 + IF(IMOY.EQ.0) NDIR=1 + IF(IMOY.EQ.1) NDIR=5 + IF(IMOY.EQ.2) NDIR=13 + IF(IMOY.EQ.3) NDIR=49 + IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1 +C + WRITE(IUO1,519) + IF(IPHI_A.EQ.1) WRITE(IUO1,515) + IF(ITHETA_A.EQ.1) WRITE(IUO1,516) + WRITE(IUO1,201) TEXTE6 + WRITE(IUO1,113) ISPIN,IDICHR,IPOL + WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A + WRITE(IUO1,140) I_MULT,IM1,MULT,IM2 + WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT + WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A + WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A + WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A + WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A +C + IF(IMOY_A.GT.3) IMOY_A=3 + IF(IMOY_A.LT.0) IMOY_A=0 + IF(IMOY_A.EQ.0) NDIR_A=1 + IF(IMOY_A.EQ.1) NDIR_A=5 + IF(IMOY_A.EQ.2) NDIR_A=13 + IF(IMOY_A.EQ.3) NDIR_A=49 +C + WRITE(IUO1,520) +C + ELSEIF(SPECTRO.EQ.'EIG') THEN +C + WRITE(IUO1,143) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP + DO JLINE=1,N_LINE_E-1 + J=(JLINE-1)*4 + WRITE(IUO1,145) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3 + &),I_SPECTRUM(J+4) + ENDDO + J=4*(N_LINE_E-1) + WRITE(IUO1,145) (I_SPECTRUM(J+K),K=1,N_LAST) +C + WRITE(IUO1,146) I_PWM,METHOD,RACC,EXPO + WRITE(IUO1,147) N_MAX,N_ITER,N_TABLE,SHIFT + WRITE(IUO1,148) I_XN,I_VA,I_GN,I_WN + WRITE(IUO1,149) LEVIN,ALPHAR,BETAR + WRITE(IUO1,533) +C + ENDIF +C + WRITE(IUO1,201) TEXTE7 +C + IF(SPECTRO.NE.'EIG') THEN +C + WRITE(IUO1,121) NO,NDIF,ISPHER,I_GR +C + IF(SPECTRO.EQ.'XAS') NDIF=NDIF+1 +C + WRITE(IUO1,122) ISFLIP,IR_DIA,ITRTL,I_TEST +C + IF(ISFLIP.EQ.0) THEN + NSTEP=3 + ELSE + NSTEP=1 + ENDIF + DO N=1,NLG + NRL=3*N + JD=3*(N-1)+1 + IF(N.EQ.NLG) NRL=NEMET + IF(N.EQ.1) NEMO=NEMET1 + IF(N.LT.NLG) THEN + WRITE(IUO1,123) NEMO,(IEMET(J), J=JD, NRL) + ELSE + NTE=NEMET-JD+1 + IF(NTE.EQ.1) WRITE(IUO1,223) NEMO,(IEMET(J),J=JD,NEMET) + IF(NTE.EQ.2) WRITE(IUO1,323) NEMO,(IEMET(J),J=JD,NEMET) + IF(NTE.EQ.3) WRITE(IUO1,123) NEMO,(IEMET(J),J=JD,NEMET) + ENDIF + ENDDO + ENDIF + IF(SPECTRO.NE.'EIG') THEN + WRITE(IUO1,124) ISOM,NONVOL(JFICH),NPATHP,VINT + WRITE(IUO1,125) IFWD,NTHOUT,I_NO,I_RA + DO JAT=1,NAT + WRITE(IUO1,126) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT) + RTHFWD(JAT)=THFWD(JAT)*PIS180 + RTHBWD(JAT)=THBWD(JAT)*PIS180 + ENDDO + WRITE(IUO1,127) IPW,NCUT,PCTINT,IPP + WRITE(IUO1,128) ILENGTH,RLENGTH,UNLENGTH + WRITE(IUO1,129) IDWSPH,ISPEED,IATTS,IPRINT + ELSE + WRITE(IUO1,144) VINT + ENDIF + WRITE(IUO1,130) IDCM,TD,T,RSJ + WRITE(IUO1,131) ILPM,XLPM0 + DO I=1,NLEC + NDEB=4*(I-1) + 1 + NFIN=4*I + IF(I.EQ.NLEC) NFIN=NAT + NUJ=NFIN-NDEB+1 + IF(NUJ.EQ.1) WRITE(IUO1,132) (UJ2(J),J=NDEB,NFIN) + IF(NUJ.EQ.2) WRITE(IUO1,232) (UJ2(J),J=NDEB,NFIN) + IF(NUJ.EQ.3) WRITE(IUO1,332) (UJ2(J),J=NDEB,NFIN) + IF(NUJ.EQ.4) WRITE(IUO1,432) (UJ2(J),J=NDEB,NFIN) + ENDDO + IF(IADS.EQ.1) THEN + IF(NATA.EQ.1) WRITE(IUO1,133) (UJ2(J),J=NAT+1,NAT+NATA) + IF(NATA.EQ.2) WRITE(IUO1,233) (UJ2(J),J=NAT+1,NAT+NATA) + IF(NATA.EQ.3) WRITE(IUO1,333) (UJ2(J),J=NAT+1,NAT+NATA) + ENDIF +C + IF(UNLENGTH.EQ.'ATU') RLENGTH=RLENGTH*BOHR/A + IF(UNLENGTH.EQ.'ANG') RLENGTH=RLENGTH/A + IF(IBAS.GT.0) THEN + OMEGA1=OMEGAD1*PIS180 + OMEGA2=OMEGAD2*PIS180 + ENDIF + QD=0. + DO J=1,NATM + UJ2(J)=UJ2(J)/(A*A) + ENDDO + IF(E0.EQ.0.) E0=0.0001 + NPOINT=NPHI*NE*NTHETA + ISORT1=0 + IF(NPOINT.GT.250) THEN + ISORT1=1 + WRITE(IUO1,510) + ENDIF +C + IF(IDWSPH.EQ.1) THEN + NFAC=N_GAUNT + ELSE + NFAC=4*NL_M + ENDIF + IF(SPECTRO.EQ.'EIG') THEN +C +C Switch for including vibrational damping into the MS matrix +C +C I_VIB = 0 : no vibrations included +C I_VIB = 1 : vibrations included +C +C and mean free path-like damping +C +C I_MFP = 0 : no Im(k) damping included +C I_MFP = 1 : Im(k) damping included +C + I_VIB=MOD(I_DAMP,2) + IF(I_VIB.EQ.1) THEN + IDWSPH=1 + ELSE + IDWSPH=0 + ENDIF + IF(I_DAMP.LE.1) THEN + I_MFP=0 + ELSE + I_MFP=1 + ENDIF + ENDIF +C +C Storage of the logarithm of the Gamma function GLD(N+1,N_INT) +C for integer (N_INT=1) and semi-integer (N_INT=2) values : +C +C GLD(N+1,1) = Log(N!) for N integer +C GLD(N+1/2,2) = Log(N!) for N semi-integer +C + IF((ISPHER.GE.0).OR.(I_MULT.EQ.1)) THEN + GLG(1)=0.0 + GLD(1,1)=0.D0 + GLD(1,2)=DLOG(SQPI/2.D0) + DO I=2,NFAC + J=I-1 + GLG(I)=GLG(J)+ALOG(FLOAT(J)) + GLD(I,1)=GLD(J,1)+DLOG(DFLOAT(J)) + GLD(I,2)=GLD(J,2)+DLOG(DFLOAT(J) +0.5D0) + ENDDO + ELSEIF((IFTHET.EQ.1).AND.(ITEST.EQ.1)) THEN + GLG(1)=0.0 + DO I=2,NFAC + J=I-1 + GLG(I)=GLG(J)+ALOG(FLOAT(J)) + ENDDO + ENDIF + EXPF(0,0)=1. + EXPR(0,0)=1. + FACT1L=0.D0 + DO L=1,2*NL_M-2 + XDEN=1./SQRT(FLOAT(L+L+1)) + DXDEN=1.D0/DSQRT(DFLOAT(L+L+1)) + FACT1L=FACT1L+DLOG(DFLOAT(L)) + FACT2L=DLOG(DFLOAT(L+1)) + DO M1=0,L + EXPF(M1,L)=EXP(0.5*(GLG(L+M1+1)-GLG(L-M1+1))) + DEXPF=DEXP(0.5D0*(GLD(L+M1+1,1)-GLD(L-M1+1,1))) + EXPR(M1,L)=EXP(0.5*(GLG(L+L+1)-GLG(L+M1+1)-GLG(L-M1+1))) + EXPF2(L,M1)=EXPF(M1,L)*XDEN + DEXPF2(L,M1)=DEXPF*DXDEN + IF(M1.GT.0) THEN + FACT2L=FACT2L+DLOG(DFLOAT(1+L+M1)) + ENDIF + IF(L.LT.NL_M) THEN + DO M2=0,L + CF(L,M1,M2)=SQRT(FLOAT((L*L-M1*M1)*(L*L-M2*M2)))/FLOAT(L) + ENDDO + ENDIF + ENDDO + FSQ(L)=EXP(0.5*REAL(FACT2L-FACT1L)) + DFSQ(L)=DEXP(0.5D0*(FACT2L-FACT1L)) + ENDDO +C + IF((INITL.LT.-1).OR.(INITL.GT.2)) THEN + INITL=1 + WRITE(IUO1,511) + ENDIF + NEPS=2-ABS(IPOL) + IF(IDICHR.GE.1) NEPS=1 + ISTEP_LF=ABS(INITL) + IF(INITL.EQ.-1) THEN + LF1=LI-1 + LF2=LF1 + ELSEIF(INITL.EQ.1) THEN + LF1=LI+1 + LF2=LF1 + ELSEIF(INITL.EQ.2) THEN + LF1=LI-1 + LF2=LI+1 + ELSEIF(INITL.EQ.0) THEN + LF1=LI + LF2=LI + ISTEP_LF=1 + ENDIF +C +C Initialization of the values of ji if spin-orbit is taken +C into account. +C +C Here : JI is the loop index going from JF1 to JF2 with : +C +C JI=1 : ji = li + 1/2 +C JI=2 : ji = li - 1/2 +C + IF(I_SO.EQ.0) THEN + JF1=1 + JF2=2 + ELSEIF(I_SO.EQ.1) THEN + IF(S_O.EQ.'1/2') THEN + IF(LI.EQ.0) THEN + JF1=1 + JF2=1 + ELSEIF(LI.EQ.1) THEN + JF1=2 + JF2=2 + ENDIF + ELSEIF(S_O.EQ.'3/2') THEN + IF(LI.EQ.1) THEN + JF1=1 + JF2=1 + ELSEIF(LI.EQ.2) THEN + JF1=2 + JF2=2 + ENDIF + ELSEIF(S_O.EQ.'5/2') THEN + IF(LI.EQ.2) THEN + JF1=1 + JF2=1 + ELSEIF(LI.EQ.3) THEN + JF1=2 + JF2=2 + ENDIF + ELSEIF(S_O.EQ.'7/2') THEN + IF(LI.EQ.3) THEN + JF1=1 + JF2=1 + ELSEIF(LI.EQ.4) THEN + JF1=2 + JF2=2 + ENDIF + ELSEIF(S_O.EQ.'9/2') THEN + IF(LI.EQ.4) THEN + JF1=1 + JF2=1 + ELSE + RETURN 7 + ENDIF + ELSE + RETURN 7 + ENDIF + ELSEIF(I_SO.EQ.2) THEN + JF1=1 + JF2=2 + ELSE + RETURN 7 + ENDIF +C + IF(NI.LE.5) THEN + NNL=NI*(NI-1)/2 +LI+1 + ELSEIF(NI.EQ.6) THEN + NNL=NI*(NI-1)/2 +LI + ELSEIF(NI.EQ.7) THEN + NNL=NI*(NI-1)/2 +LI-3 + ENDIF +C +C Storage of the Clebsch-Gordan coefficients for the spin-orbit +C dependent coupling matrix elements in the array CG(MJI,JI,JSPIN). +C +C Here : JI=1 : ji = li + 1/2 +C JI=2 : ji = li - 1/2 +C MJI : mji + 1/2 +C JSPIN=1 : msi = +1/2 +C JSPIN=2 : msi = -1/2 +C +C so that all indices remain integer +C + IF((I_SO.GT.0).OR.(ISPIN.EQ.1).OR.(SPECTRO.EQ.'APC')) THEN + DO JS=1,2 + DO JI=1,2 + DO MJI=-LI,LI+1 + CG(MJI,JI,JS)=0.0 + ENDDO + ENDDO + ENDDO + DO MJI=-LI,LI+1 + CG(MJI,1,1)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1)) + CG(MJI,1,2)=SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1)) + IF((MJI.GT.-LI).AND.(MJI.LT.LI+1)) THEN + CG(MJI,2,1)=-SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1)) + CG(MJI,2,2)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1)) + ENDIF + ENDDO + ENDIF +C +C +C Storage of the Clebsch-Gordan coefficients for the Auger multiplet +C dependent coupling matrix elements in the array CGA(LJ1,MJ1,LJ2,MJ2,LJ). +C +C Here : LJ1 is an integer index related to J1 (LJ1=2*J1) +C LMJ1 is an integer index related to MJ1 (LMJ1=2*MJ1) +C LJ2 is an integer index related to J2 (LJ2=2*J2) +C LMJ2 is an integer index related to MJ2 (LMJ2=2*MJ2) +C LJ is an integer index related to J : +C J = FLOAT(LJ) for J integer +C J = FLOAT(LJ) + 0.5 for J half integer +C +C so that all indices remain integer +C + IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN + IF(I_MULT.EQ.1) THEN + N=3 + MJ3=0.D0 + LJ_MAX=2*(LI_I+LI_A+1) + DO LJ1=0,LJ_MAX + J1=DFLOAT(LJ1)/2.D0 + DO LMJ1=-LJ1,LJ1,2 + MJ1=DFLOAT(LMJ1)/2.D0 + DO LJ2=0,LJ_MAX + J2=DFLOAT(LJ2)/2.D0 + DO LMJ2=-LJ2,LJ2,2 + MJ2=DFLOAT(LMJ2)/2.D0 + CALL N_J(J1,MJ1,J2,MJ2,MJ3,NJ,I_INT,N) +C + JJ12=J1-J2 + JL12=MJ1-MJ2 +C + LJ12=INT(JJ12+SIGN(SMALL,JJ12)) + LL12=INT(JL12+SIGN(SMALL,JL12)) +C + JJ_MIN=ABS(LJ12) + JJ_MAX=J1+J2 + LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN)) + LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX)) +C + DO LJJ=LJJ_MIN,LJJ_MAX,1 + IF(I_INT.EQ.1) THEN + JJ=DFLOAT(LJJ) + ELSE + JJ=DFLOAT(LJJ)+0.5D0 + ENDIF + L_EXP=INT(J1-J2+MJ1+MJ2) + IF(MOD(L_EXP,2).EQ.0) THEN + CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=NJ(LJJ)*SQRT(2.*REAL(JJ + &)+1.) + ELSE + CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=-NJ(LJJ)*SQRT(2.*REAL(J + &J)+1.) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +C +C Storage of another of the spin Clebsch-Gordan used +C when the Auger line is multiplet-resolved. It +C originates from the coupling of SA and SC, +C the spins of the Auger electron of the original +C core electron (which is supposed to be the same +C as that of the photoelectron). +C +C CG_S(I,J,K) with : I = 1 ---> MSA = -1/2 +C I = 2 ---> MSA = 1/2 +C J = 1 ---> MSC = -1/2 +C J = 2 ---> MSC = 1/2 +C K = 1 ---> S = 0 +C K = 2 ---> S = 1 +C +C MS = MSA+MSC +C + IF(I_MULT.EQ.1) THEN + CG_S(1,1,1)=0. + CG_S(1,1,2)=1. + CG_S(1,2,1)=-0.707107 + CG_S(1,2,2)= 0.707107 + CG_S(2,1,1)= 0.707107 + CG_S(2,1,2)= 0.707107 + CG_S(2,2,1)= 0. + CG_S(2,2,2)= 1. + ENDIF +C +C Initialization of the variables used when only one multiplet +C is taken into account in the Auger peak +C + IF(I_MULT.EQ.1) THEN + MULTIPLET=CHAR(48+IM1)//MULT//CHAR(48+IM2) + IF(MOD(IM1,2).EQ.0) THEN + WRITE(IUO1,522) IM1 + STOP + ENDIF + S_MUL=(IM1-1)/2 + J_MUL=IM2 + IF(MULT.EQ.'S') THEN + L_MUL=0 + ELSEIF(MULT.EQ.'P') THEN + L_MUL=1 + ELSEIF(MULT.EQ.'D') THEN + L_MUL=2 + ELSEIF(MULT.EQ.'F') THEN + L_MUL=3 + ELSEIF(MULT.EQ.'G') THEN + L_MUL=4 + ELSEIF(MULT.EQ.'H') THEN + L_MUL=5 + ELSEIF(MULT.EQ.'I') THEN + L_MUL=6 + ELSEIF(MULT.EQ.'K') THEN + L_MUL=7 + ELSEIF(MULT.EQ.'L') THEN + L_MUL=8 + ELSEIF(MULT.EQ.'M') THEN + L_MUL=9 + ELSE + WRITE(IUO1,521) MULTIPLET + STOP + ENDIF + ENDIF +C +C.......... Check of the dimensioning in the Gaussian case .......... +C + CALL STOP_EXT(I_EXT,I_EXT_A,SPECTRO) +C +C.................... Read FORMAT .................... +C +C + 1 FORMAT(A7) + 2 FORMAT(21X,10A4) + 3 FORMAT(7X,A3,9X,A1,9X,I1,6X,I4) + 4 FORMAT(8X,F6.3,4X,F6.3,4X,F6.3,3X,A3) + 5 FORMAT(49X,A7) + 6 FORMAT(7X,F6.2,4X,F6.2,4X,F6.2) + 7 FORMAT(8X,I2,8X,I2,8X,I2,8X,I2) + 8 FORMAT(8X,I2,8X,F6.3,3X,I3,9X,I1) + 9 FORMAT(8X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2) + 10 FORMAT(9X,I1,8X,I2,7X,F5.1,5X,F5.1) + 11 FORMAT(7X,F5.1,3(5X,F5.1)) + 12 FORMAT(7X,F6.2,4X,F6.2,6X,I1) + 13 FORMAT(7X,A3,9X,I1,9X,I1,8X,I2) + 14 FORMAT(8X,I2,9X,I1,9X,I1,9X,I1,9X,I1) + 15 FORMAT(7X,I3,7X,I3,7X,I3,7X,I3) + 16 FORMAT(6X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3) + 17 FORMAT(6X,F7.2,3X,F7.2,2X,F8.2) + 18 FORMAT(9X,I1,9X,I1,8X,F5.2,6X,I1) + 19 FORMAT(7X,I3,6X,F7.2,3X,F7.2,2X,F8.2) + 20 FORMAT(8X,I1,A1,8X,A3,7X,I2,8X,I2) + 21 FORMAT(8X,I2,8X,I2,9X,I1,9X,I1) + 22 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1) + 23 FORMAT(8X,I2) + 24 FORMAT(8X,I2,3(8X,I2)) + 25 FORMAT(9X,I1,8X,I2,6X,I4,8X,F6.2) + 26 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1) + 27 FORMAT(9X,I1,6X,F6.2,7X,I1,7X,F6.2) + 28 FORMAT(9X,I1,9X,I1,7X,F8.4,4X,I1) + 29 FORMAT(9X,I1,7X,F6.2,4X,A3) + 30 FORMAT(9X,I1,8X,I2,9X,I1,9X,I1) + 31 FORMAT(9X,I1,6X,F8.3,2X,F8.3,5X,F4.2) + 32 FORMAT(8X,I2,7X,F6.2) + 33 FORMAT(8X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5) + 34 FORMAT(9X,A24,5X,I2) + 35 FORMAT(18X,I2,8X,I2,8X,I2) + 36 FORMAT(18X,A2,8X,A2,8X,A2) + 37 FORMAT(18X,F8.5,2X,F8.5,2X,F8.5) + 38 FORMAT(9X,I1,7X,F5.1,5X,F5.1,5X,F5.1) + 39 FORMAT(8X,A1,I1,8X,I2,6X,F7.2,3X,F7.2) + 40 FORMAT(8X,A1,I1,8X,A1,I1,8X,A1,I1) + 41 FORMAT(6X,F7.2,3X,F7.2,5X,F6.3) + 42 FORMAT(9X,I1,8X,I1,A1,I1) + 43 FORMAT(7X,I3,6X,F7.2,3X,F7.2,6X,I1) + 44 FORMAT(9X,I1) + 46 FORMAT(8X,I2,6X,A4,9X,F7.5,2X,F6.3) + 47 FORMAT(5X,I5,6X,I4,6X,I4,8X,F6.3) + 48 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1) + 49 FORMAT(8X,I2,6X,F7.2,3X,F7.2) +C +C +C.................... Write FORMAT .................... +C +C + 100 FORMAT(//////////,'******************************', '************* + &***************************************') + 101 FORMAT('*********************',40X,'*********************') + 102 FORMAT('*********************',10A4,'*********************') + 103 FORMAT(10X,A3,9X,A1,9X,I1,6X,I4,9X,'CRIST,CENTR,IBAS,NAT') + 104 FORMAT(11X,F6.3,4X,F6.3,4X,F6.3,15X,'A,BSURA,CSURA') + 105 FORMAT(///,'ooooooooooooooooooooooooooooooooooooooooo','oooooooooo + &ooooooooooooooooooooooooooooooo',/,'oooooooooooooooo',50X,'ooooooo + &ooooooooo',/,'oooooooooooooooo INPUT DATA FILE : ',A24,' ooo + &ooooooooooooo',/,'oooooooooooooooo',50X,'oooooooooooooooo',/,'oooo + &oooooooooooooooooooooooo','ooooooooooooooooooooooooooooooooooooooo + &oooooooooo','ooooo',///) + 106 FORMAT(10X,F6.2,4X,F6.2,4X,F6.2,16X,'ALPHAD,BETAD,GAMMAD') + 107 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'H,K,I,L') + 108 FORMAT(12X,I1,8X,F6.3,3X,I3,9X,I1,9X,'NIV,COUPUR,ITEST,IESURF') + 109 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2,4X,'ATBAS,CHEM(NAT)',' + &,NZAT(NAT)') + 110 FORMAT(12X,I1,8X,I2,7X,F5.1,5X,F5.1,7X,'IREL,NREL,PCREL(NREL)') + 112 FORMAT(10X,F6.2,4X,F6.2,6X,I1,19X,'OMEGA1,OMEGA2,IADS') + 113 FORMAT(12X,I1,9X,I1,8X,I2,19X,'ISPIN,IDICHR,IPOL') + 114 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI,ITHETA,IE,', + &'IFTHET') + 115 FORMAT(10X,I3,7X,I3,7X,I3,7X,I3,9X,'NPHI,NTHETA,NE,NFTHET') + 116 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI0,THETA0,E0,R0') + 117 FORMAT(9X,F7.2,3X,F7.2,2X,F8.2,16X,'THLUM,PHILUM,ELUM') + 118 FORMAT(12X,I1,9X,I1,8X,F5.2,6X,I1,9X,'IMOD,IMOY,ACCEPT,ICHKDIR') + 119 FORMAT(10X,I3,6X,F7.2,3X,F7.2,2X,F8.2,6X,'NE,EK_INI,','EK_FIN,EPH_ + &INI') + 120 FORMAT(11X,I1,A1,8X,A3,7X,I2,8X,I2,9X,'LI,S-O,INITL,I_SO') + 121 FORMAT(11X,I2,8X,I2,9X,I1,9X,I1,9X,'NO,NDIF,ISPHER,I_GR') + 122 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'ISFLIP,IR_DIA,ITRTL,I_TEST') + 123 FORMAT(11X,I2,3(8X,I2),9X,'NEMET,IEMET(NEMET)') + 124 FORMAT(12X,I1,8X,I2,6X,I4,7X,F6.2,6X,'ISOM,NONVOL,NPATH,VINT') + 125 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'IFWD,NTHOUT,I_NO,I_RA') + 126 FORMAT(12X,I1,7X,F6.2,6X,I1,7X,F6.2,6X,'N_RA(NAT),THFWD(NAT)',',IB + &WD(NAT),THBWD(NAT)') + 127 FORMAT(12X,I1,9X,I1,7X,F8.4,4X,I1,9X,'IPW,NCUT,PCTINT,IPP') + 128 FORMAT(12X,I1,7X,F6.2,4X,A3,19X,'ILENGTH,RLENGTH,UNLENGTH') + 129 FORMAT(12X,I1,8X,I2,9X,I1,9X,I1,9X,'IDWSPH,ISPEED,IATT,IPRINT') + 130 FORMAT(12X,I1,6X,F8.3,2X,F8.3,5X,F4.2,6X,'IDCM,TD,T,RSJ') + 131 FORMAT(11X,I2,7X,F6.2,26X,'ILPM,XLPM0') + 132 FORMAT(11X,F8.5,33X,'UJ2(NAT) : ','SUBSTRATE') + 133 FORMAT(11X,F8.5,33X,'UJ2(NATA) : ','ADSORBATES') + 134 FORMAT(11X,A1,I1,8X,I2,6X,F7.2,3X,F7.2,6X,'EDGE,INITL,THLUM,','PHI + &LUM') + 135 FORMAT(11X,A1,I1,8X,A1,I1,8X,A1,I1,19X,'EDGE_C,EDGE_I,','EDGE_A') + 136 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI_A,ITHETA_A,','IFTHET_A,I_ + &INT') + 137 FORMAT(10X,I3,7X,I3,7X,I3,19X,'NPHI_A,NTHETA_A,NFTHET_A') + 138 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI0_A,THETA0_A,R0_A') + 139 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI1_A,THETA1_A,R1_A') + 140 FORMAT(12X,I1,8X,I1,A1,I1,28X,'I_MULT,MULT') + 141 FORMAT(12X,I1,39X,'ISPIN') + 142 FORMAT(9X,F7.2,3X,F7.2,26X,'TH_INI,PHI_INI') + 143 FORMAT(10X,I3,6X,F7.2,3X,F7.2,6X,I1,9X,'NE,EK_INI,EK_FIN,I_DAMP') + 144 FORMAT(10X,F6.2,36X,'VINT') + 145 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'I_SPECTRUM(NE)') + 146 FORMAT(11X,I2,6X,A4,9X,F7.5,2X,F6.3,5X,'I_PWM,METHOD,ACC,EXPO') + 147 FORMAT(8X,I5,6X,I4,6X,I4,8X,F6.3,5X,'N_MAX,N_ITER,N_TABLE,SHIFT') + 148 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'I_XN,I_VA,I_GN,I_WN') + 149 FORMAT(11X,I2,6X,F7.2,3X,F7.2,16X,'L,ALPHA,BETA') +C + 201 FORMAT(///,21X,10A4,////) + 203 FORMAT('**************************************************', + &'********************************',//////////) + 204 FORMAT(11X,F6.3,5X,I1,29X,'A,IBAS') + 206 FORMAT(10X,F6.2,36X,'ALPHAD') + 207 FORMAT(11X,I2,8X,I2,8X,I2,19X,'H,K,L') + 209 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'VECBAS') + 210 FORMAT(10X,F5.1,3(5X,F5.1),7X,'PCREL(NREL)') + 211 FORMAT(20X,'SUBSTRATE : ',10(F5.1,',')) + 212 FORMAT(32X,I1,19X,'IADS') + 216 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI1,THETA1,EFIN,R1') + 223 FORMAT(11X,I2,1(8X,I2),29X,'NEMET,IEMET(NEMET)') + 232 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NAT) : ','SUBSTRATE') + 233 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NATA) : ','ADSORBATES') +C + 303 FORMAT(/,33X,'ATOMS OF TYPE ',I1,' :',/) + 304 FORMAT(11X,F6.3,35X,'A') + 306 FORMAT(10X,F6.2,36X,'BETAD') + 309 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'XADS,YADS,ZADS') + 311 FORMAT(20X,'ADSORBATE : ',3(F5.1,',')) + 323 FORMAT(11X,I2,2(8X,I2),19X,'NEMET,IEMET(NEMET)') + 332 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NAT) : ','SUBSTRATE') + 333 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NATA) : ','ADSORBATES') +C + 404 FORMAT(11X,F6.3,4X,F6.3,25X,'A,CSURA') + 432 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5,3X,'UJ2(NAT) : ','SUBSTRA + &TE') +C + 501 FORMAT(//,30X,'POSITION OF THE ADSORBATES :') + 502 FORMAT(///,25X,'VALUE OF THE RELAXATIONS :',/) + 503 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL PHOTOELECTRON',' D + &IFFRACTION') + 504 FORMAT(///,18X,'TYPE OF CALCULATION : FINE STRUCTURE ','OSCILLATIO + &NS') + 505 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR PHOTOELECTRON',' DIFFR + &ACTION') + 506 FORMAT(///,23X,'TYPE OF CALCULATION : SCATTERING FACTOR') + 507 FORMAT(///,28X,'TYPE OF CALCULATION : EXAFS') + 508 FORMAT(///,2X,' <<<<<<<<<< THE THETA VARIATION EXCEEDS THE ', 'P + &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///) + 509 FORMAT(///,2X,' <<<<<<<<<< THE THLUM VARIATION EXCEEDS THE ', 'P + &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///) + 510 FORMAT(///,4X,' <<<<<<<<<< AS THE CALCULATION HAS MORE THAN ','25 + &0 POINTS, SOME OUTPUTS HAVE BEEN SUPRESSED >>>>>>>>>>',///) + 511 FORMAT(///,4X,' <<<<<<<<<< INCORRECT VALUE OF INITL, THE ', 'C + &ALCULATION IS PERFORMED WITH INITL = 1 >>>>>>>>>>') + 512 FORMAT(///,4X,' <<<<<<<<<< IMPOSSIBLE TO HAVE A SPIN RESOLVED ',' + &EXAFS EXPERIMENT : DECREASE IDICHR >>>>>>>>>>') + 513 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IPOL = 0 AND ','ID + &ICHR > 0 >>>>>>>>>>') + 514 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IDICHR = 2 AND ',' + &ISPIN = 0 >>>>>>>>>>') + 515 FORMAT(///,12X,'TYPE OF CALCULATION : AZIMUTHAL AUGER ELECTRON',' + &DIFFRACTION') + 516 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR AUGER ELECTRON',' DIFF + &RACTION') + 517 FORMAT(///,10X,'TYPE OF CALCULATION : AUGER PHOTOELECTRON ','COINC + &IDENCE SPECTROSCOPY') + 518 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','----- + &-------------------') + 519 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','----- + &-------------------') + 520 FORMAT(///,9X,'----------------------------------------------','-- + &--------------------') + 521 FORMAT(///,4X,' <<<<<<<<<< ',A3,' IS NOT IMPLEMENTED IN THIS ','V + &ERSION >>>>>>>>>>') + 522 FORMAT(///,4X,' <<<<<<<<<< WRONG NAME FOR THE MULTIPLET',' >>>>> + &>>>>>',/,4X,' <<<<<<<<<< ODD NUMBER ','EXPECTED INSTEAD OF',I2,' + & >>>>>>>>>>') + 523 FORMAT(///,4X,' <<<<<<<<<< BOTH DETECTOR DIRECTIONS MUST BE ','EI + &THER INTERNAL OR EXTERNAL >>>>>>>>>>',/,8X,' -----> PROCEEDING WI + &TH EXTERNAL DIRECTIONS',/) + 524 FORMAT(///,4X,' <<<<<<<<<< AVERAGING OVER ',I3,' DOMAINS ','FOR P + &HOTOELECTRON >>>>>>>>>>',/,4X,' <<<<<<<<<< AVERAGING OVER ',I3, + &' DOMAINS ','FOR AUGER ELECTRON >>>>>>>>>>',/,8X,' -----> IMPOSS + &IBLE : CHECK INPUT FILES !') + 525 FORMAT(///,14X,'ATOMIC CALCULATION : Z AXIS ALONG POLARIZATION ',' + &DIRECTION',/,' ',/,' ',/,' ') + 526 FORMAT(///,18X,'ATOMIC CALCULATION : Z AXIS ALONG LIGHT ','DIRECTI + &ON',/,' ',/,' ',/,' ') + 527 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' PHOTOELEC + &TRON DIFFRACTION') + 528 FORMAT(///,10X,'TYPE OF CALCULATION : FULL HEMISPHERE',' AUGER ELE + &CTRON DIFFRACTION') + 529 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL LEED',' VARIATIONS + &') + 530 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' LEED') + 531 FORMAT(///,18X,'TYPE OF CALCULATION : LEED ENERGY ','VARIATIONS') + 532 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR LEED',' VARIATIONS') + 533 FORMAT(///,17X,'TYPE OF CALCULATION : EIGENVALUE',' ANALYSIS') + 534 FORMAT(///,22X,'THE AMPLITUDES WILL BE PRINTED SEPARATELY') +C + 701 FORMAT(6X,I1,1X,I3,2X,I4) + 702 FORMAT(6X,I1,1X,I3,3X,I3) + 703 FORMAT(15X,F8.3,3X,F8.3) + 713 FORMAT(6X,I1,1X,I3) +C + RETURN +C + END +C +C======================================================================= +C + FUNCTION SIG2(RJ,JTYP) +C +C This routine evaluates the mean square displacements. +C + USE DIM_MOD +C + USE DEBWAL_MOD , T => TEMP + USE MASSAT_MOD , XM => XMT + USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT + &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT +C + REAL MJ +C +C +C + DATA COEF/145.52539/ + DATA RZ2,RZ4,RZ6/1.644934,1.082323,1.017343/ +C + A=TD/T + BJ=QD*RJ + U=BJ/A + MJ=XM(JTYP) + C=COEF/(2.*MJ*TD) + COMP=RZ2-U*U*RZ4+U*U*U*U*RZ6 + X1=0. + X2=0. + X3=0. + X4=0. + DO 10 N=1,8 + Z=FLOAT(N) + X1=X1+EXP(-Z*A)*((A/Z)+(1./(Z*Z))) + X2=X2+1./(Z**8+U*U*(Z**6)) + X3=X3+EXP(-Z*A)*Z/(Z*Z+U*U) + X4=X4+EXP(-Z*A)/(Z*Z+U*U) + 10 CONTINUE + P1=1.+4.*(RZ2-X1)/(A*A) + P2=-2.*(1.-COS(BJ))/(BJ*BJ) + P3=-4.*(COMP-(U**6)*X2)/(A*A) + P4=4.*SIN(BJ)*X3/(A*BJ) + P5=4.*COS(BJ)*X4/(A*A) + SIG2=C*(P1+P2+P3+P4+P5)/(A0*A0) +C + RETURN +C + END +C +C======================================================================= +C + DOUBLE PRECISION FUNCTION SIXJ_IN(J1,J2,L1,L2,L3) +C +C This function calculates the initial value {J1 J2 L1+L2} +C {L1 L2 L3 } +C +C A 6j symbol {J1 J2 J3} is non zero only if +C {J4 J5 J6} +C +C (J1,J2,J3),(J4,J5,J3),(J2,J4,J6) and (J1,J5,J6) satisfy the triangular inequality : +C +C (a,b,c) non zero if |a-b| <= c <= (a+b) . This means also that (a+b) and c must +C have the same nature (integer or half-integer). +C +C (J1,J2,J3) and (J4,J5,J3) are taken care of by the bounds of J3, JJ_MIN and JJ_MAX, +C as chosen in the N_J routine. Here we check the two last ones. +C +C Last modified : 8 Dec 2008 +C +C + USE DIM_MOD + USE LOGAMAD_MOD +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + REAL*8 J1,J2,L1,L2,L3 +C +C + DATA SMALL /0.0001/ +C + IZERO=0 +C +C Check for unphysical values of L3 +C + IF(DABS(J2-L1).GT.L3) IZERO=1 + IF(J2+L1.LT.L3) IZERO=1 + IF(IG(J2+L1).NE.IG(L3)) IZERO=1 + IF(DABS(J1-L2).GT.L3) IZERO=1 + IF(J1+L2.LT.L3) IZERO=1 + IF(IG(J1+L2).NE.IG(L3)) IZERO=1 +C + IF(IZERO.EQ.1) THEN + SIXJ_IN=0.D0 + ELSE +C +C Storage indices of the angular momenta. +C + LJ1=INT(J1+SIGN(SMALL,J1)) + LJ2=INT(J2+SIGN(SMALL,J2)) + LL1=INT(L1+SIGN(SMALL,L1)) + LL2=INT(L2+SIGN(SMALL,L2)) + LL3=INT(L3+SIGN(SMALL,L3)) + LL1_2=INT(L1+L1+SIGN(SMALL,L1)) + LL2_2=INT(L2+L2+SIGN(SMALL,L2)) +C + MSIGN=INT(J1+J2+L1+L2+SIGN(SMALL,J1+J2+L1+L2)) + IF(MOD(MSIGN,2).EQ.0) THEN + SIGNE=1.D0 + ELSE + SIGNE=-1.D0 + ENDIF +C + D1=GLD(LL1_2+1,1) + GLD(LL2_2+1,1) - GLD(LL1_2+LL2_2+2,1) + D2=GLD(INT(J1+J2+L1+L2)+2,IG(J1+J2+L1+L2)) - GLD(INT(J1+J2-L1-L2 + &)+1,IG(J1+J2-L1-L2)) + D3=GLD(INT(J1-J2+L1+L2)+1,IG(J1-J2+L1+L2)) - GLD(INT(J1+L2-L3)+1 + &,IG(J1+L2-L3)) + D4=GLD(INT(J2-J1+L1+L2)+1,IG(J2-J1+L1+L2)) -GLD(INT(-J1+L2+L3)+1 + &,IG(-J1+L2+L3)) + D5=GLD(INT(J1-L2+L3)+1,IG(J1-L2+L3)) - GLD(INT(J1+L2+L3)+2,IG(J1 + &+L2+L3)) + D6=GLD(INT(J2+L3-L1)+1,IG(J2+L3-L1)) - GLD(INT(J2-L3+L1)+1,IG(J2 + &-L3+L1)) + D7=GLD(INT(L1+L3-J2)+1,IG(L1+L3-J2)) +GLD(INT(L1+J2+L3)+2,IG(L1+ + &J2+L3)) +C + SIXJ_IN=SIGNE*DSQRT(DEXP(D1+D2+D3+D4+D5+D6-D7)) +C + ENDIF +C + END +C +C======================================================================= +C + SUBROUTINE SPH_HAR(NL,X,CF,YLM,NC) +C +C This routine computes the complex spherical harmonics using Condon and +C Shortley phase convention. +C +C If the angular direction R=(THETAR,PHIR) is given in cartesian +C coordinates by (XR,YR,ZR), the arguments of the subroutine are : +C +C X = ZR = cos(THETAR) +C CF = XR + i YR = sin(THETAR)*exp(i PHIR) +C +C NL is the dimensioning of the YLM array and NC is +C the maximum l value to be computed. +C + USE DIM_MOD +C + USE EXPFAC2_MOD + USE FACTSQ_MOD +C + COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF +C + DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ +C +C + YLM(0,0)=CMPLX(SQ4PI_INV) + YLM(1,0)=X*SQR3_INV + DO L=2,NC + Y=1./FLOAT(L) + YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) + &-1.5))*YLM(L-2,0) + ENDDO +C + C2=-1. + C=-0.5*CF +C + C1=1. + COEF=(1.,0.) + DO M=1,NC + C1=C1*C2 + COEF=COEF*C + YMM=SQ4PI_INV*COEF*FSQ(M) + YLM(M,M)=YMM + YLM(M,-M)=C1*CONJG(YMM) + YMMP=X*SQRT(FLOAT(M+M+3))*YMM + YLM(M+1,M)=YMMP + YLM(M+1,-M)=C1*CONJG(YMMP) + IF(M.LT.NC-1) THEN + DO L=M+2,NC + YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2( + &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M)) + YLM(L,-M)=C1*CONJG(YLM(L,M)) + ENDDO + ENDIF + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE SPH_HAR2(NL,X,CF,YLM,NC) +C +C This routine computes the complex spherical harmonics using Condon and +C Shortley phase convention. +C +C If the angular direction R=(THETAR,PHIR) is given in cartesian +C coordinates by (XR,YR,ZR), the arguments of the subroutine are : +C +C X = ZR = cos(THETAR) +C CF = XR + i YR = sin(THETAR)*exp(i PHIR) +C +C NL is the dimensioning of the YLM array and NC is +C the maximum l value to be computed. +C +C This is the double precision version of sph_har.f +C +C + USE DIM_MOD +C + USE DEXPFAC2_MOD + USE DFACTSQ_MOD +C +C +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMPLEX*16 YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF +C + DATA SQ4PI_INV,SQR3_INV /0.282094791774D0,0.488602511903D0/ +C +C + YLM(0,0)=DCMPLX(SQ4PI_INV) + YLM(1,0)=X*SQR3_INV + DO L=2,NC + Y=1.D0/DFLOAT(L) + YLM(L,0)=X*DSQRT(4.D0-Y*Y)*YLM(L-1,0) - (1.D0-Y)*DSQRT(1.D0+2.D0 + &/(DFLOAT(L)-1.5D0))*YLM(L-2,0) + ENDDO +C + C2=-1.D0 + C=-0.5D0*CF +C + C1=1.D0 + COEF=(1.D0,0.D0) + DO M=1,NC + C1=C1*C2 + COEF=COEF*C + YMM=SQ4PI_INV*COEF*DFSQ(M) + YLM(M,M)=YMM + YLM(M,-M)=C1*DCONJG(YMM) + YMMP=X*DSQRT(DFLOAT(M+M+3))*YMM + YLM(M+1,M)=YMMP + YLM(M+1,-M)=C1*DCONJG(YMMP) + IF(M.LT.NC-1) THEN + DO L=M+2,NC + YLM(L,M)=(X*DFLOAT(L+L-1)*DEXPF2(L-1,M)*YLM(L-1,M) - DFLOAT( + &L+M-1)*DEXPF2(L-2,M)*YLM(L-2,M))/(DEXPF2(L,M)*DFLOAT(L-M)) + YLM(L,-M)=C1*DCONJG(YLM(L,M)) + ENDDO + ENDIF + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE STOP_EXT(I_EXT,I_EXT_A,SPECTRO) +C +C This routine stops the code when the dimension N_TILT_M in the +C spec.inc file is insufficient for the number of values to +C Gaussian average over (as generated by the ext_dir.f code) +C + USE DIM_MOD +C + USE INFILES_MOD + USE INUNITS_MOD + USE OUTUNITS_MOD +C +C +C + CHARACTER*3 SPECTRO +C + NSET=1 + NSET_A=1 +C + IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN + IF(I_EXT.EQ.-1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,15) IDIR,NSET + CLOSE(IUI6) + ENDIF + IF(I_EXT_A.EQ.-1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,15) IDIR,NSET_A + CLOSE(IUI6) + ENDIF + ENDIF + IF(SPECTRO.EQ.'APC') THEN + IF(I_EXT.EQ.-1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,15) IDIR,NSET + CLOSE(IUI6) + ENDIF + IF(I_EXT_A.EQ.-1) THEN + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,15) IDIR,NSET_A + CLOSE(IUI9) + ENDIF + ENDIF +C + IF(MAX(NSET,NSET_A).GT.N_TILT_M) THEN + WRITE(IUO1,10) MAX(NSET,NSET_A) + STOP + ENDIF +C + 10 FORMAT(///,16X,'<<<<<<<<<< N_TILT_M SHOULD BE AT LEAST ',I3,' >> + &>>>>>>>>') + 15 FORMAT(6X,I1,1X,I3) +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI + &,NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C This subroutine stops the code before the long MS calculations +C when the dimensioning NDIM_M of the treatment routines +C (treat_aed,treat_apc,treat_phd,treat_xas) is insufficient. +C +C +C Last modified : 06 Oct 2006 +C + USE DIM_MOD + USE OUTUNITS_MOD +C + CHARACTER*3 SPECTRO +C +C + IF(ISOM.EQ.0) THEN +C +C Photoelectron diffraction case +C + IF(SPECTRO.EQ.'PHD') THEN + 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 + ENDIF + NTT=NPLAN*NDP + IF(NTT.GT.NDIM_M) GOTO 10 + IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 +C +C Auger electron diffraction case +C + ELSEIF(SPECTRO.EQ.'AED') THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NEMET*NTHETA_A*NPHI_A*NE + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NEMET*NTHETA_A*NPHI_A*NE*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NEMET*NTHETA_A*NE + ENDIF + NTT=NPLAN*NDP + IF(NTT.GT.NDIM_M) GOTO 20 + IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 +C +C X-ray absorption case +C + ELSEIF(SPECTRO.EQ.'XAS') THEN + NDP=NEMET*NE + NTT=NPLAN*NDP + IF(NTT.GT.NDIM_M) GOTO 30 +C +C Auger Photoelectron coincidence spectroscopy case +C + ELSEIF(SPECTRO.EQ.'APC') THEN + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A + ENDIF + ELSEIF(I_EXT.EQ.-1) THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A + ENDIF + ELSEIF(I_EXT.EQ.2) THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NEMET*NTHETA*NE*NTHETA_A + ENDIF + ENDIF + NTT=NPLAN*NDP + IF(NTT.GT.NDIM_M) GOTO 40 + IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 + IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 + ENDIF +C + ELSE +C +C Photoelectron diffraction case +C + IF(SPECTRO.EQ.'PHD') THEN + 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 + ENDIF + NTT=NFICHLEC*NDP + IF(NTT.GT.NDIM_M) GOTO 10 + IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 +C +C Auger electron diffraction case +C + ELSEIF(SPECTRO.EQ.'AED') THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NTHETA_A*NPHI_A*NE + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NTHETA_A*NPHI_A*NE*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NTHETA_A*NE + ENDIF + NTT=NFICHLEC*NDP + IF(NTT.GT.NDIM_M) GOTO 20 + IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 +C +C X-ray absorption case +C + ELSEIF(SPECTRO.EQ.'XAS') THEN + NDP=NE + NTT=NFICHLEC*NDP + IF(NTT.GT.NDIM_M) GOTO 30 +C +C Auger Photoelectron coincidence spectroscopy case +C + ELSEIF(SPECTRO.EQ.'APC') THEN + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NTHETA*NPHI*NE*NTHETA_A + ENDIF + ELSEIF(I_EXT.EQ.-1) THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NTHETA*NPHI*NE*2*NTHETA_A + ENDIF + ELSEIF(I_EXT.EQ.2) THEN + IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN + NDP=NTHETA*NE*NTHETA_A*NPHI_A + ELSEIF(I_EXT_A.EQ.-1) THEN + NDP=NTHETA*NE*NTHETA_A*NPHI_A*2 + ELSEIF(I_EXT_A.EQ.2) THEN + NDP=NTHETA*NE*NTHETA_A + ENDIF + ENDIF + NTT=NFICHLEC*NDP + IF(NTT.GT.NDIM_M) GOTO 40 + IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 + IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 + ENDIF + ENDIF +C + GOTO 5 +C + 10 WRITE(IUO1,11) NTT + STOP + 20 WRITE(IUO1,21) NTT + STOP + 30 WRITE(IUO1,31) NTT + STOP + 40 WRITE(IUO1,41) NTT + STOP + 50 WRITE(IUO1,51) MAX(NTHETA,NPHI,NTHETA_A,NPHI_A) + STOP +C + 11 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN + &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT + &_PHD SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE + &AT LEAST ',I8,' >>>>>>>>>>') + 21 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN + &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT + &_AED SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE + &AT LEAST ',I8,' >>>>>>>>>>') + 31 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN + &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT + &_XAS SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE + &AT LEAST ',I8,' >>>>>>>>>>') + 41 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN + &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT + &_APC SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE + &AT LEAST ',I8,' >>>>>>>>>>') + 51 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL',' + &IN THE INCLUDE FILE - SHOULD BE AT LEAST ',I6,' >>>>>>>>>>') +C + 5 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE SUP_ZEROS(TL,LMAX,NE,NAT,IUO1,ITRTL) +C +C This routine suppresses possible zeros in the TL arrays so that +C the code runs faster because of lower values of LMAX. Actually, +C the TL array is not modified, it is just the LMAX array that is +C altered. This is particularly useful for energy variations or +C for matrix inversion +C + USE DIM_MOD +C + COMPLEX TL_,TL(0:NT_M,4,NATM,NE_M) +C + INTEGER LMAX(NATM,NE_M) +C + IF(ITRTL.EQ.1) THEN + SMALL=0.1 + ELSEIF(ITRTL.EQ.2) THEN + SMALL=0.01 + ELSEIF(ITRTL.EQ.3) THEN + SMALL=0.001 + ELSEIF(ITRTL.EQ.4) THEN + SMALL=0.0001 + ELSEIF(ITRTL.EQ.5) THEN + SMALL=0.00001 + ELSEIF(ITRTL.EQ.6) THEN + SMALL=0.000001 + ELSEIF(ITRTL.EQ.7) THEN + SMALL=0.0000001 + ELSEIF(ITRTL.EQ.8) THEN + SMALL=0.00000001 + ELSE + ITRTL=9 + SMALL=0.000000001 + ENDIF +C + WRITE(IUO1,10) + WRITE(IUO1,15) ITRTL +C + DO JE=1,NE + WRITE(IUO1,20) JE + DO JAT=1,NAT + NONZERO=0 + LM=LMAX(JAT,JE) + DO L=0,LM + TL_=TL(L,1,JAT,JE) + IF((ABS(REAL(TL_)).GE.SMALL).OR.(ABS(AIMAG(TL_)).GE.SMALL)) + &THEN + NONZERO=NONZERO+1 + ENDIF + ENDDO + LMAX(JAT,JE)=NONZERO-1 + WRITE(IUO1,30) JAT,LM,NONZERO-1 + ENDDO + ENDDO +C + WRITE(IUO1,40) +C + 10 FORMAT(//,' ---> CHECK FOR ZEROS IN THE TL FILE TO REDUCE',' THE + & AMOUNT OF COMPUTING :',/) + 15 FORMAT(/,' (ONLY THE MATRIX ELEMENTS NON ZERO ','TO THE FIRST ',I + &1,' DECIMAL DIGITS ARE KEPT)',/) + 20 FORMAT(/,15X,'ENERGY POINT No ',I3,/) + 30 FORMAT(8X,'PROTOTYPICAL ATOM No ',I5,' INITIAL LMAX = ',I2,' FI + &NAL LMAX = ',I2) + 40 FORMAT(//) +C + RETURN +C + END +C +C======================================================================= +C + FUNCTION UJ_SQ(JTYP) +C +C This routine evaluates the mean square displacements UJ_SQ, +C first along une direction (x, y or z): UJ2 within the Debye model, +C using the Debye function formulation +C +C X1 is the Debye function phi_1 +C UJ_SQ is given in unit of the square of the lattice parameter A0 +C Temperatures are expressed in Kelvin +C +C The coefficient COEF equals: +C +C 3 hbar^{2} N_A 10^{3} / (4 k_B) +C +C where N_A is the Avogadro number, k_B is Boltzmann's constant +C and 10^3 arises from the fact that the atomic mass is +C expressed in grams +C +C Then UJ_SQ is obtained as UJ_SQ = (2 + RSJ) UJJ for surface atoms +C UJ_SQ = 3 UJJ for bulk atoms +C +C +C For empty spheres, two possibilities are provided. By construction, +C they are very light (their mass is taken as 1/1836 of the mass +C of a H atom) and so they will vibrate a lot (IDCM = 1). When +C setting IDCM = 2, their mean square displacement is set to a +C tiny value so that they hardly vibrate (frozen empty spheres) +C +C Last modified : 31 Jan 2017 +C + USE DIM_MOD +C + USE DEBWAL_MOD , T => TEMP + USE MASSAT_MOD , XM => XMT + USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT + &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT + USE VIBRAT_MOD +C + REAL MJ +C +C +C + DATA COEF /36.381551/ ! 3 hbar^{2} / (4 k_B) for MJ in grams + DATA RZ2 /1.644934/ ! Pi^2 / 6 + DATA LITTLE /0.01/ ! lowest temperature for calculation of phi_1 +C + N_MAX=20 +C +C Computation of the 1D mean square displacement UJ2 +C + A=TD/T + MJ=XM(JTYP) + C=COEF/(MJ*TD) +C + X1=0. + IF(T.GT.LITTLE) THEN + DO N=1,N_MAX + Z=FLOAT(N) + X1=X1+EXP(-Z*A)*(A+1./Z)/Z + ENDDO + ENDIF +C + P1=1.+4.*(RZ2-X1)/(A*A) + UJJ=C*P1/(A0*A0) +C +C 3D mean square displacement UJ_SQ +C + IF(IDCM.EQ.1) THEN + UJ_SQ=(3.+FLOAT(I_FREE(JTYP))*(RSJ-1.))*UJJ + ELSEIF(IDCM.EQ.2) THEN + UJ_SQ=1.0E-20 + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE DIRAN(VINT,ECIN,J_EL) +C +C This subroutine calculates the direction(s) of the analyzer with +C or without an angular averaging. +C +C DIRANA is the internal direction +C ANADIR is the external direction +C +C J_EL is the type of electron : 1 ---> photoelectron +C 2 ---> Auger electron +C +C Last modified : 23/03/2006 +C +C + USE DIRECT_MOD + USE DIRECT_A_MOD + USE MOYEN_MOD + USE MOYEN_A_MOD + USE OUTUNITS_MOD + USE TESTS_MOD , I1 => ITEST, I2 => ISORT1, N1 => NPATHP, I3 => ISO + &M + USE TYPCAL_MOD + USE TYPCAL_A_MOD +C + COMPLEX COEF,IC + DATA PI,PIS2,PIS180 /3.141593,1.570796,0.017453/ +C + IC=(0.,1.) +C + IF(J_EL.EQ.1) THEN + ANADIR(1,1)=SIN(RTHEXT)*COS(RPHI) + ANADIR(2,1)=SIN(RTHEXT)*SIN(RPHI) + ANADIR(3,1)=COS(RTHEXT) + IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN + CALL REFRAC(VINT,ECIN,RTHEXT,RTHINT) + ELSE + RTHINT=RTHEXT + ENDIF + IF((IPRINT.GT.0).AND.(I_EXT.NE.2)) THEN + DTHEXT=RTHEXT/PIS180 + DTHINT=RTHINT/PIS180 + IF(I_TEST.NE.2) WRITE(IUO1,20) DTHEXT,DTHINT + ENDIF + DIRANA(1,1)=SIN(RTHINT)*COS(RPHI) + DIRANA(2,1)=SIN(RTHINT)*SIN(RPHI) + DIRANA(3,1)=COS(RTHINT) + THETAR(1)=RTHINT + PHIR(1)=RPHI +C +C The change in the definition below is necessary as RPHI is +C used to define the rotation axis of the direction of the detector +C when doing polar variations +C + IF(ITHETA.EQ.1) THEN + IF(RPHI.GT.PIS2) THEN + RTHEXT=-RTHEXT + RPHI=RPHI-PI + ELSEIF(RPHI.LT.-PIS2) THEN + RTHEXT=-RTHEXT + RPHI=RPHI+PI + ENDIF + ENDIF +C + IF(IMOY.GE.1) THEN + N=2**(IMOY-1) + S=SIN(ACCEPT*PI/180.) + RN=FLOAT(N) + J=1 + DO K1=-N,N + RK1=FLOAT(K1) + DO K2=-N,N + RK2=FLOAT(K2) + D=SQRT(RK1*RK1+RK2*RK2) + IF((D-RN).GT.0.000001) GOTO 10 + IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 10 + C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S) + J=J+1 +C + ANADIR(1,J)=(RK1*S*COS(RTHEXT)*COS(RPHI) -RK2*S*SIN(RPHI)+ + &C*ANADIR(1,1))/RN + ANADIR(2,J)=(RK1*S*COS(RTHEXT)*SIN(RPHI) +RK2*S*COS(RPHI)+ + &C*ANADIR(2,1))/RN + ANADIR(3,J)=(-RK1*S*SIN(RTHEXT) +C*ANADIR(3,1))/RN + THETA_R=ACOS(ANADIR(3,J)) + COEF=ANADIR(1,J)+IC*ANADIR(2,J) + CALL ARCSIN(COEF,ANADIR(3,J),PHI_R) + IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN + CALL REFRAC(VINT,ECIN,THETA_R,THINT_R) + ELSE + THINT_R=THETA_R + ENDIF +C + DIRANA(1,J)=SIN(THINT_R)*COS(PHI_R) + DIRANA(2,J)=SIN(THINT_R)*SIN(PHI_R) + DIRANA(3,J)=COS(THINT_R) +C + THETAR(J)=THINT_R + PHIR(J)=PHI_R + 10 CONTINUE + ENDDO + ENDDO + ENDIF +C + ELSEIF(J_EL.EQ.2) THEN + ANADIR_A(1,1)=SIN(RTHEXT_A)*COS(RPHI_A) + ANADIR_A(2,1)=SIN(RTHEXT_A)*SIN(RPHI_A) + ANADIR_A(3,1)=COS(RTHEXT_A) + IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN + CALL REFRAC(VINT,ECIN,RTHEXT_A,RTHINT_A) + ELSE + RTHINT_A=RTHEXT_A + ENDIF + IF((IPRINT.GT.0).AND.(I_EXT_A.NE.2)) THEN + DTHEXT_A=RTHEXT_A/PIS180 + DTHINT_A=RTHINT_A/PIS180 + IF(I_TEST_A.NE.2) WRITE(IUO1,21) DTHEXT_A,DTHINT_A + ENDIF + DIRANA_A(1,1)=SIN(RTHINT_A)*COS(RPHI_A) + DIRANA_A(2,1)=SIN(RTHINT_A)*SIN(RPHI_A) + DIRANA_A(3,1)=COS(RTHINT_A) + THETAR_A(1)=RTHINT_A + PHIR_A(1)=RPHI_A +C +C The change in the definition below is necessary as RPHI is +C used to define the rotation axis of the direction of the detector +C when doing polar variations +C + IF(ITHETA_A.EQ.1) THEN + IF(RPHI_A.GT.PIS2) THEN + RTHEXT_A=-RTHEXT_A + RPHI_A=RPHI_A-PI + ELSEIF(RPHI_A.LT.-PIS2) THEN + RTHEXT_A=-RTHEXT_A + RPHI_A=RPHI_A+PI + ENDIF + ENDIF +C + IF(IMOY_A.GE.1) THEN + N=2**(IMOY_A-1) + S=SIN(ACCEPT_A*PI/180.) + RN=FLOAT(N) + J=1 + DO K1=-N,N + RK1=FLOAT(K1) + DO K2=-N,N + RK2=FLOAT(K2) + D=SQRT(RK1*RK1+RK2*RK2) + IF((D-RN).GT.0.000001) GOTO 15 + IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 15 + C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S) + J=J+1 +C + ANADIR_A(1,J)=(RK1*S*COS(RTHEXT_A)*COS(RPHI_A) -RK2*S*SIN( + &RPHI_A)+C*ANADIR_A(1,1))/RN + ANADIR_A(2,J)=(RK1*S*COS(RTHEXT_A)*SIN(RPHI_A) +RK2*S*COS( + &RPHI_A)+C*ANADIR_A(2,1))/RN + ANADIR_A(3,J)=(-RK1*S*SIN(RTHEXT_A) +C*ANADIR_A(3,1))/RN + THETA_R_A=ACOS(ANADIR_A(3,J)) + COEF=ANADIR_A(1,J)+IC*ANADIR_A(2,J) + CALL ARCSIN(COEF,ANADIR_A(3,J),PHI_R_A) + IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN + CALL REFRAC(VINT,ECIN,THETA_R_A,THINT_R_A) + ELSE + THINT_R_A=THETA_R_A + ENDIF +C + DIRANA_A(1,J)=SIN(THINT_R_A)*COS(PHI_R_A) + DIRANA_A(2,J)=SIN(THINT_R_A)*SIN(PHI_R_A) + DIRANA_A(3,J)=COS(THINT_R_A) +C + THETAR_A(J)=THINT_R_A + PHIR_A(J)=PHI_R_A + 15 CONTINUE + ENDDO + ENDDO + ENDIF +C + ENDIF +C + 20 FORMAT(/,10X,'PHOTOELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T + &HETA =', F7.2) + 21 FORMAT(/,10X,'AUGER ELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T + &HETA =', F7.2) +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE REFRAC(VINT,EKIN,RTHETA,RTHINT) +C +C This routine calculates the refraction of a plane wave beam induced +C by the surface potential barrier VINT. EKIN is the kinetic energy +C outside the crystal. +C +C Last modified : 3 Dec 2008 +C + DATA PIS180,SMALL /0.017453,0.001/ +C + IF(VINT.LT.0.) VINT=ABS(VINT) + IF(ABS(VINT).LT.SMALL) THEN + RTHINT=RTHETA + ELSE + U=VINT/(EKIN+VINT) + DTHETA=RTHETA/PIS180 + REFRA=SIN(RTHETA)*SIN(RTHETA)*(1.-U) + RTHINT=ASIN(SQRT(REFRA)) + IF(DTHETA.LT.0.) THEN + RTHINT=-RTHINT + ENDIF + ENDIF +C + RETURN +C + END +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 +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 +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 +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 +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 +C +C======================================================================= +C + SUBROUTINE FINDPATHS(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIMI + &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) +C +C This routine generates all the paths and filters them according to the +C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). +C It corresponds to the spin-independent case from a non spin-orbit +C resolved initial core state LI +C +C Last modified : 16 May 2007 +C + USE DIM_MOD +C + USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH + USE COOR_MOD + USE DEBWAL_MOD + USE INIT_L_MOD + USE PATH_MOD + USE ROT_MOD + USE TESTPA_MOD + USE TESTPB_MOD + USE TRANS_MOD + USE TLDW_MOD + USE VARIA_MOD +C + DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),R(NDIF_M) +C +C +C + COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK + COMPLEX IC,COMPL1,PW(0:NDIF_M) + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX YLM1(0:NL_M,-NL_M:NL_M) + COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 +C + DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ +C + IC=(0.,1.) + IEULER=1 +C + IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) + IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) +C +C I_CP = 0 : all open paths generated +C I_CP = 1 : only closed paths generated +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO JTYP=1,N_TYP + IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) + IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) + ND=ND+1 +C +C I_ABS = 0 : the atom before the scatterer is not the absorber +C I_ABS = 1 : the atom before the scatterer is the absorber +C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) +C + IF(ND.EQ.1) THEN + I_ABS=1 + ELSE + I_ABS=0 + ENDIF +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPJ=NATYP(JTYP) + ELSE + NBTYPJ=1 + ENDIF +C + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + IF(JATL.EQ.IATL) GOTO 12 + XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) + YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) + ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + JPOS(ND,1)=JTYP + JPOS(ND,2)=JNUM + JPOS(ND,3)=JATL + NPATH(ND)=NPATH(ND)+1. + IF(ND.GT.1) THEN + COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( + &R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(ITYP).EQ.0) THEN + IF(COSTHMIJ.LT.COSFWDI) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(ITYP).EQ.1) THEN + IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + RHOIJ=VK(JE)*R(ND) + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THIJ=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) + IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 + ZSURFI=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(ITYP)=SIG2(R(ND-1),ITYP) + ENDIF + IF(ABS(ZSURFI).LE.SMALL) THEN + IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN + CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO + &STHMIJ) + 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 + 40 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) + ENDIF + ENDIF + IF(ND.EQ.1) THEN + RHO01=RHOIJ + TH01=THIJ + PHI01=PHIIJ + CALL DJMN2(TH01,RLM01,LF2,2) + GOTO 30 + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + LMJ=LMAX(ITYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 + CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) + CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, + &BMIJ,CMIJ,RHOMI,RHOIJ) + 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F + &REF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 42 + I_ABS=0 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO KTYP=1,N_TYP + ND=ND+1 + IF(ND.GT.NDIF) GOTO 20 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPK=NATYP(KTYP) + ELSE + NBTYPK=1 + ENDIF +C + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.EQ.JATL) GOTO 22 + JPOS(ND,1)=KTYP + JPOS(ND,2)=KNUM + JPOS(ND,3)=KATL + XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) + YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) + ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF(IT(ND-1).EQ.1) GOTO 32 + RHOJK=R(ND)*VK(JE) + NPATH(ND)=NPATH(ND)+1. + COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) + &/(R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(JTYP).EQ.0) THEN + IF(COSTHIJK.LT.COSFWDJ) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(JTYP).EQ.1) THEN + IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH + &EN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + IF(IT(ND-1).EQ.1) GOTO 32 + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THJK=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + IF(ND-1.LT.NDIF) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 + ZSURFJ=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(JTYP)=SIG2(R(ND-1),JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(COSTHIJK-1.).GT.SMALL) THEN + CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 + &.*COSTHIJK) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 50 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) + ENDIF + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + LMJ=LMAX(JTYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT)) + & IT(ND)=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 + IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + ENDIF + CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A + &IJK,BIJK,CIJK,RHOIJ,RHOJK) + CEX(ND)=CEXP(IC*RHOJK)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI + &JK,FREF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 32 + CALL FINDPATHS2(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH + &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) + 32 DIJ=DIJ-R(ND) + 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDDO + 20 CONTINUE + ND=ND-1 + ENDDO + 42 DIJ=DIJ-R(ND) + 12 IF(ND.GT.1) THEN + IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDIF + ENDDO + ND=ND-1 + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE FINDPATHS2(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM + &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) +C +C This routine generates all the paths and filters them according to the +C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). +C It corresponds to the spin-independent case from a non spin-orbit +C resolved initial core state LI +C +C Last modified : 16 May 2007 +C + USE DIM_MOD +C + USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH + USE COOR_MOD + USE DEBWAL_MOD + USE INIT_L_MOD + USE PATH_MOD + USE ROT_MOD + USE TESTPA_MOD + USE TESTPB_MOD + USE TRANS_MOD + USE TLDW_MOD + USE VARIA_MOD +C + COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK + COMPLEX IC,COMPL1,PW(0:NDIF_M) + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX YLM1(0:NL_M,-NL_M:NL_M) + COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 +C + DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),R(NDIF_M) +C +C +C + DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ +C + IC=(0.,1.) + IEULER=1 +C + IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) + IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) +C +C I_CP = 0 : all open paths generated +C I_CP = 1 : only closed paths generated +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO JTYP=1,N_TYP + IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) + IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) + ND=ND+1 +C +C I_ABS = 0 : the atom before the scatterer is not the absorber +C I_ABS = 1 : the atom before the scatterer is the absorber +C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) +C + IF(ND.EQ.1) THEN + I_ABS=1 + ELSE + I_ABS=0 + ENDIF +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPJ=NATYP(JTYP) + ELSE + NBTYPJ=1 + ENDIF +C + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + IF(JATL.EQ.IATL) GOTO 12 + XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) + YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) + ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + JPOS(ND,1)=JTYP + JPOS(ND,2)=JNUM + JPOS(ND,3)=JATL + NPATH(ND)=NPATH(ND)+1. + IF(ND.GT.1) THEN + COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( + &R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(ITYP).EQ.0) THEN + IF(COSTHMIJ.LT.COSFWDI) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(ITYP).EQ.1) THEN + IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + RHOIJ=VK(JE)*R(ND) + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THIJ=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) + IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 + ZSURFI=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(ITYP)=SIG2(R(ND-1),ITYP) + ENDIF + IF(ABS(ZSURFI).LE.SMALL) THEN + IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN + CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO + &STHMIJ) + 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 + 40 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) + ENDIF + ENDIF + IF(ND.EQ.1) THEN + RHO01=RHOIJ + TH01=THIJ + PHI01=PHIIJ + CALL DJMN2(TH01,RLM01,LF2,2) + GOTO 30 + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + LMJ=LMAX(ITYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 + CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, + &BMIJ,CMIJ,RHOMI,RHOIJ) + 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F + &REF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 42 + I_ABS=0 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO KTYP=1,N_TYP + ND=ND+1 + IF(ND.GT.NDIF) GOTO 20 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPK=NATYP(KTYP) + ELSE + NBTYPK=1 + ENDIF +C + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.EQ.JATL) GOTO 22 + JPOS(ND,1)=KTYP + JPOS(ND,2)=KNUM + JPOS(ND,3)=KATL + XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) + YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) + ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF(IT(ND-1).EQ.1) GOTO 32 + RHOJK=R(ND)*VK(JE) + NPATH(ND)=NPATH(ND)+1. + COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) + &/(R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(JTYP).EQ.0) THEN + IF(COSTHIJK.LT.COSFWDJ) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(JTYP).EQ.1) THEN + IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH + &EN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + IF(IT(ND-1).EQ.1) GOTO 32 + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THJK=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + IF(ND-1.LT.NDIF) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 + ZSURFJ=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(JTYP)=SIG2(R(ND-1),JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(COSTHIJK-1.).GT.SMALL) THEN + CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 + &.*COSTHIJK) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 50 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) + ENDIF + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + LMJ=LMAX(JTYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) + &=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 + IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + ENDIF + CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A + &IJK,BIJK,CIJK,RHOIJ,RHOJK) + CEX(ND)=CEXP(IC*RHOJK)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI + &JK,FREF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 32 + CALL FINDPATHS3(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH + &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) + 32 DIJ=DIJ-R(ND) + 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDDO + 20 CONTINUE + ND=ND-1 + ENDDO + 42 DIJ=DIJ-R(ND) + 12 IF(ND.GT.1) THEN + IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDIF + ENDDO + ND=ND-1 + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE FINDPATHS3(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM + &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) +C +C This routine generates all the paths and filters them according to the +C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). +C It corresponds to the spin-independent case from a non spin-orbit +C resolved initial core state LI +C +C Last modified : 16 May 2007 +C + USE DIM_MOD +C + USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH + USE COOR_MOD + USE DEBWAL_MOD + USE INIT_L_MOD + USE PATH_MOD + USE ROT_MOD + USE TESTPA_MOD + USE TESTPB_MOD + USE TRANS_MOD + USE TLDW_MOD + USE VARIA_MOD +C + DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),R(NDIF_M) +C +C +C + COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK + COMPLEX IC,COMPL1,PW(0:NDIF_M) + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX YLM1(0:NL_M,-NL_M:NL_M) + COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 +C + DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ +C + IC=(0.,1.) + IEULER=1 +C + IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) + IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) +C +C I_CP = 0 : all open paths generated +C I_CP = 1 : only closed paths generated +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO JTYP=1,N_TYP + IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) + IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) + ND=ND+1 +C +C I_ABS = 0 : the atom before the scatterer is not the absorber +C I_ABS = 1 : the atom before the scatterer is the absorber +C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) +C + IF(ND.EQ.1) THEN + I_ABS=1 + ELSE + I_ABS=0 + ENDIF +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPJ=NATYP(JTYP) + ELSE + NBTYPJ=1 + ENDIF +C + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + IF(JATL.EQ.IATL) GOTO 12 + XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) + YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) + ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + JPOS(ND,1)=JTYP + JPOS(ND,2)=JNUM + JPOS(ND,3)=JATL + NPATH(ND)=NPATH(ND)+1. + IF(ND.GT.1) THEN + COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( + &R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(ITYP).EQ.0) THEN + IF(COSTHMIJ.LT.COSFWDI) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(ITYP).EQ.1) THEN + IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + RHOIJ=VK(JE)*R(ND) + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THIJ=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) + IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 + ZSURFI=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(ITYP)=SIG2(R(ND-1),ITYP) + ENDIF + IF(ABS(ZSURFI).LE.SMALL) THEN + IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN + CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO + &STHMIJ) + 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 + 40 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) + ENDIF + ENDIF + IF(ND.EQ.1) THEN + RHO01=RHOIJ + TH01=THIJ + PHI01=PHIIJ + CALL DJMN2(TH01,RLM01,LF2,2) + GOTO 30 + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + LMJ=LMAX(ITYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 + CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, + &BMIJ,CMIJ,RHOMI,RHOIJ) + 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F + &REF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 42 + I_ABS=0 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO KTYP=1,N_TYP + ND=ND+1 + IF(ND.GT.NDIF) GOTO 20 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPK=NATYP(KTYP) + ELSE + NBTYPK=1 + ENDIF +C + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.EQ.JATL) GOTO 22 + JPOS(ND,1)=KTYP + JPOS(ND,2)=KNUM + JPOS(ND,3)=KATL + XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) + YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) + ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF(IT(ND-1).EQ.1) GOTO 32 + RHOJK=R(ND)*VK(JE) + NPATH(ND)=NPATH(ND)+1. + COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) + &/(R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(JTYP).EQ.0) THEN + IF(COSTHIJK.LT.COSFWDJ) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(JTYP).EQ.1) THEN + IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH + &EN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + IF(IT(ND-1).EQ.1) GOTO 32 + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THJK=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + IF(ND-1.LT.NDIF) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 + ZSURFJ=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(JTYP)=SIG2(R(ND-1),JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(COSTHIJK-1.).GT.SMALL) THEN + CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 + &.*COSTHIJK) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 50 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) + ENDIF + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + LMJ=LMAX(JTYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) + &=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 + IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + ENDIF + CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A + &IJK,BIJK,CIJK,RHOIJ,RHOJK) + CEX(ND)=CEXP(IC*RHOJK)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI + &JK,FREF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 32 + CALL FINDPATHS4(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH + &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) + 32 DIJ=DIJ-R(ND) + 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDDO + 20 CONTINUE + ND=ND-1 + ENDDO + 42 DIJ=DIJ-R(ND) + 12 IF(ND.GT.1) THEN + IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDIF + ENDDO + ND=ND-1 + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE FINDPATHS4(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM + &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) +C +C This routine generates all the paths and filters them according to the +C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). +C It corresponds to the spin-independent case from a non spin-orbit +C resolved initial core state LI +C +C Last modified : 16 May 2007 +C + USE DIM_MOD +C + USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH + USE COOR_MOD + USE DEBWAL_MOD + USE INIT_L_MOD + USE PATH_MOD + USE ROT_MOD + USE TESTPA_MOD + USE TESTPB_MOD + USE TRANS_MOD + USE TLDW_MOD + USE VARIA_MOD +C + DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),R(NDIF_M) +C +C +C + COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK + COMPLEX IC,COMPL1,PW(0:NDIF_M) + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX YLM1(0:NL_M,-NL_M:NL_M) + COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 +C + DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ +C + IC=(0.,1.) + IEULER=1 +C + IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) + IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) +C +C I_CP = 0 : all open paths generated +C I_CP = 1 : only closed paths generated +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO JTYP=1,N_TYP + IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) + IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) + ND=ND+1 +C +C I_ABS = 0 : the atom before the scatterer is not the absorber +C I_ABS = 1 : the atom before the scatterer is the absorber +C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) +C + IF(ND.EQ.1) THEN + I_ABS=1 + ELSE + I_ABS=0 + ENDIF +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPJ=NATYP(JTYP) + ELSE + NBTYPJ=1 + ENDIF +C + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + IF(JATL.EQ.IATL) GOTO 12 + XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) + YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) + ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + JPOS(ND,1)=JTYP + JPOS(ND,2)=JNUM + JPOS(ND,3)=JATL + NPATH(ND)=NPATH(ND)+1. + IF(ND.GT.1) THEN + COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( + &R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(ITYP).EQ.0) THEN + IF(COSTHMIJ.LT.COSFWDI) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(ITYP).EQ.1) THEN + IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + RHOIJ=VK(JE)*R(ND) + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THIJ=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) + IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 + ZSURFI=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(ITYP)=SIG2(R(ND-1),ITYP) + ENDIF + IF(ABS(ZSURFI).LE.SMALL) THEN + IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN + CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO + &STHMIJ) + 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 + 40 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) + ENDIF + ENDIF + IF(ND.EQ.1) THEN + RHO01=RHOIJ + TH01=THIJ + PHI01=PHIIJ + CALL DJMN2(TH01,RLM01,LF2,2) + GOTO 30 + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + LMJ=LMAX(ITYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 + CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, + &BMIJ,CMIJ,RHOMI,RHOIJ) + 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F + &REF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 42 + I_ABS=0 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO KTYP=1,N_TYP + ND=ND+1 + IF(ND.GT.NDIF) GOTO 20 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPK=NATYP(KTYP) + ELSE + NBTYPK=1 + ENDIF +C + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.EQ.JATL) GOTO 22 + JPOS(ND,1)=KTYP + JPOS(ND,2)=KNUM + JPOS(ND,3)=KATL + XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) + YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) + ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF(IT(ND-1).EQ.1) GOTO 32 + RHOJK=R(ND)*VK(JE) + NPATH(ND)=NPATH(ND)+1. + COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) + &/(R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(JTYP).EQ.0) THEN + IF(COSTHIJK.LT.COSFWDJ) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(JTYP).EQ.1) THEN + IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH + &EN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + IF(IT(ND-1).EQ.1) GOTO 32 + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THJK=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + IF(ND-1.LT.NDIF) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 + ZSURFJ=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(JTYP)=SIG2(R(ND-1),JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(COSTHIJK-1.).GT.SMALL) THEN + CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 + &.*COSTHIJK) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 50 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) + ENDIF + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + LMJ=LMAX(JTYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) + &=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 + IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + ENDIF + CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A + &IJK,BIJK,CIJK,RHOIJ,RHOJK) + CEX(ND)=CEXP(IC*RHOJK)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI + &JK,FREF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 32 + CALL FINDPATHS5(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH + &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) + 32 DIJ=DIJ-R(ND) + 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDDO + 20 CONTINUE + ND=ND-1 + ENDDO + 42 DIJ=DIJ-R(ND) + 12 IF(ND.GT.1) THEN + IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDIF + ENDDO + ND=ND-1 + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE FINDPATHS5(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM + &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) +C +C This routine generates all the paths and filters them according to the +C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). +C It corresponds to the spin-independent case from a non spin-orbit +C resolved initial core state LI +C +C Last modified : 16 May 2007 +C + USE DIM_MOD +C + USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH + USE COOR_MOD + USE DEBWAL_MOD + USE INIT_L_MOD + USE PATH_MOD + USE ROT_MOD + USE TESTPA_MOD + USE TESTPB_MOD + USE TRANS_MOD + USE TLDW_MOD + USE VARIA_MOD +C + DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),R(NDIF_M) +C +C +C + COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK + COMPLEX IC,COMPL1,PW(0:NDIF_M) + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX YLM1(0:NL_M,-NL_M:NL_M) + COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 +C + DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ +C + IC=(0.,1.) + IEULER=1 +C + IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) + IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) +C +C I_CP = 0 : all open paths generated +C I_CP = 1 : only closed paths generated +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO JTYP=1,N_TYP + IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) + IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) + ND=ND+1 +C +C I_ABS = 0 : the atom before the scatterer is not the absorber +C I_ABS = 1 : the atom before the scatterer is the absorber +C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) +C + IF(ND.EQ.1) THEN + I_ABS=1 + ELSE + I_ABS=0 + ENDIF +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPJ=NATYP(JTYP) + ELSE + NBTYPJ=1 + ENDIF +C + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + IF(JATL.EQ.IATL) GOTO 12 + XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) + YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) + ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + JPOS(ND,1)=JTYP + JPOS(ND,2)=JNUM + JPOS(ND,3)=JATL + NPATH(ND)=NPATH(ND)+1. + IF(ND.GT.1) THEN + COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( + &R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(ITYP).EQ.0) THEN + IF(COSTHMIJ.LT.COSFWDI) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(ITYP).EQ.1) THEN + IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 + RHOIJ=VK(JE)*R(ND) + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THIJ=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) + IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 + ZSURFI=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(ITYP)=SIG2(R(ND-1),ITYP) + ENDIF + IF(ABS(ZSURFI).LE.SMALL) THEN + IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN + CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO + &STHMIJ) + 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 + 40 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) + ENDIF + ENDIF + IF(ND.EQ.1) THEN + RHO01=RHOIJ + TH01=THIJ + PHI01=PHIIJ + CALL DJMN2(TH01,RLM01,LF2,2) + GOTO 30 + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + LMJ=LMAX(ITYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 + CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, + &BMIJ,CMIJ,RHOMI,RHOIJ) + 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F + &REF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 42 + I_ABS=0 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN + N_TYP=N_PROT + ELSE + N_TYP=1 + ENDIF +C + DO KTYP=1,N_TYP + ND=ND+1 + IF(ND.GT.NDIF) GOTO 20 +C + IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN + NBTYPK=NATYP(KTYP) + ELSE + NBTYPK=1 + ENDIF +C + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.EQ.JATL) GOTO 22 + JPOS(ND,1)=KTYP + JPOS(ND,2)=KNUM + JPOS(ND,3)=KATL + XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) + YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) + ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) + R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) + DIJ=DIJ+R(ND) + IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 + IF(IT(ND-1).EQ.1) GOTO 32 + RHOJK=R(ND)*VK(JE) + NPATH(ND)=NPATH(ND)+1. + COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) + &/(R(ND)*R(ND-1)) + IF(IFWD.EQ.1) THEN + IF(IBWD(JTYP).EQ.0) THEN + IF(COSTHIJK.LT.COSFWDJ) THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ELSEIF(IBWD(JTYP).EQ.1) THEN + IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH + &EN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN + NTHOF=NTHOF+1 + IN(ND-1)=1 + IF(NTHOF.GT.NTHOUT) THEN + IT(ND-1)=1 + ENDIF + ENDIF + ENDIF + ENDIF + IF(IT(ND-1).EQ.1) GOTO 32 + CTROIS1=ZR(ND)/R(ND) + IF(CTROIS1.GT.1) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + THJK=ACOS(CTROIS1) + COMPL1= XR(ND)+IC*YR(ND) + IF(ND-1.LT.NDIF) THEN + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 + ZSURFJ=ZSURF-ZR(ND-1) + IF(IDCM.EQ.1) THEN + UJ2(JTYP)=SIG2(R(ND-1),JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(COSTHIJK-1.).GT.SMALL) THEN + CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 + &.*COSTHIJK) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 50 IF(IDWSPH.EQ.1) THEN + DW(ND-1)=1. + ELSE + DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) + ENDIF + ENDIF + IF(IPW.EQ.1) THEN + CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) + PWI=FTHETA*DW(ND-1)/R(ND) + PW(ND)=PW(ND-1)*PWI + CTL2=PI4*PW(ND)*CEX(1)/VK(JE) + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + LMJ=LMAX(JTYP,JE) + IF(ND.GT.NCUT) THEN + IT(ND)=1 + ELSE + IT(ND)=0 + ENDIF + CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) + CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) + XMAXT=0. + DO LJ=0,LMJ + CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) + DO LF=LF1,LF2,ISTEP_LF + PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) + XMAXT=AMAX1(XMAXT,CABS(PW1)) + ENDDO + ENDDO + IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) + &=0 + ENDIF + IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 + IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN + CALL ARCSIN(COMPL1,CTROIS1,PHIJK) + ENDIF + CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) + IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 + CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A + &IJK,BIJK,CIJK,RHOIJ,RHOJK) + CEX(ND)=CEXP(IC*RHOJK)/R(ND) + CEXDW(ND)=CEX(ND)*DW(ND-1) + IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN + IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN + CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI + &JK,FREF,IJ,DIJ,TAU) + NPATH2(ND)=NPATH2(ND)+1. + ENDIF + ENDIF + IF(ND.EQ.NDIF) GOTO 32 +c CALL FINDPATHS(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK, +c 1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) + 32 DIJ=DIJ-R(ND) + 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDDO + 20 CONTINUE + ND=ND-1 + ENDDO + 42 DIJ=DIJ-R(ND) + 12 IF(ND.GT.1) THEN + IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 + IT(ND-1)=0 + IN(ND-1)=0 + ENDIF + ENDDO + ND=ND-1 + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE MATDIF(NO,ND,LF,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A21,B2 + &1,C21,RHO1,RHO2) +C +C This routine calculates the Rehr-Albers scattering matrix +C F_{LAMBDA1,LAMBDA2}. The result is stored in the COMMON block +C /SCATMAT/ as F21(NSPIN2_M,NLAMBDA_M,NLAMBDA_M,NDIF_M). +C +C Last modified : 3 Aug 2007 +C + USE DIM_MOD +C + USE EXPFAC_MOD + USE LBD_MOD + USE LINLBD_MOD + USE RA_MOD + USE SCATMAT_MOD + USE TRANS_MOD + USE TLDW_MOD +C + REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + COMPLEX HLM1(0:NO_ST_M,0:NL_M-1),HLM2(0:NO_ST_M,0:NL_M-1) + COMPLEX SL,RHO1,RHO2,IC,ZEROC,ONEC,ONEOVK + COMPLEX SL_2_1,SL_2_2 + COMPLEX EXP1,EXP2,PROD1,PROD2 +C + DATA PI,SMALL /3.141593,0.0001/ +C + IC=(0.,1.) + ZEROC=(0.,0.) + ONEC=(1.,0.) + ONEOVK=1./VK(JE) + IB=0 + LMJ=LMAX(JTYP,JE) + IF(ABS(ABS(B21)-PI).LT.SMALL) IB=-1 + IF(ABS(B21).LT.SMALL) IB=1 + IF(NO.EQ.8) THEN + NN2=LMAX(JTYP,JE)+1 + ELSE + NN2=NO + ENDIF +C +C NO is atom-dependent and is decreased with the rank of the scatterer +C in the path when I_NO > 0. Here LAMBDA1 depends on the scatterer JTYP +C while LAMBDA2 depends on the next atom (KTYP) in the path +C + IF(I_NO.EQ.0) THEN + NO1=N_RA(JTYP) + NO2=N_RA(KTYP) + ELSE + NO1=MAX(N_RA(JTYP)-(ND-1)/I_NO,0) + NO2=MAX(N_RA(KTYP)-ND/I_NO,0) + ENDIF + IF(I_ABS.EQ.0) THEN + NUMAX1=NO1/2 + NUMAX2=NO2/2 + ELSEIF(I_ABS.EQ.1) THEN + NUMAX1=MIN0(LF,NO1/2) + NUMAX2=NO2/2 + ELSEIF(I_ABS.EQ.2) THEN + NUMAX1=NO1/2 + NUMAX2=MIN0(LF,NO2/2) + ENDIF + LBDM(1,ND)=(NO1+1)*(NO1+2)/2 + LBDM(2,ND)=(NO2+1)*(NO2+2)/2 +C + EXP2=-EXP(-IC*A21) + EXP1=EXP(-IC*C21) +C + DO LAMBDA1=1,LBDMAX + DO LAMBDA2=1,LBDMAX + F21(1,LAMBDA2,LAMBDA1,ND)=ZEROC + ENDDO + ENDDO +C + IF(ABS(RHO1-RHO2).GT.SMALL) THEN + CALL POLHAN(ISPHER,NUMAX1,LMJ,RHO1,HLM1) + CALL POLHAN(ISPHER,NN2,LMJ,RHO2,HLM2) + NEQUAL=0 + ELSE + CALL POLHAN(ISPHER,NN2,LMJ,RHO1,HLM1) + NEQUAL=1 + ENDIF +C +C Calculation of the scattering matrix when the scattering angle +C is different from 0 and pi +C + IF(IB.EQ.0) THEN + CALL DJMN(B21,RLM,LMJ) + DO NU1=0,NUMAX1 + MUMAX1=NO1-2*NU1 + IF(I_ABS.EQ.1) MUMAX1=MIN(LF-NU1,MUMAX1) + DO NU2=0,NUMAX2 + MUMAX2=NO2-2*NU2 +C +C Case MU1 = 0 +C + LAMBDA1=LBD(0,NU1) +C +C Case MU2 = 0 +C + LAMBDA2=LBD(0,NU2) + LMIN=MAX(NU1,NU2) + SL=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(NU2,L)=HLM1(NU2,L) + ENDIF + IF(ISPEED.EQ.1) THEN + SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TL(L,1,JTYP,JE)*HLM1(NU1,L + &)*HLM2(NU2,L) + ELSE + SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TLT(L,1,JTYP,JE)*HLM1(NU1, + &L)*HLM2(NU2,L) + ENDIF + ENDDO + F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK +C +C Case MU2 > 0 +C + PROD2=ONEC + SIG2=1. + DO MU2=1,MUMAX2 + LAMBDA2_1=LBD(MU2,NU2) + LAMBDA2_2=LBD(-MU2,NU2) + PROD2=PROD2*EXP2 + SIG2=-SIG2 + LMIN=MAX(NU1,MU2+NU2) + SL=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L) + ENDIF + C1=EXPF(0,L)/EXPF(MU2,L) + IF(ISPEED.EQ.1) THEN + SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TL(L,1,JTYP,JE)*HLM + &1(NU1,L)*HLM2(MU2+NU2,L) + ELSE + SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TLT(L,1,JTYP,JE)*HL + &M1(NU1,L)*HLM2(MU2+NU2,L) + ENDIF + ENDDO + F21(1,LAMBDA2_1,LAMBDA1,ND)=SL*PROD2*ONEOVK*SIG2 + F21(1,LAMBDA2_2,LAMBDA1,ND)=SL*ONEOVK/PROD2 + ENDDO +C +C Case MU1 > 0 +C + PROD1=ONEC + SIG1=1. + DO MU1=1,MUMAX1 + LAMBDA1_1=LBD(MU1,NU1) + LAMBDA1_2=LBD(-MU1,NU1) + PROD1=PROD1*EXP1 + SIG1=-SIG1 +C +C Case MU2 = 0 +C + LAMBDA2=LBD(0,NU2) + LMIN=MAX(MU1,NU1,NU2) + SL=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(NU2,L)=HLM1(NU2,L) + ENDIF + C1=EXPF(MU1,L)/EXPF(0,L) + IF(ISPEED.EQ.1) THEN + SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TL(L,1,JTYP,JE)*HLM + &1(NU1,L)*HLM2(NU2,L) + ELSE + SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TLT(L,1,JTYP,JE)*HL + &M1(NU1,L)*HLM2(NU2,L) + ENDIF + ENDDO + F21(1,LAMBDA2,LAMBDA1_1,ND)=SL*PROD1*ONEOVK*SIG1 + F21(1,LAMBDA2,LAMBDA1_2,ND)=SL*ONEOVK/PROD1 +C +C Case MU2 > 0 +C + PROD2=ONEC + SIG2=SIG1 + DO MU2=1,MUMAX2 + LAMBDA2_1=LBD(MU2,NU2) + LAMBDA2_2=LBD(-MU2,NU2) + PROD2=PROD2*EXP2 + SIG2=-SIG2 + LMIN=MAX(MU1,NU1,MU2+NU2) + SL_2_1=ZEROC + SL_2_2=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L) + ENDIF + C1=EXPF(MU1,L)/EXPF(MU2,L) + IF(ISPEED.EQ.1) THEN + SL=FLOAT(L+L+1)*C1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2( + &MU2+NU2,L) + ELSE + SL=FLOAT(L+L+1)*C1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2 + &(MU2+NU2,L) + ENDIF + SL_2_1=SL_2_1+SL*RLM(MU2,-MU1,L) + SL_2_2=SL_2_2+SL*RLM(MU2,MU1,L) + ENDDO + F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL_2_2*PROD1*PROD2*ONEOVK* + &SIG2 + F21(1,LAMBDA2_2,LAMBDA1_1,ND)=SL_2_1*PROD1*ONEOVK/PROD2 + F21(1,LAMBDA2_1,LAMBDA1_2,ND)=SL_2_1*ONEOVK*PROD2*SIG2/P + &ROD1 + F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL_2_2*ONEOVK/(PROD1*PROD2 + &) + ENDDO + ENDDO + ENDDO + ENDDO +C +C Calculation of the scattering matrix when the scattering angle +C is equal to 0 (forward scattering) or pi (backscattering) +C + ELSEIF(IB.EQ.1) THEN + DO NU1=0,NUMAX1 + DO NU2=0,NUMAX2 + MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2) + IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1) +C +C Case MU = 0 +C + LAMBDA1=LBD(0,NU1) + LAMBDA2=LBD(0,NU2) + LMIN=MAX(NU1,NU2) + SL=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(NU2,L)=HLM1(NU2,L) + ENDIF + IF(ISPEED.EQ.1) THEN + SL=SL+FLOAT(L+L+1)*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2, + &L) + ELSE + SL=SL+FLOAT(L+L+1)*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2 + &,L) + ENDIF + ENDDO + F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK +C +C Case MU > 0 +C + CST1=1. + DO MU=1,MUMAX1 + LAMBDA1=LBD(MU,NU2) + LAMBDA2=LBD(-MU,NU2) + CST1=-CST1 + LMIN=MAX(NU1,MU+NU2) + SL=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(MU+NU2,L)=HLM1(MU+NU2,L) + ENDIF + IF(ISPEED.EQ.1) THEN + SL=SL+FLOAT(L+L+1)*CST1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL + &M2(MU+NU2,L) + ELSE + SL=SL+FLOAT(L+L+1)*CST1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H + &LM2(MU+NU2,L) + ENDIF + ENDDO + F21(1,LAMBDA1,LAMBDA1,ND)=SL*ONEOVK + F21(1,LAMBDA2,LAMBDA2,ND)=SL*ONEOVK + ENDDO + ENDDO + ENDDO + ELSEIF(IB.EQ.-1) THEN + DO NU1=0,NUMAX1 + DO NU2=0,NUMAX2 + MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2) + IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1) +C +C Case MU = 0 +C + LAMBDA1=LBD(0,NU1) + LAMBDA2=LBD(0,NU2) + LMIN=MAX(NU1,NU2) + SL=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(NU2,L)=HLM1(NU2,L) + ENDIF + IF(MOD(L,2).EQ.0) THEN + CST2=1.0 + ELSE + CST2=-1.0 + ENDIF + IF(ISPEED.EQ.1) THEN + SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2 + &(NU2,L) + ELSE + SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM + &2(NU2,L) + ENDIF + ENDDO + F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK +C +C Case MU > 0 +C + CST1=1. + DO MU=1,MUMAX1 + MUP=-MU + LAMBDA1_1=LBD(MUP,NU1) + LAMBDA1_2=LBD(-MUP,NU1) + LAMBDA2_1=LBD(MU,NU2) + LAMBDA2_2=LBD(-MU,NU2) + CST1=-CST1 + LMIN=MAX(NU1,MU+NU2) + SL=ZEROC + DO L=LMIN,LMJ + IF(NEQUAL.EQ.1) THEN + HLM2(MU+NU2,L)=HLM1(MU+NU2,L) + ENDIF + IF(MOD(L,2).EQ.0) THEN + CST2=CST1 + ELSE + CST2=-CST1 + ENDIF + IF(ISPEED.EQ.1) THEN + SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL + &M2(MU+NU2,L) + ELSE + SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H + &LM2(MU+NU2,L) + ENDIF + ENDDO + F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL*ONEOVK + F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL*ONEOVK + ENDDO + ENDDO + ENDDO + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE PATHOP(JPOS,JORDP,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ, + &FREF,IJ,D,TAU) +C +C This subroutine calculates the contribution of a given path to +C the scattering path operator TAU. +C +C Last modified : 3 Aug 2007 +C + USE DIM_MOD +C + USE APPROX_MOD + USE EXPFAC_MOD + USE EXTREM_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE LBD_MOD + USE LINLBD_MOD + USE OUTUNITS_MOD + USE PATH_MOD + USE PRINTP_MOD + USE RA_MOD + USE ROT_MOD + USE SCATMAT_MOD , F => F21 + USE TESTS_MOD + USE TLDW_MOD + USE TRANS_MOD + USE VARIA_MOD +C + INTEGER JPOS(NDIF_M,3),AMU1 +C +C + REAL RLMIJ(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX H(NLAMBDA_M,NLAMBDA_M) + COMPLEX G(NLAMBDA_M,NLAMBDA_M) + COMPLEX HLM01(0:NO_ST_M,0:NL_M-1),HLMIJ(0:NO_ST_M,0:NL_M-1) + COMPLEX SUM_NUJ_0,SUM_MUJ_0,SUM_NU1_0 + COMPLEX SUM_NUJ_1,SUM_MUJ_1,SUM_NU1_1 + COMPLEX SUM_NU1_2,SUM_NU1_3 + COMPLEX RHO01,RHOIJ + COMPLEX RLMF_0,RLMF_1 + COMPLEX CF,CJ,OVK + COMPLEX EXP_J,EXP_F,SUM_1 + COMPLEX TL_J + COMPLEX COEF,ONEC,ZEROC +C +C +C + DATA PI,XCOMP /3.141593,1.E-10/ +C + ZEROC=(0.,0.) + ONEC=(1.,0.) +C + OVK=(1.,0.)/VK(JE) + IF(NPATHP.GT.0) THEN + FM1=FMIN(JORDP) + XMAX=0. + ENDIF + EXP_J=CEXP((0.,-1.)*(PHIIJ-PI)) + EXP_F=CEXP((0.,1.)*PHI01) + JTYP=JPOS(JORDP,1) + ITYP=JPOS(1,1) + JATL=JPOS(JORDP,3) + IF(I_CP.EQ.0) THEN + LMJ=LMAX(JTYP,JE) + ELSE + LMJ=LF2 + ENDIF + IF(NO.EQ.8) THEN + NN2=LMJ+1 + ELSE + NN2=NO + ENDIF + IF(NO.GT.LF2) THEN + NN=LF2 + ELSE + NN=NO + ENDIF +C +C NO is atom-dependent and is decreased with the rank of the scatterer +C in the path when I_NO > 0 (except for the first scatterer ITYP for +C which there is no such decrease) +C + NO1=N_RA(ITYP) + IF(I_NO.EQ.0) THEN + IF(IJ.EQ.1) THEN + NOJ=N_RA(JTYP) + ELSE + NOJ=0 + ENDIF + ELSE + IF(IJ.EQ.1) THEN + NOJ= MAX(N_RA(JTYP)-(JORDP-1)/I_NO,0) + ELSE + NOJ=0 + ENDIF + ENDIF + NUMX=NO1/2 + NUMAXJ=NOJ/2 +C +C Calculation of the attenuation coefficients along the path +C + COEF=CEX(1)*OVK + DO JSC=2,JORDP + COEF=COEF*CEXDW(JSC) + ENDDO +C +C Call of the subroutines used for the R-A termination matrix +C This termination matrix is now merged into PATHOP +C + CALL DJMN2(-THIJ,RLMIJ,LMJ,1) + CALL POLHAN(ISPHER,NN,LF2,RHO01,HLM01) + CALL POLHAN(ISPHER,NN2,LMJ,RHOIJ,HLMIJ) +C + LBD1M1=LBDM(1,1) + LBD1M2=LBDM(2,1) +C +C Calculation of the L-independent part of TAU, called H +C + IF(JORDP.GE.3) THEN + DO JPAT=2,JORDP-1 + LBD2M=LBDM(1,JPAT) + LBD3M=LBDM(2,JPAT) + DO LAMBDA1=1,LBD1M1 + DO LAMBDA3=1,LBD3M + SUM_1=ZEROC + DO LAMBDA2=1,LBD2M + IF(JPAT.GT.2) THEN + SUM_1=SUM_1+H(LAMBDA2,LAMBDA1)*F(1,LAMBDA3,LAMBDA2,JPA + &T) + ELSE + SUM_1=SUM_1+F(1,LAMBDA2,LAMBDA1,1)*F(1,LAMBDA3,LAMBDA2 + &,2) + ENDIF + ENDDO + G(LAMBDA3,LAMBDA1)=SUM_1 + ENDDO + ENDDO + DO LAMBDA1=1,LBD1M1 + DO LAMBDA2=1,LBD3M + H(LAMBDA2,LAMBDA1)=G(LAMBDA2,LAMBDA1) + ENDDO + ENDDO + ENDDO + ELSEIF(JORDP.EQ.2) THEN + DO LAMBDA1=1,LBD1M1 + DO LAMBDA2=1,LBD1M2 + H(LAMBDA2,LAMBDA1)=F(1,LAMBDA2,LAMBDA1,1) + ENDDO + ENDDO + ELSEIF(JORDP.EQ.1) THEN + DO LAMBDA1=1,LBD1M1 + DO LAMBDA2=1,LBD1M1 + H(LAMBDA2,LAMBDA1)=ONEC + ENDDO + ENDDO + ENDIF +C +C Calculation of the path operator TAU +C + DO LF=LF1,LF2,ISTEP_LF + ILF=LF*LF+LF+1 +C + NU1MAX1=MIN(LF,NUMX) +C +C Case MF = 0 +C + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + NUJMAX=MIN(LJ,NUMAXJ) + IF(JORDP.EQ.1) THEN + NU1MAX=MIN(NU1MAX1,LJ) + ELSE + NU1MAX=NU1MAX1 + ENDIF +C + IF(ISPEED.EQ.1) THEN + TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE) + ELSE + TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE) + ENDIF +C +C Case MJ = 0 +C + SUM_NU1_0=ZEROC +C + DO NU1=0,NU1MAX + IF(JORDP.GT.1) THEN + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) + ELSE + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) + ENDIF +C + DO MU1=-MU1MAX,MU1MAX + LAMBDA1=LBD(MU1,NU1) + AMU1=ABS(MU1) +C + RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF) +C + SUM_NUJ_0=ZEROC +C + IF(JORDP.GT.1) THEN + DO NUJ=0,NUJMAX + MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) +C + SUM_MUJ_0=ZEROC +C + DO MUJ=-MUJMAX,MUJMAX +C + LAMBDAJ=LBD(MUJ,NUJ) +C + SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0,L + &J) + ENDDO + SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) +C + ENDDO + ELSE + SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ) + ENDIF +C + SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 +C + ENDDO +C + ENDDO +C + TAU(ILJ,ILF,JATL)=TAU(ILJ,ILF,JATL)+TL_J*SUM_NU1_0 +C + IF(NPATHP.EQ.0) GOTO 35 +C + FM2=FMAX(JORDP) + XINT=CABS(TL_J*SUM_NU1_0) + XMAX=AMAX1(XINT,XMAX) + FMAX(JORDP)=AMAX1(FM2,XINT) + IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) + IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN + FREF=FMAX(JORDP) + ENDIF + 35 CONTINUE +C +C Case MJ > 0 +C + CJ=ONEC + DO MJ=1,LJ + INDJ=ILJ+MJ + INDJP=ILJ-MJ + CJ=CJ*EXP_J +C + SUM_NU1_0=ZEROC + SUM_NU1_1=ZEROC +C + DO NU1=0,NU1MAX + IF(JORDP.GT.1) THEN + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) + ELSE + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) + ENDIF +C + DO MU1=-MU1MAX,MU1MAX + LAMBDA1=LBD(MU1,NU1) + AMU1=ABS(MU1) +C + RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF) +C + SUM_NUJ_0=ZEROC + SUM_NUJ_1=ZEROC +C + IF(JORDP.GT.1) THEN + DO NUJ=0,NUJMAX + MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) +C + SUM_MUJ_0=ZEROC + SUM_MUJ_1=ZEROC +C + DO MUJ=-MUJMAX,MUJMAX +C + LAMBDAJ=LBD(MUJ,NUJ) +C + SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,- + &MJ,LJ) + SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,M + &J,LJ) +C + ENDDO +C + SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) + SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ) +C + ENDDO + ELSE + SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ) + SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ) + ENDIF +C + SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 + SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1 +C + ENDDO +C + ENDDO +C + TAU(INDJP,ILF,JATL)=TAU(INDJP,ILF,JATL)+CONJG(CJ)*TL_J*SUM_N + &U1_1 + TAU(INDJ,ILF,JATL)=TAU(INDJ,ILF,JATL)+CJ*TL_J*SUM_NU1_0 +C + IF(NPATHP.EQ.0) GOTO 45 +C + FM2=FMAX(JORDP) + XINT1=CABS(CJ*TL_J*SUM_NU1_0) + XINT2=CABS(CONJG(CJ)*TL_J*SUM_NU1_1) + XMAX=AMAX1(XINT1,XINT2,XMAX) + FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2) + IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) + IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN + FREF=FMAX(JORDP) + ENDIF + 45 CONTINUE + ENDDO + ENDDO +C +C Case MF > 0 +C + CF=ONEC + DO MF=1,LF + INDF=ILF+MF + INDFP=ILF-MF + CF=CF*EXP_F +C + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + NUJMAX=MIN(LJ,NUMAXJ) + IF(JORDP.EQ.1) THEN + NU1MAX=MIN(NU1MAX1,LJ) + ELSE + NU1MAX=NU1MAX1 + ENDIF +C + IF(ISPEED.EQ.1) THEN + TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE) + ELSE + TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE) + ENDIF +C +C Case MJ = 0 +C + SUM_NU1_0=ZEROC + SUM_NU1_1=ZEROC +C + DO NU1=0,NU1MAX + IF(JORDP.GT.1) THEN + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) + ELSE + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) + ENDIF +C + DO MU1=-MU1MAX,MU1MAX + LAMBDA1=LBD(MU1,NU1) + AMU1=ABS(MU1) +C + RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF) + RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF) +C + SUM_NUJ_0=ZEROC +C + IF(JORDP.GT.1) THEN + DO NUJ=0,NUJMAX + MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) +C + SUM_MUJ_0=ZEROC +C + DO MUJ=-MUJMAX,MUJMAX +C + LAMBDAJ=LBD(MUJ,NUJ) +C + SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0 + &,LJ) +C + ENDDO +C + SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) +C + ENDDO + ELSE + SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ) + ENDIF +C + SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 + SUM_NU1_1=SUM_NU1_1+RLMF_1*SUM_NUJ_0 +C + ENDDO +C + ENDDO +C + TAU(ILJ,INDF,JATL)=TAU(ILJ,INDF,JATL)+CF*TL_J*SUM_NU1_0 + TAU(ILJ,INDFP,JATL)=TAU(ILJ,INDFP,JATL)+CONJG(CF)*TL_J*SUM_N + &U1_1 +C + IF(NPATHP.EQ.0) GOTO 25 +C + FM2=FMAX(JORDP) + XINT1=CABS(CF*TL_J*SUM_NU1_0) + XINT2=CABS(CONJG(CF)*TL_J*SUM_NU1_1) + XMAX=AMAX1(XINT1,XINT2,XMAX) + FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2) + IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) + IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN + FREF=FMAX(JORDP) + ENDIF + 25 CONTINUE +C +C Case MJ > 0 +C + CJ=ONEC + DO MJ=1,LJ + INDJ=ILJ+MJ + INDJP=ILJ-MJ + CJ=CJ*EXP_J +C + SUM_NU1_0=ZEROC + SUM_NU1_1=ZEROC + SUM_NU1_2=ZEROC + SUM_NU1_3=ZEROC +C + DO NU1=0,NU1MAX + IF(JORDP.GT.1) THEN + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) + ELSE + MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) + ENDIF +C + DO MU1=-MU1MAX,MU1MAX + LAMBDA1=LBD(MU1,NU1) + AMU1=ABS(MU1) +C + RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF) + RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF) +C + SUM_NUJ_0=ZEROC + SUM_NUJ_1=ZEROC +C + IF(JORDP.GT.1) THEN + DO NUJ=0,NUJMAX + MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) +C + SUM_MUJ_0=ZEROC + SUM_MUJ_1=ZEROC +C + DO MUJ=-MUJMAX,MUJMAX +C + LAMBDAJ=LBD(MUJ,NUJ) +C + SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ + &,-MJ,LJ) + SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ + &,MJ,LJ) +C + ENDDO +C + SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) + SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ) +C + ENDDO + ELSE + SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ) + SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ) + ENDIF +C + SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 + SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1 + SUM_NU1_2=SUM_NU1_2+RLMF_1*SUM_NUJ_0 + SUM_NU1_3=SUM_NU1_3+RLMF_1*SUM_NUJ_1 +C + ENDDO +C + ENDDO +C + TAU(INDJP,INDF,JATL)=TAU(INDJP,INDF,JATL)+CF*CONJG(CJ)*TL_ + &J*SUM_NU1_1 + TAU(INDJP,INDFP,JATL)=TAU(INDJP,INDFP,JATL)+CONJG(CF*CJ)*T + &L_J*SUM_NU1_3 + TAU(INDJ,INDF,JATL)=TAU(INDJ,INDF,JATL)+CF*CJ*TL_J*SUM_NU1 + &_0 + TAU(INDJ,INDFP,JATL)=TAU(INDJ,INDFP,JATL)+CONJG(CF)*CJ*TL_ + &J*SUM_NU1_2 +C + IF(NPATHP.EQ.0) GOTO 15 +C + FM2=FMAX(JORDP) + XINT1=CABS(CF*CJ*TL_J*SUM_NU1_0) + XINT2=CABS(CF*CONJG(CJ)*TL_J*SUM_NU1_1) + XINT3=CABS(CONJG(CF)*CJ*TL_J*SUM_NU1_2) + XINT4=CABS(CONJG(CF*CJ)*TL_J*SUM_NU1_3) + XMAX=AMAX1(XINT1,XINT2,XINT3,XINT4,XMAX) + FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2,XINT3,XINT4) + IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) + IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN + FREF=FMAX(JORDP) + ENDIF + 15 CONTINUE + ENDDO + ENDDO + ENDDO + ENDDO +C + IF(NPATHP.EQ.0) GOTO 16 + FMIN(JORDP)=AMIN1(FM1,XMAX) + IF(XMAX.GT.FMN(NPATHP)) THEN + CALL LOCATE(FMN,NPATHP,XMAX,JMX) + DO KF=NPATHP,JMX+2,-1 + FMN(KF)=FMN(KF-1) + JON(KF)=JON(KF-1) + PATH(KF)=PATH(KF-1) + DMN(KF)=DMN(KF-1) + DO KD=1,10 + JPON(KF,KD)=JPON(KF-1,KD) + ENDDO + ENDDO + FMN(JMX+1)=XMAX + JON(JMX+1)=JORDP + PATH(JMX+1)=NPATH(JORDP) + DMN(JMX+1)=D + DO KD=1,JORDP + JPON(JMX+1,KD)=JPOS(KD,3) + ENDDO + ENDIF + IF((FMIN(JORDP)-FM1).LT.-XCOMP) NPMI(JORDP)=NPATH(JORDP) + IF((IPRINT.EQ.3).AND.(IJ.EQ.1)) THEN + WRITE(IUSCR,1) JORDP,NPATH(JORDP),XMAX,D,(JPOS(KD,3),KD=1,JORDP) + & + ENDIF +C + 16 RETURN +C + 1 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X)) +C + END +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 +C +C======================================================================= +C + SUBROUTINE PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,NATC + &LU,NFICHLEC,JFICH,NP) +C +C This subroutine computes the PhD formula in the spin-independent case +C from a non spin-orbit resolved initial core state LI. +C +C Alternatively, it can compute the PhD amplitude for the APECS process. +C +C The calculation is performed using a series expansion for the +C expression of the scattering path operator +C +C Last modified : 10 Jan 2016 +C + USE DIM_MOD +C + USE ALGORITHM_MOD + USE AMPLI_MOD + USE APPROX_MOD + USE COOR_MOD , NTCLU => NATCLU, NTP => NATYP + USE DEBWAL_MOD + USE DIRECT_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 LINLBD_MOD + USE MOYEN_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PATH_MOD + USE PRINTP_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTPA_MOD + USE TESTPB_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TYPCAL_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD , PHLUM => PHILUM + USE VALIN_AV_MOD + USE VALFIN_MOD +C + REAL NPATH1(0:NDIF_M),NOPA + REAL LUM(3),AXE(3),EPS(3),DIRLUM(3),E_PH(NE_M) +C + COMPLEX IC,ONEC,ZEROC,COEF,PW(0:NDIF_M),DELTA + COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI + COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) + COMPLEX YLMR(0:NL_M,-NL_M:NL_M),MATRIX(3,2) + COMPLEX YLME(0:NL_M,-NL_M:NL_M) + COMPLEX R2,MLFLI(2,-LI_M:LI_M,3,2,3) + COMPLEX SJDIR_1,SJDIR_2,SJDIF_1,SJDIF_2 + COMPLEX RHOK(NE_M,NATM,0:18,5,NSPIN2_M),RD + COMPLEX SLJDIF,ATT_M,MLIL0(2,-LI_M:LI_M,6),SLF_1,SLF_2 + COMPLEX SL0DIF,SMJDIF +C + DIMENSION VAL(NATCLU_M),NATYP(NATM),DIRPOL(3,2) + DIMENSION EMET(3),R_L(9),COORD(3,NATCLU_M) + DIMENSION R(NDIF_M),XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),JPA(NDIF_M) +C +C +C + CHARACTER*7 STAT + CHARACTER*13 OUTDATA1,OUTDATA2 +C +C + CHARACTER*24 OUTFILE + CHARACTER*24 AMPFILE +C + DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/ + DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/ +C + ALGO1='SE' + ALGO2=' ' + ALGO3=' ' + ALGO4=' ' +C + I_DIR=0 + NSET=1 + JEL=1 + OUTDATA1='CROSS-SECTION' + IF(I_AMP.EQ.1) THEN + I_MI=1 + OUTDATA2='MS AMPLITUDES' + ELSE + I_MI=0 + ENDIF +C + IF(SPECTRO.EQ.'PHD') THEN + IOUT=IUO2 + OUTFILE=OUTFILE2 + STAT='UNKNOWN' + IF(I_MI.EQ.1) THEN + IOUT2=IUSCR2+1 + N_DOT=1 + DO J_CHAR=1,24 + IF(OUTFILE(J_CHAR:J_CHAR).EQ.'.') GOTO 888 + N_DOT=N_DOT+1 + ENDDO + 888 CONTINUE + AMPFILE=OUTFILE(1:N_DOT)//'amp' + OPEN(UNIT=IOUT2, FILE=AMPFILE, STATUS=STAT) + ENDIF + ELSEIF(SPECTRO.EQ.'APC') THEN + IOUT=IUSCR2+1 + OUTFILE='res/phot.amp' + STAT='UNKNOWN' + ENDIF +C +C Position of the light when the analyzer is along the z axis : +C (X_LUM_Z,Y_LUM_Z,Z_LUM_Z) +C + RTHLUM=THLUM*PIS180 + RPHLUM=PHLUM*PIS180 + X_LUM_Z=SIN(RTHLUM)*COS(RPHLUM) + Y_LUM_Z=SIN(RTHLUM)*SIN(RPHLUM) + Z_LUM_Z=COS(RTHLUM) +C + IF(IMOD.EQ.0) THEN +C +C The analyzer is rotated +C + DIRLUM(1)=X_LUM_Z + DIRLUM(2)=Y_LUM_Z + DIRLUM(3)=Z_LUM_Z + ELSE +C +C The sample is rotated ---> light and analyzer rotated +C + IF(I_EXT.EQ.0) THEN + RTH0=THETA0*PIS180 + RPH0=PHI0*PIS180 + RTH=RTH0 + RPH=RPH0 +C +C R_L is the rotation matrix from 0z to (THETA0,PHI0) expressed as +C a function of the Euler angles ALPHA=PHI0, BETA=THETA0, GAMMA=-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 light when the analyzer is along (THETA0,PHI0) : LUM(3) +C + LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) + LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) + LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9) +C + ENDIF + ENDIF +C + IC=(0.,1.) + ONEC=(1.,0.) + ZEROC=(0.,0.) + NSCAT=NATCLU-1 + ATTSE=1. + ATTSJ=1. + NPATH2(0)=1. + NPATH(0)=1. + NPMA(0)=1. + NPMI(0)=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,IP + &H_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,I + &E,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 +C +C Construction of the linear index LAMBDA=(MU,NU) +C + LAMBDA0=0 + DO N_O=0,NO + NMX=N_O/2 + DO NU=0,NMX + DO MU=-N_O,N_O + NMU=2*NU+ABS(MU) + IF(NMU.EQ.N_O) THEN + LAMBDA0=LAMBDA0+1 + LBD(MU,NU)=LAMBDA0 + ENDIF + ENDDO + ENDDO + ENDDO + LBDMAX=LAMBDA0 + IJK=0 +C +C Loop over the planes +C + DO JPLAN=1,NPLAN + Z=VAL(JPLAN) + IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN + DZZEM=ABS(Z-ZEM) + IF(DZZEM.LT.SMALL) GOTO 10 + GOTO 1 + ENDIF + 10 CONTINUE +C +C Loop over the different absorbers in a given plane +C + DO JEMET=1,NEMET + CALL EMETT(JEMET,IEMET,Z,SYM_AT,NATYP,EMET,NTYPEM,JNEM,*4) + GO TO 2 + 4 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,51) JPLAN,NTYPEM + ENDIF + GO TO 3 + 2 IF((ABS(EMET(3)).GT.COUPUR).AND.(IBAS.EQ.1)) GOTO 5 + IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) THEN + WRITE(IUO1,52) JPLAN,EMET(1),EMET(2),EMET(3),NTYPEM + ENDIF + ENDIF + IF(ISOM.EQ.1) NP=JPLAN + ZSURFE=VAL(1)-EMET(3) +C +C Loop over the energies +C + DO JE=1,NE + FMIN(0)=1. + FMAX(0)=1. + IF(NE.GT.1) THEN + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + E_PH(JE)=ELUM+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ELSEIF(NE.EQ.1) THEN + ECIN=E0 + E_PH(JE)=ELUM + ENDIF + IF(I_TEST.NE.1) THEN + CFM=8.*PI*E_PH(JE)*FINSTRUC + ELSE + CFM=1. + ENDIF + CALL LPM(ECIN,XLPM,*6) + XLPM1=XLPM/A + IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 + IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR + ENDIF + IF(ITL.EQ.0) THEN + VK(JE)=SQRT(ECIN+VINT)*CONV*A*(1.,0.) + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDIF + GAMMA=1./(2.*XLPM1) + IF(IPOTC.EQ.0) THEN + VK(JE)=VK(JE)+IC*GAMMA + ENDIF + IF(I_TEST.NE.1) THEN + VKR=REAL(VK(JE)) + ELSE + VKR=1. + ENDIF + IF(I_MI.EQ.1) THEN + WRITE(IOUT2,21) ECIN,VKR*CFM + ENDIF + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN + IF(IDCM.GE.1) WRITE(IUO1,22) + DO JAT=1,N_PROT + IF(IDCM.EQ.0) THEN + XK2UJ2=VK2(JE)*UJ2(JAT) + ELSE + XK2UJ2=VK2(JE)*UJ_SQ(JAT) + WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A + ENDIF + CALL DWSPH(JAT,JE,XK2UJ2,TLT,ISPEED) + DO LAT=0,LMAX(JAT,JE) + TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) + ENDDO + ENDDO + ENDIF + IF(ABS(I_EXT).GE.1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,13) I_DIR,NSET,N_DUM1 + READ(IUI6,14) I_DUM1,N_DUM2,N_DUM3 + ENDIF +C +C Initialization of TAU(INDJ,LINFMAX,JTYP) +C + JATL=0 + DO JTYP=1,N_PROT + NBTYP=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYP + JATL=JATL+1 + DO LF=LF1,LF2,ISTEP_LF + ILF=LF*LF+LF+1 + DO MF=-LF,LF + INDF=ILF+MF + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + TAU(INDJ,INDF,JATL)=ZEROC + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +C +C Storage of the coupling matrix elements MLFLI along the basis +C directions X,Y ET Z +C +C These basis directions refer to the polarization if IDICHR = 0 +C but to the light when IDICHR = 1 +C +C JBASE = 1 : X +C JBASE = 2 : Y +C JBASE = 3 : Z +C + DO MI=-LI,LI + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + DELTA=DLT(JE,NTYPEM,NNL,LR) + RD=RHOK(JE,NTYPEM,NNL,LR,1) + DO MF=-LF,LF + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 333 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 333 + MR=2+MF-MI + CALL COUMAT(ITL,MI,LF,MF,DELTA,RD,MATRIX) + DO JBASE=1,3 + MLFLI(1,MI,MR,LR,JBASE)=MATRIX(JBASE,1) + IF(IDICHR.GE.1) THEN + MLFLI(2,MI,MR,LR,JBASE)=MATRIX(JBASE,2) + ENDIF + ENDDO + 333 CONTINUE + ENDDO + ENDDO + ENDDO +C +C Calculation of the scattering path operator TAU +C + IF(I_TEST.EQ.2) GOTO 666 + PW(0)=ONEC + PW(1)=ONEC + ND=0 + TH01=0. + PHI01=0. + RHO01=ZEROC + THMI=0. + PHMI=0. + RHOMI=ZEROC + JATLEM=JNEM + IF(NTYPEM.GT.1) THEN + DO JAEM=NTYPEM-1,1,-1 + JATLEM=JATLEM+NATYP(JAEM) + ENDDO + ENDIF + DO JD=1,NDIF + NPATH2(JD)=0. + NPATH(JD)=0. + IT(JD)=0 + IN(JD)=0 + FMIN(JD)=1.E+20 + FMAX(JD)=0. + ENDDO + NTHOF=0 +C +C Calculation of the maximal intensity for the paths of order NCUT +C (plane waves). This will be taken as a reference for the IPW filter. +C + IF(IPW.EQ.1) THEN + NDIFOLD=NDIF + NOOLD=NO + ISPHEROLD=ISPHER + NDIF=NCUT + NO=0 + ISPHER=0 + IREF=1 + IPW=0 + IJ=0 + DIJ=0. + FREF=0. + CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PH + &MI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) + NDIF=NDIFOLD + NO=NOOLD + ISPHER=ISPHEROLD + PW(0)=ONEC + PW(1)=ONEC + IPW=1 + ND=0 + TH01=0. + PHI01=0. + RHO01=ZEROC + THMI=0. + PHMI=0. + RHOMI=ZEROC + JATLEM=JNEM + IF(NTYPEM.GT.1) THEN + DO JAEM=NTYPEM-1,1,-1 + JATLEM=JATLEM+NATYP(JAEM) + ENDDO + ENDIF + DO JD=1,NDIF + NPATH2(JD)=0. + NPATH(JD)=0. + IT(JD)=0 + IN(JD)=0 + FMIN(JD)=1.E+20 + FMAX(JD)=0. + ENDDO + NTHOF=0 +C +C New initialization of TAU(INDJ,INDF,JATL) after the PW calculation +C + JATL=0 + DO JTYP=1,N_PROT + NBTYP=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYP + JATL=JATL+1 + DO LF=LF1,LF2,ISTEP_LF + ILF=LF*LF+LF+1 + DO MF=-LF,LF + INDF=ILF+MF + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + TAU(INDJ,INDF,JATL)=ZEROC + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF +C +C Generation and print-out of the paths +C + IF (NPATHP.GT.0) THEN + DO JP=1,NPATHP-1 + FMN(JP)=0. + PATH(JP)=0. + JON(JP)=0 + ENDDO + FMN(NPATHP)=-1. + PATH(NPATHP)=0. + JON(NPATHP)=0 + ENDIF + IREF=0 + IJ=1 + IF(IPRINT.EQ.3) THEN + OPEN(UNIT=IUSCR, STATUS='SCRATCH') + ENDIF + DIJ=0. + CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHMI + &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) + IF(NPATHP.EQ.0) GOTO 15 + IF(NSCAT.GT.1) THEN + XPATOT=REAL((DFLOAT(NSCAT)**DFLOAT(NDIF+1) -1.D0)/DFLOAT(NSCA + &T-1)) + ELSE + XPATOT=FLOAT(NDIF+1) + ENDIF + IF(XPATOT.LT.2.14748E+09) THEN + NPATOT=INT(XPATOT) + IF(NPATOT.LT.NPATHP) NPATHP=NPATOT-1 + ENDIF + WRITE(IUO1,84) NPATHP + WRITE(IUO1,81) + DO JPT=1,NPATHP + IF(PATH(NPATHP).GT.2.14E+09) THEN + WRITE(IUO1,82) JPT,JON(JPT),PATH(JPT),FMN(JPT),DMN(JPT),JNE + &M,(JPON(JPT,KD),KD=1,JON(JPT)) + ELSE + WRITE(IUO1,83) JPT,JON(JPT),INT(PATH(JPT)),FMN(JPT),DMN(JPT + &),JNEM,(JPON(JPT,KD),KD=1,JON(JPT)) + ENDIF + ENDDO + IF(IPRINT.EQ.3) THEN + IF(XPATOT.GT.2.14748E+09) GOTO 172 + WRITE(IUO1,85) + WRITE(IUO1,71) + NPATOT=INT(XPATOT) + DO JOP=0,NDIF + IF(JOP.EQ.0) THEN + XINT0=FMAX(0) + DIST0=0. + WRITE(IUO1,70) JOP,JOP+1,XINT0,DIST0,JNEM + GOTO 75 + ENDIF + WRITE(IUO1,77) + DO JLINE=1,NPATOT-1 + READ(IUSCR,69,ERR=75,END=75) JOPA,NOPA,XMAX,DIST0,(JPA(KD + &),KD=1,JOPA) + IF(JOPA.EQ.JOP) THEN + IF(NOPA.GT.2.14E+09) THEN + WRITE(IUO1,76) JOPA,NOPA,XMAX,DIST0,JNEM,(JPA(KD),KD=1 + &,JOPA) + ELSE + WRITE(IUO1,70) JOPA,INT(NOPA),XMAX,DIST0,JNEM,(JPA(KD) + &,KD=1,JOPA) + ENDIF + ENDIF + ENDDO + IF(JOP.EQ.NDIF) WRITE(IUO1,80) + 75 REWIND IUSCR + ENDDO + GOTO 73 + 172 WRITE(IUO1,74) + CLOSE(IUSCR,STATUS='DELETE') + 73 ENDIF + DO JD=0,NDIF + NPATH1(JD)=REAL(DFLOAT(NSCAT)**DFLOAT(JD)) + IF(NPATH1(JD).GT.2.14E+09) THEN + IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0. + WRITE(IUO1,53) JD,NPATH1(JD),NPATH2(JD),FMIN(JD),NPMI(JD),F + &MAX(JD),NPMA(JD) + IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT + ELSE + IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0. + WRITE(IUO1,58) JD,INT(NPATH1(JD)+0.1),INT(NPATH2(JD)+0.1),F + &MIN(JD),INT(NPMI(JD)+0.1),FMAX(JD),INT(NPMA(JD)+0.1) + IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT + ENDIF + ENDDO + 666 CONTINUE +C +C Calculation of the Photoelectron Diffraction formula +C +C +C Loop over the 'fixed' angle +C + 15 DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + IF(I_EXT.EQ.0) THEN + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + XINCRF=FLOAT(J_FIXED-1)*FIX_STEP + ELSE + XINCRF=0. + ENDIF + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(ABS(I_EXT).GE.1) THEN + READ(IUI6,86) JSET,JLINE,THD,PHD + IF(I_EXT.EQ.-1) BACKSPACE IUI6 + THETA0=THD + PHI0=PHD + ENDIF + IF(IPH_1.EQ.1) THEN + IF(I_EXT.EQ.0) THEN + DPHI=PHI0+XINCRF + ELSE + DPHI=PHD + ENDIF + RPHI=DPHI*PIS180 + IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI + ELSE + ISAUT=0 + IF(I_EXT.EQ.0) THEN + DTHETA=THETA0+XINCRF + ELSE + DTHETA=THD + ENDIF + RTHETA=DTHETA*PIS180 + IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 + IF(I_EXT.GE.1) ISAUT=0 + IF(I_TEST.EQ.2) ISAUT=0 + IF(ISAUT.GT.0) GOTO 8 + IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA + IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) + IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) +C +C THETA-dependent number of PHI points for stereographic +C representation (to obtain a uniform sampling density). +C (Courtesy of J. Osterwalder - University of Zurich) +C + IF(STEREO.EQ.'YES') THEN + N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+SMALL)+1 + ENDIF +C + ENDIF + IF((N_FIXED.GT.1).AND.(IMOD.EQ.1)) THEN +C +C When there are several sets of scans (N_FIXED > 1), +C the initial position LUM of the light is recalculated +C for each initial position (RTH,RPH) of the analyzer +C + IF(IPH_1.EQ.1) THEN + RTH=THETA0*PIS180 + RPH=RPHI + ELSE + RTH=RTHETA + RPH=PHI0*PIS180 + ENDIF +C + R_L(1)=COS(RTH)*COS(RPH) + R_L(2)=-SIN(RPH) + R_L(3)=SIN(RTH)*COS(RPH) + R_L(4)=COS(RTH)*SIN(RPH) + R_L(5)=COS(RPH) + R_L(6)=SIN(RTH)*SIN(RPH) + R_L(7)=-SIN(RTH) + R_L(8)=0. + R_L(9)=COS(RTH) +C + LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) + LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) + LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9) + ENDIF +C +C Loop over the scanned angle +C + DO J_SCAN=1,N_SCAN + IF(N_SCAN.GT.1) THEN + XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1) + ELSEIF(N_SCAN.EQ.1) THEN + XINCRS=0. + ENDIF + IF(I_EXT.EQ.-1) THEN + READ(IUI6,86) JSET,JLINE,THD,PHD + BACKSPACE IUI6 + ENDIF + IF(IPH_1.EQ.1) THEN + ISAUT=0 + IF(I_EXT.EQ.0) THEN + DTHETA=THETA0+XINCRS + ELSE + DTHETA=THD + ENDIF + RTHETA=DTHETA*PIS180 + IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 + IF(I_EXT.GE.1) ISAUT=0 + IF(I_TEST.EQ.2) ISAUT=0 + IF(ISAUT.GT.0) GOTO 8 + IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA + IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) + IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) + ELSE + IF(I_EXT.EQ.0) THEN + DPHI=PHI0+XINCRS + ELSE + DPHI=PHD + ENDIF + RPHI=DPHI*PIS180 + IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI + ENDIF +C +C Loop over the sets of directions to average over (for gaussian average) +C +C + SSETDIR_1=0. + SSETDIF_1=0. + SSETDIR_2=0. + SSETDIF_2=0. +C + SSET2DIR_1=0. + SSET2DIF_1=0. + SSET2DIR_2=0. + SSET2DIF_2=0. +C + IF(I_EXT.EQ.-1) THEN + JREF=INT(NSET)/2+1 + ELSE + JREF=1 + ENDIF +C + DO J_SET=1,NSET + IF(I_EXT.EQ.-1) THEN + READ(IUI6,86) JSET,JLINE,THD,PHD,W + DTHETA=THD + DPHI=PHD + RTHETA=DTHETA*PIS180 + RPHI=DPHI*PIS180 +C +C Here, there are several sets of scans (NSET > 1), so +C the initial position LUM of the light must be +C recalculated for each initial position of the analyzer +C + RTH=TH_0(J_SET)*PIS180 + RPH=PH_0(J_SET)*PIS180 +C + IF(IMOD.EQ.1) THEN + R_L(1)=COS(RTH)*COS(RPH) + R_L(2)=-SIN(RPH) + R_L(3)=SIN(RTH)*COS(RPH) + R_L(4)=COS(RTH)*SIN(RPH) + R_L(5)=COS(RPH) + R_L(6)=SIN(RTH)*SIN(RPH) + R_L(7)=-SIN(RTH) + R_L(8)=0. + R_L(9)=COS(RTH) +C + LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) + LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) + LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9) +C + ENDIF + ELSE + W=1. + ENDIF +C + IF(I_EXT.EQ.-1) PRINT 89 +C + CALL DIRAN(VINT,ECIN,JEL) +C + IF(J_SET.EQ.JREF) THEN + DTHETAP=DTHETA + DPHIP=DPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + WRITE(IUO1,88) DTHETA,DPHI + ENDIF +C +C .......... Case IMOD=1 only .......... +C +C Calculation of the position of the light when the analyzer is at +C (THETA,PHI). DIRLUM is the direction of the light and its initial +C value (at (THETA0,PHI0)) is LUM. AXE is the direction of the theta +C rotation axis and EPS is defined so that (AXE,DIRLUM,EPS) is a +C direct orthonormal basis. The transform of a vector R by a rotation +C of OMEGA about AXE is then given by +C +C R' = R COS(OMEGA) + (AXE.R)(1-COS(OMEGA)) AXE + (AXE^R) SIN(OMEGA) +C +C Here, DIRANA is the internal direction of the analyzer and ANADIR +C its external position +C +C Note that when the initial position of the analyzer is (RTH,RPH) +C which coincides with (RTH0,RPH0) only for the first fixed angle +C + IF(IMOD.EQ.1) THEN + IF(ITHETA.EQ.1) THEN + AXE(1)=-SIN(RPH) + AXE(2)=COS(RPH) + AXE(3)=0. + RANGLE=RTHETA-RTH + ELSEIF(IPHI.EQ.1) THEN + AXE(1)=0. + AXE(2)=0. + AXE(3)=1. + RANGLE=RPHI-RPH + ENDIF + CALL PRVECT(AXE,LUM,EPS,CVECT) + PRS=PRSCAL(AXE,LUM) + IF(J_SCAN.EQ.1) THEN + DIRLUM(1)=LUM(1) + DIRLUM(2)=LUM(2) + DIRLUM(3)=LUM(3) + ELSE + DIRLUM(1)=LUM(1)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(1)+ + &SIN(RANGLE)*EPS(1) + DIRLUM(2)=LUM(2)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(2)+ + &SIN(RANGLE)*EPS(2) + DIRLUM(3)=LUM(3)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(3)+ + &SIN(RANGLE)*EPS(3) + ENDIF + ENDIF + IF(DIRLUM(3).GT.1.) DIRLUM(3)=1. + IF(DIRLUM(3).LT.-1.) DIRLUM(3)=-1. + THETALUM=ACOS(DIRLUM(3)) + IF(I_TEST.EQ.2) THETALUM=-THETALUM + COEF=DIRLUM(1)+IC*DIRLUM(2) + CALL ARCSIN(COEF,DIRLUM(3),PHILUM) + ANALUM=ANADIR(1,1)*DIRLUM(1) + ANADIR(2,1)*DIRLUM(2) +ANADIR( + &3,1)*DIRLUM(3) +C + SEPSDIR_1=0. + SEPSDIF_1=0. + SEPSDIR_2=0. + SEPSDIF_2=0. +C +C Loop over the directions of polarization +C + DO JEPS=1,NEPS + IF((JEPS.EQ.1).AND.(IPOL.GE.0)) THEN + DIRPOL(1,JEPS)=COS(THETALUM)*COS(PHILUM) + DIRPOL(2,JEPS)=COS(THETALUM)*SIN(PHILUM) + DIRPOL(3,JEPS)=-SIN(THETALUM) + ELSE + DIRPOL(1,JEPS)=-SIN(PHILUM) + DIRPOL(2,JEPS)=COS(PHILUM) + DIRPOL(3,JEPS)=0. + ENDIF + IF(ABS(IPOL).EQ.1) THEN + IF(IPRINT.GT.0) THEN + WRITE(IUO1,61) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3), + & (DIRPOL(K,1),K=1,3),ANALUM + ENDIF + ELSE + IF((JEPS.EQ.1).AND.(IPRINT.GT.0)) THEN + WRITE(IUO1,63) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),ANA + &LUM + ENDIF + ENDIF + IF((JEPS.EQ.1).AND.(I_EXT.EQ.-1)) PRINT 89 +C +C Calculation of the coupling matrix MLIL0 +C + DO MI=-LI,LI + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + LRR=3*(LR-1) + DO MF=-LF,LF + MR=2+MF-MI + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 777 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 777 + LMR=LRR+MR + IF(IDICHR.EQ.0) THEN + IF(I_TEST.NE.1) THEN + MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRPOL(1,JEPS) + & +MLFLI(1,MI,MR,LR,2)*DIRPOL(2,JEPS) +MLFLI(1,MI,MR,LR,3)*DIRPOL(3 + &,JEPS) + ELSE + MLIL0(1,MI,LMR)=ONEC + ENDIF + ELSEIF(IDICHR.GE.1) THEN + IF(I_TEST.NE.1) THEN + MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRLUM(1) +MLF + &LI(1,MI,MR,LR,2)*DIRLUM(2) +MLFLI(1,MI,MR,LR,3)*DIRLUM(3) + MLIL0(2,MI,LMR)=MLFLI(2,MI,MR,LR,1)*DIRLUM(1) +MLF + &LI(2,MI,MR,LR,2)*DIRLUM(2) +MLFLI(2,MI,MR,LR,3)*DIRLUM(3) + ELSE + MLIL0(1,MI,LMR)=ONEC + ENDIF + ENDIF + 777 CONTINUE + ENDDO + ENDDO + ENDDO +C + SRDIF_1=0. + SRDIR_1=0. + SRDIF_2=0. + SRDIR_2=0. +C +C Loop over the different directions of the analyzer contained in a cone +C + DO JDIR=1,NDIR + IF(IATTS.EQ.1) THEN + ATTSE=EXP(-ZSURFE*GAMMA/DIRANA(3,JDIR)) + ENDIF +C + SMIDIR_1=0. + SMIDIF_1=0. + SMIDIR_2=0. + SMIDIF_2=0. +C +C Loop over the equiprobable azimuthal quantum numbers MI corresponding +C to the initial state LI +C + LME=LMAX(1,JE) + CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME) + DO MI=-LI,LI + SJDIR_1=ZEROC + SJDIF_1=ZEROC + SJDIR_2=ZEROC + SJDIF_2=ZEROC +C +C Calculation of the direct emission (used a a reference for the +C output), which is not contained in the calculation of TAU +C + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + LRR=3*(LR-1) + ILF=LF*LF+LF+1 + IF(ISPEED.EQ.1) THEN + R2=TL(LF,1,1,JE) + ELSE + R2=TLT(LF,1,1,JE) + ENDIF + DO MF=-LF,LF + MR=2+MF-MI + LMR=LRR+MR + INDF=ILF+MF + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 444 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 444 + SJDIR_1=SJDIR_1+YLME(LF,MF)*ATTSE*MLIL0(1,MI,LMR)*R2 + IF(IDICHR.GE.1) THEN + SJDIR_2=SJDIR_2+YLME(LF,MF)*ATTSE*MLIL0(2,MI,LMR)*R2 + & + ENDIF +C +C Contribution of the absorber to TAU (initialization of SJDIF) +C + IF(I_TEST.EQ.2) GOTO 444 + SL0DIF=ZEROC + DO L0=0,LME + IL0=L0*L0+L0+1 + SL0DIF=SL0DIF+YLME(L0,0)*TAU(IL0,INDF,1) + DO M0=1,L0 + IND01=IL0+M0 + IND02=IL0-M0 + SL0DIF=SL0DIF+(YLME(L0,M0)*TAU(IND01,INDF,1)+YLME(L + &0,-M0)*TAU(IND02,INDF,1)) + ENDDO + ENDDO + SJDIF_1=SJDIF_1+SL0DIF*MLIL0(1,MI,LMR) + IF(IDICHR.GE.1) THEN + SJDIF_2=SJDIF_2+SL0DIF*MLIL0(2,MI,LMR) + ENDIF + 444 CONTINUE + ENDDO + ENDDO + SJDIF_1=SJDIF_1*ATTSE + IF(IDICHR.GE.1) THEN + SJDIF_2=SJDIF_2*ATTSE + ENDIF +C +C Loop over the last atom J encountered by the photoelectron +C before escaping the solid +C + IF(I_TEST.EQ.2) GOTO 111 + DO JTYP=2,N_PROT + NBTYP=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYP + JATL=NCORR(JNUM,JTYP) + XOJ=SYM_AT(1,JATL)-EMET(1) + YOJ=SYM_AT(2,JATL)-EMET(2) + ZOJ=SYM_AT(3,JATL)-EMET(3) + ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ) + ZSURFJ=VAL(1)-SYM_AT(3,JATL) + CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLMR,LMJ) + IF(IATTS.EQ.1) THEN + ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR)) + ENDIF + CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+ZOJ*DIRANA + &(3,JDIR))/ROJ + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78 + CTROIS1=ZOJ/ROJ + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + IF(IDCM.GE.1) THEN + UJ2(JTYP)=UJ_SQ(JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(CSTHJR-1.).GT.SMALL) THEN + CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)*(DIRANA(3,JDIR)-CTRO + &IS1)/(2.-2.*CSTHJR) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 78 IF(IDWSPH.EQ.1) THEN + DWTER=1. + ELSE + DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR)) + ENDIF + IF(JATL.EQ.JATLEM) THEN + ATT_M=ATTSE*DWTER + ELSE + ATT_M=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*CSTHJR) + ENDIF +C + SLF_1=ZEROC + SLF_2=ZEROC + DO LF=LF1,LF2,ISTEP_LF + LR=1+(1+LF-LI)/2 + LRR=3*(LR-1) + ILF=LF*LF+LF+1 + DO MF=-LF,LF + MR=2+MF-MI + INDF=ILF+MF + IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 555 + IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 555 + LMR=LRR+MR + SLJDIF=ZEROC + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDF,JATL) + IF(LJ.GT.0) THEN + DO MJ=1,LJ + INDJ1=ILJ+MJ + INDJ2=ILJ-MJ + SMJDIF=SMJDIF+(YLMR(LJ,MJ)*TAU(INDJ1,INDF,JATL)+YL + &MR(LJ,-MJ)*TAU(INDJ2,INDF,JATL)) + ENDDO + ENDIF + SLJDIF=SLJDIF+SMJDIF + ENDDO + SLF_1=SLF_1+SLJDIF*MLIL0(1,MI,LMR) + IF(IDICHR.GE.1) THEN + SLF_2=SLF_2+SLJDIF*MLIL0(2,MI,LMR) + ENDIF + 555 CONTINUE + ENDDO + ENDDO + SJDIF_1=SJDIF_1+SLF_1*ATT_M + IF(IDICHR.GE.1) THEN + SJDIF_2=SJDIF_2+SLF_2*ATT_M + ENDIF +C +C End of the loops over the last atom J +C + ENDDO + ENDDO +C +C Writing the amplitudes in file IOUT for APECS, or +C in file IOUT2 for PhD (orientated orbitals' case) +C + 111 IF(SPECTRO.EQ.'APC') THEN + WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEPS, + &JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1 + IF(IDICHR.GE.1) THEN + WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEP + &S,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2 + ENDIF + ELSE + IF(I_MI.EQ.1) THEN + WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JE + &PS,JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1 + IF(IDICHR.GE.1) THEN + WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN, + &JEPS,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2 + ENDIF + ENDIF +C +C Computing the square modulus +C + SMIDIF_1=SMIDIF_1+CABS(SJDIR_1+SJDIF_1)*CABS(SJDIR_1+SJD + &IF_1) + SMIDIR_1=SMIDIR_1+CABS(SJDIR_1)*CABS(SJDIR_1) + IF(IDICHR.GE.1) THEN + SMIDIF_2=SMIDIF_2+CABS(SJDIR_2+SJDIF_2)*CABS(SJDIR_2+S + &JDIF_2) + SMIDIR_2=SMIDIR_2+CABS(SJDIR_2)*CABS(SJDIR_2) + ENDIF + ENDIF +C +C End of the loop over MI +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 220 + SRDIR_1=SRDIR_1+SMIDIR_1 + SRDIF_1=SRDIF_1+SMIDIF_1 + IF(IDICHR.GE.1) THEN + SRDIR_2=SRDIR_2+SMIDIR_2 + SRDIF_2=SRDIF_2+SMIDIF_2 + ENDIF + 220 CONTINUE +C +C End of the loop on the directions of the analyzer +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 221 + SEPSDIF_1=SEPSDIF_1+SRDIF_1*VKR*CFM/NDIR + SEPSDIR_1=SEPSDIR_1+SRDIR_1*VKR*CFM/NDIR + IF(IDICHR.GE.1) THEN + SEPSDIF_2=SEPSDIF_2+SRDIF_2*VKR*CFM/NDIR + SEPSDIR_2=SEPSDIR_2+SRDIR_2*VKR*CFM/NDIR + ENDIF + 221 CONTINUE +C +C End of the loop on the polarization +C + ENDDO +C + SSETDIR_1=SSETDIR_1+SEPSDIR_1*W + SSETDIF_1=SSETDIF_1+SEPSDIF_1*W + IF(ICHKDIR.EQ.2) THEN + IF(JSET.EQ.JREF) THEN + SSET2DIR_1=SEPSDIR_1 + SSET2DIF_1=SEPSDIF_1 + ENDIF + ENDIF + IF(IDICHR.GE.1) THEN + SSETDIR_2=SSETDIR_2+SEPSDIR_2*W + SSETDIF_2=SSETDIF_2+SEPSDIF_2*W + IF(ICHKDIR.EQ.2) THEN + IF(JSET.EQ.JREF) THEN + SSET2DIR_2=SEPSDIR_2 + SSET2DIF_2=SEPSDIF_2 + ENDIF + ENDIF + ENDIF +C +C End of the loop on the set averaging +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 222 + IF(IDICHR.EQ.0) THEN + IF(ISOM.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS + &ETDIF_1 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1, + &SSET2DIF_1 + ENDIF + ELSE + WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS + &ETDIF_1 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1, + &SSET2DIF_1 + ENDIF + ENDIF + ELSE + IF(ISOM.EQ.2) THEN + WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS + &ETDIF_1,SSETDIR_2,SSETDIF_2 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1, + &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2 + ENDIF + ELSE + WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS + &ETDIF_1,SSETDIR_2,SSETDIF_2 + IF(ICHKDIR.EQ.2) THEN + WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1, + &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2 + ENDIF + ENDIF + ENDIF + 222 CONTINUE +C +C End of the loop on the scanned angle +C + ENDDO +C + 8 CONTINUE +C +C End of the loop on the fixed angle +C + ENDDO +C +C End of the loop on the energy +C + CLOSE(IUI6) + ENDDO +C + 3 CONTINUE +C +C End of the loop on the emitters +C + ENDDO +C + GO TO 1 + 5 IPLAN=JPLAN-1 + IJK=IJK+1 + IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN + ENDIF + 1 CONTINUE +C +C End of the loop on the planes +C + ENDDO +C + IF(ABS(I_EXT).GE.1) CLOSE(IUI6) + IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*) + IF(SPECTRO.EQ.'APC') CLOSE(IOUT) + IF(SPECTRO.EQ.'APC') GOTO 7 +c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN + IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN + NP=0 + CALL TREAT_PHD(ISOM,NFICHLEC,JFICH,NP) + ENDIF + IF(I_EXT.EQ.2) THEN + CALL WEIGHT_SUM(ISOM,I_EXT,0,1) + ENDIF + GOTO 7 + 6 WRITE(IUO1,55) +C + 9 FORMAT(9(2X,I1),2X,I2) + 11 FORMAT(I4,2X,I4,2X,I4) + 12 FORMAT(2X,A3,11X,A13) + 13 FORMAT(6X,I1,1X,I3,2X,I4) + 14 FORMAT(6X,I1,1X,I3,3X,I3) + 19 FORMAT(2(2X,I1),1X,I2,6(2X,I1),2X,I2) + 20 FORMAT(2(5X,F6.2,2X,F6.2),2X,I1) + 21 FORMAT(10X,E12.6,3X,E12.6) + 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,2 + &5X,' 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 AB + &SORBER : (',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 INTENS + &ITY : ',E12.6,2X,'No OF THE PATH : ',F15.1, + & /,10X,' MAXIMAL INTENSITY : ',E12.6,2X,'No OF T + &HE 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,/,10 + &X,' EFFECTIVE NUMBER OF PATHS : ',I10, /,10X,' MI + &NIMAL 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') + 61 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6. + &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI + &GHT ', ' : (',F6.3,',',F6.3,',',F6.3, + & ')',/,16X,'DIRECTION OF THE POLARIZATION : ( + &', F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZER.LIGHT ',' + & : ',F7.4) + 63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6. + &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI + &GHT ', ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZE + &R.LIGHT : ',F7.4) + 65 FORMAT(////,3X,'++++++++++++++++++',9X, + *'THETA = ',F6.2,' DEGREES',9X,'++++++++', + *'++++++++++',///) + 66 FORMAT(////,3X,'++++++++++++++++++',9X, + *'PHI = ',F6.2,' DEGREES',9X,'++++++++++', + *'++++++++++',///) + 67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,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,E1 + &2.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,'LEN + >H',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',' O + &RDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ','OF A)') + 85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ',/,24X,'(THE L + &ENGTH 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,E1 + &2.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 +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 diff --git a/src/msspec/tests.py b/src/msspec/tests.py new file mode 100644 index 0000000..2ca9b5f --- /dev/null +++ b/src/msspec/tests.py @@ -0,0 +1,151 @@ +# coding: utf-8 + +from msspec.calculator import MSSPEC +from msspec.utils import * +from msspec.misc import set_log_level + +from ase.build import bulk + +from hashlib import md5 +from pickle import dumps + +import unittest +import sys +import os + +set_log_level('error') +RESULTS_FILENAME = os.path.join(os.path.dirname(__file__), 'results.txt') + +def perform_test(obj, funcname, filename=RESULTS_FILENAME): + f = getattr(obj, '_' + funcname) + output = md5(dumps(f())).hexdigest() + results = {} + with open(filename, 'r') as fd: + for line in fd: + k, v = line.split() + results[k] = v + k = '{}.{}'.format(obj.__class__.__name__, funcname) + obj.assertEqual(output, results[k]) + + +class UtilsTestCase(unittest.TestCase): + def setUp(self): + self.a0 = 3.6 + self.cluster = bulk('Cu', a=self.a0, cubic=True) + self.cluster = self.cluster.repeat((4, 4, 4)) + center_cluster(self.cluster) + + def _test_base_cluster(self): + output = self.cluster + output = output.get_positions() + return output + + def _test_cut_sphere(self): + output = cut_sphere(self.cluster, radius=self.a0 + .01) + output = output.get_positions() + return output + + def _test_cut_plane(self): + output = cut_plane(self.cluster, z=0.1) + output = output.get_positions() + return output + + + def test_base_cluster(self): + return perform_test(self, 'test_base_cluster') + + def test_cut_sphere(self): + return perform_test(self, 'test_cut_sphere') + + def test_cut_plane(self): + return perform_test(self, 'test_cut_plane') + + def runTest(self): + pass + +class PEDCopperTestCase(unittest.TestCase): + def setUp(self): + a0 = 3.6 # The lattice parameter in angstroms + + # Create the copper cubic cell + cluster = bulk('Cu', a=a0, cubic=True) + # Repeat the cell many times along x, y and z + cluster = cluster.repeat((4, 4, 4)) + # Put the center of the structure at the origin + center_cluster(cluster) + # Keep atoms inside a given radius + cluster = cut_sphere(cluster, radius=a0 + .01) + # Keep only atoms below the plane z <= 0 + cluster = cut_plane(cluster, z=0.1) + + # Set the absorber (the deepest atom centered in the xy-plane) + cluster.absorber = get_atom_index(cluster, 0, 0, -a0) + # Create a calculator for the PhotoElectron Diffration + self.calc = MSSPEC(spectroscopy='PED', txt=None) + # Set the cluster to use for the calculation + self.calc.set_atoms(cluster) + + def _test_theta_scan(self): + # Run the calculation + data = self.calc.get_theta_scan(level='2p3/2') + return data[-1].cross_section + #data.save('theta.hdf5') + #return data[-1] + + def _test_phi_scan(self): + # Run the calculation + data = self.calc.get_phi_scan(level='2p3/2', theta=35.) + return data[-1].cross_section + + def test_theta_scan(self): + perform_test(self, 'test_theta_scan') + + def test_phi_scan(self): + perform_test(self, 'test_phi_scan') + + def runTest(self): + pass + + def tearDown(self): + self.calc.shutdown() + + +def run_tests(): + suite = unittest.TestSuite() + + suite.addTest(UtilsTestCase('test_base_cluster')) + suite.addTest(UtilsTestCase('test_cut_sphere')) + suite.addTest(UtilsTestCase('test_cut_plane')) + + suite.addTest(PEDCopperTestCase('test_phi_scan')) + suite.addTest(PEDCopperTestCase('test_theta_scan')) + runner = unittest.TextTestRunner(verbosity=2) + rc = runner.run(suite) + exit(rc) + +def create_tests_results(): + with open(RESULTS_FILENAME, 'w') as fd: + pass + + def create_results(obj, *funcs, **kwargs): + obj.setUp() + with open(RESULTS_FILENAME, 'a') as fd: + for funcname in funcs: + clsname = obj.__class__.__name__ + print(('Generating results for test: {}.{}'.format(clsname, funcname))) + o = getattr(obj, '_' + funcname)() + k = '{}.{}'.format(obj.__class__.__name__, funcname) + fd.write('{} {}\n'.format(k, md5(dumps(o)).hexdigest())) + obj.tearDown() + + tc = UtilsTestCase() + create_results(tc, 'test_base_cluster') + create_results(tc, 'test_cut_sphere') + create_results(tc, 'test_cut_plane') + + tc = PEDCopperTestCase() + create_results(tc, 'test_phi_scan') + create_results(tc, 'test_theta_scan') + +def delete_results_file(): + os.remove(RESULTS_FILENAME) diff --git a/src/msspec/utils.py b/src/msspec/utils.py new file mode 100644 index 0000000..82b9367 --- /dev/null +++ b/src/msspec/utils.py @@ -0,0 +1,332 @@ +# -*- encoding: utf-8 -*- +# vim: set fdm=indent ts=4 sw=4 sts=4 et tw=80 ai cc=+0 mouse=a nu : # + +""" +Module utils +============ + + +""" + +import numpy as np +from ase import Atoms, Atom +from ase.visualize import view + +class MsSpecAtoms(Atoms): + def __init__(self, *args, **kwargs): + Atoms.__init__(self, *args, **kwargs) + self.__absorber_index = None + + def set_absorber(self, index): + self.__absorber_index = index + + def get_absorber(self): + return self.__absorber_index + +class EmptySphere(Atom): + def __init__(self, *args, **kwargs): + Atom.__init__(self, *args, **kwargs) + self.symbol = 'X' + + +def get_atom_index(atoms, x, y, z): + """ Return the index of the atom that is the closest to the coordiantes + given as parameters. + + :param ase.Atoms atoms: an ASE Atoms object + :param float x: the x position in angstroms + :param float y: the y position in angstroms + :param float z: the z position in angstroms + + :return: the index of the atom as an integer + :rtype: int + """ + # get all distances + d = np.linalg.norm(atoms.get_positions() - np.array([x, y, z]), axis = 1) + # get the index of the min distance + i = np.argmin(d) + # return the index and the corresponding distance + return i + + +def center_cluster(atoms, invert=False): + """ Centers an Atoms object by translating it so the origin is roughly + at the center of the cluster. + The function supposes that the cluster is wrapped inside the unit cell, + with the origin being at the corner of the cell. + It is used in combination with the cut functions, which work only if the + origin is at the center of the cluster + + :param ase.Atoms atoms: an ASE Atoms object + :param bool invert: if True, performs the opposite translation (uncentering the cluster) + + """ + for i, cell_vector in enumerate(atoms.get_cell()): + if invert: + atoms.translate(0.5*cell_vector) + else: + atoms.translate(-0.5*cell_vector) + + +def cut_sphere(atoms, radius): + assert radius >= 0, "Please give a positive radius value" + radii = np.linalg.norm(atoms.positions, axis=1) + indices = np.where(radii <= radius)[0] + return atoms[indices] + + + + +def _cut_sphere(atoms, radius=None): + """ Removes all the atoms of an Atoms object outside a sphere with a + given radius + + :param ase.Atoms atoms: an ASE Atoms object + :param float radius: the radius of the sphere + + :return: The modified atom cluster + :rtype: ase.Atoms + """ + if radius is None: + raise ValueError("radius not set") + + new_atoms = atoms.copy() + + del_list = [] + for index, position in enumerate(new_atoms.positions): + if np.linalg.norm(position) > radius: + del_list.append(index) + + del_list.reverse() + for index in del_list: + del new_atoms[index] + + return new_atoms + +def cut_cylinder(atoms, axis="z", radius=None): + """ Removes all the atoms of an Atoms object outside a cylinder with a + given axis and radius + + :param ase.Atoms atoms: an ASE Atoms object + :param str axis: string "x", "y", or "z". The axis of the cylinder, "z" by default + :param float radius: the radius of the cylinder + + :return: The modified atom cluster + :rtype: ase.Atoms + """ + if radius is None: + raise ValueError("radius not set") + + new_atoms = atoms.copy() + + dims = {"x": 0, "y": 1, "z": 2} + if axis in dims: + axis = dims[axis] + else: + raise ValueError("axis not valid, must be 'x','y', or 'z'") + + del_list = [] + for index, position in enumerate(new_atoms.positions): + # calculating the distance of the atom to the given axis + r = 0 + for dim in range(3): + if dim != axis: + r = r + position[dim]**2 + r = np.sqrt(r) + + if r > radius: + del_list.append(index) + + del_list.reverse() + for index in del_list: + del new_atoms[index] + + return new_atoms + +def cut_cone(atoms, radius, z = 0): + """Shapes the cluster as a cone. + + Keeps all the atoms of the input Atoms object inside a cone of based radius *radius* and of height *z*. + + :param atoms: The cluster to modify. + :type atoms: :py:class:`ase.Atoms` + :param radius: The base cone radius in :math:`\mathring{A}`. + :type radius: float + :param z: The height of the cone in :math:`\mathring{A}`. + :type z: float + :return: A new cluster. + :rtype: :py:class:`ase.Atoms` + """ + new_atoms = atoms.copy() + origin = np.array((0, 0, 0)) + max_theta = np.arctan(radius/(-z)) + + u = np.array((0, 0, -z)) + normu = np.linalg.norm(u) + new_atoms.translate(u) + indices = [] + for i in range(len(new_atoms)): + v = new_atoms[i].position + normv = np.linalg.norm(v) + + _ = np.dot(u, v)/normu/normv + if _ == 0: + print(v) + theta = np.arccos(_) + if theta <= max_theta: + indices.append(i) + + + new_atoms = new_atoms[indices] + new_atoms.translate(-u) # pylint: disable=invalid-unary-operand-type + + return new_atoms + +def cut_plane(atoms, x=None, y=None, z=None): + """ Removes the atoms whose coordinates are higher (or lower, for a + negative cutoff value) than the coordinates given for every dimension. + + For example, + + .. code-block:: python + + cut_plane(atoms, x=[-5,5], y=3.6, z=0) + #every atom whose x-coordinate is higher than 5 or lower than -5, and/or + #y-coordinate is higher than 3.6, and/or z-coordinate is higher than 0 + #is deleted. + + :param ase.Atoms atoms: an ASE Atoms object + :param int x: x cutoff value + :param int y: y cutoff value + :param int z: z cutoff value + + :return: The modified atom cluster + :rtype: ase.Atoms + """ + dim_names = ('x', 'y', 'z') + dim_values = [x, y, z] + for i, (name, value) in enumerate(zip(dim_names, dim_values)): + assert isinstance(value, (int, float, list, tuple, type(None))), "Wrong type" + if isinstance(value, (tuple, list)): + assert len(value) == 2 and np.all([isinstance(el, (int, float, type(None))) for el in value]), \ + "Wrong length" + else: + try: + if value >= 0: + dim_values[i] = [-np.inf, value] + else: + dim_values[i] = [value, np.inf] + except: + dim_values[i] = [value, value] + + if dim_values[i][0] is None: + dim_values[i][0] = -np.inf + if dim_values[i][1] is None: + dim_values[i][1] = np.inf + + dim_values = np.array(dim_values) + + 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] + +def hemispherical_cluster(cluster, emitter_tag=0, emitter_plane=0, diameter=0, planes=0): + + """Creates and returns a cluster based on an Atoms object and some parameters. + + :param cluster: the Atoms object used to create the cluster + :type cluster: Atoms object + :param emitter_tag: the tag of your emitter + :type emitter_tag: integer + :param diameter: the diameter of your cluster in Angströms + :type diameter: float + :param planes: the number of planes of your cluster + :type planes: integer + :param emitter_plane: the plane where your emitter will be starting by 0 for the first plane + :type emitter_plane: integer + + See :ref:`hemispherical_cluster_faq` for more informations. + """ + + def get_xypos(cluster, ze, symbol=None): + nmin = None + + for atom in cluster: + if ze - eps < atom.z < ze + eps and (atom.symbol == symbol or symbol == None): + n = np.sqrt(atom.x**2 + atom.y**2) + if (n < nmin) or (nmin is None): + nmin = n + iatom = atom.index + + pos = cluster.get_positions()[iatom] + tx, ty = pos[0], pos[1] + return tx, ty + + cell = cluster.get_cell() + + eps = 0.01 # a useful small value + c = cell[:, 2].max() # a lattice parameter + a = cell[:, 0].max() # a lattice parameter + p = np.alen(np.unique(np.round(cluster.get_positions()[:, 2], 4))) # the number of planes in the cluster + symbol = cluster[np.where(cluster.get_tags() == emitter_tag)[0][0]].symbol # the symbol of your emitter + + assert (diameter != 0 or planes != 0), "At least one of diameter or planes parameter must be use." + + if diameter == 0: + l = 1+2*(planes*c/p+1) # calculate the minimal diameter according to the number of planes + else: + l = diameter + + rep = int(2*l/min(a,c)) # number of repetition in each direction + cluster = cluster.repeat((rep, rep, rep)) # repeat the cluster + + center_cluster(cluster) # center the cluster + cluster.set_cell(cell) # reset the cell + cluster = cut_plane(cluster, z=eps) # cut the cluster so that we have a centered surface + + i = np.where(cluster.get_tags() == emitter_tag) # positions where atoms have the tag of the emitter_tag + all_ze = np.sort(np.unique(np.round(cluster.get_positions()[:, 2][i], 4))) # an array of all unique z corresponding to where we have the right atom's tag + all_z = np.sort(np.unique(np.round(cluster.get_positions()[:, 2], 4))) # an array of all unique z + + n = np.where(all_z == all_z.max())[0][0] - np.where(all_z == all_ze.max())[0][0] # calculate the number of planes above the emitter's plane + ze = all_ze.max() # the height of the emitter's plane + + + # if the number of planes above the emitter's plane is smaller than it must be, recalculate n and ze + while n < emitter_plane: + all_ze = all_ze[:-1] + n = np.where(all_z == all_z.max())[0][0] - np.where(all_z == all_ze.max())[0][0] + ze = all_ze.max() + + + tx, ty = get_xypos(cluster, ze, symbol) # values of x and y of the emitter + Atoms.translate(cluster, [-tx, -ty, 0]) # center the cluster on the emitter + + z_cut = all_z[np.where(all_z == all_ze.max())[0][0] + emitter_plane] # calculate where to cut to get the right number of planes above the emitter + Atoms.translate(cluster, [0, 0, -z_cut]) # translate the surface at z=0 + cluster = cut_plane(cluster, z=eps) # cut the planes above those we want to keep + + radius = diameter/2 + if planes!=0: + all_z = np.sort(np.unique(np.round(cluster.get_positions()[:, 2], 4))) # an array of all unique remaining z + zplan = all_z[-planes] + xplan, yplan = get_xypos(cluster, zplan) + radius = np.sqrt(xplan**2 + yplan**2 + zplan**2) + if diameter!=0: + assert (radius <= diameter/2), "The number of planes is too high compared to the diameter." + radius = max(radius, diameter/2) + + cluster = cut_sphere(cluster, radius=radius + eps) # cut a sphere in our cluster with the diameter which is indicate in the parameters + + if planes!=0: + zcut = np.sort(np.unique(np.round(cluster.get_positions()[:, 2], 4)))[::-1][planes-1] - eps # calculate where to cut to get the right number of planes + cluster = cut_plane(cluster, z=zcut) # cut the right number of planes + + all_z = np.sort(np.unique(np.round(cluster.get_positions()[:, 2], 4))) # an array of all unique remaining z + assert emitter_plane < np.alen(all_z), "There are not enough existing plans." + ze = all_z[- emitter_plane - 1] # the z-coordinate of the emitter + Atoms.translate(cluster, [0, 0, -ze]) # put the emitter in (0,0,0) + + return cluster \ No newline at end of file diff --git a/src/setup.py b/src/setup.py new file mode 100644 index 0000000..b53c88c --- /dev/null +++ b/src/setup.py @@ -0,0 +1,10 @@ +#vim: set et ts=4 sw=4: +# coding: utf-8 + +from setuptools import setup, find_packages +import msspec + +setup(name='msspec', + version=msspec.__version__, + include_package_data=True, + packages=find_packages(include='msspec.*'))