From 93782236b0a4c872e3182e4b73981ecb1bfd570c Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Thu, 5 Dec 2019 18:26:41 +0100 Subject: [PATCH] Add the eigen value "spectroscopy" support. The msspec/spec/fortran folder is totally different now. Most of the fortran subroutines are in their own file and are located in different folders The Makefile has been rewritten and can generate 3 libraries: - one for Photoelectron Diffration in series expansion - two for Eigen value calculation with matrix inversion and power method --- src/msspec/__init__.py | 16 + src/msspec/calcio.py | 3 + src/msspec/calculator.py | 101 +- src/msspec/parameters.py | 21 +- src/msspec/phagen/fortran/Makefile | 11 +- src/msspec/spec/fortran/Makefile | 71 +- src/msspec/spec/fortran/cluster_gen/amas.f | 142 + src/msspec/spec/fortran/cluster_gen/base.f | 130 + src/msspec/spec/fortran/cluster_gen/centre.f | 61 + src/msspec/spec/fortran/cluster_gen/chbase.f | 30 + src/msspec/spec/fortran/cluster_gen/chnot.f | 18 + src/msspec/spec/fortran/cluster_gen/invmat.f | 43 + src/msspec/spec/fortran/cluster_gen/mulmat.f | 30 + src/msspec/spec/fortran/cluster_gen/numat.f | 44 + src/msspec/spec/fortran/cluster_gen/rela.f | 220 + src/msspec/spec/fortran/cluster_gen/rotbas.f | 132 + src/msspec/spec/fortran/cluster_gen/rzb110.f | 22 + src/msspec/spec/fortran/cluster_gen/test.f | 22 + src/msspec/spec/fortran/cluster_gen/test1.f | 43 + src/msspec/spec/fortran/common_sub/arcsin.f | 28 + src/msspec/spec/fortran/common_sub/atdata.f | 51 + .../spec/fortran/common_sub/auger_mult.f | 39 + src/msspec/spec/fortran/common_sub/besphe.f | 159 + src/msspec/spec/fortran/common_sub/besphe2.f | 156 + .../spec/fortran/common_sub/check_vib.f | 97 + src/msspec/spec/fortran/common_sub/diran.f | 190 + src/msspec/spec/fortran/common_sub/djmn.f | 171 + src/msspec/spec/fortran/common_sub/djmn2.f | 191 + src/msspec/spec/fortran/common_sub/emett.f | 52 + src/msspec/spec/fortran/common_sub/euler.f | 50 + src/msspec/spec/fortran/common_sub/gaunt.f | 108 + src/msspec/spec/fortran/common_sub/gaunt2.f | 108 + src/msspec/spec/fortran/common_sub/harsph.f | 61 + src/msspec/spec/fortran/common_sub/harsph2.f | 34 + src/msspec/spec/fortran/common_sub/harsph3.f | 70 + src/msspec/spec/fortran/common_sub/headers.f | 250 + src/msspec/spec/fortran/common_sub/ig.f | 25 + src/msspec/spec/fortran/common_sub/locate.f | 37 + src/msspec/spec/fortran/common_sub/lpm.f | 59 + src/msspec/spec/fortran/common_sub/n_j.f | 340 + src/msspec/spec/fortran/common_sub/ordre.f | 48 + src/msspec/spec/fortran/common_sub/ordre2.f | 47 + src/msspec/spec/fortran/common_sub/plm.f | 43 + src/msspec/spec/fortran/common_sub/polhan.f | 49 + src/msspec/spec/fortran/common_sub/polleg.f | 21 + src/msspec/spec/fortran/common_sub/prscal.f | 14 + src/msspec/spec/fortran/common_sub/prvect.f | 17 + .../spec/fortran/common_sub/read_data.f | 1932 ++ src/msspec/spec/fortran/common_sub/refrac.f | 29 + src/msspec/spec/fortran/common_sub/sig2.f | 48 + src/msspec/spec/fortran/common_sub/sixj_in.f | 82 + src/msspec/spec/fortran/common_sub/sph_har.f | 61 + src/msspec/spec/fortran/common_sub/sph_har2.f | 67 + src/msspec/spec/fortran/common_sub/stop_ext.f | 59 + .../spec/fortran/common_sub/stop_treat.f | 197 + .../spec/fortran/common_sub/sup_zeros.f | 72 + src/msspec/spec/fortran/common_sub/sym_clus.f | 1850 ++ src/msspec/spec/fortran/common_sub/uj_sq.f | 79 + src/msspec/spec/fortran/eig/common/dwsph.f | 85 + .../spec/fortran/eig/common/eig_mat_ms.f | 261 + src/msspec/spec/fortran/eig/common/facdif1.f | 116 + .../spec/fortran/eig/common/lapack_eig.f | 21492 ++++++++++++++++ src/msspec/spec/fortran/eig/common/plotfd.f | 103 + src/msspec/spec/fortran/eig/mi/acc_conv.f | 189 + src/msspec/spec/fortran/eig/mi/acc_scal.f | 693 + src/msspec/spec/fortran/eig/mi/check_conv.f | 96 + src/msspec/spec/fortran/eig/mi/coefficients.f | 89 + src/msspec/spec/fortran/eig/mi/conv_series.f | 32 + src/msspec/spec/fortran/eig/mi/do_main.f | 1557 ++ src/msspec/spec/fortran/eig/mi/eigdif_mi.f | 104 + .../spec/fortran/eig/mi/interp_points.f | 38 + src/msspec/spec/fortran/eig/mi/levin.f | 191 + src/msspec/spec/fortran/{ => eig/mi}/main.f | 0 src/msspec/spec/fortran/eig/mi/new.f.hidden | 3972 +++ .../spec/fortran/eig/mi/remain_series.f | 78 + .../spec/fortran/eig/mi/spec_rad_power.f | 348 + src/msspec/spec/fortran/eig/pw/acc_conv.f | 194 + src/msspec/spec/fortran/eig/pw/acc_scal.f | 693 + src/msspec/spec/fortran/eig/pw/check_conv.f | 97 + src/msspec/spec/fortran/eig/pw/coefficients.f | 90 + src/msspec/spec/fortran/eig/pw/conv_series.f | 33 + src/msspec/spec/fortran/eig/pw/do_main.f | 1558 ++ src/msspec/spec/fortran/eig/pw/eigdif_mi.f | 115 + .../spec/fortran/eig/pw/interp_points.f | 39 + src/msspec/spec/fortran/eig/pw/levin.f | 192 + src/msspec/spec/fortran/eig/pw/main.f | 20 + src/msspec/spec/fortran/eig/pw/new.f.hidden | 2079 ++ .../spec/fortran/eig/pw/remain_series.f | 79 + .../spec/fortran/eig/pw/spec_rad_power.f | 547 + .../spec/fortran/{ => memalloc}/allocation.f | 12 +- .../spec/fortran/{ => memalloc}/dim_mod.f | 3 + .../spec/fortran/{ => memalloc}/modules.f | 128 + .../fortran/phd_se_noso_nosp_nosym/coumat.f | 121 + .../fortran/phd_se_noso_nosp_nosym/do_main.f | 1654 ++ .../fortran/phd_se_noso_nosp_nosym/dwsph.f | 85 + .../fortran/phd_se_noso_nosp_nosym/facdif.f | 26 + .../fortran/phd_se_noso_nosp_nosym/facdif1.f | 113 + .../phd_se_noso_nosp_nosym/findpaths1.f | 366 + .../phd_se_noso_nosp_nosym/findpaths2.f | 367 + .../phd_se_noso_nosp_nosym/findpaths3.f | 367 + .../phd_se_noso_nosp_nosym/findpaths4.f | 367 + .../phd_se_noso_nosp_nosym/findpaths5.f | 367 + .../fortran/phd_se_noso_nosp_nosym/main.f | 20 + .../fortran/phd_se_noso_nosp_nosym/matdif.f | 344 + .../fortran/phd_se_noso_nosp_nosym/pathop.f | 550 + .../phd_se_noso_nosp_nosym/phddif_se.f | 1306 + .../fortran/phd_se_noso_nosp_nosym/plotfd.f | 106 + .../phd_se_noso_nosp_nosym/treat_phd.f | 769 + .../phd_se_noso_nosp_nosym/weight_sum.f | 335 + src/msspec/spec/fortran/prog.f | 13 - .../{ => renormalization}/renormalization.f | 0 src/msspec/spec/fortran/spec.f | 13322 ---------- 112 files changed, 50652 insertions(+), 13420 deletions(-) create mode 100644 src/msspec/spec/fortran/cluster_gen/amas.f create mode 100644 src/msspec/spec/fortran/cluster_gen/base.f create mode 100644 src/msspec/spec/fortran/cluster_gen/centre.f create mode 100644 src/msspec/spec/fortran/cluster_gen/chbase.f create mode 100644 src/msspec/spec/fortran/cluster_gen/chnot.f create mode 100644 src/msspec/spec/fortran/cluster_gen/invmat.f create mode 100644 src/msspec/spec/fortran/cluster_gen/mulmat.f create mode 100644 src/msspec/spec/fortran/cluster_gen/numat.f create mode 100644 src/msspec/spec/fortran/cluster_gen/rela.f create mode 100644 src/msspec/spec/fortran/cluster_gen/rotbas.f create mode 100644 src/msspec/spec/fortran/cluster_gen/rzb110.f create mode 100644 src/msspec/spec/fortran/cluster_gen/test.f create mode 100644 src/msspec/spec/fortran/cluster_gen/test1.f create mode 100644 src/msspec/spec/fortran/common_sub/arcsin.f create mode 100644 src/msspec/spec/fortran/common_sub/atdata.f create mode 100644 src/msspec/spec/fortran/common_sub/auger_mult.f create mode 100644 src/msspec/spec/fortran/common_sub/besphe.f create mode 100644 src/msspec/spec/fortran/common_sub/besphe2.f create mode 100644 src/msspec/spec/fortran/common_sub/check_vib.f create mode 100644 src/msspec/spec/fortran/common_sub/diran.f create mode 100644 src/msspec/spec/fortran/common_sub/djmn.f create mode 100644 src/msspec/spec/fortran/common_sub/djmn2.f create mode 100644 src/msspec/spec/fortran/common_sub/emett.f create mode 100644 src/msspec/spec/fortran/common_sub/euler.f create mode 100644 src/msspec/spec/fortran/common_sub/gaunt.f create mode 100644 src/msspec/spec/fortran/common_sub/gaunt2.f create mode 100644 src/msspec/spec/fortran/common_sub/harsph.f create mode 100644 src/msspec/spec/fortran/common_sub/harsph2.f create mode 100644 src/msspec/spec/fortran/common_sub/harsph3.f create mode 100644 src/msspec/spec/fortran/common_sub/headers.f create mode 100644 src/msspec/spec/fortran/common_sub/ig.f create mode 100644 src/msspec/spec/fortran/common_sub/locate.f create mode 100644 src/msspec/spec/fortran/common_sub/lpm.f create mode 100644 src/msspec/spec/fortran/common_sub/n_j.f create mode 100644 src/msspec/spec/fortran/common_sub/ordre.f create mode 100644 src/msspec/spec/fortran/common_sub/ordre2.f create mode 100644 src/msspec/spec/fortran/common_sub/plm.f create mode 100644 src/msspec/spec/fortran/common_sub/polhan.f create mode 100644 src/msspec/spec/fortran/common_sub/polleg.f create mode 100644 src/msspec/spec/fortran/common_sub/prscal.f create mode 100644 src/msspec/spec/fortran/common_sub/prvect.f create mode 100644 src/msspec/spec/fortran/common_sub/read_data.f create mode 100644 src/msspec/spec/fortran/common_sub/refrac.f create mode 100644 src/msspec/spec/fortran/common_sub/sig2.f create mode 100644 src/msspec/spec/fortran/common_sub/sixj_in.f create mode 100644 src/msspec/spec/fortran/common_sub/sph_har.f create mode 100644 src/msspec/spec/fortran/common_sub/sph_har2.f create mode 100644 src/msspec/spec/fortran/common_sub/stop_ext.f create mode 100644 src/msspec/spec/fortran/common_sub/stop_treat.f create mode 100644 src/msspec/spec/fortran/common_sub/sup_zeros.f create mode 100644 src/msspec/spec/fortran/common_sub/sym_clus.f create mode 100644 src/msspec/spec/fortran/common_sub/uj_sq.f create mode 100644 src/msspec/spec/fortran/eig/common/dwsph.f create mode 100644 src/msspec/spec/fortran/eig/common/eig_mat_ms.f create mode 100644 src/msspec/spec/fortran/eig/common/facdif1.f create mode 100644 src/msspec/spec/fortran/eig/common/lapack_eig.f create mode 100644 src/msspec/spec/fortran/eig/common/plotfd.f create mode 100644 src/msspec/spec/fortran/eig/mi/acc_conv.f create mode 100644 src/msspec/spec/fortran/eig/mi/acc_scal.f create mode 100644 src/msspec/spec/fortran/eig/mi/check_conv.f create mode 100644 src/msspec/spec/fortran/eig/mi/coefficients.f create mode 100644 src/msspec/spec/fortran/eig/mi/conv_series.f create mode 100644 src/msspec/spec/fortran/eig/mi/do_main.f create mode 100644 src/msspec/spec/fortran/eig/mi/eigdif_mi.f create mode 100644 src/msspec/spec/fortran/eig/mi/interp_points.f create mode 100644 src/msspec/spec/fortran/eig/mi/levin.f rename src/msspec/spec/fortran/{ => eig/mi}/main.f (100%) create mode 100644 src/msspec/spec/fortran/eig/mi/new.f.hidden create mode 100644 src/msspec/spec/fortran/eig/mi/remain_series.f create mode 100644 src/msspec/spec/fortran/eig/mi/spec_rad_power.f create mode 100644 src/msspec/spec/fortran/eig/pw/acc_conv.f create mode 100644 src/msspec/spec/fortran/eig/pw/acc_scal.f create mode 100644 src/msspec/spec/fortran/eig/pw/check_conv.f create mode 100644 src/msspec/spec/fortran/eig/pw/coefficients.f create mode 100644 src/msspec/spec/fortran/eig/pw/conv_series.f create mode 100644 src/msspec/spec/fortran/eig/pw/do_main.f create mode 100644 src/msspec/spec/fortran/eig/pw/eigdif_mi.f create mode 100644 src/msspec/spec/fortran/eig/pw/interp_points.f create mode 100644 src/msspec/spec/fortran/eig/pw/levin.f create mode 100644 src/msspec/spec/fortran/eig/pw/main.f create mode 100644 src/msspec/spec/fortran/eig/pw/new.f.hidden create mode 100644 src/msspec/spec/fortran/eig/pw/remain_series.f create mode 100644 src/msspec/spec/fortran/eig/pw/spec_rad_power.f rename src/msspec/spec/fortran/{ => memalloc}/allocation.f (95%) rename src/msspec/spec/fortran/{ => memalloc}/dim_mod.f (96%) rename src/msspec/spec/fortran/{ => memalloc}/modules.f (90%) create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths4.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths5.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/main.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/matdif.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/phddif_se.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/plotfd.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/treat_phd.f create mode 100644 src/msspec/spec/fortran/phd_se_noso_nosp_nosym/weight_sum.f delete mode 100644 src/msspec/spec/fortran/prog.f rename src/msspec/spec/fortran/{ => renormalization}/renormalization.f (100%) delete mode 100644 src/msspec/spec/fortran/spec.f diff --git a/src/msspec/__init__.py b/src/msspec/__init__.py index 2ebfb1e..fe5175a 100644 --- a/src/msspec/__init__.py +++ b/src/msspec/__init__.py @@ -1,2 +1,18 @@ +import ase from .version import __version__ +from .misc import LOGGER + __sha__ = "$Id$" + +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() diff --git a/src/msspec/calcio.py b/src/msspec/calcio.py index 04326a9..f30ce10 100644 --- a/src/msspec/calcio.py +++ b/src/msspec/calcio.py @@ -678,7 +678,10 @@ class SpecIO(object): else: ibwd_arr = np.zeros((nat), dtype=np.int) thbwd_arr = np.ones((nat)) + print("nat", nat) + print("thbwd_arr", thbwd_arr) for at in p.extra_atoms: + print(at) i = at.get('proto_index') - 1 thfwd_arr[i] = at.get('forward_angle') thbwd_arr[i] = at.get('backward_angle') diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py index b9b4aca..325b384 100644 --- a/src/msspec/calculator.py +++ b/src/msspec/calculator.py @@ -59,42 +59,15 @@ from msspec.parameters import (PhagenParameters, PhagenMallocParameters, 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 msspec.phagen.fortran.libphagen import main as do_phagen + +from msspec.spec.fortran import phd_se_noso_nosp_nosym +from msspec.spec.fortran import eig_mi +from msspec.spec.fortran import eig_pw 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 @@ -146,9 +119,8 @@ class _MSCALCULATOR(Calculator): elif spectroscopy == 'EIG': self.spectroscopy_parameters = EIGParameters(self.phagen_parameters, self.spec_parameters) - #pass else: - raise NameError('No such spectrosopy') + raise NameError('No such spectroscopy') self.source_parameters = SourceParameters(self.global_parameters, self.phagen_parameters, @@ -210,30 +182,30 @@ class _MSCALCULATOR(Calculator): #os.chdir(self.tmp_folder) - inv = cor = 'NO' - if algorithm == 'expansion': - pass - elif algorithm == 'inversion': - inv = 'YES' - elif algorithm == 'correlation': - cor = 'YES' + #inv = cor = 'NO' + #if algorithm == 'expansion': + # pass + #elif algorithm == 'inversion': + # inv = 'YES' + #elif algorithm == 'correlation': + # cor = 'YES' # spin orbit resolved (not yet) - sorb = 'NO' + #sorb = 'NO' # spin resolved - dichro_spinpol = False - if dichroism in ('sum_over_spin', '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' + #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!') + #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') @@ -375,7 +347,30 @@ class _MSCALCULATOR(Calculator): for key, value in requirements.items(): setattr(self.spec_malloc_parameters, key, value) - + + # Get the spec function to launch + if self.global_parameters.spectroscopy == 'PED': + if self.global_parameters.algorithm == 'expansion': + do_spec = phd_se_noso_nosp_nosym.run + else: + LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not " + "an allowed combination.".format(self.global_parameters.spectroscopy, + self.global_parameters.algorithm)) + raise ValueError + elif self.global_parameters.spectroscopy == 'EIG': + if self.global_parameters.algorithm == 'inversion': + do_spec = eig_mi.run + elif self.global_parameters.algorithm == 'power': + do_spec = eig_pw.run + else: + LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not " + "an allowed combination.".format(self.global_parameters.spectroscopy, + self.global_parameters.algorithm)) + raise ValueError + else: + LOGGER.error("\'{}\' spectroscopy is not supported yet.".format(self.global_parameters.spectroscopy)) + raise NotImplementedError + # cannot use this, unfortunately #do_spec(*requirements.values()) do_spec( @@ -893,7 +888,7 @@ class _EIG(_MSCALCULATOR): # update the parameters self.scan_parameters.set_parameter('kinetic_energy', kinetic_energy) - all_ke = self.scan_parameters.get_parameter('ke_array') + all_ke = self.scan_parameters.get_parameter('ke_array').value 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( diff --git a/src/msspec/parameters.py b/src/msspec/parameters.py index eaeb91e..5537539 100644 --- a/src/msspec/parameters.py +++ b/src/msspec/parameters.py @@ -536,9 +536,9 @@ class SpecParameters(BaseParameters): 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, + Parameter('eigval_ipwm', types=int, limits=[-4, 4], default=0, fmt='d'), - Parameter('eigval_method', types=str, default='EPSI', + Parameter('eigval_method', types=str, default='AITK', allowed_values=['AITK', 'RICH', 'SALZ', 'EPSI', 'EPSG', 'RHOA', 'THET', 'LEGE', 'CHEB', 'OVER', 'DURB', 'DLEV', 'TLEV', 'ULEV', 'VLEV', @@ -801,6 +801,17 @@ class GlobalParameters(BaseParameters): phagen_calctype, spec_calctype = mapping[p.value] self.phagen_parameters.calctype = phagen_calctype self.spec_parameters.calctype_spectro = spec_calctype + + def bind_spinpol(self, p): + if p.value == True: + LOGGER.error('Spin polarization is not yet enabled in the Python version.') + raise NotImplementedError + + def bind_dichroism(self, p): + if p.value is not None: + LOGGER.error('Dichroism is not yet enabled in the Python version.') + raise NotImplemented + class MuffintinParameters(BaseParameters): def __init__(self, phagen_parameters, spec_parameters): @@ -1372,7 +1383,7 @@ class CalculationParameters(BaseParameters): doc=textwrap.dedent(""" The scattering order. Only meaningful for the 'expansion' algorithm. Its value is limited to 10.""")), - Parameter('renormalization_mode', allowed_values=(None, 'Sigma_n', 'G_n'), + Parameter('renormalization_mode', allowed_values=(None, 'G_n', 'Sigma_n'), types=(type(None), str), default=None, doc=textwrap.dedent(""" Enable the calculation of the coefficients for the renormalization of @@ -1512,9 +1523,9 @@ class CalculationParameters(BaseParameters): if p.value is None: self.spec_parameters.calc_iren = 0 else: - if p.value.lower() == 'Sigma_n'.lower(): + if p.value.lower() == 'G_n'.lower(): self.spec_parameters.calc_iren = 1 - elif p.value.lower() == 'G_n'.lower(): + elif p.value.lower() == 'Sigma_n'.lower(): self.spec_parameters.calc_iren = 2 LOGGER.info("Renormalization activated with \'{}\' method".format(p.value)) diff --git a/src/msspec/phagen/fortran/Makefile b/src/msspec/phagen/fortran/Makefile index b6b4528..6665315 100644 --- a/src/msspec/phagen/fortran/Makefile +++ b/src/msspec/phagen/fortran/Makefile @@ -17,13 +17,13 @@ endif .PHONY: clean -pybinding: libphagen.so +pybinding: libphagen -libphagen.so: $(objects) main.f +libphagen: $(objects) main.f @echo "building Python binding..." @$(F2PY) -I. $(objects) $(F2PY_OPTS)-c -m libphagen main.f - @cp libphagen.cpython*.so ../ - @mv libphagen.cpython*.so libphagen.so +# @cp libphagen.cpython*.so ../ +# @mv libphagen.cpython*.so libphagen.so $(objects): $(objects_src) @echo "compiling subroutines and functions for phagen..." @@ -31,5 +31,4 @@ $(objects): $(objects_src) clean: @echo "cleaning..." - @rm -rf *.so *.o *.mod - @rm -rf ../*.so + @rm -rf *.o *.mod diff --git a/src/msspec/spec/fortran/Makefile b/src/msspec/spec/fortran/Makefile index cba5c62..c8dd069 100644 --- a/src/msspec/spec/fortran/Makefile +++ b/src/msspec/spec/fortran/Makefile @@ -6,8 +6,38 @@ F2PY_OPTS:= DEBUG:=0 -objects_src := dim_mod.f modules.f renormalization.f allocation.f spec.f -objects := $(patsubst %.f,%.o, $(objects_src)) +includes := -I./memalloc/ -I./cluster_gen/ -I./common_sub -I./renormalization +includes += -I./phd_se_noso_nosp_nosym +includes += -I./eig/common -I./eig/new_mi -I./eig/new_pw + +memalloc_src:=memalloc/dim_mod.f memalloc/modules.f memalloc/allocation.f +memalloc_obj:=$(patsubst %.f,%.o, $(memalloc_src)) + +cluster_gen_src:=$(wildcard cluster_gen/*.f) +cluster_gen_obj:=$(patsubst %.f,%.o, $(cluster_gen_src)) + +common_sub_src:=$(wildcard common_sub/*.f) +common_sub_obj:=$(patsubst %.f,%.o, $(common_sub_src)) + +renormalization_src:=$(wildcard renormalization/*.f) +renormalization_obj:=$(patsubst %.f,%.o, $(renormalization_src)) + +phd_se_noso_nosp_nosym_src:=$(filter-out phd_se_noso_nosp_nosym/main.f, $(wildcard phd_se_noso_nosp_nosym/*.f)) +phd_se_noso_nosp_nosym_obj:=$(patsubst %.f,%.o, $(phd_se_noso_nosp_nosym_src)) + +eig_common_src:=$(wildcard eig/common/*.f) +eig_common_obj:=$(patsubst %.f,%.o, $(eig_common_src)) + +eig_mi_src:=$(filter-out eig/mi/main.f, $(wildcard eig/mi/*.f)) +eig_mi_obj:=$(patsubst %.f,%.o, $(eig_mi_src)) + +eig_pw_src:=$(filter-out eig/pw/main.f, $(wildcard eig/pw/*.f)) +eig_pw_obj:=$(patsubst %.f,%.o, $(eig_pw_src)) + +objects_src := $(memalloc_src) $(cluster_gen_src) $(common_sub_src) +objects_src += $(renormalization_src) $(phd_se_noso_nosp_nosym_src) +objects_src += $(eig_common_src) $(eig_mi_src) $(eig_pw_src) +objects:=$(patsubst %.f,%.o, $(objects_src)) EXE=prog @@ -16,32 +46,35 @@ ifeq ($(DEBUG),1) F2PY_OPTS:=$(F2PY_OPTS) --debug-capi --debug endif +export COMP +export COMP_OPTS .PHONY: clean -pybinding: libspec.so -libspec.so: $(objects) main.f +pybinding: phd_se_noso_nosp_nosym eig_mi eig_pw + +phd_se_noso_nosp_nosym: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(phd_se_noso_nosp_nosym_obj) @echo "building Python binding..." - @$(F2PY) -I. $(objects) $(F2PY_OPTS) -c -m libspec main.f - @cp libspec.cpython*.so ../ - @mv libspec.cpython*.so libspec.so + @$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ phd_se_noso_nosp_nosym/main.f +# @cp $@.cpython*.so ../ -exe: $(objects) prog.f - @$(COMP) -c main.f - @$(COMP) -c prog.f - @$(COMP) -o $(EXE) $(objects) main.o prog.o +eig_mi: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(eig_common_obj) $(eig_mi_obj) + @echo "building Python binding..." + @$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ eig/mi/main.f +# @cp $@.cpython*.so ../ +eig_pw: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(eig_common_obj) $(eig_pw_obj) + @echo "building Python binding..." + @$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ eig/pw/main.f +# @cp $@.cpython*.so ../ -$(objects): $(objects_src) - @echo "compiling subroutines and functions for spec..." -# $(COMP) -cpp -fPIC -O2 -ffast-math -mcmodel=large -fdefault-real-4 -c $^ -# @$(COMP) $(OPTS) -fPIC -mcmodel=large -c $^ - @$(COMP) $(COMP_OPTS) -fPIC -c $^ +%.o: %.f + @echo "compiling $@..." + @$(COMP) $(COMP_OPTS) -I./memalloc/ -fPIC -o $@ -c $^ clean: @echo "cleaning..." - @rm -rf *.so *.o *.mod - @rm -rf $(EXE) - @rm -rf ../*.so + @rm -rf *.o *.mod + @rm -rf $(objects) diff --git a/src/msspec/spec/fortran/cluster_gen/amas.f b/src/msspec/spec/fortran/cluster_gen/amas.f new file mode 100644 index 0000000..c251c27 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/amas.f @@ -0,0 +1,142 @@ + 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 diff --git a/src/msspec/spec/fortran/cluster_gen/base.f b/src/msspec/spec/fortran/cluster_gen/base.f new file mode 100644 index 0000000..5cbbe56 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/base.f @@ -0,0 +1,130 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/centre.f b/src/msspec/spec/fortran/cluster_gen/centre.f new file mode 100644 index 0000000..56de6c4 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/centre.f @@ -0,0 +1,61 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/chbase.f b/src/msspec/spec/fortran/cluster_gen/chbase.f new file mode 100644 index 0000000..684b273 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/chbase.f @@ -0,0 +1,30 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/chnot.f b/src/msspec/spec/fortran/cluster_gen/chnot.f new file mode 100644 index 0000000..c352ab2 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/chnot.f @@ -0,0 +1,18 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/invmat.f b/src/msspec/spec/fortran/cluster_gen/invmat.f new file mode 100644 index 0000000..359ad58 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/invmat.f @@ -0,0 +1,43 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/mulmat.f b/src/msspec/spec/fortran/cluster_gen/mulmat.f new file mode 100644 index 0000000..0dc1a84 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/mulmat.f @@ -0,0 +1,30 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/numat.f b/src/msspec/spec/fortran/cluster_gen/numat.f new file mode 100644 index 0000000..3f15b5f --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/numat.f @@ -0,0 +1,44 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/rela.f b/src/msspec/spec/fortran/cluster_gen/rela.f new file mode 100644 index 0000000..7b9e2a3 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/rela.f @@ -0,0 +1,220 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/rotbas.f b/src/msspec/spec/fortran/cluster_gen/rotbas.f new file mode 100644 index 0000000..db3d62f --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/rotbas.f @@ -0,0 +1,132 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/rzb110.f b/src/msspec/spec/fortran/cluster_gen/rzb110.f new file mode 100644 index 0000000..9961469 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/rzb110.f @@ -0,0 +1,22 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/test.f b/src/msspec/spec/fortran/cluster_gen/test.f new file mode 100644 index 0000000..8667da0 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/test.f @@ -0,0 +1,22 @@ +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 diff --git a/src/msspec/spec/fortran/cluster_gen/test1.f b/src/msspec/spec/fortran/cluster_gen/test1.f new file mode 100644 index 0000000..1372670 --- /dev/null +++ b/src/msspec/spec/fortran/cluster_gen/test1.f @@ -0,0 +1,43 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/arcsin.f b/src/msspec/spec/fortran/common_sub/arcsin.f new file mode 100644 index 0000000..3e803ba --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/arcsin.f @@ -0,0 +1,28 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/atdata.f b/src/msspec/spec/fortran/common_sub/atdata.f new file mode 100644 index 0000000..d7616b9 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/atdata.f @@ -0,0 +1,51 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/auger_mult.f b/src/msspec/spec/fortran/common_sub/auger_mult.f new file mode 100644 index 0000000..9c9fe41 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/auger_mult.f @@ -0,0 +1,39 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/besphe.f b/src/msspec/spec/fortran/common_sub/besphe.f new file mode 100644 index 0000000..3de3340 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/besphe.f @@ -0,0 +1,159 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/besphe2.f b/src/msspec/spec/fortran/common_sub/besphe2.f new file mode 100644 index 0000000..1ca3d44 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/besphe2.f @@ -0,0 +1,156 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/check_vib.f b/src/msspec/spec/fortran/common_sub/check_vib.f new file mode 100644 index 0000000..da4abc9 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/check_vib.f @@ -0,0 +1,97 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/diran.f b/src/msspec/spec/fortran/common_sub/diran.f new file mode 100644 index 0000000..20dbecc --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/diran.f @@ -0,0 +1,190 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/djmn.f b/src/msspec/spec/fortran/common_sub/djmn.f new file mode 100644 index 0000000..15abcac --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/djmn.f @@ -0,0 +1,171 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/djmn2.f b/src/msspec/spec/fortran/common_sub/djmn2.f new file mode 100644 index 0000000..95c7bca --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/djmn2.f @@ -0,0 +1,191 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/emett.f b/src/msspec/spec/fortran/common_sub/emett.f new file mode 100644 index 0000000..de45880 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/emett.f @@ -0,0 +1,52 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/euler.f b/src/msspec/spec/fortran/common_sub/euler.f new file mode 100644 index 0000000..d67b4ad --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/euler.f @@ -0,0 +1,50 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/gaunt.f b/src/msspec/spec/fortran/common_sub/gaunt.f new file mode 100644 index 0000000..a56a2d5 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/gaunt.f @@ -0,0 +1,108 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/gaunt2.f b/src/msspec/spec/fortran/common_sub/gaunt2.f new file mode 100644 index 0000000..3978601 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/gaunt2.f @@ -0,0 +1,108 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/harsph.f b/src/msspec/spec/fortran/common_sub/harsph.f new file mode 100644 index 0000000..94796e2 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/harsph.f @@ -0,0 +1,61 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/harsph2.f b/src/msspec/spec/fortran/common_sub/harsph2.f new file mode 100644 index 0000000..0867ff3 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/harsph2.f @@ -0,0 +1,34 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/harsph3.f b/src/msspec/spec/fortran/common_sub/harsph3.f new file mode 100644 index 0000000..41ff239 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/harsph3.f @@ -0,0 +1,70 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/headers.f b/src/msspec/spec/fortran/common_sub/headers.f new file mode 100644 index 0000000..8a2e9e7 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/headers.f @@ -0,0 +1,250 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/ig.f b/src/msspec/spec/fortran/common_sub/ig.f new file mode 100644 index 0000000..56cfb4f --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/ig.f @@ -0,0 +1,25 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/locate.f b/src/msspec/spec/fortran/common_sub/locate.f new file mode 100644 index 0000000..e6c2c46 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/locate.f @@ -0,0 +1,37 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/lpm.f b/src/msspec/spec/fortran/common_sub/lpm.f new file mode 100644 index 0000000..09c1f48 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/lpm.f @@ -0,0 +1,59 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/n_j.f b/src/msspec/spec/fortran/common_sub/n_j.f new file mode 100644 index 0000000..0e608db --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/n_j.f @@ -0,0 +1,340 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/ordre.f b/src/msspec/spec/fortran/common_sub/ordre.f new file mode 100644 index 0000000..55c07fa --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/ordre.f @@ -0,0 +1,48 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/ordre2.f b/src/msspec/spec/fortran/common_sub/ordre2.f new file mode 100644 index 0000000..d2e980e --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/ordre2.f @@ -0,0 +1,47 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/plm.f b/src/msspec/spec/fortran/common_sub/plm.f new file mode 100644 index 0000000..b141f3e --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/plm.f @@ -0,0 +1,43 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/polhan.f b/src/msspec/spec/fortran/common_sub/polhan.f new file mode 100644 index 0000000..c5eb001 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/polhan.f @@ -0,0 +1,49 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/polleg.f b/src/msspec/spec/fortran/common_sub/polleg.f new file mode 100644 index 0000000..4ff5c26 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/polleg.f @@ -0,0 +1,21 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/prscal.f b/src/msspec/spec/fortran/common_sub/prscal.f new file mode 100644 index 0000000..f364b29 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/prscal.f @@ -0,0 +1,14 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/prvect.f b/src/msspec/spec/fortran/common_sub/prvect.f new file mode 100644 index 0000000..8a1e63d --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/prvect.f @@ -0,0 +1,17 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/read_data.f b/src/msspec/spec/fortran/common_sub/read_data.f new file mode 100644 index 0000000..28d10ae --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/read_data.f @@ -0,0 +1,1932 @@ +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 RENORM_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 + READ(ICOM,50) I_REN,N_REN,REN_R,REN_I +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 + WRITE(IUO1,150) I_REN,N_REN,REN_R,REN_I +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 Computing the renormalization coefficients +C + IF(I_REN.LE.4) THEN + CALL COEF_RENORM(NDIF) + ELSEIF(I_REN.EQ.5) THEN + CALL COEF_LOEWDIN(NDIF) + 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) + 50 FORMAT(9X,I1,9X,I1,6X,F8.3,2X,F8.3) +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') + 150 FORMAT(12X,I1,9X,I1,6X,F8.3,2X,F8.3,5X,'I_REN,N_REN,REN_R,REN_I') +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 diff --git a/src/msspec/spec/fortran/common_sub/refrac.f b/src/msspec/spec/fortran/common_sub/refrac.f new file mode 100644 index 0000000..3479f6c --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/refrac.f @@ -0,0 +1,29 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/sig2.f b/src/msspec/spec/fortran/common_sub/sig2.f new file mode 100644 index 0000000..da359c6 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/sig2.f @@ -0,0 +1,48 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/sixj_in.f b/src/msspec/spec/fortran/common_sub/sixj_in.f new file mode 100644 index 0000000..59186e8 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/sixj_in.f @@ -0,0 +1,82 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/sph_har.f b/src/msspec/spec/fortran/common_sub/sph_har.f new file mode 100644 index 0000000..c8103ad --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/sph_har.f @@ -0,0 +1,61 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/sph_har2.f b/src/msspec/spec/fortran/common_sub/sph_har2.f new file mode 100644 index 0000000..bdc8d6f --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/sph_har2.f @@ -0,0 +1,67 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/stop_ext.f b/src/msspec/spec/fortran/common_sub/stop_ext.f new file mode 100644 index 0000000..4108375 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/stop_ext.f @@ -0,0 +1,59 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/stop_treat.f b/src/msspec/spec/fortran/common_sub/stop_treat.f new file mode 100644 index 0000000..1f64b94 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/stop_treat.f @@ -0,0 +1,197 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/sup_zeros.f b/src/msspec/spec/fortran/common_sub/sup_zeros.f new file mode 100644 index 0000000..4c3c7a9 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/sup_zeros.f @@ -0,0 +1,72 @@ +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 diff --git a/src/msspec/spec/fortran/common_sub/sym_clus.f b/src/msspec/spec/fortran/common_sub/sym_clus.f new file mode 100644 index 0000000..5481fdd --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/sym_clus.f @@ -0,0 +1,1850 @@ +C +C======================================================================= +C + SUBROUTINE SYM_CLUS(CUNIT,COORD,CHEM_OLD,NZAT,NTYP,IPHA) +C +C This subroutine reorganizes the cluster into equivalence classes +C taking advantage of its symmetry properties. The corresponding +C symmetry operations are stored for further use. +C +C Written by Mihai Gavaza : 15 Feb 2000 +C Modified by Didier Sebilleau : 05 Nov 2003 +C +C INCLUDE 'spec.inc' + USE DIM_MOD +C + USE ATOMS_MOD, NZ_AT => NZAT + USE CLUSLIM_MOD, Z_PLAN => VAL + USE COOR_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE ROT_CUB_MOD + USE SYMMOP_MOD + USE TAU_PROT_MOD + USE TAUSYMMOP_MOD + USE TESTS_MOD +C +C +C + COMPLEX ONEC,IC,JC1,JC2,JC4,JC5 + COMPLEX ONEC_,IC_,JC1_,JC2_,JC4_,JC5_ +C + PARAMETER(ONEC=(1.,0.),IC=(0.,1.),JC1=(0.5,0.866025)) + PARAMETER(ONEC_=(-1.,0.),IC_=(0.,-1.),JC1_=(-0.5,-0.866025)) + PARAMETER(JC2=JC1*JC1,JC4=JC2*JC2,JC5=JC4*JC1) + PARAMETER(JC2_=ONEC_*JC2,JC4_=ONEC_*JC4,JC5_=ONEC_*JC5) +C + REAL*4 COORD(3,NATCLU_M),COORD1(3,NATCLU_M),SYM_AT1(3,NATCLU_M) + REAL*4 DNBR(NATCLU_M,NATCLU_M),DIST0(NATCLU_M),DIST1(NATCLU_M) + REAL*4 S_M(3,3,64),S_MUL(3,3) +C + INTEGER NSYM_M(64),CONT_G(48,32),SIZE_G(32) + INTEGER INV_P(NATP_M,64),INV_PT(NATP_M,64),NAT_SYM(4) + INTEGER I_SET(NATP_M),GR(NATP_M) + INTEGER NEQAT(NATCLU_M),NBRZ(NATCLU_M,NATCLU_M),NZAT(NATCLU_M) + INTEGER IUSED(NATCLU_M),NTYP(NATCLU_M),NGAIN_B(NATP_M) + INTEGER NQAT(NATCLU_M),I_33(32),IS_WRONG(64),OLD_G(32),NEW_G(32) + INTEGER N_NEW_OLD(NATCLU_M) +C + CHARACTER*2 CHEM_OLD(NATCLU_M) + CHARACTER*3 NAME_G(0:32) + CHARACTER*4 ANG_ROT(4) + CHARACTER*5 NAME_S(64) + CHARACTER*8 AT_ADD(2) +C +C + LOGICAL EQUIV,MATCH +C +C Matrices of the 64 symmetry operations in the form S_M(I,J) +C I is chosen as the line index and J as the column one +C +C Matrices for the rotations of the group Oh +C +C The greek indices for the cubic rotations have been written as : +C +C alpha ----> l +C beta ----> m +C gamma ----> n +C delta ----> o +C + DATA ((S_M(I,J,1), J=1,3), I=1,3) /1.,0.,0.,0.,1.,0.,0.,0.,1./ + & ! E + DATA ((S_M(I,J,2), J=1,3), I=1,3) /1.,0.,0.,0.,-1.,0.,0.,0.,-1./ + & ! C2X + DATA ((S_M(I,J,3), J=1,3), I=1,3) /-1.,0.,0.,0.,1.,0.,0.,0.,-1./ + & ! C2Y + DATA ((S_M(I,J,4), J=1,3), I=1,3) /-1.,0.,0.,0.,-1.,0.,0.,0.,1./ + & ! C2Z + DATA ((S_M(I,J,5), J=1,3), I=1,3) /0.,0.,1.,1.,0.,0.,0.,1.,0./ + & ! C3l + DATA ((S_M(I,J,6), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,1.,-1.,0.,0./ + & ! C3m + DATA ((S_M(I,J,7), J=1,3), I=1,3) /0.,0.,-1.,1.,0.,0.,0.,-1.,0./ + & ! C3n + DATA ((S_M(I,J,8), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,-1.,1.,0.,0./ + & ! C3o + DATA ((S_M(I,J,9), J=1,3), I=1,3) /0.,1.,0.,0.,0.,1.,1.,0.,0./ + & ! C3l2 + DATA ((S_M(I,J,10), J=1,3), I=1,3) /0.,0.,-1.,-1.,0.,0.,0.,1.,0./ + & ! C3m2 + DATA ((S_M(I,J,11), J=1,3), I=1,3) /0.,1.,0.,0.,0.,-1.,-1.,0.,0./ + & ! C3n2 + DATA ((S_M(I,J,12), J=1,3), I=1,3) /0.,0.,1.,-1.,0.,0.,0.,-1.,0./ + & ! C3o2 + DATA ((S_M(I,J,13), J=1,3), I=1,3) /1.,0.,0.,0.,0.,-1.,0.,1.,0./ + & ! C4X + DATA ((S_M(I,J,14), J=1,3), I=1,3) /0.,0.,1.,0.,1.,0.,-1.,0.,0./ + & ! C4Y + DATA ((S_M(I,J,15), J=1,3), I=1,3) /0.,-1.,0.,1.,0.,0.,0.,0.,1./ + & ! C4Z + DATA ((S_M(I,J,16), J=1,3), I=1,3) /1.,0.,0.,0.,0.,1.,0.,-1.,0./ + & ! C4X3 + DATA ((S_M(I,J,17), J=1,3), I=1,3) /0.,0.,-1.,0.,1.,0.,1.,0.,0./ + & ! C4Y3 + DATA ((S_M(I,J,18), J=1,3), I=1,3) /0.,1.,0.,-1.,0.,0.,0.,0.,1./ + & ! C4Z3 + DATA ((S_M(I,J,19), J=1,3), I=1,3) /0.,1.,0.,1.,0.,0.,0.,0.,-1./ + & ! C2a + DATA ((S_M(I,J,20), J=1,3), I=1,3) /0.,-1.,0.,-1.,0.,0.,0.,0.,-1. + &/ ! C2b + DATA ((S_M(I,J,21), J=1,3), I=1,3) /0.,0.,1.,0.,-1.,0.,1.,0.,0./ + & ! C2c + DATA ((S_M(I,J,22), J=1,3), I=1,3) /0.,0.,-1.,0.,-1.,0.,-1.,0.,0. + &/ ! C2d + DATA ((S_M(I,J,23), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,-1.,0.,-1.,0. + &/ ! C2e + DATA ((S_M(I,J,24), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,1.,0.,1.,0./ + & ! C2f +C +C Matrices for the rotations of the group D6h +C + DATA ((S_M(I,J,25), J=1,3), I=1,3) /-0.5,-0.866025,0.,0.866025,- + &0.5,0.,0.,0.,1./ ! C3Z + DATA ((S_M(I,J,26), J=1,3), I=1,3) /-0.5,0.866025,0.,-0.866025,- + &0.5,0.,0.,0.,1./ ! C3Z2 + DATA ((S_M(I,J,27), J=1,3), I=1,3) /0.5,-0.866025,0.,0.866025,0. + &5,0.,0.,0.,1./ ! C6Z + DATA ((S_M(I,J,28), J=1,3), I=1,3) /0.5,0.866025,0.,-0.866025,0. + &5,0.,0.,0.,1./ ! C6Z5 + DATA ((S_M(I,J,29), J=1,3), I=1,3) /-0.5,-0.866025,0.,-0.866025, + &0.5,0.,0.,0.,-1./ ! C2A + DATA ((S_M(I,J,30), J=1,3), I=1,3) /-0.5,0.866025,0.,0.866025,0. + &5,0.,0.,0.,-1./ ! C2B + DATA ((S_M(I,J,31), J=1,3), I=1,3) /0.5,-0.866025,0.,-0.866025,- + &0.5,0.,0.,0.,-1./ ! C2C + DATA ((S_M(I,J,32), J=1,3), I=1,3) /0.5,0.866025,0.,0.866025,-0. + &5,0.,0.,0.,-1./ ! C2D +C +C Matrices for the roto-inversions of the group Oh +C + DATA ((S_M(I,J,33), J=1,3), I=1,3) /-1.,0.,0.,0.,-1.,0.,0.,0.,-1. + &/ ! I + DATA ((S_M(I,J,34), J=1,3), I=1,3) /-1.,0.,0.,0.,1.,0.,0.,0.,1./ + & ! IC2X + DATA ((S_M(I,J,35), J=1,3), I=1,3) /1.,0.,0.,0.,-1.,0.,0.,0.,1./ + & ! IC2Y + DATA ((S_M(I,J,36), J=1,3), I=1,3) /1.,0.,0.,0.,1.,0.,0.,0.,-1./ + & ! IC2Z + DATA ((S_M(I,J,37), J=1,3), I=1,3) /0.,0.,-1.,-1.,0.,0.,0.,-1., + &0./ ! IC3l + DATA ((S_M(I,J,38), J=1,3), I=1,3)/0.,1.,0.,0.,0.,-1.,1.,0.,0./ + & ! IC3m + DATA ((S_M(I,J,39), J=1,3), I=1,3) /0.,0.,1.,-1.,0.,0.,0.,1.,0./ + & ! IC3n + DATA ((S_M(I,J,40), J=1,3), I=1,3) /0.,1.,0.,0.,0.,1.,-1.,0.,0./ + & ! IC3o + DATA ((S_M(I,J,41), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,-1.,-1.,0.,0. + &/ ! IC3l2 + DATA ((S_M(I,J,42), J=1,3), I=1,3) /0.,0.,1.,1.,0.,0.,0.,-1.,0./ + & ! IC3m2 + DATA ((S_M(I,J,43), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,1.,1.,0.,0./ + & ! IC3n2 + DATA ((S_M(I,J,44), J=1,3), I=1,3) /0.,0.,-1.,1.,0.,0.,0.,1.,0./ + & ! IC3o2 + DATA ((S_M(I,J,45), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,1.,0.,-1.,0./ + & ! IC4X + DATA ((S_M(I,J,46), J=1,3), I=1,3) /0.,0.,-1.,0.,-1.,0.,1.,0.,0./ + & ! IC4Y + DATA ((S_M(I,J,47), J=1,3), I=1,3) /0.,1.,0.,-1.,0.,0.,0.,0.,-1./ + & ! IC4Z + DATA ((S_M(I,J,48), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,-1.,0.,1.,0./ + & ! IC4X3 + DATA ((S_M(I,J,49), J=1,3), I=1,3) /0.,0.,1.,0.,-1.,0.,-1.,0.,0./ + & ! IC4Y3 + DATA ((S_M(I,J,50), J=1,3), I=1,3) /0.,-1.,0.,1.,0.,0.,0.,0.,-1./ + & ! IC4Z3 + DATA ((S_M(I,J,51), J=1,3), I=1,3) /0.,-1.,0.,-1.,0.,0.,0.,0.,1./ + & ! IC2a + DATA ((S_M(I,J,52), J=1,3), I=1,3) /0.,1.,0.,1.,0.,0.,0.,0.,1./ + & ! IC2b + DATA ((S_M(I,J,53), J=1,3), I=1,3) /0.,0.,-1.,0.,1.,0.,-1.,0.,0./ + & ! IC2c + DATA ((S_M(I,J,54), J=1,3), I=1,3) /0.,0.,1.,0.,1.,0.,1.,0.,0./ + & ! IC2d + DATA ((S_M(I,J,55), J=1,3), I=1,3) /1.,0.,0.,0.,0.,1.,0.,1.,0./ + & ! IC2e + DATA ((S_M(I,J,56), J=1,3), I=1,3) /1.,0.,0.,0.,0.,-1.,0.,-1.,0./ + & ! IC2f +C +C Matrices for the roto-inversions of the group D6h +C + DATA ((S_M(I,J,57), J=1,3), I=1,3) /0.5,0.866025,0.,-0.866025,0. + &5,0.,0.,0.,-1./ ! IC3Z + DATA ((S_M(I,J,58), J=1,3), I=1,3) /0.5,-0.866025,0.,0.866025,0. + &5,0.,0.,0.,-1./ ! IC3Z2 + DATA ((S_M(I,J,59), J=1,3), I=1,3) /-0.5,0.866025,0.,-0.866025,- + &0.5,0.,0.,0.,-1./ ! IC6Z + DATA ((S_M(I,J,60), J=1,3), I=1,3) /-0.5,-0.866025,0.,0.866025,- + &0.5,0.,0.,0.,-1./ ! IC6Z5 + DATA ((S_M(I,J,61), J=1,3), I=1,3) /0.5,0.866025,0.,0.866025,-0. + &5,0.,0.,0.,1./ ! IC2A + DATA ((S_M(I,J,62), J=1,3), I=1,3)/0.5,-0.866025,0.,-0.866025,-0. + &5,0.,0.,0.,1./ ! IC2B + DATA ((S_M(I,J,63), J=1,3), I=1,3) /-0.5,0.866025,0.,0.866025,0. + &5,0.,0.,0.,1./ ! IC2C + DATA ((S_M(I,J,64), J=1,3), I=1,3) /-0.5,-0.866025,0.,-0.866025, + &0.5,0.,0.,0.,1./ ! IC2D +C +C For a given symmetry operation S, IZ can have three values : +C +C IZ = 1 ----> delta_{L, L'} in S_{L L'} +C IZ = 0 ----> delta_{l, l'} only in S_{L L'} +C IZ = -1 ----> delta_{L,-L'} in S_{L L'} +C + IZ = (/1,-1,-1,1,0,0,0,0,0,0,0,0,0,0,1,0,0,1,-1,-1,0,0,0,0,1,1, + &1,1,-1,-1,-1,-1,1,-1,-1,1,0,0,0,0,0,0,0,0,0,0,1,0,0,1,-1,-1,0,0, + &0,0,1,1,1,1,-1,-1,-1,-1/) +C +C For a given symmetry operation S, S_{L L'} is proportional to +C ZL**L and ZM1**M (and ZM2**M' if IZ=0) +C + ZL = (/1.,-1.,-1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1., + &-1.,-1.,1.,1.,1.,1.,1.,1.,1.,1.,-1.,-1.,-1.,-1.,-1.,1.,1.,-1.,-1. + &,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,1.,1.,-1.,- + &1.,-1.,-1.,-1.,-1.,-1.,-1.,1.,1.,1.,1./) +C + ZM1 = (/ONEC,ONEC,ONEC_,ONEC_,ONEC,IC_,ONEC_,IC,IC_,ONEC_,IC, + &ONEC,IC,ONEC,IC_,IC_,ONEC_,IC,IC_,IC,ONEC,ONEC_,IC,IC_,JC4,JC2, + &JC5,JC1,JC5_,JC1_,JC4_,JC2_,ONEC,ONEC,ONEC_,ONEC_,ONEC,IC_,ONEC_, + &IC,IC_,ONEC_,IC,ONEC,IC,ONEC,IC_,IC_,ONEC_,IC,IC_,IC,ONEC,ONEC_, + &IC,IC_,JC4,JC2,JC5,JC1,JC5_,JC1_,JC4_,JC2_/) + ZM2 = (/ONEC,ONEC,ONEC,ONEC,IC_,ONEC,IC,ONEC_,ONEC_,IC_,ONEC, + &IC,IC_,ONEC,ONEC,IC,ONEC_,ONEC,ONEC,ONEC,ONEC_,ONEC,IC,IC_,ONEC, + &ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,IC_,ONEC, + &IC,ONEC_,ONEC_,IC_,ONEC,IC,IC_,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC, + &ONEC,ONEC_,ONEC,IC,IC_,ONEC,ONEC,IC,ONEC_,ONEC,ONEC,ONEC,ONEC/) +C +C Name of the crystallographic point-groups +C + DATA NAME_G /'---', + & ' C1',' Ci',' C2','C1h','C2h',' D2','C2v','D2h', + & ' C4',' S4','C4h',' D4','C4v','D2d','D4h',' C3', + & 'C3i',' D3','C3v','D3d',' C6','C3h','C6h',' D6', + & 'C6v','D3h','D6h',' T',' Th',' Td',' O',' Oh'/ +C +C Content of the crystallographic point-groups : CONT_G(JROT,JGROUP) +C +C In some cases, two contents are given. They correspond to a rotation of +C the x and y axes about 0z by pi/4 in the cube (D2,C2v,D2h,D2d) +C or pi/6 in the hexagon (D3,C3v,D3d,D3h). In this case, x and y +C are respectively transformed into a and b in the first case, +C and D and A in the second. The cube is invariant by any pi/2 +C rotation and the hexagon by any pi/3 rotation about 0z. +C +C + DATA (CONT_G(I,1), I=1,48) /1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0/ ! C1 + DATA (CONT_G(I,2), I=1,48) /1,33,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0/ ! Ci + DATA (CONT_G(I,3), I=1,48) /1,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! C2 + DATA (CONT_G(I,4), I=1,48) /1,36,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! C1h + DATA (CONT_G(I,5), I=1,48) /1,4,33,36,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! C2h + DATA (CONT_G(I,6), I=1,48) /1,2,3,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,19,20/ + & ! D2 + DATA (CONT_G(I,7), I=1,48) /1,4,34,35,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,51,52/ + & ! C2v + DATA (CONT_G(I,8), I=1,48) /1,2,3,4,33,34,35,36,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,19,20,33,36, + &51,52/ ! D2h + DATA (CONT_G(I,9), I=1,48) /1,4,15,18,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! C4 + DATA (CONT_G(I,10), I=1,48)/1,4,47,50,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! S4 + DATA (CONT_G(I,11), I=1,48)/1,4,15,18,33,36,47,50,0,0,0,0,0,0, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0/ ! C4h + DATA (CONT_G(I,12), I=1,48)/1,2,3,4,15,18,19,20,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! D4 + DATA (CONT_G(I,13), I=1,48)/1,4,15,18,34,35,51,52,0,0,0,0,0,0, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0/ ! C4v + DATA (CONT_G(I,14), I=1,48)/1,2,3,4,47,50,51,52,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,19,20,34,35, + &47,50/ ! D2d + DATA (CONT_G(I,15), I=1,48)/1,2,3,4,15,18,19,20,33,34,35,36,47, + * 50,51,52,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0/ ! D4h + DATA (CONT_G(I,16), I=1,48)/1,25,26,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! C3 + DATA (CONT_G(I,17), I=1,48)/1,25,26,33,57,58,0,0,0,0,0,0,0,0, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0/ ! C3i + DATA (CONT_G(I,18), I=1,48)/1,3,25,26,31,32,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,25,26,29, + &30/ ! D3 + DATA (CONT_G(I,19), I=1,48)/1,25,26,34,61,62,0,0,0,0,0,0,0,0, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,25,26, + & 35,63,64/ ! C3v + DATA (CONT_G(I,20), I=1,48)/1,3,25,26,31,32,33,35,57,58,63,64, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,25,26,29,30, + & 33,34,57,58,61,62/ ! D3d + DATA (CONT_G(I,21), I=1,48)/1,4,25,26,27,28,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! C6 + DATA (CONT_G(I,22), I=1,48)/1,25,26,36,59,60,0,0,0,0,0,0,0,0, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0/ ! C3h + DATA (CONT_G(I,23), I=1,48)/1,4,25,26,27,28,33,36,57,58,59,60, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0/ ! C6h + DATA (CONT_G(I,24), I=1,48)/1,2,3,4,25,26,27,28,29,30,31,32,0, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0/ ! D6 + DATA (CONT_G(I,25), I=1,48)/1,4,25,26,27,28,34,35,61,62,63,64, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0/ ! C6v + DATA (CONT_G(I,26), I=1,48)/1,3,25,26,31,32,34,36,59,60,61,62, + * 0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,25,26,29,30, + & 35,36,59,60,63,64/ ! D3h + DATA (CONT_G(I,27), I=1,48)/1,2,3,4,25,26,27,28,29,30,31,32,33, + * 34,35,36,57,58,59,60, + & 61,62,63,64,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0,0/ ! D6h + DATA (CONT_G(I,28), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + & ! T + DATA (CONT_G(I,29), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,33,34, + * 35,36,37,38,39,40,41, + & 42,43,44,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0/ ! Th + DATA (CONT_G(I,30), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,45,46, + * 47,48,49,50,51,52,53, + & 54,55,56,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0/ ! Td + DATA (CONT_G(I,31), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,13,14, + * 15,16,17,18,19,20,21, + & 22,23,24,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + & 0,0,0,0,0,0,0/ ! O + DATA (CONT_G(I,32), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,13,14, + * 15,16,17,18,19,20,21,22,23,24,33, + & 34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49, + & 50,51,52,53,54,55,56/ ! Oh +C +C Size of the point-groups +C + DATA SIZE_G /1,2,2,2,4,4,4,8,4,4,8,8,8,8,16,3,6,6,6,12,6,6,12,12, + &12,12,24,12,24,24,24,48/ +C +C Groups containing the space inversion I +C + DATA I_33 /0,1,0,0,1,0,0,1,0,0,1,0,0,0,1,0,1,0,0,1,0,0,1,0,0,0, + &1,0,1,0,0,1/ +C +C Name of the symmetry operations +C +C Note : the three-fold rotation axes alpha, beta, gamma and delta +C of the cubic groups have been coded respectively +C l, m, n and o +C + DATA NAME_S /' E',' C2X',' C2Y',' C2Z',' C3l',' C3m', + & ' C3n',' C3o',' C3l2',' C3m2',' C3n2',' C3o2', + & ' C4X',' C4Y',' C4Z',' C4X3',' C4Y3',' C4Z3', + & ' C2a',' C2b',' C2c',' C2d',' C2e',' C2f', + & ' C3Z',' C3Z2',' C6Z',' C6Z5',' C2A',' C2B', + & ' C2C',' C2D',' I',' IC2X',' IC2Y',' IC2Z', + & ' IC3l',' IC3m',' IC3n',' IC3o','IC3l2','IC3m2', + & 'IC3n2','IC3o2',' IC4X',' IC4Y',' IC4Z','IC4X3', + & 'IC4Y3','IC4Z3',' IC2a',' IC2b',' IC2c',' IC2d', + & ' IC2e',' IC2f',' IC3Z','IC3Z2',' IC6Z','IC6Z5', + & ' IC2A',' IC2B',' IC2C',' IC2D'/ +C + DATA ANG_ROT /'PI/4','PI/2','PI/6','PI/3'/ +C + DATA AT_ADD /' ','<--- NEW'/ +C + DATA SMALL /0.001/ +C + PRINT 444 +C + DO JS=1,64 + IS_WRONG(JS)=0 + ENDDO + IROT=0 + NAT_NEW=NATCLU +C + IF(I_GR.EQ.2) THEN + I_SB=1 + ELSE + I_SB=0 + ENDIF +C + 111 DO JAT=1,NAT_NEW + NEQAT(JAT)=0 + ENDDO +C +C Calculates the distance between the atoms and all +C their neighbors +C + DIST0(1)=0. + DO JAT1=1,NAT_NEW + INEW_AT(JAT1)=0 + NABOR=0 + DO JAT2=1,NAT_NEW + IF(JAT1.EQ.JAT2) GO TO 10 + NABOR=NABOR+1 + NBRZ(NABOR,JAT1)=NZAT(JAT2) + RAB=SQRT((COORD(1,JAT1)-COORD(1,JAT2))*(COORD(1,JAT1)- + & COORD(1,JAT2))+(COORD(2,JAT1)-COORD(2,JAT2))*(COORD(2,JAT1)- + & COORD(2,JAT2))+(COORD(3,JAT1)-COORD(3,JAT2))*(COORD(3,JAT1)- + & COORD(3,JAT2))) + IF((JAT2.GT.JAT1).AND.(RAB.LT.SMALL)) GOTO 895 + IF(JAT1.EQ.1) DIST0(JAT2)=RAB + DNBR(NABOR,JAT1)=RAB + 10 CONTINUE + ENDDO + ENDDO +C +C Generates the set of class distances to the absorber +C + CALL ORDRE(NAT_NEW,DIST0,NDIST,DIST1) +C +C Determines the prototypical and equivalent atoms: +C two atoms are equivalent if they have the same type, +C they are at the same distance from the emitter +C and they have the same geometrical environment. +C This part of the routine has been adapted from +C R. Gunnella and C. R. Natoli. +C + JTYP_C_M=0 + NEQAT_M=0 + JTYP=2 + NASHUFF=2 + NABORS=NAT_NEW-1 +C + NATYP(1)=1 + NQAT(1)=1 + NCORR(1,1)=1 + NEQAT(1)=1 + NCHTYP(1)=1 + I_Z(1,1)=1 + Z_L(1,1)=1. + Z_M1(1,1)=ONEC + Z_M2(1,1)=ONEC + SYM_AT(1,1)=COORD(1,1) + SYM_AT(2,1)=COORD(2,1) + SYM_AT(3,1)=COORD(3,1) + NZ_AT(1)=NZAT(1) + CHEM(1)=CHEM_OLD(1) + INEW_AT(1)=0 + N_NEW_OLD(1)=1 +C + NATYP(2)=1 + NQAT(2)=2 + NCORR(1,2)=2 + NEQAT(2)=2 + NCHTYP(2)=2 + I_Z(1,2)=1 + Z_L(1,2)=1. + Z_M1(1,2)=ONEC + Z_M2(1,2)=ONEC + SYM_AT(1,2)=COORD(1,2) + SYM_AT(2,2)=COORD(2,2) + SYM_AT(3,2)=COORD(3,2) + NZ_AT(2)=NZAT(2) + CHEM(2)=CHEM_OLD(2) + INEW_AT(2)=0 + N_NEW_OLD(2)=2 +C + JNUM=0 + DO JAT1=2,NAT_NEW + IF(JNUM.GT.NEQAT_M) THEN + NEQAT_M=JNUM + JTYP_C_M=JTYP + ENDIF + JNUM=1 + NA1P1=JAT1+1 + IF(NA1P1.GT.NAT_NEW) GO TO 32 + DO JAT2=NA1P1,NAT_NEW + IF(NZAT(JAT1).NE.NZAT(JAT2)) GO TO 30 + N1=JAT1-1 + N2=JAT2-1 + IF(ABS(DNBR(N1,1)-DNBR(N2,1)).GT.SMALL) GOTO 30 + DO NAB=1,NABORS + IUSED(NAB)=0 + ENDDO + DO NABOR1=1,NABORS + NZT=NBRZ(NABOR1,JAT1) + RABT=DNBR(NABOR1,JAT1) + EQUIV=.FALSE. + DO NABOR2=1,NABORS + IF(IUSED(NABOR2).EQ.1) GOTO 22 + IF(NBRZ(NABOR2,JAT2).NE.NZT) GOTO 22 + IF(ABS(DNBR(NABOR2,JAT2)-RABT).GT.SMALL) GOTO 22 + EQUIV=.TRUE. + IUSED(NABOR2)=1 + GOTO 23 + 22 CONTINUE + ENDDO + 23 IF(.NOT.EQUIV) GO TO 30 + ENDDO + IF(NEQAT(JAT1).EQ.0) THEN + JTYP=JTYP+1 + NASHUFF=NASHUFF+1 + NCORR(JNUM,JTYP)=NASHUFF + I_Z(JNUM,JTYP)=1 + Z_L(JNUM,JTYP)=1. + Z_M1(JNUM,JTYP)=ONEC + Z_M2(JNUM,JTYP)=ONEC + SYM_AT(1,NASHUFF)=COORD(1,JAT1) + SYM_AT(2,NASHUFF)=COORD(2,JAT1) + SYM_AT(3,NASHUFF)=COORD(3,JAT1) + N_NEW_OLD(NASHUFF)=JAT1 + NEQAT(JAT1)=JTYP + NCHTYP(JTYP)=NTYP(JAT1) + NZ_AT(NASHUFF)=NZAT(JAT1) + CHEM(NASHUFF)=CHEM_OLD(JAT1) + NQAT(NASHUFF)=JTYP + IF(JAT1.GT.NATCLU) INEW_AT(NASHUFF)=1 + ENDIF + IF(NEQAT(JAT2).EQ.0) THEN + JNUM=JNUM+1 + NATYP(JTYP)=JNUM + NASHUFF=NASHUFF+1 + NCORR(JNUM,JTYP)=NASHUFF + SYM_AT(1,NASHUFF)=COORD(1,JAT2) + SYM_AT(2,NASHUFF)=COORD(2,JAT2) + SYM_AT(3,NASHUFF)=COORD(3,JAT2) + N_NEW_OLD(NASHUFF)=JAT2 + NEQAT(JAT2)=JTYP + NCHTYP(JTYP)=NTYP(JAT2) + NZ_AT(NASHUFF)=NZAT(JAT2) + CHEM(NASHUFF)=CHEM_OLD(JAT2) + NQAT(NASHUFF)=JTYP + IF(JAT2.GT.NATCLU) INEW_AT(NASHUFF)=1 + ENDIF +30 CONTINUE + ENDDO +32 IF(NEQAT(JAT1).EQ.0) THEN + JTYP=JTYP+1 + NATYP(JTYP)=JNUM + NASHUFF=NASHUFF+1 + NCORR(JNUM,JTYP)=NASHUFF + I_Z(JNUM,JTYP)=1 + Z_L(JNUM,JTYP)=1. + Z_M1(JNUM,JTYP)=ONEC + Z_M2(JNUM,JTYP)=ONEC + SYM_AT(1,NASHUFF)=COORD(1,JAT1) + SYM_AT(2,NASHUFF)=COORD(2,JAT1) + SYM_AT(3,NASHUFF)=COORD(3,JAT1) + N_NEW_OLD(NASHUFF)=JAT1 + NEQAT(JAT1)=JTYP + NCHTYP(JTYP)=NTYP(JAT1) + NZ_AT(NASHUFF)=NZAT(JAT1) + CHEM(NASHUFF)=CHEM_OLD(JAT1) + NQAT(NASHUFF)=JTYP + IF(JAT1.GT.NATCLU) INEW_AT(NASHUFF)=1 + ENDIF + CONTINUE + ENDDO + N_PROT=JTYP +C +C Stop if the maximal number of prototypical and equivalent +C atoms are not correctly dimensionned +C + IF(N_PROT.GT.NATP_M) THEN + WRITE(IUO1,897) N_PROT + STOP + ENDIF + IF(NEQAT_M.GT.NAT_EQ_M) THEN + WRITE(IUO1,898) NEQAT_M + STOP + ENDIF +C + DO JAT=1,NAT_NEW + COORD1(1,JAT)=SYM_AT(1,JAT)-SYM_AT(1,1) + COORD1(2,JAT)=SYM_AT(2,JAT)-SYM_AT(2,1) + COORD1(3,JAT)=SYM_AT(3,JAT)-SYM_AT(3,1) + ENDDO +C +C Test of all symmetry operations for the largest +C symmetry class +C + NROTCLUS=0 + 556 NSYM_M(1)=1 + NSIZE_C=1 + DO JROT=2,64 + DO JNUM1=1,NEQAT_M + JAT1=NCORR(JNUM1,JTYP_C_M) + MATCH=.FALSE. + SYM_AT1(1,JAT1)=S_M(1,1,JROT)*COORD1(1,JAT1)+S_M(1,2, + & JROT)*COORD1(2,JAT1)+S_M(1,3,JROT)*COORD1(3,JAT1) + SYM_AT1(2,JAT1)=S_M(2,1,JROT)*COORD1(1,JAT1)+S_M(2,2, + & JROT)*COORD1(2,JAT1)+S_M(2,3,JROT)*COORD1(3,JAT1) + SYM_AT1(3,JAT1)=S_M(3,1,JROT)*COORD1(1,JAT1)+S_M(3,2, + & JROT)*COORD1(2,JAT1)+S_M(3,3,JROT)*COORD1(3,JAT1) + DO JNUM2=1,NEQAT_M + JAT2=NCORR(JNUM2,JTYP_C_M) + AD=ABS(COORD1(1,JAT2)-SYM_AT1(1,JAT1))+ABS(COORD1(2, + & JAT2)-SYM_AT1(2,JAT1))+ABS(COORD1(3,JAT2)-SYM_AT1(3,JAT1)) + IF(AD.LT.SMALL) THEN + MATCH=.TRUE. + ENDIF + ENDDO + IF(.NOT.MATCH) GOTO 333 + ENDDO + NSIZE_C=NSIZE_C+1 + NSYM_M(NSIZE_C)=JROT + 333 CONTINUE + ENDDO +C +C Test on all classes of the symmetry operations that work +C for the largest class +C + NSYM_G(1)=1 + NSIZE_GR=1 + I_THREE=0 + I_INCRG=0 + I_INVG=0 + DO JSYM=2,NSIZE_C + JROT=NSYM_M(JSYM) + DO JTYP=1,N_PROT + NEQATS=NATYP(JTYP) + DO JNUM1=1,NEQATS + JAT1=NCORR(JNUM1,JTYP) + MATCH=.FALSE. + SYM_AT1(1,JAT1)=S_M(1,1,JROT)*COORD1(1,JAT1)+S_M(1,2, + & JROT)*COORD1(2,JAT1)+S_M(1,3,JROT)*COORD1(3,JAT1) + SYM_AT1(2,JAT1)=S_M(2,1,JROT)*COORD1(1,JAT1)+S_M(2,2, + & JROT)*COORD1(2,JAT1)+S_M(2,3,JROT)*COORD1(3,JAT1) + SYM_AT1(3,JAT1)=S_M(3,1,JROT)*COORD1(1,JAT1)+S_M(3,2, + & JROT)*COORD1(2,JAT1)+S_M(3,3,JROT)*COORD1(3,JAT1) + DO JNUM2=1,NEQATS + JAT2=NCORR(JNUM2,JTYP) + AD=ABS(COORD1(1,JAT2)-SYM_AT1(1,JAT1))+ABS( + & COORD1(2,JAT2)-SYM_AT1(2,JAT1))+ABS(COORD1(3,JAT2)- + & SYM_AT1(3,JAT1)) + IF(AD.LT.SMALL) THEN + MATCH=.TRUE. + ENDIF + ENDDO + IF(.NOT.MATCH) GOTO 335 + ENDDO + ENDDO + IF(MATCH) THEN + NSIZE_GR=NSIZE_GR+1 + NSYM_G(NSIZE_GR)=JROT + IF(JROT.EQ.25) I_THREE=1 + IF(JROT.EQ.33) I_INVG=1 + ENDIF + 335 CONTINUE + ENDDO + IF(NSIZE_GR.GT.48) GOTO 998 +C +C Set up of the parameter used to check if a larger +C group containing the inversion I can be constructed +C if the inversion is physically acceptable as an approximation +C + IF((I_GR.EQ.2).AND.(I_INVG.EQ.0)) THEN + IF(I_INV.EQ.1) THEN + I_INCRG=1 + ENDIF + ENDIF +C + IF(NROTCLUS.LE.2) THEN + IF(NSIZE_GR.GT.1) THEN + WRITE(IUO1,699) NSIZE_GR + ELSE + WRITE(IUO1,698) NSIZE_GR + ENDIF + IF(NSIZE_GR.EQ.1) THEN + WRITE(IUO1,705) NAME_S(NSYM_G(1)) + ELSEIF(NSIZE_GR.EQ.2) THEN + WRITE(IUO1,704) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)) + ELSEIF(NSIZE_GR.EQ.3) THEN + WRITE(IUO1,703) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)), + & NAME_S(NSYM_G(3)) + ELSEIF(NSIZE_GR.EQ.4) THEN + WRITE(IUO1,702) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)), + & NAME_S(NSYM_G(3)),NAME_S(NSYM_G(4)) + ELSEIF(NSIZE_GR.EQ.6) THEN + WRITE(IUO1,701) (NAME_S(NSYM_G(JROT)), JROT=1,6) + ELSEIF(NSIZE_GR.GE.8) THEN + WRITE(IUO1,700) (NAME_S(NSYM_G(JROT)), JROT=1,NSIZE_GR) + ENDIF + IF(NROTCLUS.GT.0) THEN + IF(I_THREE.EQ.0) THEN + WRITE(IUO1,706) ANG_ROT(NROTCLUS) + ELSE + WRITE(IUO1,706) ANG_ROT(NROTCLUS+2) + ENDIF + ENDIF + ENDIF +C +C Finding the cluster's symmetry group +C + 555 JGROUP=0 + IF(NSIZE_GR.EQ.1) THEN + JGROUP=1 + ELSEIF(NSIZE_GR.EQ.2) THEN + IF(NSYM_G(2).EQ.33) THEN + JGROUP=2 + ELSEIF(NSYM_G(2).EQ.4) THEN + JGROUP=3 + ELSEIF(NSYM_G(2).EQ.36) THEN + JGROUP=4 + ENDIF + ELSEIF(NSIZE_GR.EQ.3) THEN + JGROUP=16 + ELSEIF(NSIZE_GR.EQ.4) THEN + IF(NSYM_G(3).EQ.33) THEN + JGROUP=5 + ELSEIF((NSYM_G(3).EQ.3).OR.(NSYM_G(3).EQ.19)) THEN + JGROUP=6 + ELSEIF((NSYM_G(3).EQ.34).OR.(NSYM_G(3).EQ.51)) THEN + JGROUP=7 + ELSEIF(NSYM_G(3).EQ.15) THEN + JGROUP=9 + ELSEIF(NSYM_G(3).EQ.47) THEN + JGROUP=10 + ENDIF + ELSEIF(NSIZE_GR.EQ.6) THEN + IF(NSYM_G(4).EQ.26) THEN + JGROUP=18 + ELSEIF((NSYM_G(4).EQ.34).OR.(NSYM_G(4).EQ.35)) THEN + JGROUP=19 + ELSEIF(NSYM_G(4).EQ.33) THEN + JGROUP=17 + ELSEIF(NSYM_G(4).EQ.26) THEN + JGROUP=21 + ELSEIF(NSYM_G(4).EQ.36) THEN + JGROUP=22 + ENDIF + ELSEIF(NSIZE_GR.EQ.8) THEN + IF(NSYM_G(4).EQ.33) THEN + IF(NSYM_G(8).EQ.50) THEN + JGROUP=11 + ELSE + JGROUP=8 + ENDIF + ELSE + IF(NSYM_G(5).EQ.15) THEN + JGROUP=12 + ELSE + IF(NSYM_G(3).EQ.15) THEN + JGROUP=13 + ELSEIF((NSYM_G(3).EQ.3).OR.(NSYM_G(3).EQ.19)) THEN + JGROUP=14 + ENDIF + ENDIF + ENDIF + ELSEIF(NSIZE_GR.EQ.12) THEN + IF(NSYM_G(5).EQ.5) THEN + JGROUP=28 + ELSEIF(NSYM_G(7).EQ.33) THEN + IF(NSYM_G(12).EQ.60) THEN + JGROUP=23 + ELSE + JGROUP=20 + ENDIF + ELSE + IF(NSYM_G(3).EQ.3) THEN + JGROUP=24 + ELSEIF(NSYM_G(9).EQ.59) THEN + JGROUP=26 + ELSEIF(NSYM_G(5).EQ.27) THEN + JGROUP=25 + ENDIF + ENDIF + ELSEIF(NSIZE_GR.EQ.16) THEN + JGROUP=15 + ELSEIF(NSIZE_GR.EQ.24) THEN + IF(NSYM_G(17).EQ.57) THEN + JGROUP=27 + ELSEIF(NSYM_G(17).EQ.17) THEN + JGROUP=31 + ELSEIF(NSYM_G(17).EQ.49) THEN + JGROUP=30 + ELSEIF(NSYM_G(17).EQ.37) THEN + JGROUP=29 + ENDIF + ELSEIF(NSIZE_GR.EQ.48) THEN + JGROUP=32 + ENDIF +c IF((JGROUP.GT.0).AND.(NEQAT_M.LE.NSIZE_GR)) THEN + IF(JGROUP.GT.0) THEN + WRITE(IUO1,886) + WRITE(IUO1,880) NAME_G(JGROUP) + ELSE +C +C If no group is found, the cluster is rotated by pi/4 ,or pi/6 for +C hexagonal structures (i. e. when C3z=25 is present), around Oz +C at most twice to account for possible misnaming of the Ox axis. +C Then, the search for the point-group is restarted. +C + IF(NROTCLUS.LT.2) THEN + NROTCLUS=NROTCLUS+1 + DO JPROT=1,N_PROT + NEQATS=NATYP(JPROT) + DO JNUM=1,NEQATS + JAT=NCORR(JNUM,JPROT) + X=COORD1(1,JAT) + Y=COORD1(2,JAT) + IF(I_THREE.EQ.0) THEN + COORD1(1,JAT)=0.707107*(X-Y) + COORD1(2,JAT)=0.707107*(X+Y) + ELSE + COORD1(1,JAT)=0.866025*X-0.500000*Y + COORD1(2,JAT)=0.500000*X+0.866025*Y + ENDIF + COORD1(3,JAT)=COORD1(3,JAT) + SYM_AT(1,JAT)=COORD1(1,JAT)+SYM_AT(1,1) + SYM_AT(2,JAT)=COORD1(2,JAT)+SYM_AT(2,1) + SYM_AT(3,JAT)=COORD1(3,JAT)+SYM_AT(3,1) + ENDDO + ENDDO + GOTO 556 + ELSE + IF((JGROUP.EQ.0).AND.(NROTCLUS.EQ.2)) WRITE(IUO1,881) + ENDIF + ENDIF + IF(JGROUP.GE.28) WRITE(IUO1,697) + IF((JGROUP.GT.0) .AND.(I_INCRG.EQ.1)) WRITE(IUO1,722) +C +C Recovery of the original cluster when no group has been found +C + IF((NROTCLUS.EQ.2).AND.(JGROUP.EQ.0)) THEN + DO JPROT=1,N_PROT + NEQATS=NATYP(JPROT) + DO JNUM=1,NEQATS + JAT=NCORR(JNUM,JPROT) + X=COORD1(1,JAT) + Y=COORD1(2,JAT) + IF(I_THREE.EQ.0) THEN + COORD1(1,JAT)=Y + COORD1(2,JAT)=-X + ELSE + COORD1(1,JAT)=0.500000*X+0.866025*Y + COORD1(2,JAT)=-0.866025*X+0.500000*Y + ENDIF + COORD1(3,JAT)=COORD1(3,JAT) + SYM_AT(1,JAT)=COORD1(1,JAT)+SYM_AT(1,1) + SYM_AT(2,JAT)=COORD1(2,JAT)+SYM_AT(2,1) + SYM_AT(3,JAT)=COORD1(3,JAT)+SYM_AT(3,1) + ENDDO + ENDDO + NROTCLUS=NROTCLUS+1 + GOTO 556 + ENDIF +C +C If still no group is found, or if the group can be augmented by +C the inversion (as an approximation), check of the other symmetries that +C should be present to account for group properties (i. e. those +C obtained by multiplication of those that are effectively present) +C + IF((JGROUP.EQ.0).OR.(I_INCRG.EQ.1)) THEN + IF(I_INCRG.EQ.1) THEN + NSIZE_GR=NSIZE_GR+1 + NSYM_G(NSIZE_GR)=33 + ENDIF + NSIZE_RE=NSIZE_GR + 553 I_NEW=0 + DO JSYM1=2,NSIZE_RE + JS1=NSYM_G(JSYM1) + DO JSYM2=JSYM1,NSIZE_RE + JS2=NSYM_G(JSYM2) + DO I=1,3 + DO J=1,3 + S_MUL(I,J)=0. + DO K=1,3 + S_MUL(I,J)=S_MUL(I,J)+S_M(I,K,JS1)*S_M(K, + & J,JS2) + ENDDO + ENDDO + ENDDO + I_EQ=0 + DO JSYM3=1,NSIZE_RE + JS3=NSYM_G(JSYM3) + I_OLD=0 + DO I=1,3 + DO J=1,3 + S1=S_MUL(I,J) + S2=S_M(I,J,JS3) + IF(ABS(S1-S2).LT.SMALL) I_OLD=I_OLD+1 + ENDDO + ENDDO + IF(I_OLD.EQ.9) I_EQ=1 + ENDDO + IF(I_EQ.EQ.0) THEN + I_NEW=I_NEW+1 + J_RE=NSIZE_GR+I_NEW + DO JS4=2,64 + I_OLD=0 + DO I=1,3 + DO J=1,3 + S1=S_MUL(I,J) + S2=S_M(I,J,JS4) + IF(ABS(S1-S2).LT.SMALL) I_OLD=I_OLD+1 + ENDDO + ENDDO + IF(I_OLD.EQ.9) THEN + NSYM_G(J_RE)=JS4 + NSIZE_RE=NSIZE_RE+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + IF(I_NEW.GT.0) GOTO 553 +C + IF(NSIZE_RE.GT.NSIZE_GR) THEN + WRITE(IUO1,696) NSIZE_RE + IF(NSIZE_RE.EQ.2) THEN + WRITE(IUO1,704) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)) + ELSEIF(NSIZE_RE.EQ.3) THEN + WRITE(IUO1,703) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)), + & NAME_S(NSYM_G(3)) + ELSEIF(NSIZE_RE.EQ.4) THEN + WRITE(IUO1,702) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)), + & NAME_S(NSYM_G(3)),NAME_S(NSYM_G(4)) + ELSEIF(NSIZE_RE.EQ.6) THEN + WRITE(IUO1,701) (NAME_S(NSYM_G(JROT)), JROT=1,6) + ELSEIF(NSIZE_RE.GE.8) THEN + WRITE(IUO1,700) (NAME_S(NSYM_G(JROT)), JROT=1, + & NSIZE_RE) + ENDIF + ENDIF + ENDIF +C +C If no group has been found, it means that the cluster does not +C retain the whole symmetry of the crystal. When I_GR = 1 or 2, +C the largest group consistent with the symmetry operations +C found is sought. Then a new cluster is built to support +C all the symmetries of this group. +C + I_BACK=0 + IF(((JGROUP.EQ.0).OR.(I_INCRG.EQ.1)).AND.(I_GR.GE.1)) THEN +C +C Search for the different point-groups containing the NSIZE_RE +C symmetries found. If the cluster can not support the +C inversion I (I_INV=0), a test is made on the content +C of the point-groups to suppress those that contain I. +C + WRITE(IUO1,707) + WRITE(IUO1,708) +C +C Input cluster +C + NB_GR=0 + DO JG=1,32 + IF((I_INV.EQ.0).AND.(I_33(JG).EQ.1)) GOTO 223 + JS_MAX=SIZE_G(JG) + IF(JS_MAX.LT.NSIZE_RE) GOTO 223 +C + ICHECK_S=0 + DO JSYM=1,NSIZE_RE + JS_RE=NSYM_G(JSYM) +C + DO JS_GR1=1,JS_MAX + JS_NE1=CONT_G(JS_GR1,JG) + IWRONG=0 + IF(IROT.GT.0) THEN + DO JS=1,IROT + IF(JS_NE1.EQ.IS_WRONG(JS)) THEN + IWRONG=1 + ENDIF + ENDDO + ENDIF + IF(JS_NE1.EQ.JS_RE) THEN + ICHECK_S=ICHECK_S+1 + ENDIF + ENDDO +C + ENDDO +C + IF(IWRONG.EQ.1) GOTO 223 + IF(ICHECK_S.EQ.NSIZE_RE) THEN + NB_GR=NB_GR+1 + OLD_G(NB_GR)=JG + ENDIF + 223 CONTINUE +C + ENDDO + NB_GR1=NB_GR + WRITE(IUO1,709) (NAME_G(OLD_G(J)), J=1,NB_GR1) + WRITE(IUO1,710) +C +C Input cluster rotated +C + DO JG=1,32 + IF((I_INV.EQ.0).AND.(I_33(JG).EQ.1)) GOTO 225 + IOLD=0 + DO J_OLD=1,NB_GR1 + IF(OLD_G(J_OLD).EQ.JG) THEN + IOLD=IOLD+1 + ENDIF + ENDDO + IF(IOLD.NE.0) GOTO 225 + JS_MAX=SIZE_G(JG) + IF(JS_MAX.LT.NSIZE_RE) GOTO 225 +C + ICHECK_S=0 + DO JSYM=1,NSIZE_RE + JS_RE=NSYM_G(JSYM) +C + DO JS_GR1=1,JS_MAX + JS_GR2=49-JS_GR1 + JS_NE2=CONT_G(JS_GR2,JG) + IWRONG=0 + IF(IROT.GT.0) THEN + DO JS=1,IROT + IF(JS_NE2.EQ.IS_WRONG(JS)) THEN + IWRONG=1 + ENDIF + ENDDO + ENDIF + IF(JS_NE2.EQ.JS_RE) THEN + ICHECK_S=ICHECK_S+1 + ENDIF + ENDDO +C + ENDDO +C + IF(IWRONG.EQ.1) GOTO 225 + IF(ICHECK_S.EQ.NSIZE_RE) THEN + NB_GR=NB_GR+1 + OLD_G(NB_GR)=JG + ENDIF + 225 CONTINUE +C + ENDDO + IF(NB_GR1.LT.NB_GR) THEN + WRITE(IUO1,713) + WRITE(IUO1,711) (NAME_G(OLD_G(J)), J=NB_GR1+1,NB_GR) + WRITE(IUO1,712) + ENDIF + IF(I_INV.EQ.0) THEN + IF(I_GR.EQ.2) THEN + WRITE(IUO1,721) + ELSE + WRITE(IUO1,726) + ENDIF + ENDIF + CALL ORDRE2(NB_GR,OLD_G,NB_G,NEW_G) +C +C Construction of the augmented cluster consistent with the group JGROUP_M. +C Note that this group must be consistent with the original cluster. +C This is checked through 3 criteria : +C +C 1. No atom must be generated above the surface plane +C +C 2. If an atom generated by a symmetry of JGROUP_M coincides +C with one of the original cluster, it must have the same +C atomic number +C +C 3. Every new atom generated by a symmetry of JGROUP_M must +C be outside the original cluster except those meeting +C the previous criterion +C +C When one of this criteria is not satisfied, it means that the group +C JGROUP_M can not accomodate the original cluster. Hence, a smaller +C group must be looked for +C +C An extra criterion is used when I_GR = 1 : +C +C 4. No surface atom can be transformed into a bulk atom +C and likewise no bulk atom into a surface atom +C +C + JG_MIN=NEW_G(1) + I_MINUS=0 + 222 JGROUP_M=NEW_G(NB_G-I_MINUS) + IF(JGROUP_M.LT.JG_MIN) THEN + IF(I_GR.GE.1) THEN + I_GR=0 + WRITE(IUO1,723) + GOTO 111 + ELSE + WRITE(IUO1,719) + STOP + ENDIF + ENDIF + JS_M=SIZE_G(JGROUP_M) + WRITE(IUO1,714) NAME_G(JGROUP_M) + I_END=0 + IROT=0 + NAT=NAT_NEW +C + DO JS=2,JS_M + JROT=CONT_G(JS,JGROUP_M) +C + DO J_AT=2,NAT + IF(I_END.EQ.1) GOTO 224 + X_NEW=S_M(1,1,JROT)*(COORD(1,J_AT)-COORD(1,1)) + S_M( + & 1,2,JROT)*(COORD(2,J_AT)-COORD(2,1)) +S_M(1,3,JROT)*(COORD( + & 3,J_AT)-COORD(3,1)) + COORD(1,1) + Y_NEW=S_M(2,1,JROT)*(COORD(1,J_AT)-COORD(1,1)) + S_M( + & 2,2,JROT)*(COORD(2,J_AT)-COORD(2,1)) +S_M(2,3,JROT)*(COORD( + & 3,J_AT)-COORD(3,1)) + COORD(2,1) + Z_NEW=S_M(3,1,JROT)*(COORD(1,J_AT)-COORD(1,1)) + S_M( + & 3,2,JROT)*(COORD(2,J_AT)-COORD(2,1)) +S_M(3,3,JROT)*(COORD( + & 3,J_AT)-COORD(3,1)) + COORD(3,1) +C +C Check for criterion 1 +C + IF(Z_NEW.GT.VALZ_MAX) THEN + WRITE(IUO1,715) (COORD(J,J_AT), J=1,3),X_NEW, + & Y_NEW,Z_NEW + WRITE(IUO1,716) NAME_S(JROT),VALZ_MAX + IROT=IROT+1 + IS_WRONG(IROT)=JROT + ENDIF + IF(IROT.GT.0) THEN + I_END=1 + GOTO 224 + ENDIF + NZ_NEW=NZAT(J_AT) + I_OLD=0 + I_IN_OK=0 +C +C Check for criterion 2 +C + DO J_AT_P=2,NAT + D2=(X_NEW-COORD(1,J_AT_P))*(X_NEW-COORD(1,J_AT_P) + & ) + (Y_NEW-COORD(2,J_AT_P))*(Y_NEW-COORD(2,J_AT_P)) +( + & Z_NEW-COORD(3,J_AT_P))*(Z_NEW-COORD(3,J_AT_P)) + NZ_OLD=NZAT(J_AT_P) + IF(D2.LT.SMALL) THEN + I_OLD=I_OLD+1 + IF(NZ_NEW.NE.NZ_OLD) THEN + IROT=IROT+1 + IS_WRONG(IROT)=JROT + WRITE(IUO1,715) (COORD(J,J_AT), J=1,3), + & X_NEW,Y_NEW,Z_NEW + WRITE(IUO1,717) CHEM_OLD(J_AT),J_AT, + & NAME_S(JROT),CHEM_OLD(J_AT_P),J_AT_P + ELSE + I_IN_OK=1 + ENDIF + ENDIF + ENDDO + IF(I_IN_OK.EQ.1) GOTO 226 +C +C Check for criterion 3 +C + DO JPLAN=1,NPLAN + IF(ABS(Z_NEW-Z_PLAN(JPLAN)).LT.SMALL) THEN + IF(X_NEW.GT.X_MIN(JPLAN)) THEN + IF(X_NEW.LT.X_MAX(JPLAN)) THEN + IF(Y_NEW.GT.Y_MIN(JPLAN)) THEN + IF(Y_NEW.LT.Y_MAX(JPLAN)) THEN + IROT=IROT+1 + IS_WRONG(IROT)=JROT + WRITE(IUO1,715) (COORD(J, + & J_AT), J=1,3),X_NEW,Y_NEW,Z_NEW + WRITE(IUO1,720) NAME_S(JROT) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO +C +C Check for criterion 4 +C + IF(I_SB.EQ.0) THEN + Z_DIF=ABS(Z_NEW-COORD(3,J_AT)) + Z_TYP=ABS(Z_NEW-VALZ_MAX) + IF(Z_DIF.GT.SMALL) THEN + WRITE(IUO1,715) (COORD(J,J_AT), J=1,3),X_NEW, + & Y_NEW,Z_NEW + IF(Z_TYP.LT.SMALL) THEN + WRITE(IUO1,725) NAME_S(JROT),I_GR + ELSE + WRITE(IUO1,724) NAME_S(JROT),I_GR + ENDIF + IROT=IROT+1 + IS_WRONG(IROT)=JROT + ENDIF + IF(IROT.GT.0) THEN + I_END=1 + GOTO 224 + ENDIF + ENDIF +C + 226 IF(I_OLD.EQ.0) THEN + NAT=NAT+1 + IF(NAT.GT.NATCLU_M) THEN + WRITE(IUO1,718) NAT + STOP + ENDIF + COORD(1,NAT)=X_NEW + COORD(2,NAT)=Y_NEW + COORD(3,NAT)=Z_NEW + VALZ(NAT)=Z_NEW + CHEM_OLD(NAT)=CHEM_OLD(J_AT) + NZAT(NAT)=NZAT(J_AT) + NTYP(NAT)=NTYP(J_AT) + ENDIF + 224 CONTINUE + ENDDO +C + ENDDO +C + I_BACK=1 + IF(IROT.GT.0) THEN + I_MINUS=I_MINUS+1 + GOTO 222 + ENDIF + ENDIF + IF(I_BACK.EQ.1) THEN + NAT_NEW=NAT + GOTO 111 + ENDIF +C +C Writes the classes of atoms by increasing distance +C + WRITE(IUO1,888) + DO JDIST=NDIST,1,-1 + DO JTYP=1,N_PROT + NMAX=NATYP(JTYP) + DO JCLASS=1,NMAX + N=NCORR(JCLASS,JTYP) + D1=SQRT(COORD1(1,N)*COORD1(1,N)+COORD1(2,N)*COORD1(2, + & N)+COORD1(3,N)*COORD1(3,N)) + IF(ABS(D1-DIST1(JDIST)).LT.SMALL) THEN + WRITE(IUO1,557) N,SYM_AT(1,N),SYM_AT(2,N),SYM_AT( + & 3,N),NQAT(N),JCLASS,CHEM(N),DIST1(JDIST),AT_ADD(INEW_AT( + & N)+1) + ENDIF + ENDDO + ENDDO + ENDDO +C +C Writes the augmented symmetrized cluster into the output +C file OUTFILE4 for further use if necessary +C + OPEN(UNIT=IUO4, FILE=OUTFILE4, STATUS='UNKNOWN') + WRITE(IUO4,778) IPHA + DO JTYP=1,N_PROT + NMAX=NATYP(JTYP) + DO JCLASS=1,NMAX + N=NCORR(JCLASS,JTYP) + X=SYM_AT(1,N)/CUNIT + Y=SYM_AT(2,N)/CUNIT + Z=SYM_AT(3,N)/CUNIT + IF(IPHA.EQ.0) THEN + WRITE(IUO4,125) N,CHEM(N),NZ_AT(N),X,Y,Z,JTYP + ELSEIF(IPHA.EQ.1) THEN + WRITE(IUO4,779) N,CHEM(N),NZ_AT(N),X,Y,Z,JTYP + ELSEIF(IPHA.EQ.2) THEN + WRITE(IUO4,*) NZ_AT(N),X,Y,Z,JTYP + ENDIF + ENDDO + ENDDO + CLOSE(IUO4) +C +C Construction of the symmetry operations list. +C Associates the appropriate symmetry operation +C for all equivalent atoms +C + IF(IPRINT.GE.2) WRITE(IUO1,887) + 438 CONTINUE + I_CALC_ROT=0 + DO JTYP=1,N_PROT + ISYM(1,JTYP)=1 + NEQATS=NATYP(JTYP) + IF(NEQATS.EQ.1) THEN + IF(JTYP.GT.N_PROT) GOTO 555 + GOTO 338 + ENDIF + NAP=NCORR(1,JTYP) + DO JNUM=1,NEQATS + IF(JNUM.GE.2) THEN + JSYM_0=2 + ELSE + JSYM_0=1 + ENDIF + NA=NCORR(JNUM,JTYP) + X=COORD1(1,NAP) + Y=COORD1(2,NAP) + Z=COORD1(3,NAP) + DO JSYM=JSYM_0,NSIZE_GR + JROT=NSYM_G(JSYM) + SYM_AT1(1,NAP)=S_M(1,1,JROT)*X+S_M(1,2,JROT)*Y+S_M(1, + & 3,JROT)*Z + SYM_AT1(2,NAP)=S_M(2,1,JROT)*X+S_M(2,2,JROT)*Y+S_M(2, + & 3,JROT)*Z + SYM_AT1(3,NAP)=S_M(3,1,JROT)*X+S_M(3,2,JROT)*Y+S_M(3, + & 3,JROT)*Z + AD=ABS(COORD1(1,NA)-SYM_AT1(1,NAP))+ABS(COORD1(2,NA)- + & SYM_AT1(2,NAP))+ABS(COORD1(3,NA)-SYM_AT1(3,NAP)) + IF(AD.LT.SMALL)THEN + ISYM(JNUM,JTYP)=JROT + I_Z(JNUM,JTYP)=IZ(JROT) + Z_L(JNUM,JTYP)=ZL(JROT) + Z_M1(JNUM,JTYP)=ZM1(JROT) + Z_M2(JNUM,JTYP)=ZM2(JROT) + IF(IZ(JROT).EQ.0) THEN + I_CALC_ROT=I_CALC_ROT+1 + ENDIF + GOTO 404 + ENDIF + ENDDO + IF(ISYM(JNUM,JTYP).EQ.0) THEN + N_PROT=N_PROT+1 + NCHTYP(N_PROT)=NCHTYP(JTYP) + NCORR(1,N_PROT)=NA + NATYP(N_PROT)=1 + I_Z(1,N_PROT)=1 + Z_L(1,N_PROT)=1. + Z_M1(1,N_PROT)=ONEC + Z_M2(1,N_PROT)=ONEC + DO JCHANGE=JNUM,NEQATS-1 + NCORR(JCHANGE,JTYP)=NCORR(JCHANGE+1,JTYP) + ENDDO + NATYP(JTYP)=NATYP(JTYP)-1 + GOTO 438 + ENDIF + 404 CONTINUE + IF((IPRINT.GE.2).AND.(NSIZE_GR.GT.1)) THEN + JR=ISYM(JNUM,JTYP) + WRITE(IUO1,849) JTYP,JNUM,NCORR(JNUM,JTYP),NAME_S(JR) + & ,JR,Z_L(JNUM,JTYP),Z_M1(JNUM,JTYP),Z_M2(JNUM,JTYP),I_Z( + & JNUM,JTYP) + ENDIF + ENDDO + WRITE(IUO1,*) ' ' + 338 CONTINUE + ENDDO +C + GAIN_G=REAL(NAT_NEW)/REAL(N_PROT) + WRITE(IUO1,854) GAIN_G +C +C Test of the symmetry operations leaving the prototypical +C atoms invariant. Associates the apropriate symmetry +C relation and/or selection rule for each atom. +C +C NAT_SYM(J) is the number of prototypical atoms in the +C various symmetry sets : +C +C J = 1 : atom 0 +C J = 2 : z axis +C J = 3 : x0y plane +C J = 4 : other atoms +C + IF(IPRINT.GE.2) WRITE(IUO1,889) + NAT_SYM(1)=1 + NAT_SYM(2)=0 + NAT_SYM(3)=0 + NAT_SYM(4)=0 + I_SET(1)=1 +C +C Loop on the prototypical atoms +C + DO JTYP=1,N_PROT +C + ISTEP_L(JTYP)=1 + ISTEP_M(JTYP)=1 + I_REL_MP(JTYP)=0 + I_LM(JTYP)=0 + I_Z_P(JTYP)=0 + Z_L_P(JTYP)=1. + Z_M_P(JTYP)=ONEC +C + NSYM_P=1 + NSYM_PT=1 + INV_P(JTYP,NSYM_P)=1 + INV_PT(JTYP,NSYM_PT)=1 +C + JAT_P=NCORR(1,JTYP) + X=COORD1(1,JAT_P) + Y=COORD1(2,JAT_P) + Z=COORD1(3,JAT_P) + X_A=ABS(X) + Y_A=ABS(Y) + Z_A=ABS(Z) + IF(JTYP.GT.1) THEN + IF((X_A+Y_A.LT.SMALL).AND.(Z_A.GE.SMALL)) THEN + NAT_SYM(2)=NAT_SYM(2)+1 + I_SET(JTYP)=2 + ELSEIF((Z_A.LT.SMALL).AND.(X_A+Y_A.GE.SMALL)) THEN + NAT_SYM(3)=NAT_SYM(3)+1 + I_SET(JTYP)=3 + ELSEIF(((X_A+Y_A).GE.SMALL).AND.(Z_A.GE.SMALL)) THEN + NAT_SYM(4)=NAT_SYM(4)+1 + I_SET(JTYP)=4 + ENDIF + ENDIF +C +C Loop on the symmetries keeping the cluster unchanged +C + DO JSYM=2,NSIZE_GR +C + JROT=NSYM_G(JSYM) + X1=S_M(1,1,JROT)*X+S_M(1,2,JROT)*Y+S_M(1,3,JROT)*Z + Y1=S_M(2,1,JROT)*X+S_M(2,2,JROT)*Y+S_M(2,3,JROT)*Z + Z1=S_M(3,1,JROT)*X+S_M(3,2,JROT)*Y+S_M(3,3,JROT)*Z + AD=ABS(X-X1)+ABS(Y-Y1)+ABS(Z-Z1) +C +C Case of an atom invariant by the symmetry JROT +C + IF(AD.LT.SMALL) THEN + NSYM_PT=NSYM_PT+1 + INV_PT(JTYP,NSYM_PT)=JROT + IF(IZ(JROT).NE.0) THEN + I_Z_P(JTYP)=IZ(JROT) + NSYM_P=NSYM_P+1 + INV_P(JTYP,NSYM_P)=JROT + ISL=ISTEP_L(JTYP) + ISM=ISTEP_M(JTYP) +C +C Case of an atom off the z axis +C + IF((ABS(X).GE.SMALL).OR.(ABS(Y).GE.SMALL)) THEN +C +C Symmetry = IC2z +C + IF(JROT.EQ.36) THEN + ISTEP_M(JTYP)=MAX(ISM,2) + I_LM(JTYP)=1 +C +C Symmetry = C2u or IC2u_perp +C + ELSE + I_REL_MP(JTYP)=1 + Z_L_P(JTYP)=ZL(JROT) + Z_M_P(JTYP)=ZM1(JROT) + ENDIF +C +C Case of an atom on the z axis but different from the absorber +C + ELSE + IF(ABS(Z).GE.SMALL) THEN +C +C Symmetry = C2z +C + IF(JROT.EQ.4) THEN + ISTEP_M(JTYP)=MAX(ISM,2) +C +C Symmetry = C4z +C + ELSEIF(JROT.EQ.15) THEN + ISTEP_M(JTYP)=MAX(ISM,4) +C +C Symmetry = C4z3 +C + ELSEIF(JROT.EQ.18) THEN + ISTEP_M(JTYP)=MAX(ISM,4) +C +C Symmetry = C3z +C + ELSEIF(JROT.EQ.25) THEN + ISTEP_M(JTYP)=MAX(ISM,3) +C +C Symmetry = C3z2 +C + ELSEIF(JROT.EQ.26) THEN + ISTEP_M(JTYP)=MAX(ISM,3) +C +C Symmetry = C6z +C + ELSEIF(JROT.EQ.27) THEN + ISTEP_M(JTYP)=MAX(ISM,6) +C +C Symmetry = C6z5 +C + ELSEIF(JROT.EQ.28) THEN + ISTEP_M(JTYP)=MAX(ISM,6) +C +C Symmetry = IC2u +C + ELSEIF(JROT.GT.33) THEN + I_REL_MP(JTYP)=1 + I_Z_P(JTYP)=IZ(JROT) + Z_L_P(JTYP)=ZL(JROT) + Z_M_P(JTYP)=ZM1(JROT) + ENDIF +C +C Case of atom 0 (the absorber) +C + ELSE +C +C Symmetry = C2z or IC2z +C + IF((JROT.EQ.4).OR.(JROT.EQ.36)) THEN + ISTEP_M(JTYP)=MAX(ISM,2) + IF(JROT.EQ.36) THEN + I_LM(JTYP)=1 + ENDIF +C +C Symmetry = C4z or IC4z +C + ELSEIF((JROT.EQ.15).OR.(JROT.EQ.47)) THEN + ISTEP_M(JTYP)=MAX(ISM,4) + IF(JROT.EQ.47) THEN + I_LM(JTYP)=1 + ENDIF +C +C Symmetry = C4z3 or IC4z3 +C + ELSEIF((JROT.EQ.18).OR.(JROT.EQ.50)) THEN + ISTEP_M(JTYP)=MAX(ISM,4) + IF(JROT.EQ.50) THEN + I_LM(JTYP)=1 + ENDIF +C +C Symmetry = C3z or IC3z +C + ELSEIF((JROT.EQ.25).OR.(JROT.EQ.57)) THEN + ISTEP_M(JTYP)=MAX(ISM,3) + IF(JROT.EQ.57) THEN + ISTEP_L(JTYP)=MAX(ISL,2) + ENDIF +C +C Symmetry = C3z2 or IC3z2 +C + ELSEIF((JROT.EQ.26).OR.(JROT.EQ.58)) THEN + ISTEP_M(JTYP)=MAX(ISM,3) + IF(JROT.EQ.58) THEN + ISTEP_L(JTYP)=MAX(ISL,2) + ENDIF +C +C Symmetry = C6z or IC6z +C + ELSEIF((JROT.EQ.27).OR.(JROT.EQ.59)) THEN + ISTEP_M(JTYP)=MAX(ISM,6) + IF(JROT.EQ.59) THEN + I_LM(JTYP)=1 + ENDIF +C +C Symmetry = C6z5 or IC6z5 +C + ELSEIF((JROT.EQ.28).OR.(JROT.EQ.60)) THEN + ISTEP_M(JTYP)=MAX(ISM,6) + IF(JROT.EQ.60) THEN + I_LM(JTYP)=1 + ENDIF +C +C Symmetry = I +C + ELSEIF(JROT.EQ.33) THEN + ISTEP_L(JTYP)=MAX(ISL,2) +C +C Symmetry = C2u or IC2u_perp with u within (x0y) +C + ELSE + IF(IZ(JROT).EQ.-1) THEN + I_REL_MP(JTYP)=1 + Z_L_P(JTYP)=ZL(JROT) + Z_M_P(JTYP)=ZM1(JROT) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO +C +C Finding the symmetry group (if any) associated to each prototypical atom +C + JGROUP=0 + IF(NSYM_PT.EQ.1) THEN + JGROUP=1 + ELSEIF(NSYM_PT.EQ.2) THEN + IF(INV_PT(JTYP,2).EQ.33) THEN + JGROUP=2 + ELSEIF(INV_PT(JTYP,2).EQ.4) THEN + JGROUP=3 + ELSEIF(INV_PT(JTYP,2).EQ.36) THEN + JGROUP=4 + ENDIF + ELSEIF(NSYM_PT.EQ.3) THEN + JGROUP=16 + ELSEIF(NSYM_PT.EQ.4) THEN + IF(INV_PT(JTYP,3).EQ.33) THEN + JGROUP=5 + ELSEIF((INV_PT(JTYP,3).EQ.3).OR.(INV_PT(JTYP,3).EQ.19)) + & THEN + JGROUP=6 + ELSEIF((INV_PT(JTYP,3).EQ.34).OR.(INV_PT(JTYP,3).EQ.51)) + & THEN + JGROUP=7 + ELSEIF(INV_PT(JTYP,3).EQ.15) THEN + JGROUP=9 + ELSEIF(INV_PT(JTYP,3).EQ.47) THEN + JGROUP=10 + ENDIF + ELSEIF(NSYM_PT.EQ.6) THEN + IF(INV_PT(JTYP,4).EQ.26) THEN + JGROUP=18 + ELSEIF((INV_PT(JTYP,4).EQ.34).OR.(INV_PT(JTYP,4).EQ.35)) + & THEN + JGROUP=19 + ELSEIF(INV_PT(JTYP,4).EQ.33) THEN + JGROUP=17 + ELSEIF(INV_PT(JTYP,4).EQ.26) THEN + JGROUP=21 + ELSEIF(INV_PT(JTYP,4).EQ.36) THEN + JGROUP=22 + ENDIF + ELSEIF(NSYM_PT.EQ.8) THEN + IF(INV_PT(JTYP,4).EQ.33) THEN + IF(INV_PT(JTYP,8).EQ.50) THEN + JGROUP=11 + ELSE + JGROUP=8 + ENDIF + ELSE + IF(INV_PT(JTYP,5).EQ.15) THEN + JGROUP=12 + ELSE + IF(INV_PT(JTYP,3).EQ.15) THEN + JGROUP=13 + ELSEIF((INV_PT(JTYP,3).EQ.3).OR.(INV_PT(JTYP,3). + & EQ.19)) THEN + JGROUP=14 + ENDIF + ENDIF + ENDIF + ELSEIF(NSYM_PT.EQ.12) THEN + IF(INV_PT(JTYP,5).EQ.5) THEN + JGROUP=28 + ELSEIF(INV_PT(JTYP,7).EQ.33) THEN + IF(INV_PT(JTYP,12).EQ.60) THEN + JGROUP=23 + ELSE + JGROUP=20 + ENDIF + ELSE + IF(INV_PT(JTYP,3).EQ.3) THEN + JGROUP=24 + ELSEIF(INV_PT(JTYP,9).EQ.59) THEN + JGROUP=26 + ELSEIF(INV_PT(JTYP,5).EQ.27) THEN + JGROUP=25 + ENDIF + ENDIF + ELSEIF(NSYM_PT.EQ.16) THEN + JGROUP=15 + ELSEIF(NSYM_PT.EQ.24) THEN + IF(INV_PT(JTYP,17).EQ.57) THEN + JGROUP=27 + ELSEIF(INV_PT(JTYP,17).EQ.17) THEN + JGROUP=31 + ELSEIF(INV_PT(JTYP,17).EQ.49) THEN + JGROUP=30 + ELSEIF(INV_PT(JTYP,17).EQ.37) THEN + JGROUP=29 + ENDIF + ELSEIF(NSYM_PT.EQ.48) THEN + JGROUP=32 + ENDIF + GR(JTYP)=JGROUP +C + IF((IPRINT.GE.2).AND.(NSIZE_GR.GT.1)) THEN + WRITE(IUO1,851) JTYP,JAT_P,SYM_AT(1,JAT_P),SYM_AT(2, + & JAT_P),SYM_AT(3,JAT_P),I_SET(JTYP),NSYM_PT,NSYM_P,NAME_G(GR( + & JTYP)),(NAME_S(INV_P(JTYP,JS)),JS=1,NSYM_P) + ENDIF + ENDDO + WRITE(IUO1,852) + GAIN_B=0. + DO JTYP=1,N_PROT + NGAIN_B(JTYP)=ISTEP_L(JTYP)*ISTEP_M(JTYP)*(I_REL_MP(JTYP)+1) + GAIN_B=GAIN_B+NGAIN_B(JTYP) + WRITE(IUO1,853) JTYP,I_Z_P(JTYP),INT(Z_L_P(JTYP)),Z_M_P(JTYP) + & ,ISTEP_L(JTYP),ISTEP_M(JTYP),I_LM(JTYP),I_REL_MP(JTYP),NGAIN_B( + & JTYP) + ENDDO + GAIN_B=GAIN_B/FLOAT(N_PROT) + WRITE(IUO1,855) GAIN_B +C +C Calculation and storage of r^{l}_{m m'}(pi/2) for the specific +C cubic group symmetry operations +C + IF(I_CALC_ROT.GT.0) THEN + PIS2=1.570796 + CALL DJMN(PIS2,R_PIS2,LI_M+1) + ENDIF +C +C Construction of the inverse matrices used for point-groups +C + DO I=1,3 + DO J=1,3 + DO JOP=1,NSIZE_GR + JSYM=NSYM_G(JOP) + S_INV(JSYM,J,I)=S_M(I,J,JSYM) + ENDDO + ENDDO + ENDDO + GOTO 999 +C + 895 WRITE(IUO1,896) JAT1,JAT2 + STOP + 998 WRITE(IUO1,997) NSIZE_GR + STOP + 999 PRINT 445 +C +C Input/output formats +C + 125 FORMAT(2X,I4,5X,A2,5X,I2,3F10.4,12X,I4) + 444 FORMAT(////,5X,'++++++++++++++++++++ SYMMETRIZATION OF THE ', + &'CLUSTER +++++++++++++++++++',/) + 445 FORMAT(//,5X,'+++++++++++++++++++++++++++++++++++++++++++++++','+ + &++++++++++++++++++++++++',//) + 557 FORMAT(10X,I3,3X,'(',F7.3,',',F7.3,',',F7.3,')',3X,I3,3X,I3,3X, + &A2,3X,F7.3,2X,A8) + 696 FORMAT(///,6X,I2,' SYMMETRY OPERATIONS AT LEAST SHOULD BE ', + &'PRESENT IN THE CLUSTER :',/) + 697 FORMAT(///,16X,' THE THREE-FOLD AXES HAVE BEEN CODED AS : ',//, + &30X,'alpha -----> l',/,30X,'beta -----> m',/,30X,'gamma --- + &--> n',/,30X,'delta -----> o') + 698 FORMAT(///,17X,I1,' SYMMETRY OPERATION FOUND IN THE CLUSTER :',/) + 699 FORMAT(///,16X,I2,' SYMMETRY OPERATIONS FOUND IN THE CLUSTER :',/ + &) + 700 FORMAT(12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/,12X,A5, + &2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X, + &A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5, + &2X,A5,2X,A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X, + &A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5, + &2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/, + & 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5) + 701 FORMAT(19X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5) + 702 FORMAT(26X,A5,2X,A5,2X,A5,2X,A5) + 703 FORMAT(30X,A5,2X,A5,2X,A5) + 704 FORMAT(33X,A5,2X,A5) + 705 FORMAT(37X,A5) + 706 FORMAT(/,19X,'AFTER ROTATION OF THIS CLUSTER BY ',A4,/) + 707 FORMAT(//,' ----------',9X,'CONSTRUCTION OF A NEW CLUSTER :', + &8X,'----------') + 708 FORMAT(//,10X,'THE DIFFERENT GROUPS THAT COULD SUPPORT ','THE + &CLUSTER ARE :',/) + 709 FORMAT(28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X), + &/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/, + &28X,4(A3,3X)) + 710 FORMAT(/,28X,'FOR THE INPUT CLUSTER ') + 711 FORMAT(/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3, + &3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/ + &,28X,4(A3,3X)) + 712 FORMAT(/,24X,'FOR THE ROTATED INPUT CLUSTER') + 713 FORMAT(//,36X,'AND :') + 714 FORMAT(//,25X,'---> TRYING THE GROUP : ',A3) + 715 FORMAT(/,13X,'GROUP IMPOSSIBLE : ATOM (',F7.3,',',F7.3,',',F7.3, + &')',/,19X,' TRANSFORMED INTO (',F7.3,',',F7.3,',',F7.3,')') + 716 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS ABOVE',/,20X, + &'THE SURFACE PLANE LOCATED AT Z = ',F7.3) + 717 FORMAT(27X,'NEW ATOM OF TYPE ',A2,' (No ',I4,') GENERATED BY ', + &A5,/,27X,'AT THE POSITION OF AN ATOM OF TYPE ',A2,' (No ',I4,')', + &/,27X,'IN THE ORIGINAL CLUSTER') + 718 FORMAT(///,5X,'<<<<<<<<<< NATCLU_M TOO SMALL IN THE .inc FILE ', + &'TO INCREASE >>>>>>>>>>',/,5X,'<<<<<<<<<< THE ','CLUSTER. + & SHOULD BE AT LEAST ',I4,' >>>>>>>>>>') + 719 FORMAT(///,3X,'<<<<<<<<<< ERROR : NO GROUP WAS FOUND TO ', + &'ACCOMODATE THE CLUSTER >>>>>>>>>>') + 720 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS INSIDE',/,25X, + &'THE ORIGINAL CLUSTER, BUT NOT',/,29X,'AT AN ATOMIC POSITION') + 721 FORMAT(//,11X,' THE INVERSION I IS NOT CONSISTENT WITH THIS ', + &'CLUSTER',/,17X,'AS THE ABSORBER IS CLOSER TO THE SURFACE',/,21X, + &'THAN TO THE BOTTOM OF THE CLUSTER') + 722 FORMAT(//,16X,'THE CLUSTER CAN ACCOMODATE THE INVERSION I',//, + &13X,'---> BUILDING A LARGER CLUSTER INVARIANT BY I') + 723 FORMAT(//,4X,'-------- IMPOSSIBLE TO AUGMENT THE CLUSTER TO ', + &'SUPPORT I --------',//,15X,'---> RESTARTING WITH THE + &ORIGINAL CLUSTER ...') + 724 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS OF BULK TYPE',/, + &25X,'WHILE THE ORIGINAL ONE IS OF SURFACE TYPE',/,29X,'---> + &IMPOSSIBLE WITH I_GR = ',I1) + 725 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS OF SURFACE TYPE', + &/,25X,'WHILE THE ORIGINAL ONE IS OF BULK TYPE',/,29X,'---> + &IMPOSSIBLE WITH I_GR = ',I1) + 726 FORMAT(//,11X,' THE INVERSION I IS NOT CONSISTENT WITH THIS ', + &'CALCULATION',/,10X,'AS SURFACE AND BULK ATOMS HAVE TO ','BE + &DISCRIMINATED (I_GR=1)') + 778 FORMAT(30X,I1) + 779 FORMAT(2X,I4,5X,A2,5X,I2,3F10.4,I5) + 849 FORMAT(1X,I4,4X,I2,3X,I4,2X,A5,' = ',I2,2X,F6.3,2X,'(',F6.3,',', + &F6.3,')',2X,'(',F6.3,',',F6.3,')',4X,I2) + 851 FORMAT(1X,I4,3X,I4,2X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I1,3X,I2, + &1X,I2,2X,A3,2X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X, + &A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/ + &,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X) + 852 FORMAT(///,10X,'SELECTION RULE AND/OR RELATION ON THE MATRIX',' + &ELEMENTS OF TAU :',//,4X,'CLASS',2X,'I_Z',2X,'Z_L',8X,'Z_M',9X, + &'ISTEP_L',2X,'ISTEP_M',2X,'I_LM',2X,'I_REL_MP',2X,'GAIN',/) + 853 FORMAT(4X,I3,4X,I2,3X,I2,3X,'(',F6.3,',',F6.3,')',6X,I1,8X,I1,7X, + &I1,7X,I1,6X,I2) + 854 FORMAT(//,16X,'-----> EXPECTED GAIN FOR THE GLOBAL LEVEL : ',F5. + &2,//) + 855 FORMAT(///,18X,'-----> EXPECTED GAIN FOR THE BASIS LEVEL : ',F5. + &2,//) + 880 FORMAT(33X,A3) + 881 FORMAT(/,' ---------- THESE OPERATIONS DON''T FORM A',' + &SYMMETRY GROUP ----------', /' ---------- i. e. THE CLUSTER + &IS NOT CORRECTLY',' TRUNCATED ----------',/,' ---------- + & FROM THE POINT OF VIEW OF ','SYMMETRY ----------') + 886 FORMAT(///,25X,'CLUSTER SYMMETRY GROUP :',/,33X,A4) + 887 FORMAT(///,10X,'SYMMETRY OPERATIONS ASSOCIATED WITH THE ', + &'EQUIVALENT ATOMS : ',//,2X,'CLASS',2X,'ATOM',2X,' No ',3X, + &'SYMMETRY',3X,'Z**L',8X,'Z**M',13X,'Z**M''',7X,'DELTA',/) + 888 FORMAT(///,20X,'CONTENTS OF THE SYMMETRIZED CLUSTER',/,18X,'BY + &INCREASING DISTANCE TO THE ABSORBER :',//,11X,'No',13X,'(X,Y,Z)', + &11X,'CLASS',1X,'ATOM',1X,'ChSp',4X,'DIST',//) + 889 FORMAT(///,10X,'SYMMETRY OPERATIONS LEAVING THE PROTOTYPICAL ', + &'ATOMS INVARIANT : ',//,27X,'G = 1 -----> atom 0 only',/,27X, + &'G = 2 -----> atom along 0z',/,27X,'G = 3 -----> atom within + &x0y',/,27X,'G = 4 -----> other atom',//,19X,'ST : total number + &of symmetries leaving',/,29X,'the prototypical atom invariant',// + &,19X,'SE : number of symmetries taken into account',/,29X,'( + &Euler angle BETA = 0 or pi)',//,2X,'CLASS',2X,' No ',11X,'(X,Y,Z) + &',10X,'G',3X,'ST',1X,'SE',1X,'GROUP',7X,'SE SYMMETRIES',/) + 896 FORMAT(///,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE ATOMS', + &' >>>>>>>>>>',/,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' ARE + &IDENTICAL >>>>>>>>>>') + 897 FORMAT(///,11X,'<<<<<<<<<< NATP_M TOO SMALL IN THE INCLUDE ', + &'FILE >>>>>>>>>>',/,11X,'<<<<<<<<<< SHOULD BE',' AT + &LEAST ',I4,' >>>>>>>>>>') + 898 FORMAT(///,12X,'<<<<<<<<<< NAT_EQ_M TOO SMALL IN THE INCLUDE',' + &FILE >>>>>>>>>>',/,12X,'<<<<<<<<<< SHOULD BE AT LEAST ',I4,' + &>>>>>>>>>>') + 997 FORMAT(///,'<<<<<<<<<< ',I2,' SYMMETRIES HAVE BEEN FOUND. THIS + &','>>>>>>>>>>',/,'<<<<<<<<<< EXCEEDS THE SIZE OF THE ','LARGEST + &POINT-GROUP >>>>>>>>>>') +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/common_sub/uj_sq.f b/src/msspec/spec/fortran/common_sub/uj_sq.f new file mode 100644 index 0000000..fbdafb1 --- /dev/null +++ b/src/msspec/spec/fortran/common_sub/uj_sq.f @@ -0,0 +1,79 @@ +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 diff --git a/src/msspec/spec/fortran/eig/common/dwsph.f b/src/msspec/spec/fortran/eig/common/dwsph.f new file mode 100644 index 0000000..468fec1 --- /dev/null +++ b/src/msspec/spec/fortran/eig/common/dwsph.f @@ -0,0 +1,85 @@ +C +C======================================================================= +C + SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED) +C +C This routine recomputes the T-matrix elements taking into account the +C mean square displacements. +C +C When the argument X is tiny, no vibrations are taken into account +C +C Last modified : 25 Apr 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE TRANS_MOD +C + DIMENSION GNT(0:N_GAUNT) +C + COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC +C + COMPLEX*16 FFL(0:2*NL_M) +C + DATA PI4,EPS /12.566371,1.0E-10/ +C + ZEROC=(0.,0.) +C + IF(X.GT.EPS) THEN +C +C Standard case: vibrations +C + IF(ISPEED.LT.0) THEN + NSUM_LB=ABS(ISPEED) + ENDIF +C + COEF=PI4*EXP(-X) + NL2=2*LMAX(JTYP,JE)+2 + IBESP=5 + MG1=0 + MG2=0 +C + CALL BESPHE(NL2,IBESP,X,FFL) +C + DO L=0,LMAX(JTYP,JE) + XL=FLOAT(L+L+1) + SL1=ZEROC +C + DO L1=0,LMAX(JTYP,JE) + XL1=FLOAT(L1+L1+1) + CALL GAUNT(L,MG1,L1,MG2,GNT) + L2MIN=ABS(L1-L) + IF(ISPEED.GE.0) THEN + L2MAX=L1+L + ELSEIF(ISPEED.LT.0) THEN + L2MAX=L2MIN+2*(NSUM_LB-1) + ENDIF + SL2=0. +C + DO L2=L2MIN,L2MAX,2 + XL2=FLOAT(L2+L2+1) + C=SQRT(XL1*XL2/(PI4*XL)) + SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2))) + ENDDO +C + SL1=SL1+SL2*TL(L1,1,JTYP,JE) + ENDDO +C + TLT(L,1,JTYP,JE)=COEF*SL1 +C + ENDDO +C + ELSE +C +C Argument X tiny: no vibrations +C + DO L=0,LMAX(JTYP,JE) +C + TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE) +C + ENDDO +C + ENDIF +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/common/eig_mat_ms.f b/src/msspec/spec/fortran/eig/common/eig_mat_ms.f new file mode 100644 index 0000000..7a7a091 --- /dev/null +++ b/src/msspec/spec/fortran/eig/common/eig_mat_ms.f @@ -0,0 +1,261 @@ +C +C======================================================================= +C + SUBROUTINE EIG_MAT_MS(JE,E_KIN) +C +C This subroutine stores the G_o T kernel matrix and computes +C its eigenvalues to check the larger ones. If one or more +C of these eigenvalues are larger than or equal to 1, no +C series expansion can converge +C +C Last modified : 20 Jul 2009 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE COOR_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE TRANS_MOD +C +C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD +C + CHARACTER*24 OUTFILE,PATH +C + COMPLEX*16 HL1(0:NLTWO),SM(LINMAX*NATCLU_M,LINMAX*NATCLU_M) + COMPLEX*16 SUM_L,IC,ZEROC,WORK(32*LINMAX*NATCLU_M) + COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO),TLK,EXPKJ + COMPLEX*16 W(LINMAX*NATCLU_M) + COMPLEX*16 VL(1,1),VR(1,1) +C + DOUBLE PRECISION RWORK(2*LINMAX*NATCLU_M) +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ +C + REAL W1(LINMAX*NATCLU_M),W2(LINMAX*NATCLU_M) +C + DATA PI,SMALL /3.1415926535898D0,0.0001/ +C + IC=(0.D0,1.D0) + ZEROC=(0.D0,0.D0) + IBESS=3 + NPRINT=10 +C + WRITE(IUO1,5) + IF(JE.EQ.1) THEN +C +C Name of the second output file where all the eigenvalues +C will be written +C + IOUT2=55 + IOUT3=60 + N_DOT=1 + DO J_CHAR=1,24 + IF(OUTFILE2(J_CHAR:J_CHAR).EQ.'.') GOTO 888 + N_DOT=N_DOT+1 + ENDDO + 888 CONTINUE + OUTFILE=OUTFILE2(1:N_DOT)//'egv' + PATH=OUTFILE2(1:N_DOT)//'pth' + OPEN(UNIT=IOUT2, FILE=OUTFILE, STATUS='UNKNOWN') + OPEN(UNIT=IOUT3, FILE=PATH, STATUS='UNKNOWN') + ENDIF +C +C Construction of the multiple scattering kernel matrix G_o T. +C Elements are stored using a linear index LINJ +C representing (J,LJ) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + DO LJ=0,LMJ + DO MJ=-LJ,LJ + JLIN=JLIN+1 +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.NE.JATL) THEN + XKJ=DBLE(SYM_AT(1,KATL)-XJ) + YKJ=DBLE(SYM_AT(2,KATL)-YJ) + ZKJ=DBLE(SYM_AT(3,KATL)-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))* + & RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM, + & LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ, + & HL1) + ENDIF +C + DO LK=0,LMK + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + KLIN=KLIN+1 + SM(KLIN,JLIN)=ZEROC + SUM_L=ZEROC + IF(KATL.NE.JATL) THEN + CALL GAUNT2(LK,MK,LJ,MJ,GNT) +C + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L=SUM_L+(IC**L)* + & HL1(L)*YLM(L,M)*GNT(L) + ENDIF + ENDDO + SUM_L=SUM_L*ATTKJ*4.D0*PI*IC + ELSE + SUM_L=ZEROC + ENDIF +C + SM(KLIN,JLIN)=TLK*SUM_L +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + N_DIM=LINMAX*NATCLU_M +C +C Eigenvalues of the kernel multiple scattering matrix SM +C + CALL ZGEEV('N','N',JLIN,SM,N_DIM,W,VL,1,VR,1,WORK,34*N_DIM,RWORK, + &INFO) + IF(INFO.NE.0) THEN + WRITE(IUO1,*) ' ' + WRITE(IUO1,*) ' ---> WORK(1),INFO =',WORK(1),INFO + WRITE(IUO1,*) ' ' + ENDIF +C + N_EIG=0 +C + WRITE(IOUT2,75) + WRITE(IOUT2,110) + WRITE(IOUT2,80) E_KIN + WRITE(IOUT2,110) + WRITE(IOUT2,75) + WRITE(IOUT2,105) + WRITE(IOUT2,75) + XMAX_L=0. + N_XMAX=0 +C + DO LIN=1,JLIN + EIG=REAL(CDABS(W(LIN))) + WRITE(IOUT2,100) REAL(DBLE(W(LIN))),REAL(DIMAG(W(LIN))),EIG + IF((EIG-XMAX_L).GT.0.0001) N_XMAX=LIN + XMAX_L=MAX(XMAX_L,EIG) + W1(LIN)=EIG + IF(EIG.GT.1.000) THEN + N_EIG=N_EIG+1 + ENDIF + ENDDO +C + WRITE(IOUT2,75) + WRITE(IOUT2,85) XMAX_L + WRITE(IOUT2,90) N_XMAX + WRITE(IOUT2,95) W(N_XMAX) + WRITE(IOUT2,75) +C + CALL ORDRE(JLIN,W1,NFIN,W2) +C +C + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,15) W2(1) + WRITE(IUO1,20) W2(NFIN) + WRITE(IUO1,10) + WRITE(IUO1,10) + IF(N_EIG.GE.1) THEN + IF(N_EIG.EQ.1) THEN + WRITE(IUO1,25) JLIN + ELSE + WRITE(IUO1,30) N_EIG,JLIN + ENDIF + ENDIF +C + WRITE(IUO1,65) N_XMAX + WRITE(IUO1,70) W(N_XMAX) + WRITE(IUO1,10) + WRITE(IOUT3,100) REAL(DBLE(W(N_XMAX))),REAL(DIMAG(W(N_XMAX))) +C + NPR=NPRINT/5 + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,35) 5*NPR + WRITE(IUO1,10) +C + DO JP=0,NPR-1 + J=5*JP + WRITE(IUO1,40) W2(J+1),W2(J+2),W2(J+3),W2(J+4),W2(J+5) + ENDDO + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,45) W2(1) + WRITE(IUO2,*) E_KIN,W2(1) + IF(N_EIG.EQ.0) THEN + WRITE(IUO1,50) + ELSE + WRITE(IUO1,55) + ENDIF + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,60) +C + RETURN +C + 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','--------- + &--------') + 10 FORMAT(11X,'-',54X,'-') + 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-') + 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-') + 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-') + 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X, + &'-') + 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-') + 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-') + 45 FORMAT(11X,'-',5X,'SPECTRAL RADIUS OF THE KERNEL MATRIX :',F6.3, + &5X,'-') + 50 FORMAT(11X,'-',5X,'---> THE MULTIPLE SCATTERING SERIES ', + &'CONVERGES',4X,'-') + 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/ + &,11X,'-',18X,'SCATTERING SERIES',19X,'-') + 60 FORMAT(11X,'----------------------------------------','---------- + &------',/) + 65 FORMAT(11X,'-',5X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,'- + &') + 70 FORMAT(11X,'-',5X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.3, + &')',8X,'-') + 75 FORMAT(' ') + 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV') + 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3) + 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5) + 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,') + &') + 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3) + 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :') + 110 FORMAT(2X,'-------------------------------') +C + END diff --git a/src/msspec/spec/fortran/eig/common/facdif1.f b/src/msspec/spec/fortran/eig/common/facdif1.f new file mode 100644 index 0000000..3254b80 --- /dev/null +++ b/src/msspec/spec/fortran/eig/common/facdif1.f @@ -0,0 +1,116 @@ +C +C======================================================================= +C + SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT, + &JE,*) +C +C This routine computes a spherical wave scattering factor +C +C Last modified : 03/04/2006 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE APPROX_MOD + USE EXPFAC_MOD + USE TRANS_MOD + USE TYPCAL_MOD, I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, + &I6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST + + DIMENSION PLMM(0:100,0:100) + DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ + COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE + COMPLEX RHOJK +C +C + DATA PI/3.141593/ +C + A=1. + INTER=0 + IF(ITL.EQ.1) VKE=VK(JE) + RHOJ=VKE*RJ + RHOJK=VKE*RJK + HLM1=(1.,0.) + HLM2=(1.,0.) + HLM3=(1.,0.) + HLM4=(1.,0.) + IEM=1 + CSTH=COS(BETA) + IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN + INTER=1 + BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI)) + ENDIF + CALL PLM(CSTH,PLMM,LMAX(JAT,JE)) + IF(ISPHER.EQ.0) NO1=0 + IF(ISPHER.EQ.1) THEN + IF(NO.EQ.8) THEN + NO1=LMAX(JAT,JE)+1 + ELSE + NO1=NO + ENDIF + CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM) + IF(IEM.EQ.0) THEN + HLM4=HLM(0,L) + ENDIF + IF(RJK.GT.0.0001) THEN + NDUM=0 + CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN) + ENDIF + CALL DJMN(THRJ,D,L) + A1=ABS(D(0,M,L)) + IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) + & RETURN 1 + ENDIF + MUMAX=MIN0(L,NO1) + SMU=(0.,0.) + DO 10 MU=0,MUMAX + IF(MOD(MU,2).EQ.0) THEN + B=1. + ELSE + B=-1. + IF(SIN(BETA).LT.0.) THEN + A=-1. + ENDIF + ENDIF + IF(ISPHER.LE.1) THEN + ALMU=(1.,0.) + C=1. + ENDIF + IF(ISPHER.EQ.0) GOTO 40 + IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L)) + IF(MU.GT.0) THEN + C=B*FLOAT(L+L+1)/EXPF(MU,L) + ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B* + * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU + ELSE + C=1. + ALMU=CMPLX(D(M,0,L))/BLMU + ENDIF + 40 SNU=(0.,0.) + NU1=INT(0.5*(NO1-MU)+0.0001) + NUMAX=MIN0(NU1,L-MU) + DO 20 NU=0,NUMAX + SLP=(0.,0.) + LPMIN=MAX0(MU,NU) + DO 30 LP=LPMIN,LMAX(JAT,JE) + IF(ISPHER.EQ.1) THEN + HLM1=HLM(NU,LP) + IF(RJK.GT.0.0001) HLM3=HLN(0,LP) + ENDIF + SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP, + & MU)*HLM3 + 30 CONTINUE + IF(ISPHER.EQ.1) THEN + HLM2=HLM(MU+NU,L) + ENDIF + SNU=SNU+SLP*HLM2 + 20 CONTINUE + SMU=SMU+SNU*C*ALMU*A*B + 10 CONTINUE + FSPH=SMU/(VKE*HLM4) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/common/lapack_eig.f b/src/msspec/spec/fortran/eig/common/lapack_eig.f new file mode 100644 index 0000000..c90c8fa --- /dev/null +++ b/src/msspec/spec/fortran/eig/common/lapack_eig.f @@ -0,0 +1,21492 @@ +C +C======================================================================= +C +C LAPACK eigenvalue subroutines +C +C======================================================================= +C +C (version 3.8.0) Jul 2018 +C +C======================================================================= +C +*> \brief ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, +* WORK, LWORK, RWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVL, JOBVR +* INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the +*> eigenvalues and, optionally, the left and/or right eigenvectors. +*> +*> The right eigenvector v(j) of A satisfies +*> A * v(j) = lambda(j) * v(j) +*> where lambda(j) is its eigenvalue. +*> The left eigenvector u(j) of A satisfies +*> u(j)**H * A = lambda(j) * u(j)**H +*> where u(j)**H denotes the conjugate transpose of u(j). +*> +*> The computed eigenvectors are normalized to have Euclidean norm +*> equal to 1 and largest component real. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': left eigenvectors of A are not computed; +*> = 'V': left eigenvectors of are computed. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': right eigenvectors of A are not computed; +*> = 'V': right eigenvectors of A are computed. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (N) +*> W contains the computed eigenvalues. +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is COMPLEX*16 array, dimension (LDVL,N) +*> If JOBVL = 'V', the left eigenvectors u(j) are stored one +*> after another in the columns of VL, in the same order +*> as their eigenvalues. +*> If JOBVL = 'N', VL is not referenced. +*> u(j) = VL(:,j), the j-th column of VL. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1; if +*> JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is COMPLEX*16 array, dimension (LDVR,N) +*> If JOBVR = 'V', the right eigenvectors v(j) are stored one +*> after another in the columns of VR, in the same order +*> as their eigenvalues. +*> If JOBVR = 'N', VR is not referenced. +*> v(j) = VR(:,j), the j-th column of VR. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1; if +*> JOBVR = 'V', LDVR >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,2*N). +*> For good performance, LWORK must generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the QR algorithm failed to compute all the +*> eigenvalues, and no eigenvectors have been computed; +*> elements and i+1:N of W contain eigenvalues which have +*> converged. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +* @precisions fortran z -> c +* +*> \ingroup complex16GEeigen +* +* ===================================================================== + SUBROUTINE zgeev( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, + $ WORK, LWORK, RWORK, INFO ) + implicit none +* +* -- LAPACK driver routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( lda, * ), VL( ldvl, * ), VR( ldvr, * ), + $ w( * ), work( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + parameter( zero = 0.0d0, one = 1.0d0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + CHARACTER SIDE + INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, + $ iwrk, k, lwork_trevc, maxwrk, minwrk, nout + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM + COMPLEX*16 TMP +* .. +* .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL dlabad, xerbla, zdscal, zgebak, zgebal, zgehrd, + $ zhseqr, zlacpy, zlascl, zscal, ztrevc3, zunghr +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE + EXTERNAL lsame, idamax, ilaenv, dlamch, dznrm2, zlange +* .. +* .. Intrinsic Functions .. + INTRINSIC dble, dcmplx, conjg, aimag, max, sqrt +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 + lquery = ( lwork.EQ.-1 ) + wantvl = lsame( jobvl, 'V' ) + wantvr = lsame( jobvr, 'V' ) + IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl, 'N' ) ) ) THEN + info = -1 + ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr, 'N' ) ) ) THEN + info = -2 + ELSE IF( n.LT.0 ) THEN + info = -3 + ELSE IF( lda.LT.max( 1, n ) ) THEN + info = -5 + ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) ) THEN + info = -8 + ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) ) THEN + info = -10 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* CWorkspace refers to complex workspace, and RWorkspace to real +* workspace. NB refers to the optimal block size for the +* immediately following subroutine, as returned by ILAENV. +* HSWORK refers to the workspace preferred by ZHSEQR, as +* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, +* the worst case.) +* + IF( info.EQ.0 ) THEN + IF( n.EQ.0 ) THEN + minwrk = 1 + maxwrk = 1 + ELSE + maxwrk = n + n*ilaenv( 1, 'ZGEHRD', ' ', n, 1, n, 0 ) + minwrk = 2*n + IF( wantvl ) THEN + maxwrk = max( maxwrk, n + ( n - 1 )*ilaenv( 1, 'ZUNGHR', + $ ' ', n, 1, n, -1 ) ) + CALL ztrevc3( 'L', 'B', SELECT, n, a, lda, + $ vl, ldvl, vr, ldvr, + $ n, nout, work, -1, rwork, -1, ierr ) + lwork_trevc = int( work(1) ) + maxwrk = max( maxwrk, n + lwork_trevc ) + CALL zhseqr( 'S', 'V', n, 1, n, a, lda, w, vl, ldvl, + $ work, -1, info ) + ELSE IF( wantvr ) THEN + maxwrk = max( maxwrk, n + ( n - 1 )*ilaenv( 1, 'ZUNGHR', + $ ' ', n, 1, n, -1 ) ) + CALL ztrevc3( 'R', 'B', SELECT, n, a, lda, + $ vl, ldvl, vr, ldvr, + $ n, nout, work, -1, rwork, -1, ierr ) + lwork_trevc = int( work(1) ) + maxwrk = max( maxwrk, n + lwork_trevc ) + CALL zhseqr( 'S', 'V', n, 1, n, a, lda, w, vr, ldvr, + $ work, -1, info ) + ELSE + CALL zhseqr( 'E', 'N', n, 1, n, a, lda, w, vr, ldvr, + $ work, -1, info ) + END IF + hswork = int( work(1) ) + maxwrk = max( maxwrk, hswork, minwrk ) + END IF + work( 1 ) = maxwrk +* + IF( lwork.LT.minwrk .AND. .NOT.lquery ) THEN + info = -12 + END IF + END IF +* + IF( info.NE.0 ) THEN + CALL xerbla( 'ZGEEV ', -info ) + RETURN + ELSE IF( lquery ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( n.EQ.0 ) + $ RETURN +* +* Get machine constants +* + eps = dlamch( 'P' ) + smlnum = dlamch( 'S' ) + bignum = one / smlnum + CALL dlabad( smlnum, bignum ) + smlnum = sqrt( smlnum ) / eps + bignum = one / smlnum +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + anrm = zlange( 'M', n, n, a, lda, dum ) + scalea = .false. + IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN + scalea = .true. + cscale = smlnum + ELSE IF( anrm.GT.bignum ) THEN + scalea = .true. + cscale = bignum + END IF + IF( scalea ) + $ CALL zlascl( 'G', 0, 0, anrm, cscale, n, n, a, lda, ierr ) +* +* Balance the matrix +* (CWorkspace: none) +* (RWorkspace: need N) +* + ibal = 1 + CALL zgebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr ) +* +* Reduce to upper Hessenberg form +* (CWorkspace: need 2*N, prefer N+N*NB) +* (RWorkspace: none) +* + itau = 1 + iwrk = itau + n + CALL zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ), + $ lwork-iwrk+1, ierr ) +* + IF( wantvl ) THEN +* +* Want left eigenvectors +* Copy Householder vectors to VL +* + side = 'L' + CALL zlacpy( 'L', n, n, a, lda, vl, ldvl ) +* +* Generate unitary matrix in VL +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL zunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ), + $ lwork-iwrk+1, ierr ) +* +* Perform QR iteration, accumulating Schur vectors in VL +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + iwrk = itau + CALL zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl, + $ work( iwrk ), lwork-iwrk+1, info ) +* + IF( wantvr ) THEN +* +* Want left and right eigenvectors +* Copy Schur vectors to VR +* + side = 'B' + CALL zlacpy( 'F', n, n, vl, ldvl, vr, ldvr ) + END IF +* + ELSE IF( wantvr ) THEN +* +* Want right eigenvectors +* Copy Householder vectors to VR +* + side = 'R' + CALL zlacpy( 'L', n, n, a, lda, vr, ldvr ) +* +* Generate unitary matrix in VR +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL zunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ), + $ lwork-iwrk+1, ierr ) +* +* Perform QR iteration, accumulating Schur vectors in VR +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + iwrk = itau + CALL zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr, + $ work( iwrk ), lwork-iwrk+1, info ) +* + ELSE +* +* Compute eigenvalues only +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + iwrk = itau + CALL zhseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr, + $ work( iwrk ), lwork-iwrk+1, info ) + END IF +* +* If INFO .NE. 0 from ZHSEQR, then quit +* + IF( info.NE.0 ) + $ GO TO 50 +* + IF( wantvl .OR. wantvr ) THEN +* +* Compute left and/or right eigenvectors +* (CWorkspace: need 2*N, prefer N + 2*N*NB) +* (RWorkspace: need 2*N) +* + irwork = ibal + n + CALL ztrevc3( side, 'B', SELECT, n, a, lda, vl, ldvl, vr, ldvr, + $ n, nout, work( iwrk ), lwork-iwrk+1, + $ rwork( irwork ), n, ierr ) + END IF +* + IF( wantvl ) THEN +* +* Undo balancing of left eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL zgebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl, + $ ierr ) +* +* Normalize left eigenvectors and make largest component real +* + DO 20 i = 1, n + scl = one / dznrm2( n, vl( 1, i ), 1 ) + CALL zdscal( n, scl, vl( 1, i ), 1 ) + DO 10 k = 1, n + rwork( irwork+k-1 ) = dble( vl( k, i ) )**2 + + $ aimag( vl( k, i ) )**2 + 10 CONTINUE + k = idamax( n, rwork( irwork ), 1 ) + tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) ) + CALL zscal( n, tmp, vl( 1, i ), 1 ) + vl( k, i ) = dcmplx( dble( vl( k, i ) ), zero ) + 20 CONTINUE + END IF +* + IF( wantvr ) THEN +* +* Undo balancing of right eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL zgebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr, + $ ierr ) +* +* Normalize right eigenvectors and make largest component real +* + DO 40 i = 1, n + scl = one / dznrm2( n, vr( 1, i ), 1 ) + CALL zdscal( n, scl, vr( 1, i ), 1 ) + DO 30 k = 1, n + rwork( irwork+k-1 ) = dble( vr( k, i ) )**2 + + $ aimag( vr( k, i ) )**2 + 30 CONTINUE + k = idamax( n, rwork( irwork ), 1 ) + tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) ) + CALL zscal( n, tmp, vr( 1, i ), 1 ) + vr( k, i ) = dcmplx( dble( vr( k, i ) ), zero ) + 40 CONTINUE + END IF +* +* Undo scaling if necessary +* + 50 CONTINUE + IF( scalea ) THEN + CALL zlascl( 'G', 0, 0, cscale, anrm, n-info, 1, w( info+1 ), + $ max( n-info, 1 ), ierr ) + IF( info.GT.0 ) THEN + CALL zlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr ) + END IF + END IF +* + work( 1 ) = maxwrk + RETURN +* +* End of ZGEEV +* + END +C +C====================================================================== +C +*> \brief \b IEEECK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* .. Scalar Arguments .. +* INTEGER ISPEC +* REAL ONE, ZERO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IEEECK is called from the ILAENV to verify that Infinity and +*> possibly NaN arithmetic is safe (i.e. will not trap). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies whether to test just for inifinity arithmetic +*> or whether to test for infinity and NaN arithmetic. +*> = 0: Verify infinity arithmetic only. +*> = 1: Verify infinity and NaN arithmetic. +*> \endverbatim +*> +*> \param[in] ZERO +*> \verbatim +*> ZERO is REAL +*> Must contain the value 0.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> \endverbatim +*> +*> \param[in] ONE +*> \verbatim +*> ONE is REAL +*> Must contain the value 1.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> +*> RETURN VALUE: INTEGER +*> = 0: Arithmetic failed to produce the correct answers +*> = 1: Arithmetic produced the correct answers +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ieeeck( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ negzro, newzro, posinf +* .. +* .. Executable Statements .. + ieeeck = 1 +* + posinf = one / zero + IF( posinf.LE.one ) THEN + ieeeck = 0 + RETURN + END IF +* + neginf = -one / zero + IF( neginf.GE.zero ) THEN + ieeeck = 0 + RETURN + END IF +* + negzro = one / ( neginf+one ) + IF( negzro.NE.zero ) THEN + ieeeck = 0 + RETURN + END IF +* + neginf = one / negzro + IF( neginf.GE.zero ) THEN + ieeeck = 0 + RETURN + END IF +* + newzro = negzro + zero + IF( newzro.NE.zero ) THEN + ieeeck = 0 + RETURN + END IF +* + posinf = one / newzro + IF( posinf.LE.one ) THEN + ieeeck = 0 + RETURN + END IF +* + neginf = neginf*posinf + IF( neginf.GE.zero ) THEN + ieeeck = 0 + RETURN + END IF +* + posinf = posinf*posinf + IF( posinf.LE.one ) THEN + ieeeck = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ispec.EQ.0 ) + $ RETURN +* + nan1 = posinf + neginf +* + nan2 = posinf / neginf +* + nan3 = posinf / posinf +* + nan4 = posinf*zero +* + nan5 = neginf*negzro +* + nan6 = nan5*zero +* + IF( nan1.EQ.nan1 ) THEN + ieeeck = 0 + RETURN + END IF +* + IF( nan2.EQ.nan2 ) THEN + ieeeck = 0 + RETURN + END IF +* + IF( nan3.EQ.nan3 ) THEN + ieeeck = 0 + RETURN + END IF +* + IF( nan4.EQ.nan4 ) THEN + ieeeck = 0 + RETURN + END IF +* + IF( nan5.EQ.nan5 ) THEN + ieeeck = 0 + RETURN + END IF +* + IF( nan6.EQ.nan6 ) THEN + ieeeck = 0 + RETURN + END IF +* + RETURN + END +C +C====================================================================== +C +*>v\brief \b ILAENV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAENV is called from the LAPACK routines to choose problem-dependent +*> parameters for the local environment. See ISPEC for a description of +*> the parameters. +*> +*> ILAENV returns an INTEGER +*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC +*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. +*> +*> This version provides a set of parameters which should give good, +*> but not optimal, performance on many of the currently available +*> computers. Users are encouraged to modify this subroutine to set +*> the tuning parameters for their particular machine using the option +*> and problem size information in the arguments. +*> +*> This routine will not function correctly if it is converted to all +*> lower case. Converting it to all upper case is allowed. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies the parameter to be returned as the value of +*> ILAENV. +*> = 1: the optimal blocksize; if this value is 1, an unblocked +*> algorithm will give the best performance. +*> = 2: the minimum block size for which the block routine +*> should be used; if the usable block size is less than +*> this value, an unblocked routine should be used. +*> = 3: the crossover point (in a block routine, for N less +*> than this value, an unblocked routine should be used) +*> = 4: the number of shifts, used in the nonsymmetric +*> eigenvalue routines (DEPRECATED) +*> = 5: the minimum column dimension for blocking to be used; +*> rectangular blocks must have dimension at least k by m, +*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) +*> = 6: the crossover point for the SVD (when reducing an m by n +*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +*> this value, a QR factorization is used first to reduce +*> the matrix to a triangular form.) +*> = 7: the number of processors +*> = 8: the crossover point for the multishift QR method +*> for nonsymmetric eigenvalue problems (DEPRECATED) +*> = 9: maximum size of the subproblems at the bottom of the +*> computation tree in the divide-and-conquer algorithm +*> (used by xGELSD and xGESDD) +*> =10: ieee NaN arithmetic can be trusted not to trap +*> =11: infinity arithmetic can be trusted not to trap +*> 12 <= ISPEC <= 16: +*> xHSEQR or related subroutines, +*> see IPARMQ for detailed explanation +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is CHARACTER*(*) +*> The name of the calling subroutine, in either upper case or +*> lower case. +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> \endverbatim +*> +*> \param[in] N3 +*> \verbatim +*> N3 is INTEGER +*> \endverbatim +*> +*> \param[in] N4 +*> \verbatim +*> N4 is INTEGER +*> Problem dimensions for the subroutine NAME; these may not all +*> be required. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The following conventions have been used when calling ILAENV from the +*> LAPACK routines: +*> 1) OPTS is a concatenation of all of the character options to +*> subroutine NAME, in the same order that they appear in the +*> argument list for NAME, even if they are not used in determining +*> the value of the parameter specified by ISPEC. +*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order +*> that they appear in the argument list for NAME. N1 is used +*> first, N2 second, and so on, and unused problem dimensions are +*> passed a value of -1. +*> 3) The parameter value returned by ILAENV is checked for validity in +*> the calling subroutine. For example, ILAENV is used to retrieve +*> the optimal blocksize for STRTRI as follows: +*> +*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +*> IF( NB.LE.1 ) NB = MAX( 1, N ) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ilaenv( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.8.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME, TWOSTAGE + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16 +* .. +* .. Intrinsic Functions .. + INTRINSIC char, ichar, int, min, real +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ, IPARAM2STAGE + EXTERNAL ieeeck, iparmq, iparam2stage +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160)ispec +* +* Invalid value for ISPEC +* + ilaenv = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ilaenv = 1 + subnam = name + ic = ichar( subnam( 1: 1 ) ) + iz = ichar( 'Z' ) + IF( iz.EQ.90 .OR. iz.EQ.122 ) THEN +* +* ASCII character set +* + IF( ic.GE.97 .AND. ic.LE.122 ) THEN + subnam( 1: 1 ) = char( ic-32 ) + DO 20 i = 2, 6 + ic = ichar( subnam( i: i ) ) + IF( ic.GE.97 .AND. ic.LE.122 ) + $ subnam( i: i ) = char( ic-32 ) + 20 CONTINUE + END IF +* + ELSE IF( iz.EQ.233 .OR. iz.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR. + $ ( ic.GE.145 .AND. ic.LE.153 ) .OR. + $ ( ic.GE.162 .AND. ic.LE.169 ) ) THEN + subnam( 1: 1 ) = char( ic+64 ) + DO 30 i = 2, 6 + ic = ichar( subnam( i: i ) ) + IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR. + $ ( ic.GE.145 .AND. ic.LE.153 ) .OR. + $ ( ic.GE.162 .AND. ic.LE.169 ) )subnam( i: + $ i ) = char( ic+64 ) + 30 CONTINUE + END IF +* + ELSE IF( iz.EQ.218 .OR. iz.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( ic.GE.225 .AND. ic.LE.250 ) THEN + subnam( 1: 1 ) = char( ic-32 ) + DO 40 i = 2, 6 + ic = ichar( subnam( i: i ) ) + IF( ic.GE.225 .AND. ic.LE.250 ) + $ subnam( i: i ) = char( ic-32 ) + 40 CONTINUE + END IF + END IF +* + c1 = subnam( 1: 1 ) + sname = c1.EQ.'S' .OR. c1.EQ.'D' + cname = c1.EQ.'C' .OR. c1.EQ.'Z' + IF( .NOT.( cname .OR. sname ) ) + $ RETURN + c2 = subnam( 2: 3 ) + c3 = subnam( 4: 6 ) + c4 = c3( 2: 3 ) + twostage = len( subnam ).GE.11 + $ .AND. subnam( 11: 11 ).EQ.'2' +* + GO TO ( 50, 60, 70 )ispec +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + nb = 1 +* + IF( c2.EQ.'GE' ) THEN + IF( c3.EQ.'TRF' ) THEN + IF( sname ) THEN + nb = 64 + ELSE + nb = 64 + END IF + ELSE IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR. + $ c3.EQ.'QLF' ) THEN + IF( sname ) THEN + nb = 32 + ELSE + nb = 32 + END IF + ELSE IF( c3.EQ.'QR ') THEN + IF( n3 .EQ. 1) THEN + IF( sname ) THEN +* M*N + IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN + nb = n1 + ELSE + nb = 32768/n2 + END IF + ELSE + IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN + nb = n1 + ELSE + nb = 32768/n2 + END IF + END IF + ELSE + IF( sname ) THEN + nb = 1 + ELSE + nb = 1 + END IF + END IF + ELSE IF( c3.EQ.'LQ ') THEN + IF( n3 .EQ. 2) THEN + IF( sname ) THEN +* M*N + IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN + nb = n1 + ELSE + nb = 32768/n2 + END IF + ELSE + IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN + nb = n1 + ELSE + nb = 32768/n2 + END IF + END IF + ELSE + IF( sname ) THEN + nb = 1 + ELSE + nb = 1 + END IF + END IF + ELSE IF( c3.EQ.'HRD' ) THEN + IF( sname ) THEN + nb = 32 + ELSE + nb = 32 + END IF + ELSE IF( c3.EQ.'BRD' ) THEN + IF( sname ) THEN + nb = 32 + ELSE + nb = 32 + END IF + ELSE IF( c3.EQ.'TRI' ) THEN + IF( sname ) THEN + nb = 64 + ELSE + nb = 64 + END IF + END IF + ELSE IF( c2.EQ.'PO' ) THEN + IF( c3.EQ.'TRF' ) THEN + IF( sname ) THEN + nb = 64 + ELSE + nb = 64 + END IF + END IF + ELSE IF( c2.EQ.'SY' ) THEN + IF( c3.EQ.'TRF' ) THEN + IF( sname ) THEN + IF( twostage ) THEN + nb = 192 + ELSE + nb = 64 + END IF + ELSE + IF( twostage ) THEN + nb = 192 + ELSE + nb = 64 + END IF + END IF + ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN + nb = 32 + ELSE IF( sname .AND. c3.EQ.'GST' ) THEN + nb = 64 + END IF + ELSE IF( cname .AND. c2.EQ.'HE' ) THEN + IF( c3.EQ.'TRF' ) THEN + IF( twostage ) THEN + nb = 192 + ELSE + nb = 64 + END IF + ELSE IF( c3.EQ.'TRD' ) THEN + nb = 32 + ELSE IF( c3.EQ.'GST' ) THEN + nb = 64 + END IF + ELSE IF( sname .AND. c2.EQ.'OR' ) THEN + IF( c3( 1: 1 ).EQ.'G' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nb = 32 + END IF + ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nb = 32 + END IF + END IF + ELSE IF( cname .AND. c2.EQ.'UN' ) THEN + IF( c3( 1: 1 ).EQ.'G' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nb = 32 + END IF + ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nb = 32 + END IF + END IF + ELSE IF( c2.EQ.'GB' ) THEN + IF( c3.EQ.'TRF' ) THEN + IF( sname ) THEN + IF( n4.LE.64 ) THEN + nb = 1 + ELSE + nb = 32 + END IF + ELSE + IF( n4.LE.64 ) THEN + nb = 1 + ELSE + nb = 32 + END IF + END IF + END IF + ELSE IF( c2.EQ.'PB' ) THEN + IF( c3.EQ.'TRF' ) THEN + IF( sname ) THEN + IF( n2.LE.64 ) THEN + nb = 1 + ELSE + nb = 32 + END IF + ELSE + IF( n2.LE.64 ) THEN + nb = 1 + ELSE + nb = 32 + END IF + END IF + END IF + ELSE IF( c2.EQ.'TR' ) THEN + IF( c3.EQ.'TRI' ) THEN + IF( sname ) THEN + nb = 64 + ELSE + nb = 64 + END IF + ELSE IF ( c3.EQ.'EVC' ) THEN + IF( sname ) THEN + nb = 64 + ELSE + nb = 64 + END IF + END IF + ELSE IF( c2.EQ.'LA' ) THEN + IF( c3.EQ.'UUM' ) THEN + IF( sname ) THEN + nb = 64 + ELSE + nb = 64 + END IF + END IF + ELSE IF( sname .AND. c2.EQ.'ST' ) THEN + IF( c3.EQ.'EBZ' ) THEN + nb = 1 + END IF + ELSE IF( c2.EQ.'GG' ) THEN + nb = 32 + IF( c3.EQ.'HD3' ) THEN + IF( sname ) THEN + nb = 32 + ELSE + nb = 32 + END IF + END IF + END IF + ilaenv = nb + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + nbmin = 2 + IF( c2.EQ.'GE' ) THEN + IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR. c3.EQ. + $ 'QLF' ) THEN + IF( sname ) THEN + nbmin = 2 + ELSE + nbmin = 2 + END IF + ELSE IF( c3.EQ.'HRD' ) THEN + IF( sname ) THEN + nbmin = 2 + ELSE + nbmin = 2 + END IF + ELSE IF( c3.EQ.'BRD' ) THEN + IF( sname ) THEN + nbmin = 2 + ELSE + nbmin = 2 + END IF + ELSE IF( c3.EQ.'TRI' ) THEN + IF( sname ) THEN + nbmin = 2 + ELSE + nbmin = 2 + END IF + END IF + ELSE IF( c2.EQ.'SY' ) THEN + IF( c3.EQ.'TRF' ) THEN + IF( sname ) THEN + nbmin = 8 + ELSE + nbmin = 8 + END IF + ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN + nbmin = 2 + END IF + ELSE IF( cname .AND. c2.EQ.'HE' ) THEN + IF( c3.EQ.'TRD' ) THEN + nbmin = 2 + END IF + ELSE IF( sname .AND. c2.EQ.'OR' ) THEN + IF( c3( 1: 1 ).EQ.'G' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nbmin = 2 + END IF + ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nbmin = 2 + END IF + END IF + ELSE IF( cname .AND. c2.EQ.'UN' ) THEN + IF( c3( 1: 1 ).EQ.'G' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nbmin = 2 + END IF + ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nbmin = 2 + END IF + END IF + ELSE IF( c2.EQ.'GG' ) THEN + nbmin = 2 + IF( c3.EQ.'HD3' ) THEN + nbmin = 2 + END IF + END IF + ilaenv = nbmin + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + nx = 0 + IF( c2.EQ.'GE' ) THEN + IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR. c3.EQ. + $ 'QLF' ) THEN + IF( sname ) THEN + nx = 128 + ELSE + nx = 128 + END IF + ELSE IF( c3.EQ.'HRD' ) THEN + IF( sname ) THEN + nx = 128 + ELSE + nx = 128 + END IF + ELSE IF( c3.EQ.'BRD' ) THEN + IF( sname ) THEN + nx = 128 + ELSE + nx = 128 + END IF + END IF + ELSE IF( c2.EQ.'SY' ) THEN + IF( sname .AND. c3.EQ.'TRD' ) THEN + nx = 32 + END IF + ELSE IF( cname .AND. c2.EQ.'HE' ) THEN + IF( c3.EQ.'TRD' ) THEN + nx = 32 + END IF + ELSE IF( sname .AND. c2.EQ.'OR' ) THEN + IF( c3( 1: 1 ).EQ.'G' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nx = 128 + END IF + END IF + ELSE IF( cname .AND. c2.EQ.'UN' ) THEN + IF( c3( 1: 1 ).EQ.'G' ) THEN + IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ. + $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' ) + $ THEN + nx = 128 + END IF + END IF + ELSE IF( c2.EQ.'GG' ) THEN + nx = 128 + IF( c3.EQ.'HD3' ) THEN + nx = 128 + END IF + END IF + ilaenv = nx + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ilaenv = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ilaenv = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ilaenv = int( REAL( MIN( N1, N2 ) )*1.6e0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ilaenv = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ilaenv = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ilaenv = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ilaenv = 1 + IF( ilaenv.EQ.1 ) THEN + ilaenv = ieeeck( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ilaenv = 1 + IF( ilaenv.EQ.1 ) THEN + ilaenv = ieeeck( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or related subroutines. +* + ilaenv = iparmq( ispec, name, opts, n1, n2, n3, n4 ) + RETURN +* +* End of ILAENV +* + END +C +C====================================================================== +C +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME(CA,CB) +* +* .. Scalar Arguments .. +* CHARACTER CA,CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> CA is CHARACTER*1 +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CB is CHARACTER*1 +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup aux_blas +* +* ===================================================================== + LOGICAL FUNCTION lsame(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ichar +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + lsame = ca .EQ. cb + IF (lsame) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + zcode = ichar('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + inta = ichar(ca) + intb = ichar(cb) +* + IF (zcode.EQ.90 .OR. zcode.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (inta.GE.97 .AND. inta.LE.122) inta = inta - 32 + IF (intb.GE.97 .AND. intb.LE.122) intb = intb - 32 +* + ELSE IF (zcode.EQ.233 .OR. zcode.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (inta.GE.129 .AND. inta.LE.137 .OR. + + inta.GE.145 .AND. inta.LE.153 .OR. + + inta.GE.162 .AND. inta.LE.169) inta = inta + 64 + IF (intb.GE.129 .AND. intb.LE.137 .OR. + + intb.GE.145 .AND. intb.LE.153 .OR. + + intb.GE.162 .AND. intb.LE.169) intb = intb + 64 +* + ELSE IF (zcode.EQ.218 .OR. zcode.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (inta.GE.225 .AND. inta.LE.250) inta = inta - 32 + IF (intb.GE.225 .AND. intb.LE.250) intb = intb - 32 + END IF + lsame = inta .EQ. intb +* +* RETURN +* +* End of LSAME +* + END +C +C====================================================================== +C +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup aux_blas +* +* ===================================================================== + SUBROUTINE xerbla( SRNAME, INFO ) +* +* -- Reference BLAS level1 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC len_trim +* .. +* .. Executable Statements .. +* + WRITE( *, fmt = 9999 )srname( 1:len_trim( srname ) ), info +* + stop +* + 9999 FORMAT( ' ** On entry to ', a, ' parameter number ', i2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END +C +C====================================================================== +C +*> \brief \b DCABS1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* .. Scalar Arguments .. +* COMPLEX*16 Z +* .. +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] Z +*> \verbatim +*> Z is COMPLEX*16 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup double_blas_level1 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION dcabs1(Z) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + COMPLEX*16 Z +* .. +* .. +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC abs,dble,dimag +* + dcabs1 = abs(dble(z)) + abs(dimag(z)) + RETURN + END +C +C====================================================================== +C +*> \brief \b IZAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup aux_blas +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 1/15/85. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION izamax(N,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL dcabs1 +* .. + izamax = 0 + IF (n.LT.1 .OR. incx.LE.0) RETURN + izamax = 1 + IF (n.EQ.1) RETURN + IF (incx.EQ.1) THEN +* +* code for increment equal to 1 +* + dmax = dcabs1(zx(1)) + DO i = 2,n + IF (dcabs1(zx(i)).GT.dmax) THEN + izamax = i + dmax = dcabs1(zx(i)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + ix = 1 + dmax = dcabs1(zx(1)) + ix = ix + incx + DO i = 2,n + IF (dcabs1(zx(ix)).GT.dmax) THEN + izamax = i + dmax = dcabs1(zx(ix)) + END IF + ix = ix + incx + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b ZGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zgemm(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX*16 A(lda,*),B(ldb,*),C(ldc,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg,max +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX*16 ONE + parameter(one= (1.0d+0,0.0d+0)) + COMPLEX*16 ZERO + parameter(zero= (0.0d+0,0.0d+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA, NCOLA and NROWB as the number of rows and columns of A +* and the number of rows of B respectively. +* + nota = lsame(transa,'N') + notb = lsame(transb,'N') + conja = lsame(transa,'C') + conjb = lsame(transb,'C') + IF (nota) THEN + nrowa = m + ncola = k + ELSE + nrowa = k + ncola = m + END IF + IF (notb) THEN + nrowb = k + ELSE + nrowb = n + END IF +* +* Test the input parameters. +* + info = 0 + IF ((.NOT.nota) .AND. (.NOT.conja) .AND. + + (.NOT.lsame(transa,'T'))) THEN + info = 1 + ELSE IF ((.NOT.notb) .AND. (.NOT.conjb) .AND. + + (.NOT.lsame(transb,'T'))) THEN + info = 2 + ELSE IF (m.LT.0) THEN + info = 3 + ELSE IF (n.LT.0) THEN + info = 4 + ELSE IF (k.LT.0) THEN + info = 5 + ELSE IF (lda.LT.max(1,nrowa)) THEN + info = 8 + ELSE IF (ldb.LT.max(1,nrowb)) THEN + info = 10 + ELSE IF (ldc.LT.max(1,m)) THEN + info = 13 + END IF + IF (info.NE.0) THEN + CALL xerbla('ZGEMM ',info) + RETURN + END IF +* +* Quick return if possible. +* + IF ((m.EQ.0) .OR. (n.EQ.0) .OR. + + (((alpha.EQ.zero).OR. (k.EQ.0)).AND. (beta.EQ.one))) RETURN +* +* And when alpha.eq.zero. +* + IF (alpha.EQ.zero) THEN + IF (beta.EQ.zero) THEN + DO 20 j = 1,n + DO 10 i = 1,m + c(i,j) = zero + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 j = 1,n + DO 30 i = 1,m + c(i,j) = beta*c(i,j) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (notb) THEN + IF (nota) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 j = 1,n + IF (beta.EQ.zero) THEN + DO 50 i = 1,m + c(i,j) = zero + 50 CONTINUE + ELSE IF (beta.NE.one) THEN + DO 60 i = 1,m + c(i,j) = beta*c(i,j) + 60 CONTINUE + END IF + DO 80 l = 1,k + temp = alpha*b(l,j) + DO 70 i = 1,m + c(i,j) = c(i,j) + temp*a(i,l) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (conja) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 j = 1,n + DO 110 i = 1,m + temp = zero + DO 100 l = 1,k + temp = temp + dconjg(a(l,i))*b(l,j) + 100 CONTINUE + IF (beta.EQ.zero) THEN + c(i,j) = alpha*temp + ELSE + c(i,j) = alpha*temp + beta*c(i,j) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 j = 1,n + DO 140 i = 1,m + temp = zero + DO 130 l = 1,k + temp = temp + a(l,i)*b(l,j) + 130 CONTINUE + IF (beta.EQ.zero) THEN + c(i,j) = alpha*temp + ELSE + c(i,j) = alpha*temp + beta*c(i,j) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (nota) THEN + IF (conjb) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 j = 1,n + IF (beta.EQ.zero) THEN + DO 160 i = 1,m + c(i,j) = zero + 160 CONTINUE + ELSE IF (beta.NE.one) THEN + DO 170 i = 1,m + c(i,j) = beta*c(i,j) + 170 CONTINUE + END IF + DO 190 l = 1,k + temp = alpha*dconjg(b(j,l)) + DO 180 i = 1,m + c(i,j) = c(i,j) + temp*a(i,l) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 j = 1,n + IF (beta.EQ.zero) THEN + DO 210 i = 1,m + c(i,j) = zero + 210 CONTINUE + ELSE IF (beta.NE.one) THEN + DO 220 i = 1,m + c(i,j) = beta*c(i,j) + 220 CONTINUE + END IF + DO 240 l = 1,k + temp = alpha*b(j,l) + DO 230 i = 1,m + c(i,j) = c(i,j) + temp*a(i,l) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (conja) THEN + IF (conjb) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 j = 1,n + DO 270 i = 1,m + temp = zero + DO 260 l = 1,k + temp = temp + dconjg(a(l,i))*dconjg(b(j,l)) + 260 CONTINUE + IF (beta.EQ.zero) THEN + c(i,j) = alpha*temp + ELSE + c(i,j) = alpha*temp + beta*c(i,j) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 j = 1,n + DO 300 i = 1,m + temp = zero + DO 290 l = 1,k + temp = temp + dconjg(a(l,i))*b(j,l) + 290 CONTINUE + IF (beta.EQ.zero) THEN + c(i,j) = alpha*temp + ELSE + c(i,j) = alpha*temp + beta*c(i,j) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (conjb) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 j = 1,n + DO 330 i = 1,m + temp = zero + DO 320 l = 1,k + temp = temp + a(l,i)*dconjg(b(j,l)) + 320 CONTINUE + IF (beta.EQ.zero) THEN + c(i,j) = alpha*temp + ELSE + c(i,j) = alpha*temp + beta*c(i,j) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 j = 1,n + DO 360 i = 1,m + temp = zero + DO 350 l = 1,k + temp = temp + a(l,i)*b(j,l) + 350 CONTINUE + IF (beta.EQ.zero) THEN + c(i,j) = alpha*temp + ELSE + c(i,j) = alpha*temp + beta*c(i,j) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMM . +* + END +C +C====================================================================== +C +*> \brief \b ZGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMV performs one of the matrix-vector operations +*> +*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or +*> +*> y := alpha*A**H*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are vectors and A is an +*> m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +*> +*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. +*> +*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +*> Before entry, the incremented array X must contain the +*> vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +*> and at least +*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +*> Before entry with BETA non-zero, the incremented array Y +*> must contain the vector y. On exit, Y is overwritten by the +*> updated vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zgemv(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A(lda,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + parameter(one= (1.0d+0,0.0d+0)) + COMPLEX*16 ZERO + parameter(zero= (0.0d+0,0.0d+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg,max +* .. +* +* Test the input parameters. +* + info = 0 + IF (.NOT.lsame(trans,'N') .AND. .NOT.lsame(trans,'T') .AND. + + .NOT.lsame(trans,'C')) THEN + info = 1 + ELSE IF (m.LT.0) THEN + info = 2 + ELSE IF (n.LT.0) THEN + info = 3 + ELSE IF (lda.LT.max(1,m)) THEN + info = 6 + ELSE IF (incx.EQ.0) THEN + info = 8 + ELSE IF (incy.EQ.0) THEN + info = 11 + END IF + IF (info.NE.0) THEN + CALL xerbla('ZGEMV ',info) + RETURN + END IF +* +* Quick return if possible. +* + IF ((m.EQ.0) .OR. (n.EQ.0) .OR. + + ((alpha.EQ.zero).AND. (beta.EQ.one))) RETURN +* + noconj = lsame(trans,'T') +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF (lsame(trans,'N')) THEN + lenx = n + leny = m + ELSE + lenx = m + leny = n + END IF + IF (incx.GT.0) THEN + kx = 1 + ELSE + kx = 1 - (lenx-1)*incx + END IF + IF (incy.GT.0) THEN + ky = 1 + ELSE + ky = 1 - (leny-1)*incy + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF (beta.NE.one) THEN + IF (incy.EQ.1) THEN + IF (beta.EQ.zero) THEN + DO 10 i = 1,leny + y(i) = zero + 10 CONTINUE + ELSE + DO 20 i = 1,leny + y(i) = beta*y(i) + 20 CONTINUE + END IF + ELSE + iy = ky + IF (beta.EQ.zero) THEN + DO 30 i = 1,leny + y(iy) = zero + iy = iy + incy + 30 CONTINUE + ELSE + DO 40 i = 1,leny + y(iy) = beta*y(iy) + iy = iy + incy + 40 CONTINUE + END IF + END IF + END IF + IF (alpha.EQ.zero) RETURN + IF (lsame(trans,'N')) THEN +* +* Form y := alpha*A*x + y. +* + jx = kx + IF (incy.EQ.1) THEN + DO 60 j = 1,n + temp = alpha*x(jx) + DO 50 i = 1,m + y(i) = y(i) + temp*a(i,j) + 50 CONTINUE + jx = jx + incx + 60 CONTINUE + ELSE + DO 80 j = 1,n + temp = alpha*x(jx) + iy = ky + DO 70 i = 1,m + y(iy) = y(iy) + temp*a(i,j) + iy = iy + incy + 70 CONTINUE + jx = jx + incx + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. +* + jy = ky + IF (incx.EQ.1) THEN + DO 110 j = 1,n + temp = zero + IF (noconj) THEN + DO 90 i = 1,m + temp = temp + a(i,j)*x(i) + 90 CONTINUE + ELSE + DO 100 i = 1,m + temp = temp + dconjg(a(i,j))*x(i) + 100 CONTINUE + END IF + y(jy) = y(jy) + alpha*temp + jy = jy + incy + 110 CONTINUE + ELSE + DO 140 j = 1,n + temp = zero + ix = kx + IF (noconj) THEN + DO 120 i = 1,m + temp = temp + a(i,j)*x(ix) + ix = ix + incx + 120 CONTINUE + ELSE + DO 130 i = 1,m + temp = temp + dconjg(a(i,j))*x(ix) + ix = ix + incx + 130 CONTINUE + END IF + y(jy) = y(jy) + alpha*temp + jy = jy + incy + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMV . +* + END +C +C====================================================================== +C +*> \brief \b ZSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zscal(N,ZA,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. + IF (n.LE.0 .OR. incx.LE.0) RETURN + IF (incx.EQ.1) THEN +* +* code for increment equal to 1 +* + DO i = 1,n + zx(i) = za*zx(i) + END DO + ELSE +* +* code for increment not equal to 1 +* + nincx = n*incx + DO i = 1,nincx,incx + zx(i) = za*zx(i) + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b ZSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSWAP interchanges two vectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zswap(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + IF (n.LE.0) RETURN + IF (incx.EQ.1 .AND. incy.EQ.1) THEN +* +* code for both increments equal to 1 + DO i = 1,n + ztemp = zx(i) + zx(i) = zy(i) + zy(i) = ztemp + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + ix = 1 + iy = 1 + IF (incx.LT.0) ix = (-n+1)*incx + 1 + IF (incy.LT.0) iy = (-n+1)*incy + 1 + DO i = 1,n + ztemp = zx(ix) + zx(ix) = zy(iy) + zy(iy) = ztemp + ix = ix + incx + iy = iy + incy + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b ZTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMM performs one of the matrix-matrix operations +*> +*> B := alpha*op( A )*B, or B := alpha*B*op( A ) +*> +*> where alpha is a scalar, B is an m by n matrix, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) multiplies B from +*> the left or right as follows: +*> +*> SIDE = 'L' or 'l' B := alpha*op( A )*B. +*> +*> SIDE = 'R' or 'r' B := alpha*B*op( A ). +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, k ), where k is m +*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ). +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B, and on exit is overwritten by the +*> transformed matrix. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ztrmm(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(lda,*),B(ldb,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg,max +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + parameter(one= (1.0d+0,0.0d+0)) + COMPLEX*16 ZERO + parameter(zero= (0.0d+0,0.0d+0)) +* .. +* +* Test the input parameters. +* + lside = lsame(side,'L') + IF (lside) THEN + nrowa = m + ELSE + nrowa = n + END IF + noconj = lsame(transa,'T') + nounit = lsame(diag,'N') + upper = lsame(uplo,'U') +* + info = 0 + IF ((.NOT.lside) .AND. (.NOT.lsame(side,'R'))) THEN + info = 1 + ELSE IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN + info = 2 + ELSE IF ((.NOT.lsame(transa,'N')) .AND. + + (.NOT.lsame(transa,'T')) .AND. + + (.NOT.lsame(transa,'C'))) THEN + info = 3 + ELSE IF ((.NOT.lsame(diag,'U')) .AND. (.NOT.lsame(diag,'N'))) THEN + info = 4 + ELSE IF (m.LT.0) THEN + info = 5 + ELSE IF (n.LT.0) THEN + info = 6 + ELSE IF (lda.LT.max(1,nrowa)) THEN + info = 9 + ELSE IF (ldb.LT.max(1,m)) THEN + info = 11 + END IF + IF (info.NE.0) THEN + CALL xerbla('ZTRMM ',info) + RETURN + END IF +* +* Quick return if possible. +* + IF (m.EQ.0 .OR. n.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (alpha.EQ.zero) THEN + DO 20 j = 1,n + DO 10 i = 1,m + b(i,j) = zero + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (lside) THEN + IF (lsame(transa,'N')) THEN +* +* Form B := alpha*A*B. +* + IF (upper) THEN + DO 50 j = 1,n + DO 40 k = 1,m + IF (b(k,j).NE.zero) THEN + temp = alpha*b(k,j) + DO 30 i = 1,k - 1 + b(i,j) = b(i,j) + temp*a(i,k) + 30 CONTINUE + IF (nounit) temp = temp*a(k,k) + b(k,j) = temp + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80 j = 1,n + DO 70 k = m,1,-1 + IF (b(k,j).NE.zero) THEN + temp = alpha*b(k,j) + b(k,j) = temp + IF (nounit) b(k,j) = b(k,j)*a(k,k) + DO 60 i = k + 1,m + b(i,j) = b(i,j) + temp*a(i,k) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A**T*B or B := alpha*A**H*B. +* + IF (upper) THEN + DO 120 j = 1,n + DO 110 i = m,1,-1 + temp = b(i,j) + IF (noconj) THEN + IF (nounit) temp = temp*a(i,i) + DO 90 k = 1,i - 1 + temp = temp + a(k,i)*b(k,j) + 90 CONTINUE + ELSE + IF (nounit) temp = temp*dconjg(a(i,i)) + DO 100 k = 1,i - 1 + temp = temp + dconjg(a(k,i))*b(k,j) + 100 CONTINUE + END IF + b(i,j) = alpha*temp + 110 CONTINUE + 120 CONTINUE + ELSE + DO 160 j = 1,n + DO 150 i = 1,m + temp = b(i,j) + IF (noconj) THEN + IF (nounit) temp = temp*a(i,i) + DO 130 k = i + 1,m + temp = temp + a(k,i)*b(k,j) + 130 CONTINUE + ELSE + IF (nounit) temp = temp*dconjg(a(i,i)) + DO 140 k = i + 1,m + temp = temp + dconjg(a(k,i))*b(k,j) + 140 CONTINUE + END IF + b(i,j) = alpha*temp + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (lsame(transa,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (upper) THEN + DO 200 j = n,1,-1 + temp = alpha + IF (nounit) temp = temp*a(j,j) + DO 170 i = 1,m + b(i,j) = temp*b(i,j) + 170 CONTINUE + DO 190 k = 1,j - 1 + IF (a(k,j).NE.zero) THEN + temp = alpha*a(k,j) + DO 180 i = 1,m + b(i,j) = b(i,j) + temp*b(i,k) + 180 CONTINUE + END IF + 190 CONTINUE + 200 CONTINUE + ELSE + DO 240 j = 1,n + temp = alpha + IF (nounit) temp = temp*a(j,j) + DO 210 i = 1,m + b(i,j) = temp*b(i,j) + 210 CONTINUE + DO 230 k = j + 1,n + IF (a(k,j).NE.zero) THEN + temp = alpha*a(k,j) + DO 220 i = 1,m + b(i,j) = b(i,j) + temp*b(i,k) + 220 CONTINUE + END IF + 230 CONTINUE + 240 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T or B := alpha*B*A**H. +* + IF (upper) THEN + DO 280 k = 1,n + DO 260 j = 1,k - 1 + IF (a(j,k).NE.zero) THEN + IF (noconj) THEN + temp = alpha*a(j,k) + ELSE + temp = alpha*dconjg(a(j,k)) + END IF + DO 250 i = 1,m + b(i,j) = b(i,j) + temp*b(i,k) + 250 CONTINUE + END IF + 260 CONTINUE + temp = alpha + IF (nounit) THEN + IF (noconj) THEN + temp = temp*a(k,k) + ELSE + temp = temp*dconjg(a(k,k)) + END IF + END IF + IF (temp.NE.one) THEN + DO 270 i = 1,m + b(i,k) = temp*b(i,k) + 270 CONTINUE + END IF + 280 CONTINUE + ELSE + DO 320 k = n,1,-1 + DO 300 j = k + 1,n + IF (a(j,k).NE.zero) THEN + IF (noconj) THEN + temp = alpha*a(j,k) + ELSE + temp = alpha*dconjg(a(j,k)) + END IF + DO 290 i = 1,m + b(i,j) = b(i,j) + temp*b(i,k) + 290 CONTINUE + END IF + 300 CONTINUE + temp = alpha + IF (nounit) THEN + IF (noconj) THEN + temp = temp*a(k,k) + ELSE + temp = temp*dconjg(a(k,k)) + END IF + END IF + IF (temp.NE.one) THEN + DO 310 i = 1,m + b(i,k) = temp*b(i,k) + 310 CONTINUE + END IF + 320 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMM . +* + END +C +C====================================================================== +C +*> \brief \b ZTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMV performs one of the matrix-vector operations +*> +*> x := A*x, or x := A**T*x, or x := A**H*x, +*> +*> where x is an n element vector and A is an n by n unit, or non-unit, +*> upper or lower triangular matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' x := A*x. +*> +*> TRANS = 'T' or 't' x := A**T*x. +*> +*> TRANS = 'C' or 'c' x := A**H*x. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ). +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. On exit, X is overwritten with the +*> transformed vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ztrmv(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(lda,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + parameter(zero= (0.0d+0,0.0d+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg,max +* .. +* +* Test the input parameters. +* + info = 0 + IF (.NOT.lsame(uplo,'U') .AND. .NOT.lsame(uplo,'L')) THEN + info = 1 + ELSE IF (.NOT.lsame(trans,'N') .AND. .NOT.lsame(trans,'T') .AND. + + .NOT.lsame(trans,'C')) THEN + info = 2 + ELSE IF (.NOT.lsame(diag,'U') .AND. .NOT.lsame(diag,'N')) THEN + info = 3 + ELSE IF (n.LT.0) THEN + info = 4 + ELSE IF (lda.LT.max(1,n)) THEN + info = 6 + ELSE IF (incx.EQ.0) THEN + info = 8 + END IF + IF (info.NE.0) THEN + CALL xerbla('ZTRMV ',info) + RETURN + END IF +* +* Quick return if possible. +* + IF (n.EQ.0) RETURN +* + noconj = lsame(trans,'T') + nounit = lsame(diag,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (incx.LE.0) THEN + kx = 1 - (n-1)*incx + ELSE IF (incx.NE.1) THEN + kx = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (lsame(trans,'N')) THEN +* +* Form x := A*x. +* + IF (lsame(uplo,'U')) THEN + IF (incx.EQ.1) THEN + DO 20 j = 1,n + IF (x(j).NE.zero) THEN + temp = x(j) + DO 10 i = 1,j - 1 + x(i) = x(i) + temp*a(i,j) + 10 CONTINUE + IF (nounit) x(j) = x(j)*a(j,j) + END IF + 20 CONTINUE + ELSE + jx = kx + DO 40 j = 1,n + IF (x(jx).NE.zero) THEN + temp = x(jx) + ix = kx + DO 30 i = 1,j - 1 + x(ix) = x(ix) + temp*a(i,j) + ix = ix + incx + 30 CONTINUE + IF (nounit) x(jx) = x(jx)*a(j,j) + END IF + jx = jx + incx + 40 CONTINUE + END IF + ELSE + IF (incx.EQ.1) THEN + DO 60 j = n,1,-1 + IF (x(j).NE.zero) THEN + temp = x(j) + DO 50 i = n,j + 1,-1 + x(i) = x(i) + temp*a(i,j) + 50 CONTINUE + IF (nounit) x(j) = x(j)*a(j,j) + END IF + 60 CONTINUE + ELSE + kx = kx + (n-1)*incx + jx = kx + DO 80 j = n,1,-1 + IF (x(jx).NE.zero) THEN + temp = x(jx) + ix = kx + DO 70 i = n,j + 1,-1 + x(ix) = x(ix) + temp*a(i,j) + ix = ix - incx + 70 CONTINUE + IF (nounit) x(jx) = x(jx)*a(j,j) + END IF + jx = jx - incx + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (lsame(uplo,'U')) THEN + IF (incx.EQ.1) THEN + DO 110 j = n,1,-1 + temp = x(j) + IF (noconj) THEN + IF (nounit) temp = temp*a(j,j) + DO 90 i = j - 1,1,-1 + temp = temp + a(i,j)*x(i) + 90 CONTINUE + ELSE + IF (nounit) temp = temp*dconjg(a(j,j)) + DO 100 i = j - 1,1,-1 + temp = temp + dconjg(a(i,j))*x(i) + 100 CONTINUE + END IF + x(j) = temp + 110 CONTINUE + ELSE + jx = kx + (n-1)*incx + DO 140 j = n,1,-1 + temp = x(jx) + ix = jx + IF (noconj) THEN + IF (nounit) temp = temp*a(j,j) + DO 120 i = j - 1,1,-1 + ix = ix - incx + temp = temp + a(i,j)*x(ix) + 120 CONTINUE + ELSE + IF (nounit) temp = temp*dconjg(a(j,j)) + DO 130 i = j - 1,1,-1 + ix = ix - incx + temp = temp + dconjg(a(i,j))*x(ix) + 130 CONTINUE + END IF + x(jx) = temp + jx = jx - incx + 140 CONTINUE + END IF + ELSE + IF (incx.EQ.1) THEN + DO 170 j = 1,n + temp = x(j) + IF (noconj) THEN + IF (nounit) temp = temp*a(j,j) + DO 150 i = j + 1,n + temp = temp + a(i,j)*x(i) + 150 CONTINUE + ELSE + IF (nounit) temp = temp*dconjg(a(j,j)) + DO 160 i = j + 1,n + temp = temp + dconjg(a(i,j))*x(i) + 160 CONTINUE + END IF + x(j) = temp + 170 CONTINUE + ELSE + jx = kx + DO 200 j = 1,n + temp = x(jx) + ix = jx + IF (noconj) THEN + IF (nounit) temp = temp*a(j,j) + DO 180 i = j + 1,n + ix = ix + incx + temp = temp + a(i,j)*x(ix) + 180 CONTINUE + ELSE + IF (nounit) temp = temp*dconjg(a(j,j)) + DO 190 i = j + 1,n + ix = ix + incx + temp = temp + dconjg(a(i,j))*x(ix) + 190 CONTINUE + END IF + x(jx) = temp + jx = jx + incx + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMV . +* + END +C +C====================================================================== +C +*> \brief \b ZGEBAK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB, SIDE +* INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION SCALE( * ) +* COMPLEX*16 V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEBAK forms the right or left eigenvectors of a complex general +*> matrix by backward transformation on the computed eigenvectors of the +*> balanced matrix output by ZGEBAL. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> Specifies the type of backward transformation required: +*> = 'N', do nothing, return immediately; +*> = 'P', do backward transformation for permutation only; +*> = 'S', do backward transformation for scaling only; +*> = 'B', do backward transformations for both permutation and +*> scaling. +*> JOB must be the same as the argument JOB supplied to ZGEBAL. +*> \endverbatim +*> +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': V contains right eigenvectors; +*> = 'L': V contains left eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows of the matrix V. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> The integers ILO and IHI determined by ZGEBAL. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION array, dimension (N) +*> Details of the permutation and scaling factors, as returned +*> by ZGEBAL. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of columns of the matrix V. M >= 0. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDV,M) +*> On entry, the matrix of right or left eigenvectors to be +*> transformed, as returned by ZHSEIN or ZTREVC. +*> On exit, V is overwritten by the transformed eigenvectors. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. LDV >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + SUBROUTINE zgebak( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 V( ldv, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + parameter( one = 1.0d+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFTV, RIGHTV + INTEGER I, II, K + DOUBLE PRECISION S +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zdscal, zswap +* .. +* .. Intrinsic Functions .. + INTRINSIC max, min +* .. +* .. Executable Statements .. +* +* Decode and Test the input parameters +* + rightv = lsame( side, 'R' ) + leftv = lsame( side, 'L' ) +* + info = 0 + IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND. + $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN + info = -1 + ELSE IF( .NOT.rightv .AND. .NOT.leftv ) THEN + info = -2 + ELSE IF( n.LT.0 ) THEN + info = -3 + ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN + info = -4 + ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN + info = -5 + ELSE IF( m.LT.0 ) THEN + info = -7 + ELSE IF( ldv.LT.max( 1, n ) ) THEN + info = -9 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZGEBAK', -info ) + RETURN + END IF +* +* Quick return if possible +* + IF( n.EQ.0 ) + $ RETURN + IF( m.EQ.0 ) + $ RETURN + IF( lsame( job, 'N' ) ) + $ RETURN +* + IF( ilo.EQ.ihi ) + $ GO TO 30 +* +* Backward balance +* + IF( lsame( job, 'S' ) .OR. lsame( job, 'B' ) ) THEN +* + IF( rightv ) THEN + DO 10 i = ilo, ihi + s = scale( i ) + CALL zdscal( m, s, v( i, 1 ), ldv ) + 10 CONTINUE + END IF +* + IF( leftv ) THEN + DO 20 i = ilo, ihi + s = one / scale( i ) + CALL zdscal( m, s, v( i, 1 ), ldv ) + 20 CONTINUE + END IF +* + END IF +* +* Backward permutation +* +* For I = ILO-1 step -1 until 1, +* IHI+1 step 1 until N do -- +* + 30 CONTINUE + IF( lsame( job, 'P' ) .OR. lsame( job, 'B' ) ) THEN + IF( rightv ) THEN + DO 40 ii = 1, n + i = ii + IF( i.GE.ilo .AND. i.LE.ihi ) + $ GO TO 40 + IF( i.LT.ilo ) + $ i = ilo - ii + k = scale( i ) + IF( k.EQ.i ) + $ GO TO 40 + CALL zswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) + 40 CONTINUE + END IF +* + IF( leftv ) THEN + DO 50 ii = 1, n + i = ii + IF( i.GE.ilo .AND. i.LE.ihi ) + $ GO TO 50 + IF( i.LT.ilo ) + $ i = ilo - ii + k = scale( i ) + IF( k.EQ.i ) + $ GO TO 50 + CALL zswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) + 50 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEBAK +* + END +C +C======================================================================= +C +*> \brief \b ZGEBAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION SCALE( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEBAL balances a general complex matrix A. This involves, first, +*> permuting A by a similarity transformation to isolate eigenvalues +*> in the first 1 to ILO-1 and last IHI+1 to N elements on the +*> diagonal; and second, applying a diagonal similarity transformation +*> to rows and columns ILO to IHI to make the rows and columns as +*> close in norm as possible. Both steps are optional. +*> +*> Balancing may reduce the 1-norm of the matrix, and improve the +*> accuracy of the computed eigenvalues and/or eigenvectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> Specifies the operations to be performed on A: +*> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 +*> for i = 1,...,N; +*> = 'P': permute only; +*> = 'S': scale only; +*> = 'B': both permute and scale. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the input matrix A. +*> On exit, A is overwritten by the balanced matrix. +*> If JOB = 'N', A is not referenced. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[out] IHI +*> \verbatim +*> IHI is INTEGER +*> ILO and IHI are set to INTEGER such that on exit +*> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. +*> If JOB = 'N' or 'S', ILO = 1 and IHI = N. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION array, dimension (N) +*> Details of the permutations and scaling factors applied to +*> A. If P(j) is the index of the row and column interchanged +*> with row and column j and D(j) is the scaling factor +*> applied to row and column j, then +*> SCALE(j) = P(j) for j = 1,...,ILO-1 +*> = D(j) for j = ILO,...,IHI +*> = P(j) for j = IHI+1,...,N. +*> The order in which the interchanges are made is N to IHI+1, +*> then 1 to ILO-1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup complex16GEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The permutations consist of row and column interchanges which put +*> the matrix in the form +*> +*> ( T1 X Y ) +*> P A P = ( 0 B Z ) +*> ( 0 0 T2 ) +*> +*> where T1 and T2 are upper triangular matrices whose eigenvalues lie +*> along the diagonal. The column indices ILO and IHI mark the starting +*> and ending columns of the submatrix B. Balancing consists of applying +*> a diagonal similarity transformation inv(D) * B * D to make the +*> 1-norms of each row of B and its corresponding column nearly equal. +*> The output matrix is +*> +*> ( T1 X*D Y ) +*> ( 0 inv(D)*B*D inv(D)*Z ). +*> ( 0 0 T2 ) +*> +*> Information about the permutations P and the diagonal matrix D is +*> returned in the vector SCALE. +*> +*> This subroutine is based on the EISPACK routine CBAL. +*> +*> Modified by Tzu-Yi Chen, Computer Science Division, University of +*> California at Berkeley, USA +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zgebal( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK computational routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 A( lda, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + parameter( zero = 0.0d+0, one = 1.0d+0 ) + DOUBLE PRECISION SCLFAC + parameter( sclfac = 2.0d+0 ) + DOUBLE PRECISION FACTOR + parameter( factor = 0.95d+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IEXC, IRA, J, K, L, M + DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, + $ sfmin2 +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL disnan, lsame, izamax, dlamch, dznrm2 +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zdscal, zswap +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dimag, max, min +* +* Test the input parameters +* + info = 0 + IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND. + $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN + info = -1 + ELSE IF( n.LT.0 ) THEN + info = -2 + ELSE IF( lda.LT.max( 1, n ) ) THEN + info = -4 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZGEBAL', -info ) + RETURN + END IF +* + k = 1 + l = n +* + IF( n.EQ.0 ) + $ GO TO 210 +* + IF( lsame( job, 'N' ) ) THEN + DO 10 i = 1, n + scale( i ) = one + 10 CONTINUE + GO TO 210 + END IF +* + IF( lsame( job, 'S' ) ) + $ GO TO 120 +* +* Permutation to isolate eigenvalues if possible +* + GO TO 50 +* +* Row and column exchange. +* + 20 CONTINUE + scale( m ) = j + IF( j.EQ.m ) + $ GO TO 30 +* + CALL zswap( l, a( 1, j ), 1, a( 1, m ), 1 ) + CALL zswap( n-k+1, a( j, k ), lda, a( m, k ), lda ) +* + 30 CONTINUE + GO TO ( 40, 80 )iexc +* +* Search for rows isolating an eigenvalue and push them down. +* + 40 CONTINUE + IF( l.EQ.1 ) + $ GO TO 210 + l = l - 1 +* + 50 CONTINUE + DO 70 j = l, 1, -1 +* + DO 60 i = 1, l + IF( i.EQ.j ) + $ GO TO 60 + IF( dble( a( j, i ) ).NE.zero .OR. dimag( a( j, i ) ).NE. + $ zero )GO TO 70 + 60 CONTINUE +* + m = l + iexc = 1 + GO TO 20 + 70 CONTINUE +* + GO TO 90 +* +* Search for columns isolating an eigenvalue and push them left. +* + 80 CONTINUE + k = k + 1 +* + 90 CONTINUE + DO 110 j = k, l +* + DO 100 i = k, l + IF( i.EQ.j ) + $ GO TO 100 + IF( dble( a( i, j ) ).NE.zero .OR. dimag( a( i, j ) ).NE. + $ zero )GO TO 110 + 100 CONTINUE +* + m = k + iexc = 2 + GO TO 20 + 110 CONTINUE +* + 120 CONTINUE + DO 130 i = k, l + scale( i ) = one + 130 CONTINUE +* + IF( lsame( job, 'P' ) ) + $ GO TO 210 +* +* Balance the submatrix in rows K to L. +* +* Iterative loop for norm reduction +* + sfmin1 = dlamch( 'S' ) / dlamch( 'P' ) + sfmax1 = one / sfmin1 + sfmin2 = sfmin1*sclfac + sfmax2 = one / sfmin2 + 140 CONTINUE + noconv = .false. +* + DO 200 i = k, l +* + c = dznrm2( l-k+1, a( k, i ), 1 ) + r = dznrm2( l-k+1, a( i, k ), lda ) + ica = izamax( l, a( 1, i ), 1 ) + ca = abs( a( ica, i ) ) + ira = izamax( n-k+1, a( i, k ), lda ) + ra = abs( a( i, ira+k-1 ) ) +* +* Guard against zero C or R due to underflow. +* + IF( c.EQ.zero .OR. r.EQ.zero ) + $ GO TO 200 + g = r / sclfac + f = one + s = c + r + 160 CONTINUE + IF( c.GE.g .OR. max( f, c, ca ).GE.sfmax2 .OR. + $ min( r, g, ra ).LE.sfmin2 )GO TO 170 + IF( disnan( c+f+ca+r+g+ra ) ) THEN +* +* Exit if NaN to avoid infinite loop +* + info = -3 + CALL xerbla( 'ZGEBAL', -info ) + RETURN + END IF + f = f*sclfac + c = c*sclfac + ca = ca*sclfac + r = r / sclfac + g = g / sclfac + ra = ra / sclfac + GO TO 160 +* + 170 CONTINUE + g = c / sclfac + 180 CONTINUE + IF( g.LT.r .OR. max( r, ra ).GE.sfmax2 .OR. + $ min( f, c, g, ca ).LE.sfmin2 )GO TO 190 + f = f / sclfac + c = c / sclfac + g = g / sclfac + ca = ca / sclfac + r = r*sclfac + ra = ra*sclfac + GO TO 180 +* +* Now balance. +* + 190 CONTINUE + IF( ( c+r ).GE.factor*s ) + $ GO TO 200 + IF( f.LT.one .AND. scale( i ).LT.one ) THEN + IF( f*scale( i ).LE.sfmin1 ) + $ GO TO 200 + END IF + IF( f.GT.one .AND. scale( i ).GT.one ) THEN + IF( scale( i ).GE.sfmax1 / f ) + $ GO TO 200 + END IF + g = one / f + scale( i ) = scale( i )*f + noconv = .true. +* + CALL zdscal( n-k+1, g, a( i, k ), lda ) + CALL zdscal( l, f, a( 1, i ), 1 ) +* + 200 CONTINUE +* + IF( noconv ) + $ GO TO 140 +* + 210 CONTINUE + ilo = k + ihi = l +* + RETURN +* +* End of ZGEBAL +* + END +C +C======================================================================= +C +*> \brief \b ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H +*> by a unitary similarity transformation: Q**H * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to ZGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= max(1,N). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the n by n general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the unitary matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16GEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zgehd2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + parameter( one = ( 1.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zlarf, zlarfg +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg, max, min +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + info = 0 + IF( n.LT.0 ) THEN + info = -1 + ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN + info = -2 + ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN + info = -3 + ELSE IF( lda.LT.max( 1, n ) ) THEN + info = -5 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZGEHD2', -info ) + RETURN + END IF +* + DO 10 i = ilo, ihi - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + alpha = a( i+1, i ) + CALL zlarfg( ihi-i, alpha, a( min( i+2, n ), i ), 1, tau( i ) ) + a( i+1, i ) = one +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL zlarf( 'Right', ihi, ihi-i, a( i+1, i ), 1, tau( i ), + $ a( 1, i+1 ), lda, work ) +* +* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left +* + CALL zlarf( 'Left', ihi-i, n-i, a( i+1, i ), 1, + $ dconjg( tau( i ) ), a( i+1, i+1 ), lda, work ) +* + a( i+1, i ) = alpha + 10 CONTINUE +* + RETURN +* +* End of ZGEHD2 +* + END +C +C======================================================================= +C +*> \brief \b ZGEHRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by +*> an unitary similarity transformation: Q**H * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to ZGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the unitary matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to +*> zero. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,N). +*> For good performance, LWORK should generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16GEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> +*> This file is a slight modification of LAPACK-3.0's DGEHRD +*> subroutine incorporating improvements proposed by Quintana-Orti and +*> Van de Geijn (2006). (See DLAHR2.) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zgehrd( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + parameter( nbmax = 64, ldt = nbmax+1, + $ tsize = ldt*nbmax ) + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d+0, 0.0d+0 ), + $ one = ( 1.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, + $ nbmin, nh, nx + COMPLEX*16 EI +* .. +* .. External Subroutines .. + EXTERNAL zaxpy, zgehd2, zgemm, zlahr2, zlarfb, ztrmm, + $ xerbla +* .. +* .. Intrinsic Functions .. + INTRINSIC max, min +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ilaenv +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + info = 0 + lquery = ( lwork.EQ.-1 ) + IF( n.LT.0 ) THEN + info = -1 + ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN + info = -2 + ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN + info = -3 + ELSE IF( lda.LT.max( 1, n ) ) THEN + info = -5 + ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN + info = -8 + END IF +* + IF( info.EQ.0 ) THEN +* +* Compute the workspace requirements +* + nb = min( nbmax, ilaenv( 1, 'ZGEHRD', ' ', n, ilo, ihi, -1 ) ) + lwkopt = n*nb + tsize + work( 1 ) = lwkopt + ENDIF +* + IF( info.NE.0 ) THEN + CALL xerbla( 'ZGEHRD', -info ) + RETURN + ELSE IF( lquery ) THEN + RETURN + END IF +* +* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero +* + DO 10 i = 1, ilo - 1 + tau( i ) = zero + 10 CONTINUE + DO 20 i = max( 1, ihi ), n - 1 + tau( i ) = zero + 20 CONTINUE +* +* Quick return if possible +* + nh = ihi - ilo + 1 + IF( nh.LE.1 ) THEN + work( 1 ) = 1 + RETURN + END IF +* +* Determine the block size +* + nb = min( nbmax, ilaenv( 1, 'ZGEHRD', ' ', n, ilo, ihi, -1 ) ) + nbmin = 2 + IF( nb.GT.1 .AND. nb.LT.nh ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code) +* + nx = max( nb, ilaenv( 3, 'ZGEHRD', ' ', n, ilo, ihi, -1 ) ) + IF( nx.LT.nh ) THEN +* +* Determine if workspace is large enough for blocked code +* + IF( lwork.LT.n*nb+tsize ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code +* + nbmin = max( 2, ilaenv( 2, 'ZGEHRD', ' ', n, ilo, ihi, + $ -1 ) ) + IF( lwork.GE.(n*nbmin + tsize) ) THEN + nb = (lwork-tsize) / n + ELSE + nb = 1 + END IF + END IF + END IF + END IF + ldwork = n +* + IF( nb.LT.nbmin .OR. nb.GE.nh ) THEN +* +* Use unblocked code below +* + i = ilo +* + ELSE +* +* Use blocked code +* + iwt = 1 + n*nb + DO 40 i = ilo, ihi - 1 - nx, nb + ib = min( nb, ihi-i ) +* +* Reduce columns i:i+ib-1 to Hessenberg form, returning the +* matrices V and T of the block reflector H = I - V*T*V**H +* which performs the reduction, and also the matrix Y = A*V*T +* + CALL zlahr2( ihi, i, ib, a( 1, i ), lda, tau( i ), + $ work( iwt ), ldt, work, ldwork ) +* +* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the +* right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set +* to 1 +* + ei = a( i+ib, i+ib-1 ) + a( i+ib, i+ib-1 ) = one + CALL zgemm( 'No transpose', 'Conjugate transpose', + $ ihi, ihi-i-ib+1, + $ ib, -one, work, ldwork, a( i+ib, i ), lda, one, + $ a( 1, i+ib ), lda ) + a( i+ib, i+ib-1 ) = ei +* +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', i, ib-1, + $ one, a( i+1, i ), lda, work, ldwork ) + DO 30 j = 0, ib-2 + CALL zaxpy( i, -one, work( ldwork*j+1 ), 1, + $ a( 1, i+j+1 ), 1 ) + 30 CONTINUE +* +* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the +* left +* + CALL zlarfb( 'Left', 'Conjugate transpose', 'Forward', + $ 'Columnwise', + $ ihi-i, n-i-ib+1, ib, a( i+1, i ), lda, + $ work( iwt ), ldt, a( i+1, i+ib ), lda, + $ work, ldwork ) + 40 CONTINUE + END IF +* +* Use unblocked code to reduce the rest of the matrix +* + CALL zgehd2( n, i, ihi, a, lda, tau, work, iinfo ) + work( 1 ) = lwkopt +* + RETURN +* +* End of ZGEHRD +* + END +C +C======================================================================= +C +*> \brief \b ZHSEQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHSEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N +* CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHSEQR computes the eigenvalues of a Hessenberg matrix H +*> and, optionally, the matrices T and Z from the Schur decomposition +*> H = Z T Z**H, where T is an upper triangular matrix (the +*> Schur form), and Z is the unitary matrix of Schur vectors. +*> +*> Optionally Z may be postmultiplied into an input unitary +*> matrix Q so that this routine can give the Schur factorization +*> of a matrix A which has been reduced to the Hessenberg form H +*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> = 'E': compute eigenvalues only; +*> = 'S': compute eigenvalues and the Schur form T. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': no Schur vectors are computed; +*> = 'I': Z is initialized to the unit matrix and the matrix Z +*> of Schur vectors of H is returned; +*> = 'V': Z must contain an unitary matrix Q on entry, and +*> the product Q*Z is returned. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that H is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to ZGEBAL, and then passed to ZGEHRD +*> when the matrix output by ZGEBAL is reduced to Hessenberg +*> form. Otherwise ILO and IHI should be set to 1 and N +*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +*> If N = 0, then ILO = 1 and IHI = 0. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO = 0 and JOB = 'S', H contains the upper +*> triangular matrix T from the Schur decomposition (the +*> Schur form). If INFO = 0 and JOB = 'E', the contents of +*> H are unspecified on exit. (The output value of H when +*> INFO.GT.0 is given under the description of INFO below.) +*> +*> Unlike earlier versions of ZHSEQR, this subroutine may +*> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 +*> or j = IHI+1, IHI+2, ... N. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (N) +*> The computed eigenvalues. If JOB = 'S', the eigenvalues are +*> stored in the same order as on the diagonal of the Schur +*> form returned in H, with W(i) = H(i,i). +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ,N) +*> If COMPZ = 'N', Z is not referenced. +*> If COMPZ = 'I', on entry Z need not be set and on exit, +*> if INFO = 0, Z contains the unitary matrix Z of the Schur +*> vectors of H. If COMPZ = 'V', on entry Z must contain an +*> N-by-N matrix Q, which is assumed to be equal to the unit +*> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, +*> if INFO = 0, Z contains Q*Z. +*> Normally Q is the unitary matrix generated by ZUNGHR +*> after the call to ZGEHRD which formed the Hessenberg matrix +*> H. (The output value of Z when INFO.GT.0 is given under +*> the description of INFO below.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if COMPZ = 'I' or +*> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK .GE. max(1,N) +*> is sufficient and delivers very good and sometimes +*> optimal performance. However, LWORK as large as 11*N +*> may be required for optimal performance. A workspace +*> query is recommended to determine the optimal workspace +*> size. +*> +*> If LWORK = -1, then ZHSEQR does a workspace query. +*> In this case, ZHSEQR checks the input parameters and +*> estimates the optimal workspace size for the given +*> values of N, ILO and IHI. The estimate is returned +*> in WORK(1). No error message related to LWORK is +*> issued by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .LT. 0: if INFO = -i, the i-th argument had an illegal +*> value +*> .GT. 0: if INFO = i, ZHSEQR failed to compute all of +*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +*> and WI contain those eigenvalues which have been +*> successfully computed. (Failures are rare.) +*> +*> If INFO .GT. 0 and JOB = 'E', then on exit, the +*> remaining unconverged eigenvalues are the eigen- +*> values of the upper Hessenberg matrix rows and +*> columns ILO through INFO of the final, output +*> value of H. +*> +*> If INFO .GT. 0 and JOB = 'S', then on exit +*> +*> (*) (initial value of H)*U = U*(final value of H) +*> +*> where U is a unitary matrix. The final +*> value of H is upper Hessenberg and triangular in +*> rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and COMPZ = 'V', then on exit +*> +*> (final value of Z) = (initial value of Z)*U +*> +*> where U is the unitary matrix in (*) (regard- +*> less of the value of JOB.) +*> +*> If INFO .GT. 0 and COMPZ = 'I', then on exit +*> (final value of Z) = U +*> where U is the unitary matrix in (*) (regard- +*> less of the value of JOB.) +*> +*> If INFO .GT. 0 and COMPZ = 'N', then Z is not +*> accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Default values supplied by +*> ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). +*> It is suggested that these defaults be adjusted in order +*> to attain best performance in each particular +*> computational environment. +*> +*> ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> ISPEC=13: Recommended deflation window size. +*> This depends on ILO, IHI and NS. NS is the +*> number of simultaneous shifts returned +*> by ILAENV(ISPEC=15). (See ISPEC=15 below.) +*> The default for (IHI-ILO+1).LE.500 is NS. +*> The default for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> ISPEC=14: Nibble crossover point. (See IPARMQ for +*> details.) Default: 14% of deflation window +*> size. +*> +*> ISPEC=15: Number of simultaneous shifts in a multishift +*> QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 1 30 NS = 2(+) +*> 30 60 NS = 4(+) +*> 60 150 NS = 10(+) +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default some or all matrices of this order +*> are passed to the implicit double shift routine +*> ZLAHQR and this parameter is ignored. See +*> ISPEC=12 above and comments in IPARMQ for +*> details. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function of N increasing from 10 to 64. +*> +*> ISPEC=16: Select structured matrix multiply. +*> If the number of simultaneous shifts (specified +*> by ISPEC=15) is less than 14, then the default +*> for ISPEC=16 is 0. Otherwise the default for +*> ISPEC=16 is 2. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> \n +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +*> of Matrix Analysis, volume 23, pages 948--973, 2002. +* +* ===================================================================== + SUBROUTINE zhseqr( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), W( * ), WORK( * ), Z( ldz, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + parameter( ntiny = 11 ) +* +* ==== NL allocates some local workspace to help small matrices +* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- +* . mended. (The default value of NMIN is 75.) Using NL = 49 +* . allows up to six simultaneous shifts and a 16-by-16 +* . deflation window. ==== + INTEGER NL + parameter( nl = 49 ) + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d0, 0.0d0 ), + $ one = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + parameter( rzero = 0.0d0 ) +* .. +* .. Local Arrays .. + COMPLEX*16 HL( nl, nl ), WORKL( nl ) +* .. +* .. Local Scalars .. + INTEGER KBOT, NMIN + LOGICAL INITZ, LQUERY, WANTT, WANTZ +* .. +* .. External Functions .. + INTEGER ILAENV + LOGICAL LSAME + EXTERNAL ilaenv, lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zcopy, zlacpy, zlahqr, zlaqr0, zlaset +* .. +* .. Intrinsic Functions .. + INTRINSIC dble, dcmplx, max, min +* .. +* .. Executable Statements .. +* +* ==== Decode and check the input parameters. ==== +* + wantt = lsame( job, 'S' ) + initz = lsame( compz, 'I' ) + wantz = initz .OR. lsame( compz, 'V' ) + work( 1 ) = dcmplx( dble( max( 1, n ) ), rzero ) + lquery = lwork.EQ.-1 +* + info = 0 + IF( .NOT.lsame( job, 'E' ) .AND. .NOT.wantt ) THEN + info = -1 + ELSE IF( .NOT.lsame( compz, 'N' ) .AND. .NOT.wantz ) THEN + info = -2 + ELSE IF( n.LT.0 ) THEN + info = -3 + ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN + info = -4 + ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN + info = -5 + ELSE IF( ldh.LT.max( 1, n ) ) THEN + info = -7 + ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.max( 1, n ) ) ) THEN + info = -10 + ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN + info = -12 + END IF +* + IF( info.NE.0 ) THEN +* +* ==== Quick return in case of invalid argument. ==== +* + CALL xerbla( 'ZHSEQR', -info ) + RETURN +* + ELSE IF( n.EQ.0 ) THEN +* +* ==== Quick return in case N = 0; nothing to do. ==== +* + RETURN +* + ELSE IF( lquery ) THEN +* +* ==== Quick return in case of a workspace query ==== +* + CALL zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z, + $ ldz, work, lwork, info ) +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== + work( 1 ) = dcmplx( max( dble( work( 1 ) ), dble( max( 1, + $ n ) ) ), rzero ) + RETURN +* + ELSE +* +* ==== copy eigenvalues isolated by ZGEBAL ==== +* + IF( ilo.GT.1 ) + $ CALL zcopy( ilo-1, h, ldh+1, w, 1 ) + IF( ihi.LT.n ) + $ CALL zcopy( n-ihi, h( ihi+1, ihi+1 ), ldh+1, w( ihi+1 ), 1 ) +* +* ==== Initialize Z, if requested ==== +* + IF( initz ) + $ CALL zlaset( 'A', n, n, zero, one, z, ldz ) +* +* ==== Quick return if possible ==== +* + IF( ilo.EQ.ihi ) THEN + w( ilo ) = h( ilo, ilo ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + nmin = ilaenv( 12, 'ZHSEQR', job( : 1 ) // compz( : 1 ), n, + $ ilo, ihi, lwork ) + nmin = max( ntiny, nmin ) +* +* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== +* + IF( n.GT.nmin ) THEN + CALL zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, + $ z, ldz, work, lwork, info ) + ELSE +* +* ==== Small matrix ==== +* + CALL zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, + $ z, ldz, info ) +* + IF( info.GT.0 ) THEN +* +* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds +* . when ZLAHQR fails. ==== +* + kbot = info +* + IF( n.GE.nl ) THEN +* +* ==== Larger matrices have enough subdiagonal scratch +* . space to call ZLAQR0 directly. ==== +* + CALL zlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, w, + $ ilo, ihi, z, ldz, work, lwork, info ) +* + ELSE +* +* ==== Tiny matrices don't have enough subdiagonal +* . scratch space to benefit from ZLAQR0. Hence, +* . tiny matrices must be copied into a larger +* . array before calling ZLAQR0. ==== +* + CALL zlacpy( 'A', n, n, h, ldh, hl, nl ) + hl( n+1, n ) = zero + CALL zlaset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ), + $ nl ) + CALL zlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w, + $ ilo, ihi, z, ldz, workl, nl, info ) + IF( wantt .OR. info.NE.0 ) + $ CALL zlacpy( 'A', n, n, hl, nl, h, ldh ) + END IF + END IF + END IF +* +* ==== Clear out the trash, if necessary. ==== +* + IF( ( wantt .OR. info.NE.0 ) .AND. n.GT.2 ) + $ CALL zlaset( 'L', n-2, n-2, zero, zero, h( 3, 1 ), ldh ) +* +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== +* + work( 1 ) = dcmplx( max( dble( max( 1, n ) ), + $ dble( work( 1 ) ) ), rzero ) + END IF +* +* ==== End of ZHSEQR ==== +* + END +C +C======================================================================= +C +*> \brief \b ZLACGV conjugates a complex vector. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLACGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLACGV( N, X, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* .. +* .. Array Arguments .. +* COMPLEX*16 X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLACGV conjugates a complex vector of length N. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The length of the vector X. N >= 0. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension +*> (1+(N-1)*abs(INCX)) +*> On entry, the vector of length N to be conjugated. +*> On exit, X is overwritten with conjg(X). +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The spacing between successive elements of X. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zlacgv( N, X, INCX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IOFF +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg +* .. +* .. Executable Statements .. +* + IF( incx.EQ.1 ) THEN + DO 10 i = 1, n + x( i ) = dconjg( x( i ) ) + 10 CONTINUE + ELSE + ioff = 1 + IF( incx.LT.0 ) + $ ioff = 1 - ( n-1 )*incx + DO 20 i = 1, n + x( ioff ) = dconjg( x( ioff ) ) + ioff = ioff + incx + 20 CONTINUE + END IF + RETURN +* +* End of ZLACGV +* + END +C +C====================================================================== +C +*> \brief \b ZLACPY copies all or part of one two-dimensional array to another. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLACPY copies all or part of a two-dimensional matrix A to another +*> matrix B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies the part of the matrix A to be copied to B. +*> = 'U': Upper triangular part +*> = 'L': Lower triangular part +*> Otherwise: All of the matrix A +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. If UPLO = 'U', only the upper trapezium +*> is accessed; if UPLO = 'L', only the lower trapezium is +*> accessed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,N) +*> On exit, B = A in the locations specified by UPLO. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zlacpy( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), B( ldb, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. Intrinsic Functions .. + INTRINSIC min +* .. +* .. Executable Statements .. +* + IF( lsame( uplo, 'U' ) ) THEN + DO 20 j = 1, n + DO 10 i = 1, min( j, m ) + b( i, j ) = a( i, j ) + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( lsame( uplo, 'L' ) ) THEN + DO 40 j = 1, n + DO 30 i = j, m + b( i, j ) = a( i, j ) + 30 CONTINUE + 40 CONTINUE +* + ELSE + DO 60 j = 1, n + DO 50 i = 1, m + b( i, j ) = a( i, j ) + 50 CONTINUE + 60 CONTINUE + END IF +* + RETURN +* +* End of ZLACPY +* + END +C +C====================================================================== +C +*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZLADIV( X, Y ) +* +* .. Scalar Arguments .. +* COMPLEX*16 X, Y +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y +*> will not overflow on an intermediary step unless the results +*> overflows. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 +*> The complex scalars X and Y. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + COMPLEX*16 FUNCTION zladiv( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + COMPLEX*16 X, Y +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION ZI, ZR +* .. +* .. External Subroutines .. + EXTERNAL dladiv +* .. +* .. Intrinsic Functions .. + INTRINSIC dble, dcmplx, dimag +* .. +* .. Executable Statements .. +* + CALL dladiv( dble( x ), dimag( x ), dble( y ), dimag( y ), zr, + $ zi ) + zladiv = dcmplx( zr, zi ) +* + RETURN +* +* End of ZLADIV +* + END +C +C====================================================================== +C +*> \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAHQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, +* IHIZ, Z, LDZ, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAHQR is an auxiliary routine called by CHSEQR to update the +*> eigenvalues and Schur decomposition already computed by CHSEQR, by +*> dealing with the Hessenberg submatrix in rows and columns ILO to +*> IHI. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular in rows and +*> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). +*> ZLAHQR works primarily with the Hessenberg submatrix in rows +*> and columns ILO to IHI, but applies transformations to all of +*> H if WANTT is .TRUE.. +*> 1 <= ILO <= max(1,IHI); IHI <= N. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO is zero and if WANTT is .TRUE., then H +*> is upper triangular in rows and columns ILO:IHI. If INFO +*> is zero and if WANTT is .FALSE., then the contents of H +*> are unspecified on exit. The output state of H in case +*> INF is positive is below under the description of INFO. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (N) +*> The computed eigenvalues ILO to IHI are stored in the +*> corresponding elements of W. If WANTT is .TRUE., the +*> eigenvalues are stored in the same order as on the diagonal +*> of the Schur form returned in H, with W(i) = H(i,i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ,N) +*> If WANTZ is .TRUE., on entry Z must contain the current +*> matrix Z of transformations accumulated by CHSEQR, and on +*> exit Z has been updated; transformations are applied only to +*> the submatrix Z(ILOZ:IHIZ,ILO:IHI). +*> If WANTZ is .FALSE., Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .GT. 0: if INFO = i, ZLAHQR failed to compute all the +*> eigenvalues ILO to IHI in a total of 30 iterations +*> per eigenvalue; elements i+1:ihi of W contain +*> those eigenvalues which have been successfully +*> computed. +*> +*> If INFO .GT. 0 and WANTT is .FALSE., then on exit, +*> the remaining unconverged eigenvalues are the +*> eigenvalues of the upper Hessenberg matrix +*> rows and columns ILO thorugh INFO of the final, +*> output value of H. +*> +*> If INFO .GT. 0 and WANTT is .TRUE., then on exit +*> (*) (initial value of H)*U = U*(final value of H) +*> where U is an orthognal matrix. The final +*> value of H is upper Hessenberg and triangular in +*> rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit +*> (final value of Z) = (initial value of Z)*U +*> where U is the orthogonal matrix in (*) +*> (regardless of the value of WANTT.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> 02-96 Based on modifications by +*> David Day, Sandia National Laboratory, USA +*> +*> 12-04 Further modifications by +*> Ralph Byers, University of Kansas, USA +*> This is a modified version of ZLAHQR from LAPACK version 3.0. +*> It is (1) more robust against overflow and underflow and +*> (2) adopts the more conservative Ahues & Tisseur stopping +*> criterion (LAWN 122, 1997). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zlahqr( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), W( * ), Z( ldz, * ) +* .. +* +* ========================================================= +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d0, 0.0d0 ), + $ one = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE, HALF + parameter( rzero = 0.0d0, rone = 1.0d0, half = 0.5d0 ) + DOUBLE PRECISION DAT1 + parameter( dat1 = 3.0d0 / 4.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, + $ v2, x, y + DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, + $ safmin, smlnum, sx, t2, tst, ulp + INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M, + $ nh, nz +* .. +* .. Local Arrays .. + COMPLEX*16 V( 2 ) +* .. +* .. External Functions .. + COMPLEX*16 ZLADIV + DOUBLE PRECISION DLAMCH + EXTERNAL zladiv, dlamch +* .. +* .. External Subroutines .. + EXTERNAL dlabad, zcopy, zlarfg, zscal +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dconjg, dimag, max, min, sqrt +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. +* + info = 0 +* +* Quick return if possible +* + IF( n.EQ.0 ) + $ RETURN + IF( ilo.EQ.ihi ) THEN + w( ilo ) = h( ilo, ilo ) + RETURN + END IF +* +* ==== clear out the trash ==== + DO 10 j = ilo, ihi - 3 + h( j+2, j ) = zero + h( j+3, j ) = zero + 10 CONTINUE + IF( ilo.LE.ihi-2 ) + $ h( ihi, ihi-2 ) = zero +* ==== ensure that subdiagonal entries are real ==== + IF( wantt ) THEN + jlo = 1 + jhi = n + ELSE + jlo = ilo + jhi = ihi + END IF + DO 20 i = ilo + 1, ihi + IF( dimag( h( i, i-1 ) ).NE.rzero ) THEN +* ==== The following redundant normalization +* . avoids problems with both gradual and +* . sudden underflow in ABS(H(I,I-1)) ==== + sc = h( i, i-1 ) / cabs1( h( i, i-1 ) ) + sc = dconjg( sc ) / abs( sc ) + h( i, i-1 ) = abs( h( i, i-1 ) ) + CALL zscal( jhi-i+1, sc, h( i, i ), ldh ) + CALL zscal( min( jhi, i+1 )-jlo+1, dconjg( sc ), + $ h( jlo, i ), 1 ) + IF( wantz ) + $ CALL zscal( ihiz-iloz+1, dconjg( sc ), z( iloz, i ), 1 ) + END IF + 20 CONTINUE +* + nh = ihi - ilo + 1 + nz = ihiz - iloz + 1 +* +* Set machine-dependent constants for the stopping criterion. +* + safmin = dlamch( 'SAFE MINIMUM' ) + safmax = rone / safmin + CALL dlabad( safmin, safmax ) + ulp = dlamch( 'PRECISION' ) + smlnum = safmin*( dble( nh ) / ulp ) +* +* I1 and I2 are the indices of the first row and last column of H +* to which transformations must be applied. If eigenvalues only are +* being computed, I1 and I2 are set inside the main loop. +* + IF( wantt ) THEN + i1 = 1 + i2 = n + END IF +* +* ITMAX is the total number of QR iterations allowed. +* + itmax = 30 * max( 10, nh ) +* +* The main loop begins here. I is the loop index and decreases from +* IHI to ILO in steps of 1. Each iteration of the loop works +* with the active submatrix in rows and columns L to I. +* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or +* H(L,L-1) is negligible so that the matrix splits. +* + i = ihi + 30 CONTINUE + IF( i.LT.ilo ) + $ GO TO 150 +* +* Perform QR iterations on rows and columns ILO to I until a +* submatrix of order 1 splits off at the bottom because a +* subdiagonal element has become negligible. +* + l = ilo + DO 130 its = 0, itmax +* +* Look for a single small subdiagonal element. +* + DO 40 k = i, l + 1, -1 + IF( cabs1( h( k, k-1 ) ).LE.smlnum ) + $ GO TO 50 + tst = cabs1( h( k-1, k-1 ) ) + cabs1( h( k, k ) ) + IF( tst.EQ.zero ) THEN + IF( k-2.GE.ilo ) + $ tst = tst + abs( dble( h( k-1, k-2 ) ) ) + IF( k+1.LE.ihi ) + $ tst = tst + abs( dble( h( k+1, k ) ) ) + END IF +* ==== The following is a conservative small subdiagonal +* . deflation criterion due to Ahues & Tisseur (LAWN 122, +* . 1997). It has better mathematical foundation and +* . improves accuracy in some examples. ==== + IF( abs( dble( h( k, k-1 ) ) ).LE.ulp*tst ) THEN + ab = max( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) ) + ba = min( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) ) + aa = max( cabs1( h( k, k ) ), + $ cabs1( h( k-1, k-1 )-h( k, k ) ) ) + bb = min( cabs1( h( k, k ) ), + $ cabs1( h( k-1, k-1 )-h( k, k ) ) ) + s = aa + ab + IF( ba*( ab / s ).LE.max( smlnum, + $ ulp*( bb*( aa / s ) ) ) )GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE + l = k + IF( l.GT.ilo ) THEN +* +* H(L,L-1) is negligible +* + h( l, l-1 ) = zero + END IF +* +* Exit from loop if a submatrix of order 1 has split off. +* + IF( l.GE.i ) + $ GO TO 140 +* +* Now the active submatrix is in rows and columns L to I. If +* eigenvalues only are being computed, only the active submatrix +* need be transformed. +* + IF( .NOT.wantt ) THEN + i1 = l + i2 = i + END IF +* + IF( its.EQ.10 ) THEN +* +* Exceptional shift. +* + s = dat1*abs( dble( h( l+1, l ) ) ) + t = s + h( l, l ) + ELSE IF( its.EQ.20 ) THEN +* +* Exceptional shift. +* + s = dat1*abs( dble( h( i, i-1 ) ) ) + t = s + h( i, i ) + ELSE +* +* Wilkinson's shift. +* + t = h( i, i ) + u = sqrt( h( i-1, i ) )*sqrt( h( i, i-1 ) ) + s = cabs1( u ) + IF( s.NE.rzero ) THEN + x = half*( h( i-1, i-1 )-t ) + sx = cabs1( x ) + s = max( s, cabs1( x ) ) + y = s*sqrt( ( x / s )**2+( u / s )**2 ) + IF( sx.GT.rzero ) THEN + IF( dble( x / sx )*dble( y )+dimag( x / sx )* + $ dimag( y ).LT.rzero )y = -y + END IF + t = t - u*zladiv( u, ( x+y ) ) + END IF + END IF +* +* Look for two consecutive small subdiagonal elements. +* + DO 60 m = i - 1, l + 1, -1 +* +* Determine the effect of starting the single-shift QR +* iteration at row M, and see if this would make H(M,M-1) +* negligible. +* + h11 = h( m, m ) + h22 = h( m+1, m+1 ) + h11s = h11 - t + h21 = dble( h( m+1, m ) ) + s = cabs1( h11s ) + abs( h21 ) + h11s = h11s / s + h21 = h21 / s + v( 1 ) = h11s + v( 2 ) = h21 + h10 = dble( h( m, m-1 ) ) + IF( abs( h10 )*abs( h21 ).LE.ulp* + $ ( cabs1( h11s )*( cabs1( h11 )+cabs1( h22 ) ) ) ) + $ GO TO 70 + 60 CONTINUE + h11 = h( l, l ) + h22 = h( l+1, l+1 ) + h11s = h11 - t + h21 = dble( h( l+1, l ) ) + s = cabs1( h11s ) + abs( h21 ) + h11s = h11s / s + h21 = h21 / s + v( 1 ) = h11s + v( 2 ) = h21 + 70 CONTINUE +* +* Single-shift QR step +* + DO 120 k = m, i - 1 +* +* The first iteration of this loop determines a reflection G +* from the vector V and applies it from left and right to H, +* thus creating a nonzero bulge below the subdiagonal. +* +* Each subsequent iteration determines a reflection G to +* restore the Hessenberg form in the (K-1)th column, and thus +* chases the bulge one step toward the bottom of the active +* submatrix. +* +* V(2) is always real before the call to ZLARFG, and hence +* after the call T2 ( = T1*V(2) ) is also real. +* + IF( k.GT.m ) + $ CALL zcopy( 2, h( k, k-1 ), 1, v, 1 ) + CALL zlarfg( 2, v( 1 ), v( 2 ), 1, t1 ) + IF( k.GT.m ) THEN + h( k, k-1 ) = v( 1 ) + h( k+1, k-1 ) = zero + END IF + v2 = v( 2 ) + t2 = dble( t1*v2 ) +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 80 j = k, i2 + sum = dconjg( t1 )*h( k, j ) + t2*h( k+1, j ) + h( k, j ) = h( k, j ) - sum + h( k+1, j ) = h( k+1, j ) - sum*v2 + 80 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+2,I). +* + DO 90 j = i1, min( k+2, i ) + sum = t1*h( j, k ) + t2*h( j, k+1 ) + h( j, k ) = h( j, k ) - sum + h( j, k+1 ) = h( j, k+1 ) - sum*dconjg( v2 ) + 90 CONTINUE +* + IF( wantz ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 100 j = iloz, ihiz + sum = t1*z( j, k ) + t2*z( j, k+1 ) + z( j, k ) = z( j, k ) - sum + z( j, k+1 ) = z( j, k+1 ) - sum*dconjg( v2 ) + 100 CONTINUE + END IF +* + IF( k.EQ.m .AND. m.GT.l ) THEN +* +* If the QR step was started at row M > L because two +* consecutive small subdiagonals were found, then extra +* scaling must be performed to ensure that H(M,M-1) remains +* real. +* + temp = one - t1 + temp = temp / abs( temp ) + h( m+1, m ) = h( m+1, m )*dconjg( temp ) + IF( m+2.LE.i ) + $ h( m+2, m+1 ) = h( m+2, m+1 )*temp + DO 110 j = m, i + IF( j.NE.m+1 ) THEN + IF( i2.GT.j ) + $ CALL zscal( i2-j, temp, h( j, j+1 ), ldh ) + CALL zscal( j-i1, dconjg( temp ), h( i1, j ), 1 ) + IF( wantz ) THEN + CALL zscal( nz, dconjg( temp ), z( iloz, j ), + $ 1 ) + END IF + END IF + 110 CONTINUE + END IF + 120 CONTINUE +* +* Ensure that H(I,I-1) is real. +* + temp = h( i, i-1 ) + IF( dimag( temp ).NE.rzero ) THEN + rtemp = abs( temp ) + h( i, i-1 ) = rtemp + temp = temp / rtemp + IF( i2.GT.i ) + $ CALL zscal( i2-i, dconjg( temp ), h( i, i+1 ), ldh ) + CALL zscal( i-i1, temp, h( i1, i ), 1 ) + IF( wantz ) THEN + CALL zscal( nz, temp, z( iloz, i ), 1 ) + END IF + END IF +* + 130 CONTINUE +* +* Failure to converge in remaining number of iterations +* + info = i + RETURN +* + 140 CONTINUE +* +* H(I,I-1) is negligible: one eigenvalue has converged. +* + w( i ) = h( i, i ) +* +* return to start of the main loop with new value of I. +* + i = l - 1 + GO TO 30 +* + 150 CONTINUE + RETURN +* +* End of ZLAHQR +* + END +C +C====================================================================== +C +*> \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAHR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* .. Scalar Arguments .. +* INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), +* $ Y( LDY, NB ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) +*> matrix A so that elements below the k-th subdiagonal are zero. The +*> reduction is performed by an unitary similarity transformation +*> Q**H * A * Q. The routine returns the matrices V and T which determine +*> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. +*> +*> This is an auxiliary routine called by ZGEHRD. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The offset for the reduction. Elements below the k-th +*> subdiagonal in the first NB columns are reduced to zero. +*> K < N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of columns to be reduced. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N-K+1) +*> On entry, the n-by-(n-k+1) general matrix A. +*> On exit, the elements on and above the k-th subdiagonal in +*> the first NB columns are overwritten with the corresponding +*> elements of the reduced matrix; the elements below the k-th +*> subdiagonal, with the array TAU, represent the matrix Q as a +*> product of elementary reflectors. The other columns of A are +*> unchanged. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (NB) +*> The scalar factors of the elementary reflectors. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,NB) +*> The upper triangular matrix T. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension (LDY,NB) +*> The n-by-nb matrix Y. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= N. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of nb elementary reflectors +*> +*> Q = H(1) H(2) . . . H(nb). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in +*> A(i+k+1:n,i), and tau in TAU(i). +*> +*> The elements of the vectors v together form the (n-k+1)-by-nb matrix +*> V which is needed, with T and Y, to apply the transformation to the +*> unreduced part of the matrix, using an update of the form: +*> A := (I - V*T*V**H) * (A - Y*V**H). +*> +*> The contents of A on exit are illustrated by the following example +*> with n = 7, k = 3 and nb = 2: +*> +*> ( a a a a a ) +*> ( a a a a a ) +*> ( a a a a a ) +*> ( h h a a a ) +*> ( v1 h a a a ) +*> ( v1 v2 a a a ) +*> ( v1 v2 a a a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> +*> This subroutine is a slight modification of LAPACK-3.0's DLAHRD +*> incorporating improvements proposed by Quintana-Orti and Van de +*> Gejin. Note that the entries of A(1:K,2:NB) differ from those +*> returned by the original LAPACK-3.0's DLAHRD routine. (This +*> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) +*> \endverbatim +* +*> \par References: +* ================ +*> +*> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the +*> performance of reduction to Hessenberg form," ACM Transactions on +*> Mathematical Software, 32(2):180-194, June 2006. +*> +* ===================================================================== + SUBROUTINE zlahr2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), T( ldt, nb ), TAU( nb ), + $ y( ldy, nb ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d+0, 0.0d+0 ), + $ one = ( 1.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 EI +* .. +* .. External Subroutines .. + EXTERNAL zaxpy, zcopy, zgemm, zgemv, zlacpy, + $ zlarfg, zscal, ztrmm, ztrmv, zlacgv +* .. +* .. Intrinsic Functions .. + INTRINSIC min +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( n.LE.1 ) + $ RETURN +* + DO 10 i = 1, nb + IF( i.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V**H +* + CALL zlacgv( i-1, a( k+i-1, 1 ), lda ) + CALL zgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy, + $ a( k+i-1, 1 ), lda, one, a( k+1, i ), 1 ) + CALL zlacgv( i-1, a( k+i-1, 1 ), lda ) +* +* Apply I - V * T**H * V**H to this column (call it b) from the +* left, using the last column of T as workspace +* +* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) +* ( V2 ) ( b2 ) +* +* where V1 is unit lower triangular +* +* w := V1**H * b1 +* + CALL zcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) + CALL ztrmv( 'Lower', 'Conjugate transpose', 'UNIT', + $ i-1, a( k+1, 1 ), + $ lda, t( 1, nb ), 1 ) +* +* w := w + V2**H * b2 +* + CALL zgemv( 'Conjugate transpose', n-k-i+1, i-1, + $ one, a( k+i, 1 ), + $ lda, a( k+i, i ), 1, one, t( 1, nb ), 1 ) +* +* w := T**H * w +* + CALL ztrmv( 'Upper', 'Conjugate transpose', 'NON-UNIT', + $ i-1, t, ldt, + $ t( 1, nb ), 1 ) +* +* b2 := b2 - V2*w +* + CALL zgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one, + $ a( k+i, 1 ), + $ lda, t( 1, nb ), 1, one, a( k+i, i ), 1 ) +* +* b1 := b1 - V1*w +* + CALL ztrmv( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', i-1, + $ a( k+1, 1 ), lda, t( 1, nb ), 1 ) + CALL zaxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 ) +* + a( k+i-1, i-1 ) = ei + END IF +* +* Generate the elementary reflector H(I) to annihilate +* A(K+I+1:N,I) +* + CALL zlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1, + $ tau( i ) ) + ei = a( k+i, i ) + a( k+i, i ) = one +* +* Compute Y(K+1:N,I) +* + CALL zgemv( 'NO TRANSPOSE', n-k, n-k-i+1, + $ one, a( k+1, i+1 ), + $ lda, a( k+i, i ), 1, zero, y( k+1, i ), 1 ) + CALL zgemv( 'Conjugate transpose', n-k-i+1, i-1, + $ one, a( k+i, 1 ), lda, + $ a( k+i, i ), 1, zero, t( 1, i ), 1 ) + CALL zgemv( 'NO TRANSPOSE', n-k, i-1, -one, + $ y( k+1, 1 ), ldy, + $ t( 1, i ), 1, one, y( k+1, i ), 1 ) + CALL zscal( n-k, tau( i ), y( k+1, i ), 1 ) +* +* Compute T(1:I,I) +* + CALL zscal( i-1, -tau( i ), t( 1, i ), 1 ) + CALL ztrmv( 'Upper', 'No Transpose', 'NON-UNIT', + $ i-1, t, ldt, + $ t( 1, i ), 1 ) + t( i, i ) = tau( i ) +* + 10 CONTINUE + a( k+nb, nb ) = ei +* +* Compute Y(1:K,1:NB) +* + CALL zlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) + CALL ztrmm( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', k, nb, + $ one, a( k+1, 1 ), lda, y, ldy ) + IF( n.GT.k+nb ) + $ CALL zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k, + $ nb, n-k-nb, one, + $ a( 1, 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y, + $ ldy ) + CALL ztrmm( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', k, nb, + $ one, t, ldt, y, ldy ) +* + RETURN +* +* End of ZLAHR2 +* + END +C +C====================================================================== +C +*> \brief \b ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION WORK( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLANGE returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> complex matrix A. +*> \endverbatim +*> +*> \return ZLANGE +*> \verbatim +*> +*> ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in ZLANGE as described +*> above. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. When M = 0, +*> ZLANGE is set to zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. When N = 0, +*> ZLANGE is set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(M,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16GEauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION zlange( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( lda, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + parameter( one = 1.0d+0, zero = 0.0d+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL lsame, disnan +* .. +* .. External Subroutines .. + EXTERNAL zlassq +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, min, sqrt +* .. +* .. Executable Statements .. +* + IF( min( m, n ).EQ.0 ) THEN + VALUE = zero + ELSE IF( lsame( norm, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = zero + DO 20 j = 1, n + DO 10 i = 1, m + temp = abs( a( i, j ) ) + IF( VALUE.LT.temp .OR. disnan( temp ) ) VALUE = temp + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = zero + DO 40 j = 1, n + sum = zero + DO 30 i = 1, m + sum = sum + abs( a( i, j ) ) + 30 CONTINUE + IF( VALUE.LT.sum .OR. disnan( sum ) ) VALUE = sum + 40 CONTINUE + ELSE IF( lsame( norm, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 i = 1, m + work( i ) = zero + 50 CONTINUE + DO 70 j = 1, n + DO 60 i = 1, m + work( i ) = work( i ) + abs( a( i, j ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = zero + DO 80 i = 1, m + temp = work( i ) + IF( VALUE.LT.temp .OR. disnan( temp ) ) VALUE = temp + 80 CONTINUE + ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN +* +* Find normF(A). +* + scale = zero + sum = one + DO 90 j = 1, n + CALL zlassq( m, a( 1, j ), 1, scale, sum ) + 90 CONTINUE + VALUE = scale*sqrt( sum ) + END IF +* + zlange = VALUE + RETURN +* +* End of ZLANGE +* + END +C +C====================================================================== +C +*> \brief \b ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQR0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, +* IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQR0 computes the eigenvalues of a Hessenberg matrix H +*> and, optionally, the matrices T and Z from the Schur decomposition +*> H = Z T Z**H, where T is an upper triangular matrix (the +*> Schur form), and Z is the unitary matrix of Schur vectors. +*> +*> Optionally Z may be postmultiplied into an input unitary +*> matrix Q so that this routine can give the Schur factorization +*> of a matrix A which has been reduced to the Hessenberg form H +*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that H is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, +*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +*> previous call to ZGEBAL, and then passed to ZGEHRD when the +*> matrix output by ZGEBAL is reduced to Hessenberg form. +*> Otherwise, ILO and IHI should be set to 1 and N, +*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +*> If N = 0, then ILO = 1 and IHI = 0. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO = 0 and WANTT is .TRUE., then H +*> contains the upper triangular matrix T from the Schur +*> decomposition (the Schur form). If INFO = 0 and WANT is +*> .FALSE., then the contents of H are unspecified on exit. +*> (The output value of H when INFO.GT.0 is given under the +*> description of INFO below.) +*> +*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and +*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (N) +*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored +*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are +*> stored in the same order as on the diagonal of the Schur +*> form returned in H, with W(i) = H(i,i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ,IHI) +*> If WANTZ is .FALSE., then Z is not referenced. +*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +*> (The output value of Z when INFO.GT.0 is given under +*> the description of INFO below.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if WANTZ is .TRUE. +*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension LWORK +*> On exit, if LWORK = -1, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK .GE. max(1,N) +*> is sufficient, but LWORK typically as large as 6*N may +*> be required for optimal performance. A workspace query +*> to determine the optimal workspace size is recommended. +*> +*> If LWORK = -1, then ZLAQR0 does a workspace query. +*> In this case, ZLAQR0 checks the input parameters and +*> estimates the optimal workspace size for the given +*> values of N, ILO and IHI. The estimate is returned +*> in WORK(1). No error message related to LWORK is +*> issued by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .GT. 0: if INFO = i, ZLAQR0 failed to compute all of +*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +*> and WI contain those eigenvalues which have been +*> successfully computed. (Failures are rare.) +*> +*> If INFO .GT. 0 and WANT is .FALSE., then on exit, +*> the remaining unconverged eigenvalues are the eigen- +*> values of the upper Hessenberg matrix rows and +*> columns ILO through INFO of the final, output +*> value of H. +*> +*> If INFO .GT. 0 and WANTT is .TRUE., then on exit +*> +*> (*) (initial value of H)*U = U*(final value of H) +*> +*> where U is a unitary matrix. The final +*> value of H is upper Hessenberg and triangular in +*> rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit +*> +*> (final value of Z(ILO:IHI,ILOZ:IHIZ) +*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +*> +*> where U is the unitary matrix in (*) (regard- +*> less of the value of WANTT.) +*> +*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +*> accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> \n +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +*> of Matrix Analysis, volume 23, pages 948--973, 2002. +*> +* ===================================================================== + SUBROUTINE zlaqr0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), W( * ), WORK( * ), Z( ldz, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + parameter( ntiny = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + parameter( kexnw = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + parameter( kexsh = 6 ) +* +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== + DOUBLE PRECISION WILK1 + parameter( wilk1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d0, 0.0d0 ), + $ one = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + parameter( two = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ kt, ktop, ku, kv, kwh, kwtop, kwv, ld, ls, + $ lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, + $ nsmax, nsr, nve, nw, nwmax, nwr, nwupbd + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ilaenv +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL zlacpy, zlahqr, zlaqr3, zlaqr4, zlaqr5 +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dimag, int, max, min, mod, + $ sqrt +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. + info = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( n.EQ.0 ) THEN + work( 1 ) = one + RETURN + END IF +* + IF( n.LE.ntiny ) THEN +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + lwkopt = 1 + IF( lwork.NE.-1 ) + $ CALL zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, + $ ihiz, z, ldz, info ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + info = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( wantt ) THEN + jbcmpz( 1: 1 ) = 'S' + ELSE + jbcmpz( 1: 1 ) = 'E' + END IF + IF( wantz ) THEN + jbcmpz( 2: 2 ) = 'V' + ELSE + jbcmpz( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + nwr = ilaenv( 13, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + nsr = ilaenv( 15, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n+6 ) / 9, ihi-ilo ) + nsr = max( 2, nsr-mod( nsr, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR3 ==== +* + CALL zlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz, + $ ihiz, z, ldz, ls, ld, w, h, ldh, n, h, ldh, n, h, + $ ldh, work, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== +* + lwkopt = max( 3*nsr / 2, int( work( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( lwork.EQ.-1 ) THEN + work( 1 ) = dcmplx( lwkopt, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + nmin = ilaenv( 12, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nmin = max( ntiny, nmin ) +* +* ==== Nibble crossover point ==== +* + nibble = ilaenv( 14, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0, nibble ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + kacc22 = ilaenv( 16, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0, kacc22 ) + kacc22 = min( 2, kacc22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nw = nwmax +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + nsmax = min( ( n+6 ) / 9, 2*lwork / 3 ) + nsmax = nsmax - mod( nsmax, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + ndfl = 1 +* +* ==== ITMAX = iteration limit ==== +* + itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) +* +* ==== Last row and column in the active block ==== +* + kbot = ihi +* +* ==== Main Loop ==== +* + DO 70 it = 1, itmax +* +* ==== Done when KBOT falls below ILO ==== +* + IF( kbot.LT.ilo ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 k = kbot, ilo + 1, -1 + IF( h( k, k-1 ).EQ.zero ) + $ GO TO 20 + 10 CONTINUE + k = ilo + 20 CONTINUE + ktop = k +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + nh = kbot - ktop + 1 + nwupbd = min( nh, nwmax ) + IF( ndfl.LT.kexnw ) THEN + nw = min( nwupbd, nwr ) + ELSE + nw = min( nwupbd, 2*nw ) + END IF + IF( nw.LT.nwmax ) THEN + IF( nw.GE.nh-1 ) THEN + nw = nh + ELSE + kwtop = kbot - nw + 1 + IF( cabs1( h( kwtop, kwtop-1 ) ).GT. + $ cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + 1 + END IF + END IF + IF( ndfl.LT.kexnw ) THEN + ndec = -1 + ELSE IF( ndec.GE.0 .OR. nw.GE.nwupbd ) THEN + ndec = ndec + 1 + IF( nw-ndec.LT.2 ) + $ ndec = 0 + nw = nw - ndec + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + kv = n - nw + 1 + kt = nw + 1 + nho = ( n-nw-1 ) - kt + 1 + kwv = nw + 2 + nve = ( n-nw ) - kwv + 1 +* +* ==== Aggressive early deflation ==== +* + CALL zlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, + $ ihiz, z, ldz, ls, ld, w, h( kv, 1 ), ldh, nho, + $ h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work, + $ lwork ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + kbot = kbot - ld +* +* ==== KS points to the shifts. ==== +* + ks = kbot - ls + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( ld.EQ.0 ) .OR. ( ( 100*ld.LE.nw*nibble ) .AND. ( kbot- + $ ktop+1.GT.min( nmin, nwmax ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR3 +* . did not provide that many shifts. ==== +* + ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) + ns = ns - mod( ns, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR3 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( mod( ndfl, kexsh ).EQ.0 ) THEN + ks = kbot - ns + 1 + DO 30 i = kbot, ks + 1, -2 + w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) + w( i-1 ) = w( i ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or +* . ZLAHQR on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( kbot-ks+1.LE.ns / 2 ) THEN + ks = kbot - ns + 1 + kt = n - ns + 1 + CALL zlacpy( 'A', ns, ns, h( ks, ks ), ldh, + $ h( kt, 1 ), ldh ) + IF( ns.GT.nmin ) THEN + CALL zlaqr4( .false., .false., ns, 1, ns, + $ h( kt, 1 ), ldh, w( ks ), 1, 1, + $ zdum, 1, work, lwork, inf ) + ELSE + CALL zlahqr( .false., .false., ns, 1, ns, + $ h( kt, 1 ), ldh, w( ks ), 1, 1, + $ zdum, 1, inf ) + END IF + ks = ks + inf +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( ks.GE.kbot ) THEN + s = cabs1( h( kbot-1, kbot-1 ) ) + + $ cabs1( h( kbot, kbot-1 ) ) + + $ cabs1( h( kbot-1, kbot ) ) + + $ cabs1( h( kbot, kbot ) ) + aa = h( kbot-1, kbot-1 ) / s + cc = h( kbot, kbot-1 ) / s + bb = h( kbot-1, kbot ) / s + dd = h( kbot, kbot ) / s + tr2 = ( aa+dd ) / two + det = ( aa-tr2 )*( dd-tr2 ) - bb*cc + rtdisc = sqrt( -det ) + w( kbot-1 ) = ( tr2+rtdisc )*s + w( kbot ) = ( tr2-rtdisc )*s +* + ks = kbot - 1 + END IF + END IF +* + IF( kbot-ks+1.GT.ns ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + sorted = .false. + DO 50 k = kbot, ks + 1, -1 + IF( sorted ) + $ GO TO 60 + sorted = .true. + DO 40 i = ks, k - 1 + IF( cabs1( w( i ) ).LT.cabs1( w( i+1 ) ) ) + $ THEN + sorted = .false. + swap = w( i ) + w( i ) = w( i+1 ) + w( i+1 ) = swap + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( kbot-ks+1.EQ.2 ) THEN + IF( cabs1( w( kbot )-h( kbot, kbot ) ).LT. + $ cabs1( w( kbot-1 )-h( kbot, kbot ) ) ) THEN + w( kbot-1 ) = w( kbot ) + ELSE + w( kbot ) = w( kbot-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + ns = min( ns, kbot-ks+1 ) + ns = ns - mod( ns, 2 ) + ks = kbot - ns + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + kdu = 3*ns - 3 + ku = n - kdu + 1 + kwh = kdu + 1 + nho = ( n-kdu+1-4 ) - ( kdu+1 ) + 1 + kwv = kdu + 4 + nve = n - kdu - kwv + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns, + $ w( ks ), h, ldh, iloz, ihiz, z, ldz, work, + $ 3, h( ku, 1 ), ldh, nve, h( kwv, 1 ), ldh, + $ nho, h( ku, kwh ), ldh ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( ld.GT.0 ) THEN + ndfl = 1 + ELSE + ndfl = ndfl + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + info = kbot + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + work( 1 ) = dcmplx( lwkopt, 0 ) +* +* ==== End of ZLAQR0 ==== +* + END +C +C====================================================================== +C +*> \brief \b ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQR1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) +* +* .. Scalar Arguments .. +* COMPLEX*16 S1, S2 +* INTEGER LDH, N +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), V( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a +*> scalar multiple of the first column of the product +*> +*> (*) K = (H - s1*I)*(H - s2*I) +*> +*> scaling to avoid overflows and most underflows. +*> +*> This is useful for starting double implicit shift bulges +*> in the QR algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> Order of the matrix H. N must be either 2 or 3. +*> \endverbatim +*> +*> \param[in] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> The 2-by-2 or 3-by-3 matrix H in (*). +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of H as declared in +*> the calling procedure. LDH.GE.N +*> \endverbatim +*> +*> \param[in] S1 +*> \verbatim +*> S1 is COMPLEX*16 +*> \endverbatim +*> +*> \param[in] S2 +*> \verbatim +*> S2 is COMPLEX*16 +*> +*> S1 and S2 are the shifts defining K in (*) above. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (N) +*> A scalar multiple of the first column of the +*> matrix K in (*). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE zlaqr1( N, H, LDH, S1, S2, V ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + COMPLEX*16 S1, S2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), V( * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO + parameter( zero = ( 0.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + parameter( rzero = 0.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, H21S, H31S + DOUBLE PRECISION S +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dimag +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. + IF( n.EQ.2 ) THEN + s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) + IF( s.EQ.rzero ) THEN + v( 1 ) = zero + v( 2 ) = zero + ELSE + h21s = h( 2, 1 ) / s + v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-s1 )* + $ ( ( h( 1, 1 )-s2 ) / s ) + v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + END IF + ELSE + s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) + + $ cabs1( h( 3, 1 ) ) + IF( s.EQ.zero ) THEN + v( 1 ) = zero + v( 2 ) = zero + v( 3 ) = zero + ELSE + h21s = h( 2, 1 ) / s + h31s = h( 3, 1 ) / s + v( 1 ) = ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) + + $ h( 1, 2 )*h21s + h( 1, 3 )*h31s + v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h( 2, 3 )*h31s + v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-s1-s2 ) + h21s*h( 3, 2 ) + END IF + END IF + END +C +C====================================================================== +C +*> \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, +* NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), +* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQR2 is identical to ZLAQR3 except that it avoids +*> recursion by calling ZLAHQR instead of ZLAQR4. +*> +*> Aggressive early deflation: +*> +*> ZLAQR2 accepts as input an upper Hessenberg matrix +*> H and performs an unitary similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an unitary similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the unitary matrix Z is updated so +*> so that the unitary Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the unitary matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by a unitary +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> Leading dimension of H just as declared in the calling +*> subroutine. N .LE. LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ,N) +*> IF WANTZ is .TRUE., then on output, the unitary +*> similarity transformation mentioned above has been +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 .LE. LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SH +*> \verbatim +*> SH is COMPLEX*16 array, dimension (KBOT) +*> On output, approximate eigenvalues that may +*> be used for shifts are stored in SH(KBOT-ND-NS+1) +*> through SR(KBOT-ND). Converged eigenvalues are +*> stored in SH(KBOT-ND+1) through SH(KBOT). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is INTEGER +*> The number of columns of T. NH.GE.NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of T just as declared in the +*> calling subroutine. NW .LE. LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is INTEGER +*> The number of rows of work array WV available for +*> workspace. NV.GE.NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is COMPLEX*16 array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is INTEGER +*> The leading dimension of W just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; ZLAQR2 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE zlaqr2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ ldz, lwork, n, nd, nh, ns, nv, nw + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), SH( * ), T( ldt, * ), V( ldv, * ), + $ work( * ), wv( ldwv, * ), z( ldz, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d0, 0.0d0 ), + $ one = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + parameter( rzero = 0.0d0, rone = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ knt, krow, kwtop, ltop, lwk1, lwk2, lwkopt +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL dlamch +* .. +* .. External Subroutines .. + EXTERNAL dlabad, zcopy, zgehrd, zgemm, zlacpy, zlahqr, + $ zlarf, zlarfg, zlaset, ztrexc, zunmhr +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dconjg, dimag, int, max, min +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + jw = min( nw, kbot-ktop+1 ) + IF( jw.LE.2 ) THEN + lwkopt = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL zgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) + lwk1 = int( work( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + CALL zunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv, + $ work, -1, info ) + lwk2 = int( work( 1 ) ) +* +* ==== Optimal workspace ==== +* + lwkopt = jw + max( lwk1, lwk2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( lwork.EQ.-1 ) THEN + work( 1 ) = dcmplx( lwkopt, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + ns = 0 + nd = 0 + work( 1 ) = one + IF( ktop.GT.kbot ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( nw.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + safmin = dlamch( 'SAFE MINIMUM' ) + safmax = rone / safmin + CALL dlabad( safmin, safmax ) + ulp = dlamch( 'PRECISION' ) + smlnum = safmin*( dble( n ) / ulp ) +* +* ==== Setup deflation window ==== +* + jw = min( nw, kbot-ktop+1 ) + kwtop = kbot - jw + 1 + IF( kwtop.EQ.ktop ) THEN + s = zero + ELSE + s = h( kwtop, kwtop-1 ) + END IF +* + IF( kbot.EQ.kwtop ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + sh( kwtop ) = h( kwtop, kwtop ) + ns = 1 + nd = 0 + IF( cabs1( s ).LE.max( smlnum, ulp*cabs1( h( kwtop, + $ kwtop ) ) ) ) THEN + ns = 0 + nd = 1 + IF( kwtop.GT.ktop ) + $ h( kwtop, kwtop-1 ) = zero + END IF + work( 1 ) = one + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + CALL zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) +* + CALL zlaset( 'A', jw, jw, zero, one, v, ldv ) + CALL zlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1, + $ jw, v, ldv, infqr ) +* +* ==== Deflation detection loop ==== +* + ns = jw + ilst = infqr + 1 + DO 10 knt = infqr + 1, jw +* +* ==== Small spike tip deflation test ==== +* + foo = cabs1( t( ns, ns ) ) + IF( foo.EQ.rzero ) + $ foo = cabs1( s ) + IF( cabs1( s )*cabs1( v( 1, ns ) ).LE.max( smlnum, ulp*foo ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + ns = ns - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + ifst = ns + CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( ns.EQ.0 ) + $ s = zero +* + IF( ns.LT.jw ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 i = infqr + 1, ns + ifst = i + DO 20 j = i + 1, ns + IF( cabs1( t( j, j ) ).GT.cabs1( t( ifst, ifst ) ) ) + $ ifst = j + 20 CONTINUE + ilst = i + IF( ifst.NE.ilst ) + $ CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 i = infqr + 1, jw + sh( kwtop+i-1 ) = t( i, i ) + 40 CONTINUE +* +* + IF( ns.LT.jw .OR. s.EQ.zero ) THEN + IF( ns.GT.1 .AND. s.NE.zero ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL zcopy( ns, v, ldv, work, 1 ) + DO 50 i = 1, ns + work( i ) = dconjg( work( i ) ) + 50 CONTINUE + beta = work( 1 ) + CALL zlarfg( ns, beta, work( 2 ), 1, tau ) + work( 1 ) = one +* + CALL zlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) +* + CALL zlarf( 'L', ns, jw, work, 1, dconjg( tau ), t, ldt, + $ work( jw+1 ) ) + CALL zlarf( 'R', ns, ns, work, 1, tau, t, ldt, + $ work( jw+1 ) ) + CALL zlarf( 'R', jw, ns, work, 1, tau, v, ldv, + $ work( jw+1 ) ) +* + CALL zgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ), + $ lwork-jw, info ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( kwtop.GT.1 ) + $ h( kwtop, kwtop-1 ) = s*dconjg( v( 1, 1 ) ) + CALL zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + CALL zcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ), + $ ldh+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( ns.GT.1 .AND. s.NE.zero ) + $ CALL zunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv, + $ work( jw+1 ), lwork-jw, info ) +* +* ==== Update vertical slab in H ==== +* + IF( wantt ) THEN + ltop = 1 + ELSE + ltop = ktop + END IF + DO 60 krow = ltop, kwtop - 1, nv + kln = min( nv, kwtop-krow ) + CALL zgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ), + $ ldh, v, ldv, zero, wv, ldwv ) + CALL zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( wantt ) THEN + DO 70 kcol = kbot + 1, n, nh + kln = min( nh, n-kcol+1 ) + CALL zgemm( 'C', 'N', jw, kln, jw, one, v, ldv, + $ h( kwtop, kcol ), ldh, zero, t, ldt ) + CALL zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ), + $ ldh ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( wantz ) THEN + DO 80 krow = iloz, ihiz, nv + kln = min( nv, ihiz-krow+1 ) + CALL zgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ), + $ ldz, v, ldv, zero, wv, ldwv ) + CALL zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ), + $ ldz ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + nd = jw - ns +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + ns = ns - infqr +* +* ==== Return optimal workspace. ==== +* + work( 1 ) = dcmplx( lwkopt, 0 ) +* +* ==== End of ZLAQR2 ==== +* + END +C +C====================================================================== +C +*> \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, +* NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), +* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Aggressive early deflation: +*> +*> ZLAQR3 accepts as input an upper Hessenberg matrix +*> H and performs an unitary similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an unitary similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the unitary matrix Z is updated so +*> so that the unitary Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the unitary matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by a unitary +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> Leading dimension of H just as declared in the calling +*> subroutine. N .LE. LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ,N) +*> IF WANTZ is .TRUE., then on output, the unitary +*> similarity transformation mentioned above has been +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 .LE. LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SH +*> \verbatim +*> SH is COMPLEX*16 array, dimension (KBOT) +*> On output, approximate eigenvalues that may +*> be used for shifts are stored in SH(KBOT-ND-NS+1) +*> through SR(KBOT-ND). Converged eigenvalues are +*> stored in SH(KBOT-ND+1) through SH(KBOT). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is INTEGER +*> The number of columns of T. NH.GE.NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of T just as declared in the +*> calling subroutine. NW .LE. LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is INTEGER +*> The number of rows of work array WV available for +*> workspace. NV.GE.NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is COMPLEX*16 array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is INTEGER +*> The leading dimension of W just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; ZLAQR3 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE zlaqr3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ ldz, lwork, n, nd, nh, ns, nv, nw + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), SH( * ), T( ldt, * ), V( ldv, * ), + $ work( * ), wv( ldwv, * ), z( ldz, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d0, 0.0d0 ), + $ one = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + parameter( rzero = 0.0d0, rone = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ knt, krow, kwtop, ltop, lwk1, lwk2, lwk3, + $ lwkopt, nmin +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL dlamch, ilaenv +* .. +* .. External Subroutines .. + EXTERNAL dlabad, zcopy, zgehrd, zgemm, zlacpy, zlahqr, + $ zlaqr4, zlarf, zlarfg, zlaset, ztrexc, zunmhr +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dconjg, dimag, int, max, min +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + jw = min( nw, kbot-ktop+1 ) + IF( jw.LE.2 ) THEN + lwkopt = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL zgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) + lwk1 = int( work( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + CALL zunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv, + $ work, -1, info ) + lwk2 = int( work( 1 ) ) +* +* ==== Workspace query call to ZLAQR4 ==== +* + CALL zlaqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v, + $ ldv, work, -1, infqr ) + lwk3 = int( work( 1 ) ) +* +* ==== Optimal workspace ==== +* + lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( lwork.EQ.-1 ) THEN + work( 1 ) = dcmplx( lwkopt, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + ns = 0 + nd = 0 + work( 1 ) = one + IF( ktop.GT.kbot ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( nw.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + safmin = dlamch( 'SAFE MINIMUM' ) + safmax = rone / safmin + CALL dlabad( safmin, safmax ) + ulp = dlamch( 'PRECISION' ) + smlnum = safmin*( dble( n ) / ulp ) +* +* ==== Setup deflation window ==== +* + jw = min( nw, kbot-ktop+1 ) + kwtop = kbot - jw + 1 + IF( kwtop.EQ.ktop ) THEN + s = zero + ELSE + s = h( kwtop, kwtop-1 ) + END IF +* + IF( kbot.EQ.kwtop ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + sh( kwtop ) = h( kwtop, kwtop ) + ns = 1 + nd = 0 + IF( cabs1( s ).LE.max( smlnum, ulp*cabs1( h( kwtop, + $ kwtop ) ) ) ) THEN + ns = 0 + nd = 1 + IF( kwtop.GT.ktop ) + $ h( kwtop, kwtop-1 ) = zero + END IF + work( 1 ) = one + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + CALL zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) +* + CALL zlaset( 'A', jw, jw, zero, one, v, ldv ) + nmin = ilaenv( 12, 'ZLAQR3', 'SV', jw, 1, jw, lwork ) + IF( jw.GT.nmin ) THEN + CALL zlaqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1, + $ jw, v, ldv, work, lwork, infqr ) + ELSE + CALL zlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1, + $ jw, v, ldv, infqr ) + END IF +* +* ==== Deflation detection loop ==== +* + ns = jw + ilst = infqr + 1 + DO 10 knt = infqr + 1, jw +* +* ==== Small spike tip deflation test ==== +* + foo = cabs1( t( ns, ns ) ) + IF( foo.EQ.rzero ) + $ foo = cabs1( s ) + IF( cabs1( s )*cabs1( v( 1, ns ) ).LE.max( smlnum, ulp*foo ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + ns = ns - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + ifst = ns + CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( ns.EQ.0 ) + $ s = zero +* + IF( ns.LT.jw ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 i = infqr + 1, ns + ifst = i + DO 20 j = i + 1, ns + IF( cabs1( t( j, j ) ).GT.cabs1( t( ifst, ifst ) ) ) + $ ifst = j + 20 CONTINUE + ilst = i + IF( ifst.NE.ilst ) + $ CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 i = infqr + 1, jw + sh( kwtop+i-1 ) = t( i, i ) + 40 CONTINUE +* +* + IF( ns.LT.jw .OR. s.EQ.zero ) THEN + IF( ns.GT.1 .AND. s.NE.zero ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL zcopy( ns, v, ldv, work, 1 ) + DO 50 i = 1, ns + work( i ) = dconjg( work( i ) ) + 50 CONTINUE + beta = work( 1 ) + CALL zlarfg( ns, beta, work( 2 ), 1, tau ) + work( 1 ) = one +* + CALL zlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) +* + CALL zlarf( 'L', ns, jw, work, 1, dconjg( tau ), t, ldt, + $ work( jw+1 ) ) + CALL zlarf( 'R', ns, ns, work, 1, tau, t, ldt, + $ work( jw+1 ) ) + CALL zlarf( 'R', jw, ns, work, 1, tau, v, ldv, + $ work( jw+1 ) ) +* + CALL zgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ), + $ lwork-jw, info ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( kwtop.GT.1 ) + $ h( kwtop, kwtop-1 ) = s*dconjg( v( 1, 1 ) ) + CALL zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + CALL zcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ), + $ ldh+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( ns.GT.1 .AND. s.NE.zero ) + $ CALL zunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv, + $ work( jw+1 ), lwork-jw, info ) +* +* ==== Update vertical slab in H ==== +* + IF( wantt ) THEN + ltop = 1 + ELSE + ltop = ktop + END IF + DO 60 krow = ltop, kwtop - 1, nv + kln = min( nv, kwtop-krow ) + CALL zgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ), + $ ldh, v, ldv, zero, wv, ldwv ) + CALL zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( wantt ) THEN + DO 70 kcol = kbot + 1, n, nh + kln = min( nh, n-kcol+1 ) + CALL zgemm( 'C', 'N', jw, kln, jw, one, v, ldv, + $ h( kwtop, kcol ), ldh, zero, t, ldt ) + CALL zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ), + $ ldh ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( wantz ) THEN + DO 80 krow = iloz, ihiz, nv + kln = min( nv, ihiz-krow+1 ) + CALL zgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ), + $ ldz, v, ldv, zero, wv, ldwv ) + CALL zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ), + $ ldz ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + nd = jw - ns +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + ns = ns - infqr +* +* ==== Return optimal workspace. ==== +* + work( 1 ) = dcmplx( lwkopt, 0 ) +* +* ==== End of ZLAQR3 ==== +* + END +C +C====================================================================== +C +*> \brief \b ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQR4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, +* IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQR4 implements one level of recursion for ZLAQR0. +*> It is a complete implementation of the small bulge multi-shift +*> QR algorithm. It may be called by ZLAQR0 and, for large enough +*> deflation window size, it may be called by ZLAQR3. This +*> subroutine is identical to ZLAQR0 except that it calls ZLAQR2 +*> instead of ZLAQR3. +*> +*> ZLAQR4 computes the eigenvalues of a Hessenberg matrix H +*> and, optionally, the matrices T and Z from the Schur decomposition +*> H = Z T Z**H, where T is an upper triangular matrix (the +*> Schur form), and Z is the unitary matrix of Schur vectors. +*> +*> Optionally Z may be postmultiplied into an input unitary +*> matrix Q so that this routine can give the Schur factorization +*> of a matrix A which has been reduced to the Hessenberg form H +*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, +*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +*> previous call to ZGEBAL, and then passed to ZGEHRD when the +*> matrix output by ZGEBAL is reduced to Hessenberg form. +*> Otherwise, ILO and IHI should be set to 1 and N, +*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +*> If N = 0, then ILO = 1 and IHI = 0. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO = 0 and WANTT is .TRUE., then H +*> contains the upper triangular matrix T from the Schur +*> decomposition (the Schur form). If INFO = 0 and WANT is +*> .FALSE., then the contents of H are unspecified on exit. +*> (The output value of H when INFO.GT.0 is given under the +*> description of INFO below.) +*> +*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and +*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (N) +*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored +*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are +*> stored in the same order as on the diagonal of the Schur +*> form returned in H, with W(i) = H(i,i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ,IHI) +*> If WANTZ is .FALSE., then Z is not referenced. +*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +*> (The output value of Z when INFO.GT.0 is given under +*> the description of INFO below.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if WANTZ is .TRUE. +*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension LWORK +*> On exit, if LWORK = -1, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK .GE. max(1,N) +*> is sufficient, but LWORK typically as large as 6*N may +*> be required for optimal performance. A workspace query +*> to determine the optimal workspace size is recommended. +*> +*> If LWORK = -1, then ZLAQR4 does a workspace query. +*> In this case, ZLAQR4 checks the input parameters and +*> estimates the optimal workspace size for the given +*> values of N, ILO and IHI. The estimate is returned +*> in WORK(1). No error message related to LWORK is +*> issued by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .GT. 0: if INFO = i, ZLAQR4 failed to compute all of +*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +*> and WI contain those eigenvalues which have been +*> successfully computed. (Failures are rare.) +*> +*> If INFO .GT. 0 and WANT is .FALSE., then on exit, +*> the remaining unconverged eigenvalues are the eigen- +*> values of the upper Hessenberg matrix rows and +*> columns ILO through INFO of the final, output +*> value of H. +*> +*> If INFO .GT. 0 and WANTT is .TRUE., then on exit +*> +*> (*) (initial value of H)*U = U*(final value of H) +*> +*> where U is a unitary matrix. The final +*> value of H is upper Hessenberg and triangular in +*> rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit +*> +*> (final value of Z(ILO:IHI,ILOZ:IHIZ) +*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +*> +*> where U is the unitary matrix in (*) (regard- +*> less of the value of WANTT.) +*> +*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +*> accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> \n +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +*> of Matrix Analysis, volume 23, pages 948--973, 2002. +*> +* ===================================================================== + SUBROUTINE zlaqr4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), W( * ), WORK( * ), Z( ldz, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + parameter( ntiny = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + parameter( kexnw = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + parameter( kexsh = 6 ) +* +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== + DOUBLE PRECISION WILK1 + parameter( wilk1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d0, 0.0d0 ), + $ one = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + parameter( two = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ kt, ktop, ku, kv, kwh, kwtop, kwv, ld, ls, + $ lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, + $ nsmax, nsr, nve, nw, nwmax, nwr, nwupbd + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ilaenv +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL zlacpy, zlahqr, zlaqr2, zlaqr5 +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dimag, int, max, min, mod, + $ sqrt +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. + info = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( n.EQ.0 ) THEN + work( 1 ) = one + RETURN + END IF +* + IF( n.LE.ntiny ) THEN +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + lwkopt = 1 + IF( lwork.NE.-1 ) + $ CALL zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, + $ ihiz, z, ldz, info ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + info = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( wantt ) THEN + jbcmpz( 1: 1 ) = 'S' + ELSE + jbcmpz( 1: 1 ) = 'E' + END IF + IF( wantz ) THEN + jbcmpz( 2: 2 ) = 'V' + ELSE + jbcmpz( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + nwr = ilaenv( 13, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + nsr = ilaenv( 15, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n+6 ) / 9, ihi-ilo ) + nsr = max( 2, nsr-mod( nsr, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR2 ==== +* + CALL zlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz, + $ ihiz, z, ldz, ls, ld, w, h, ldh, n, h, ldh, n, h, + $ ldh, work, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== +* + lwkopt = max( 3*nsr / 2, int( work( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( lwork.EQ.-1 ) THEN + work( 1 ) = dcmplx( lwkopt, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + nmin = ilaenv( 12, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nmin = max( ntiny, nmin ) +* +* ==== Nibble crossover point ==== +* + nibble = ilaenv( 14, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0, nibble ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + kacc22 = ilaenv( 16, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0, kacc22 ) + kacc22 = min( 2, kacc22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nw = nwmax +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + nsmax = min( ( n+6 ) / 9, 2*lwork / 3 ) + nsmax = nsmax - mod( nsmax, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + ndfl = 1 +* +* ==== ITMAX = iteration limit ==== +* + itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) +* +* ==== Last row and column in the active block ==== +* + kbot = ihi +* +* ==== Main Loop ==== +* + DO 70 it = 1, itmax +* +* ==== Done when KBOT falls below ILO ==== +* + IF( kbot.LT.ilo ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 k = kbot, ilo + 1, -1 + IF( h( k, k-1 ).EQ.zero ) + $ GO TO 20 + 10 CONTINUE + k = ilo + 20 CONTINUE + ktop = k +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + nh = kbot - ktop + 1 + nwupbd = min( nh, nwmax ) + IF( ndfl.LT.kexnw ) THEN + nw = min( nwupbd, nwr ) + ELSE + nw = min( nwupbd, 2*nw ) + END IF + IF( nw.LT.nwmax ) THEN + IF( nw.GE.nh-1 ) THEN + nw = nh + ELSE + kwtop = kbot - nw + 1 + IF( cabs1( h( kwtop, kwtop-1 ) ).GT. + $ cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + 1 + END IF + END IF + IF( ndfl.LT.kexnw ) THEN + ndec = -1 + ELSE IF( ndec.GE.0 .OR. nw.GE.nwupbd ) THEN + ndec = ndec + 1 + IF( nw-ndec.LT.2 ) + $ ndec = 0 + nw = nw - ndec + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + kv = n - nw + 1 + kt = nw + 1 + nho = ( n-nw-1 ) - kt + 1 + kwv = nw + 2 + nve = ( n-nw ) - kwv + 1 +* +* ==== Aggressive early deflation ==== +* + CALL zlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, + $ ihiz, z, ldz, ls, ld, w, h( kv, 1 ), ldh, nho, + $ h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work, + $ lwork ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + kbot = kbot - ld +* +* ==== KS points to the shifts. ==== +* + ks = kbot - ls + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( ld.EQ.0 ) .OR. ( ( 100*ld.LE.nw*nibble ) .AND. ( kbot- + $ ktop+1.GT.min( nmin, nwmax ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR2 +* . did not provide that many shifts. ==== +* + ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) + ns = ns - mod( ns, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR2 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( mod( ndfl, kexsh ).EQ.0 ) THEN + ks = kbot - ns + 1 + DO 30 i = kbot, ks + 1, -2 + w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) + w( i-1 ) = w( i ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAHQR +* . on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( kbot-ks+1.LE.ns / 2 ) THEN + ks = kbot - ns + 1 + kt = n - ns + 1 + CALL zlacpy( 'A', ns, ns, h( ks, ks ), ldh, + $ h( kt, 1 ), ldh ) + CALL zlahqr( .false., .false., ns, 1, ns, + $ h( kt, 1 ), ldh, w( ks ), 1, 1, zdum, + $ 1, inf ) + ks = ks + inf +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( ks.GE.kbot ) THEN + s = cabs1( h( kbot-1, kbot-1 ) ) + + $ cabs1( h( kbot, kbot-1 ) ) + + $ cabs1( h( kbot-1, kbot ) ) + + $ cabs1( h( kbot, kbot ) ) + aa = h( kbot-1, kbot-1 ) / s + cc = h( kbot, kbot-1 ) / s + bb = h( kbot-1, kbot ) / s + dd = h( kbot, kbot ) / s + tr2 = ( aa+dd ) / two + det = ( aa-tr2 )*( dd-tr2 ) - bb*cc + rtdisc = sqrt( -det ) + w( kbot-1 ) = ( tr2+rtdisc )*s + w( kbot ) = ( tr2-rtdisc )*s +* + ks = kbot - 1 + END IF + END IF +* + IF( kbot-ks+1.GT.ns ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + sorted = .false. + DO 50 k = kbot, ks + 1, -1 + IF( sorted ) + $ GO TO 60 + sorted = .true. + DO 40 i = ks, k - 1 + IF( cabs1( w( i ) ).LT.cabs1( w( i+1 ) ) ) + $ THEN + sorted = .false. + swap = w( i ) + w( i ) = w( i+1 ) + w( i+1 ) = swap + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( kbot-ks+1.EQ.2 ) THEN + IF( cabs1( w( kbot )-h( kbot, kbot ) ).LT. + $ cabs1( w( kbot-1 )-h( kbot, kbot ) ) ) THEN + w( kbot-1 ) = w( kbot ) + ELSE + w( kbot ) = w( kbot-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + ns = min( ns, kbot-ks+1 ) + ns = ns - mod( ns, 2 ) + ks = kbot - ns + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + kdu = 3*ns - 3 + ku = n - kdu + 1 + kwh = kdu + 1 + nho = ( n-kdu+1-4 ) - ( kdu+1 ) + 1 + kwv = kdu + 4 + nve = n - kdu - kwv + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns, + $ w( ks ), h, ldh, iloz, ihiz, z, ldz, work, + $ 3, h( ku, 1 ), ldh, nve, h( kwv, 1 ), ldh, + $ nho, h( ku, kwh ), ldh ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( ld.GT.0 ) THEN + ndfl = 1 + ELSE + ndfl = ndfl + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + info = kbot + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + work( 1 ) = dcmplx( lwkopt, 0 ) +* +* ==== End of ZLAQR4 ==== +* + END +C +C====================================================================== +C +*> \brief \b ZLAQR5 performs a single small-bulge multi-shift QR sweep. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQR5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, +* H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, +* WV, LDWV, NH, WH, LDWH ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, +* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), +* $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQR5, called by ZLAQR0, performs a +*> single small-bulge multi-shift QR sweep. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> WANTT = .true. if the triangular Schur factor +*> is being computed. WANTT is set to .false. otherwise. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> WANTZ = .true. if the unitary Schur factor is being +*> computed. WANTZ is set to .false. otherwise. +*> \endverbatim +*> +*> \param[in] KACC22 +*> \verbatim +*> KACC22 is INTEGER with value 0, 1, or 2. +*> Specifies the computation mode of far-from-diagonal +*> orthogonal updates. +*> = 0: ZLAQR5 does not accumulate reflections and does not +*> use matrix-matrix multiply to update far-from-diagonal +*> matrix entries. +*> = 1: ZLAQR5 accumulates reflections and uses matrix-matrix +*> multiply to update the far-from-diagonal matrix entries. +*> = 2: ZLAQR5 accumulates reflections, uses matrix-matrix +*> multiply to update the far-from-diagonal matrix entries, +*> and takes advantage of 2-by-2 block structure during +*> matrix multiplies. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> N is the order of the Hessenberg matrix H upon which this +*> subroutine operates. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> These are the first and last rows and columns of an +*> isolated diagonal block upon which the QR sweep is to be +*> applied. It is assumed without a check that +*> either KTOP = 1 or H(KTOP,KTOP-1) = 0 +*> and +*> either KBOT = N or H(KBOT+1,KBOT) = 0. +*> \endverbatim +*> +*> \param[in] NSHFTS +*> \verbatim +*> NSHFTS is INTEGER +*> NSHFTS gives the number of simultaneous shifts. NSHFTS +*> must be positive and even. +*> \endverbatim +*> +*> \param[in,out] S +*> \verbatim +*> S is COMPLEX*16 array, dimension (NSHFTS) +*> S contains the shifts of origin that define the multi- +*> shift QR sweep. On output S may be reordered. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On input H contains a Hessenberg matrix. On output a +*> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied +*> to the isolated diagonal block in rows and columns KTOP +*> through KBOT. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> LDH is the leading dimension of H just as declared in the +*> calling procedure. LDH.GE.MAX(1,N). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ,IHIZ) +*> If WANTZ = .TRUE., then the QR Sweep unitary +*> similarity transformation is accumulated into +*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ = .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> LDA is the leading dimension of Z just as declared in +*> the calling procedure. LDZ.GE.N. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDV,NSHFTS/2) +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> LDV is the leading dimension of V as declared in the +*> calling procedure. LDV.GE.3. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is COMPLEX*16 array, dimension (LDU,3*NSHFTS-3) +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> LDU is the leading dimension of U just as declared in the +*> in the calling subroutine. LDU.GE.3*NSHFTS-3. +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is INTEGER +*> NH is the number of columns in array WH available for +*> workspace. NH.GE.1. +*> \endverbatim +*> +*> \param[out] WH +*> \verbatim +*> WH is COMPLEX*16 array, dimension (LDWH,NH) +*> \endverbatim +*> +*> \param[in] LDWH +*> \verbatim +*> LDWH is INTEGER +*> Leading dimension of WH just as declared in the +*> calling procedure. LDWH.GE.3*NSHFTS-3. +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is INTEGER +*> NV is the number of rows in WV agailable for workspace. +*> NV.GE.1. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is COMPLEX*16 array, dimension (LDWV,3*NSHFTS-3) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is INTEGER +*> LDWV is the leading dimension of WV as declared in the +*> in the calling subroutine. LDWV.GE.NV. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> +* ===================================================================== + SUBROUTINE zlaqr5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, + $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, + $ WV, LDWV, NH, WH, LDWH ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ ldwh, ldwv, ldz, n, nh, nshfts, nv + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( ldh, * ), S( * ), U( ldu, * ), V( ldv, * ), + $ wh( ldwh, * ), wv( ldwv, * ), z( ldz, * ) +* .. +* +* ================================================================ +* .. Parameters .. + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d0, 0.0d0 ), + $ one = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + parameter( rzero = 0.0d0, rone = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 ALPHA, BETA, CDUM, REFSUM + DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, + $ smlnum, tst1, tst2, ulp + INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ jrow, jtop, k, k1, kdu, kms, knz, krcol, kzs, + $ m, m22, mbot, mend, mstart, mtop, nbmps, ndcol, + $ ns, nu + LOGICAL ACCUM, BLK22, BMP22 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL dlamch +* .. +* .. Intrinsic Functions .. +* + INTRINSIC abs, dble, dconjg, dimag, max, min, mod +* .. +* .. Local Arrays .. + COMPLEX*16 VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL dlabad, zgemm, zlacpy, zlaqr1, zlarfg, zlaset, + $ ztrmm +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( nshfts.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( ktop.GE.kbot ) + $ RETURN +* +* ==== NSHFTS is supposed to be even, but if it is odd, +* . then simply reduce it by one. ==== +* + ns = nshfts - mod( nshfts, 2 ) +* +* ==== Machine constants for deflation ==== +* + safmin = dlamch( 'SAFE MINIMUM' ) + safmax = rone / safmin + CALL dlabad( safmin, safmax ) + ulp = dlamch( 'PRECISION' ) + smlnum = safmin*( dble( n ) / ulp ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + accum = ( kacc22.EQ.1 ) .OR. ( kacc22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + blk22 = ( ns.GT.2 ) .AND. ( kacc22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( ktop+2.LE.kbot ) + $ h( ktop+2, ktop ) = zero +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + nbmps = ns / 2 +* +* ==== KDU = width of slab ==== +* + kdu = 6*nbmps - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + DO 210 incol = 3*( 1-nbmps ) + ktop - 1, kbot - 2, 3*nbmps - 2 + ndcol = incol + kdu + IF( accum ) + $ CALL zlaset( 'ALL', kdu, kdu, zero, one, u, ldu ) +* +* ==== Near-the-diagonal bulge chase. The following loop +* . performs the near-the-diagonal part of a small bulge +* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal +* . chunk extends from column INCOL to column NDCOL +* . (including both column INCOL and column NDCOL). The +* . following loop chases a 3*NBMPS column long chain of +* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL +* . may be less than KTOP and and NDCOL may be greater than +* . KBOT indicating phantom columns from which to chase +* . bulges before they are actually introduced or to which +* . to chase bulges beyond column KBOT.) ==== +* + DO 140 krcol = incol, min( incol+3*nbmps-3, kbot-2 ) +* +* ==== Bulges number MTOP to MBOT are active double implicit +* . shift bulges. There may or may not also be small +* . 2-by-2 bulge, if there is room. The inactive bulges +* . (if any) must wait until the active bulges have moved +* . down the diagonal to make room. The phantom matrix +* . paradigm described above helps keep track. ==== +* + mtop = max( 1, ( ( ktop-1 )-krcol+2 ) / 3+1 ) + mbot = min( nbmps, ( kbot-krcol ) / 3 ) + m22 = mbot + 1 + bmp22 = ( mbot.LT.nbmps ) .AND. ( krcol+3*( m22-1 ) ).EQ. + $ ( kbot-2 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + DO 10 m = mtop, mbot + k = krcol + 3*( m-1 ) + IF( k.EQ.ktop-1 ) THEN + CALL zlaqr1( 3, h( ktop, ktop ), ldh, s( 2*m-1 ), + $ s( 2*m ), v( 1, m ) ) + alpha = v( 1, m ) + CALL zlarfg( 3, alpha, v( 2, m ), 1, v( 1, m ) ) + ELSE + beta = h( k+1, k ) + v( 2, m ) = h( k+2, k ) + v( 3, m ) = h( k+3, k ) + CALL zlarfg( 3, beta, v( 2, m ), 1, v( 1, m ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( h( k+3, k ).NE.zero .OR. h( k+3, k+1 ).NE. + $ zero .OR. h( k+3, k+2 ).EQ.zero ) THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + h( k+1, k ) = beta + h( k+2, k ) = zero + h( k+3, k ) = zero + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL zlaqr1( 3, h( k+1, k+1 ), ldh, s( 2*m-1 ), + $ s( 2*m ), vt ) + alpha = vt( 1 ) + CALL zlarfg( 3, alpha, vt( 2 ), 1, vt( 1 ) ) + refsum = dconjg( vt( 1 ) )* + $ ( h( k+1, k )+dconjg( vt( 2 ) )* + $ h( k+2, k ) ) +* + IF( cabs1( h( k+2, k )-refsum*vt( 2 ) )+ + $ cabs1( refsum*vt( 3 ) ).GT.ulp* + $ ( cabs1( h( k, k ) )+cabs1( h( k+1, + $ k+1 ) )+cabs1( h( k+2, k+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + h( k+1, k ) = beta + h( k+2, k ) = zero + h( k+3, k ) = zero + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + h( k+1, k ) = h( k+1, k ) - refsum + h( k+2, k ) = zero + h( k+3, k ) = zero + v( 1, m ) = vt( 1 ) + v( 2, m ) = vt( 2 ) + v( 3, m ) = vt( 3 ) + END IF + END IF + END IF + 10 CONTINUE +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + k = krcol + 3*( m22-1 ) + IF( bmp22 ) THEN + IF( k.EQ.ktop-1 ) THEN + CALL zlaqr1( 2, h( k+1, k+1 ), ldh, s( 2*m22-1 ), + $ s( 2*m22 ), v( 1, m22 ) ) + beta = v( 1, m22 ) + CALL zlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) + ELSE + beta = h( k+1, k ) + v( 2, m22 ) = h( k+2, k ) + CALL zlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) + h( k+1, k ) = beta + h( k+2, k ) = zero + END IF + END IF +* +* ==== Multiply H by reflections from the left ==== +* + IF( accum ) THEN + jbot = min( ndcol, kbot ) + ELSE IF( wantt ) THEN + jbot = n + ELSE + jbot = kbot + END IF + DO 30 j = max( ktop, krcol ), jbot + mend = min( mbot, ( j-krcol+2 ) / 3 ) + DO 20 m = mtop, mend + k = krcol + 3*( m-1 ) + refsum = dconjg( v( 1, m ) )* + $ ( h( k+1, j )+dconjg( v( 2, m ) )* + $ h( k+2, j )+dconjg( v( 3, m ) )*h( k+3, j ) ) + h( k+1, j ) = h( k+1, j ) - refsum + h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m ) + h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m ) + 20 CONTINUE + 30 CONTINUE + IF( bmp22 ) THEN + k = krcol + 3*( m22-1 ) + DO 40 j = max( k+1, ktop ), jbot + refsum = dconjg( v( 1, m22 ) )* + $ ( h( k+1, j )+dconjg( v( 2, m22 ) )* + $ h( k+2, j ) ) + h( k+1, j ) = h( k+1, j ) - refsum + h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m22 ) + 40 CONTINUE + END IF +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + IF( accum ) THEN + jtop = max( ktop, incol ) + ELSE IF( wantt ) THEN + jtop = 1 + ELSE + jtop = ktop + END IF + DO 80 m = mtop, mbot + IF( v( 1, m ).NE.zero ) THEN + k = krcol + 3*( m-1 ) + DO 50 j = jtop, min( kbot, k+3 ) + refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )* + $ h( j, k+2 )+v( 3, m )*h( j, k+3 ) ) + h( j, k+1 ) = h( j, k+1 ) - refsum + h( j, k+2 ) = h( j, k+2 ) - + $ refsum*dconjg( v( 2, m ) ) + h( j, k+3 ) = h( j, k+3 ) - + $ refsum*dconjg( v( 3, m ) ) + 50 CONTINUE +* + IF( accum ) THEN +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + kms = k - incol + DO 60 j = max( 1, ktop-incol ), kdu + refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )* + $ u( j, kms+2 )+v( 3, m )*u( j, kms+3 ) ) + u( j, kms+1 ) = u( j, kms+1 ) - refsum + u( j, kms+2 ) = u( j, kms+2 ) - + $ refsum*dconjg( v( 2, m ) ) + u( j, kms+3 ) = u( j, kms+3 ) - + $ refsum*dconjg( v( 3, m ) ) + 60 CONTINUE + ELSE IF( wantz ) THEN +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + DO 70 j = iloz, ihiz + refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )* + $ z( j, k+2 )+v( 3, m )*z( j, k+3 ) ) + z( j, k+1 ) = z( j, k+1 ) - refsum + z( j, k+2 ) = z( j, k+2 ) - + $ refsum*dconjg( v( 2, m ) ) + z( j, k+3 ) = z( j, k+3 ) - + $ refsum*dconjg( v( 3, m ) ) + 70 CONTINUE + END IF + END IF + 80 CONTINUE +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + k = krcol + 3*( m22-1 ) + IF( bmp22 ) THEN + IF ( v( 1, m22 ).NE.zero ) THEN + DO 90 j = jtop, min( kbot, k+3 ) + refsum = v( 1, m22 )*( h( j, k+1 )+v( 2, m22 )* + $ h( j, k+2 ) ) + h( j, k+1 ) = h( j, k+1 ) - refsum + h( j, k+2 ) = h( j, k+2 ) - + $ refsum*dconjg( v( 2, m22 ) ) + 90 CONTINUE +* + IF( accum ) THEN + kms = k - incol + DO 100 j = max( 1, ktop-incol ), kdu + refsum = v( 1, m22 )*( u( j, kms+1 )+ + $ v( 2, m22 )*u( j, kms+2 ) ) + u( j, kms+1 ) = u( j, kms+1 ) - refsum + u( j, kms+2 ) = u( j, kms+2 ) - + $ refsum*dconjg( v( 2, m22 ) ) + 100 CONTINUE + ELSE IF( wantz ) THEN + DO 110 j = iloz, ihiz + refsum = v( 1, m22 )*( z( j, k+1 )+v( 2, m22 )* + $ z( j, k+2 ) ) + z( j, k+1 ) = z( j, k+1 ) - refsum + z( j, k+2 ) = z( j, k+2 ) - + $ refsum*dconjg( v( 2, m22 ) ) + 110 CONTINUE + END IF + END IF + END IF +* +* ==== Vigilant deflation check ==== +* + mstart = mtop + IF( krcol+3*( mstart-1 ).LT.ktop ) + $ mstart = mstart + 1 + mend = mbot + IF( bmp22 ) + $ mend = mend + 1 + IF( krcol.EQ.kbot-2 ) + $ mend = mend + 1 + DO 120 m = mstart, mend + k = min( kbot-1, krcol+3*( m-1 ) ) +* +* ==== The following convergence test requires that +* . the tradition small-compared-to-nearby-diagonals +* . criterion and the Ahues & Tisseur (LAWN 122, 1997) +* . criteria both be satisfied. The latter improves +* . accuracy in some examples. Falling back on an +* . alternate convergence criterion when TST1 or TST2 +* . is zero (as done here) is traditional but probably +* . unnecessary. ==== +* + IF( h( k+1, k ).NE.zero ) THEN + tst1 = cabs1( h( k, k ) ) + cabs1( h( k+1, k+1 ) ) + IF( tst1.EQ.rzero ) THEN + IF( k.GE.ktop+1 ) + $ tst1 = tst1 + cabs1( h( k, k-1 ) ) + IF( k.GE.ktop+2 ) + $ tst1 = tst1 + cabs1( h( k, k-2 ) ) + IF( k.GE.ktop+3 ) + $ tst1 = tst1 + cabs1( h( k, k-3 ) ) + IF( k.LE.kbot-2 ) + $ tst1 = tst1 + cabs1( h( k+2, k+1 ) ) + IF( k.LE.kbot-3 ) + $ tst1 = tst1 + cabs1( h( k+3, k+1 ) ) + IF( k.LE.kbot-4 ) + $ tst1 = tst1 + cabs1( h( k+4, k+1 ) ) + END IF + IF( cabs1( h( k+1, k ) ).LE.max( smlnum, ulp*tst1 ) ) + $ THEN + h12 = max( cabs1( h( k+1, k ) ), + $ cabs1( h( k, k+1 ) ) ) + h21 = min( cabs1( h( k+1, k ) ), + $ cabs1( h( k, k+1 ) ) ) + h11 = max( cabs1( h( k+1, k+1 ) ), + $ cabs1( h( k, k )-h( k+1, k+1 ) ) ) + h22 = min( cabs1( h( k+1, k+1 ) ), + $ cabs1( h( k, k )-h( k+1, k+1 ) ) ) + scl = h11 + h12 + tst2 = h22*( h11 / scl ) +* + IF( tst2.EQ.rzero .OR. h21*( h12 / scl ).LE. + $ max( smlnum, ulp*tst2 ) )h( k+1, k ) = zero + END IF + END IF + 120 CONTINUE +* +* ==== Fill in the last row of each bulge. ==== +* + mend = min( nbmps, ( kbot-krcol-1 ) / 3 ) + DO 130 m = mtop, mend + k = krcol + 3*( m-1 ) + refsum = v( 1, m )*v( 3, m )*h( k+4, k+3 ) + h( k+4, k+1 ) = -refsum + h( k+4, k+2 ) = -refsum*dconjg( v( 2, m ) ) + h( k+4, k+3 ) = h( k+4, k+3 ) - + $ refsum*dconjg( v( 3, m ) ) + 130 CONTINUE +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 140 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + IF( accum ) THEN + IF( wantt ) THEN + jtop = 1 + jbot = n + ELSE + jtop = ktop + jbot = kbot + END IF + IF( ( .NOT.blk22 ) .OR. ( incol.LT.ktop ) .OR. + $ ( ndcol.GT.kbot ) .OR. ( ns.LE.2 ) ) THEN +* +* ==== Updates not exploiting the 2-by-2 block +* . structure of U. K1 and NU keep track of +* . the location and size of U in the special +* . cases of introducing bulges and chasing +* . bulges off the bottom. In these special +* . cases and in case the number of shifts +* . is NS = 2, there is no 2-by-2 block +* . structure to exploit. ==== +* + k1 = max( 1, ktop-incol ) + nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1 +* +* ==== Horizontal Multiply ==== +* + DO 150 jcol = min( ndcol, kbot ) + 1, jbot, nh + jlen = min( nh, jbot-jcol+1 ) + CALL zgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ), + $ ldu, h( incol+k1, jcol ), ldh, zero, wh, + $ ldwh ) + CALL zlacpy( 'ALL', nu, jlen, wh, ldwh, + $ h( incol+k1, jcol ), ldh ) + 150 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 160 jrow = jtop, max( ktop, incol ) - 1, nv + jlen = min( nv, max( ktop, incol )-jrow ) + CALL zgemm( 'N', 'N', jlen, nu, nu, one, + $ h( jrow, incol+k1 ), ldh, u( k1, k1 ), + $ ldu, zero, wv, ldwv ) + CALL zlacpy( 'ALL', jlen, nu, wv, ldwv, + $ h( jrow, incol+k1 ), ldh ) + 160 CONTINUE +* +* ==== Z multiply (also vertical) ==== +* + IF( wantz ) THEN + DO 170 jrow = iloz, ihiz, nv + jlen = min( nv, ihiz-jrow+1 ) + CALL zgemm( 'N', 'N', jlen, nu, nu, one, + $ z( jrow, incol+k1 ), ldz, u( k1, k1 ), + $ ldu, zero, wv, ldwv ) + CALL zlacpy( 'ALL', jlen, nu, wv, ldwv, + $ z( jrow, incol+k1 ), ldz ) + 170 CONTINUE + END IF + ELSE +* +* ==== Updates exploiting U's 2-by-2 block structure. +* . (I2, I4, J2, J4 are the last rows and columns +* . of the blocks.) ==== +* + i2 = ( kdu+1 ) / 2 + i4 = kdu + j2 = i4 - i2 + j4 = kdu +* +* ==== KZS and KNZ deal with the band of zeros +* . along the diagonal of one of the triangular +* . blocks. ==== +* + kzs = ( j4-j2 ) - ( ns+1 ) + knz = ns + 1 +* +* ==== Horizontal multiply ==== +* + DO 180 jcol = min( ndcol, kbot ) + 1, jbot, nh + jlen = min( nh, jbot-jcol+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL zlacpy( 'ALL', knz, jlen, h( incol+1+j2, jcol ), + $ ldh, wh( kzs+1, 1 ), ldwh ) +* +* ==== Multiply by U21**H ==== +* + CALL zlaset( 'ALL', kzs, jlen, zero, zero, wh, ldwh ) + CALL ztrmm( 'L', 'U', 'C', 'N', knz, jlen, one, + $ u( j2+1, 1+kzs ), ldu, wh( kzs+1, 1 ), + $ ldwh ) +* +* ==== Multiply top of H by U11**H ==== +* + CALL zgemm( 'C', 'N', i2, jlen, j2, one, u, ldu, + $ h( incol+1, jcol ), ldh, one, wh, ldwh ) +* +* ==== Copy top of H to bottom of WH ==== +* + CALL zlacpy( 'ALL', j2, jlen, h( incol+1, jcol ), ldh, + $ wh( i2+1, 1 ), ldwh ) +* +* ==== Multiply by U21**H ==== +* + CALL ztrmm( 'L', 'L', 'C', 'N', j2, jlen, one, + $ u( 1, i2+1 ), ldu, wh( i2+1, 1 ), ldwh ) +* +* ==== Multiply by U22 ==== +* + CALL zgemm( 'C', 'N', i4-i2, jlen, j4-j2, one, + $ u( j2+1, i2+1 ), ldu, + $ h( incol+1+j2, jcol ), ldh, one, + $ wh( i2+1, 1 ), ldwh ) +* +* ==== Copy it back ==== +* + CALL zlacpy( 'ALL', kdu, jlen, wh, ldwh, + $ h( incol+1, jcol ), ldh ) + 180 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 190 jrow = jtop, max( incol, ktop ) - 1, nv + jlen = min( nv, max( incol, ktop )-jrow ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL zlacpy( 'ALL', jlen, knz, h( jrow, incol+1+j2 ), + $ ldh, wv( 1, 1+kzs ), ldwv ) +* +* ==== Multiply by U21 ==== +* + CALL zlaset( 'ALL', jlen, kzs, zero, zero, wv, ldwv ) + CALL ztrmm( 'R', 'U', 'N', 'N', jlen, knz, one, + $ u( j2+1, 1+kzs ), ldu, wv( 1, 1+kzs ), + $ ldwv ) +* +* ==== Multiply by U11 ==== +* + CALL zgemm( 'N', 'N', jlen, i2, j2, one, + $ h( jrow, incol+1 ), ldh, u, ldu, one, wv, + $ ldwv ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL zlacpy( 'ALL', jlen, j2, h( jrow, incol+1 ), ldh, + $ wv( 1, 1+i2 ), ldwv ) +* +* ==== Multiply by U21 ==== +* + CALL ztrmm( 'R', 'L', 'N', 'N', jlen, i4-i2, one, + $ u( 1, i2+1 ), ldu, wv( 1, 1+i2 ), ldwv ) +* +* ==== Multiply by U22 ==== +* + CALL zgemm( 'N', 'N', jlen, i4-i2, j4-j2, one, + $ h( jrow, incol+1+j2 ), ldh, + $ u( j2+1, i2+1 ), ldu, one, wv( 1, 1+i2 ), + $ ldwv ) +* +* ==== Copy it back ==== +* + CALL zlacpy( 'ALL', jlen, kdu, wv, ldwv, + $ h( jrow, incol+1 ), ldh ) + 190 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( wantz ) THEN + DO 200 jrow = iloz, ihiz, nv + jlen = min( nv, ihiz-jrow+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL zlacpy( 'ALL', jlen, knz, + $ z( jrow, incol+1+j2 ), ldz, + $ wv( 1, 1+kzs ), ldwv ) +* +* ==== Multiply by U12 ==== +* + CALL zlaset( 'ALL', jlen, kzs, zero, zero, wv, + $ ldwv ) + CALL ztrmm( 'R', 'U', 'N', 'N', jlen, knz, one, + $ u( j2+1, 1+kzs ), ldu, wv( 1, 1+kzs ), + $ ldwv ) +* +* ==== Multiply by U11 ==== +* + CALL zgemm( 'N', 'N', jlen, i2, j2, one, + $ z( jrow, incol+1 ), ldz, u, ldu, one, + $ wv, ldwv ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL zlacpy( 'ALL', jlen, j2, z( jrow, incol+1 ), + $ ldz, wv( 1, 1+i2 ), ldwv ) +* +* ==== Multiply by U21 ==== +* + CALL ztrmm( 'R', 'L', 'N', 'N', jlen, i4-i2, one, + $ u( 1, i2+1 ), ldu, wv( 1, 1+i2 ), + $ ldwv ) +* +* ==== Multiply by U22 ==== +* + CALL zgemm( 'N', 'N', jlen, i4-i2, j4-j2, one, + $ z( jrow, incol+1+j2 ), ldz, + $ u( j2+1, i2+1 ), ldu, one, + $ wv( 1, 1+i2 ), ldwv ) +* +* ==== Copy the result back to Z ==== +* + CALL zlacpy( 'ALL', jlen, kdu, wv, ldwv, + $ z( jrow, incol+1 ), ldz ) + 200 CONTINUE + END IF + END IF + END IF + 210 CONTINUE +* +* ==== End of ZLAQR5 ==== +* + END +C +C====================================================================== +C +*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, +* T, LDT, C, LDC, WORK, LDWORK ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, SIDE, STOREV, TRANS +* INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), +* $ WORK( LDWORK, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARFB applies a complex block reflector H or its transpose H**H to a +*> complex M-by-N matrix C, from either the left or the right. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply H or H**H from the Left +*> = 'R': apply H or H**H from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply H (No transpose) +*> = 'C': apply H**H (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is CHARACTER*1 +*> Indicates how H is formed from a product of elementary +*> reflectors +*> = 'F': H = H(1) H(2) . . . H(k) (Forward) +*> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Indicates how the vectors which define the elementary +*> reflectors are stored: +*> = 'C': Columnwise +*> = 'R': Rowwise +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the matrix T (= the number of elementary +*> reflectors whose product defines the block reflector). +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension +*> (LDV,K) if STOREV = 'C' +*> (LDV,M) if STOREV = 'R' and SIDE = 'L' +*> (LDV,N) if STOREV = 'R' and SIDE = 'R' +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +*> if STOREV = 'R', LDV >= K. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,K) +*> The triangular K-by-K matrix T in the representation of the +*> block reflector. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LDWORK,K) +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. +*> If SIDE = 'L', LDWORK >= max(1,N); +*> if SIDE = 'R', LDWORK >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2013 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The shape of the matrix V and the storage of the vectors which define +*> the H(i) is best illustrated by the following example with n = 5 and +*> k = 3. The elements equal to 1 are not stored; the corresponding +*> array elements are modified but restored on exit. The rest of the +*> array is not used. +*> +*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +*> +*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +*> ( v1 1 ) ( 1 v2 v2 v2 ) +*> ( v1 v2 1 ) ( 1 v3 v3 ) +*> ( v1 v2 v3 ) +*> ( v1 v2 v3 ) +*> +*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +*> +*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) +*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +*> ( 1 v3 ) +*> ( 1 ) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zlarfb( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2013 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 C( ldc, * ), T( ldt, * ), V( ldv, * ), + $ work( ldwork, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + parameter( one = ( 1.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL zcopy, zgemm, zlacgv, ztrmm +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( m.LE.0 .OR. n.LE.0 ) + $ RETURN +* + IF( lsame( trans, 'N' ) ) THEN + transt = 'C' + ELSE + transt = 'N' + END IF +* + IF( lsame( storev, 'C' ) ) THEN +* + IF( lsame( direct, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( lsame( side, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* +* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) +* +* W := C1**H +* + DO 10 j = 1, k + CALL zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + CALL zlacgv( n, work( 1, j ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', n, + $ k, one, v, ldv, work, ldwork ) + IF( m.GT.k ) THEN +* +* W := W + C2**H * V2 +* + CALL zgemm( 'Conjugate transpose', 'No transpose', n, + $ k, m-k, one, c( k+1, 1 ), ldc, + $ v( k+1, 1 ), ldv, one, work, ldwork ) + END IF +* +* W := W * T**H or W * T +* + CALL ztrmm( 'Right', 'Upper', transt, 'Non-unit', n, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - V * W**H +* + IF( m.GT.k ) THEN +* +* C2 := C2 - V2 * W**H +* + CALL zgemm( 'No transpose', 'Conjugate transpose', + $ m-k, n, k, -one, v( k+1, 1 ), ldv, work, + $ ldwork, one, c( k+1, 1 ), ldc ) + END IF +* +* W := W * V1**H +* + CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', n, k, one, v, ldv, work, ldwork ) +* +* C1 := C1 - W**H +* + DO 30 j = 1, k + DO 20 i = 1, n + c( j, i ) = c( j, i ) - dconjg( work( i, j ) ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( lsame( side, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 j = 1, k + CALL zcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', m, + $ k, one, v, ldv, work, ldwork ) + IF( n.GT.k ) THEN +* +* W := W + C2 * V2 +* + CALL zgemm( 'No transpose', 'No transpose', m, k, n-k, + $ one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv, + $ one, work, ldwork ) + END IF +* +* W := W * T or W * T**H +* + CALL ztrmm( 'Right', 'Upper', trans, 'Non-unit', m, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - W * V**H +* + IF( n.GT.k ) THEN +* +* C2 := C2 - W * V2**H +* + CALL zgemm( 'No transpose', 'Conjugate transpose', m, + $ n-k, k, -one, work, ldwork, v( k+1, 1 ), + $ ldv, one, c( 1, k+1 ), ldc ) + END IF +* +* W := W * V1**H +* + CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', m, k, one, v, ldv, work, ldwork ) +* +* C1 := C1 - W +* + DO 60 j = 1, k + DO 50 i = 1, m + c( i, j ) = c( i, j ) - work( i, j ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( lsame( side, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* +* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) +* +* W := C2**H +* + DO 70 j = 1, k + CALL zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + CALL zlacgv( n, work( 1, j ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', n, + $ k, one, v( m-k+1, 1 ), ldv, work, ldwork ) + IF( m.GT.k ) THEN +* +* W := W + C1**H * V1 +* + CALL zgemm( 'Conjugate transpose', 'No transpose', n, + $ k, m-k, one, c, ldc, v, ldv, one, work, + $ ldwork ) + END IF +* +* W := W * T**H or W * T +* + CALL ztrmm( 'Right', 'Lower', transt, 'Non-unit', n, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - V * W**H +* + IF( m.GT.k ) THEN +* +* C1 := C1 - V1 * W**H +* + CALL zgemm( 'No transpose', 'Conjugate transpose', + $ m-k, n, k, -one, v, ldv, work, ldwork, + $ one, c, ldc ) + END IF +* +* W := W * V2**H +* + CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', n, k, one, v( m-k+1, 1 ), ldv, work, + $ ldwork ) +* +* C2 := C2 - W**H +* + DO 90 j = 1, k + DO 80 i = 1, n + c( m-k+j, i ) = c( m-k+j, i ) - + $ dconjg( work( i, j ) ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( lsame( side, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 j = 1, k + CALL zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', m, + $ k, one, v( n-k+1, 1 ), ldv, work, ldwork ) + IF( n.GT.k ) THEN +* +* W := W + C1 * V1 +* + CALL zgemm( 'No transpose', 'No transpose', m, k, n-k, + $ one, c, ldc, v, ldv, one, work, ldwork ) + END IF +* +* W := W * T or W * T**H +* + CALL ztrmm( 'Right', 'Lower', trans, 'Non-unit', m, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - W * V**H +* + IF( n.GT.k ) THEN +* +* C1 := C1 - W * V1**H +* + CALL zgemm( 'No transpose', 'Conjugate transpose', m, + $ n-k, k, -one, work, ldwork, v, ldv, one, + $ c, ldc ) + END IF +* +* W := W * V2**H +* + CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', m, k, one, v( n-k+1, 1 ), ldv, work, + $ ldwork ) +* +* C2 := C2 - W +* + DO 120 j = 1, k + DO 110 i = 1, m + c( i, n-k+j ) = c( i, n-k+j ) - work( i, j ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( lsame( storev, 'R' ) ) THEN +* + IF( lsame( direct, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( lsame( side, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* +* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) +* +* W := C1**H +* + DO 130 j = 1, k + CALL zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + CALL zlacgv( n, work( 1, j ), 1 ) + 130 CONTINUE +* +* W := W * V1**H +* + CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', n, k, one, v, ldv, work, ldwork ) + IF( m.GT.k ) THEN +* +* W := W + C2**H * V2**H +* + CALL zgemm( 'Conjugate transpose', + $ 'Conjugate transpose', n, k, m-k, one, + $ c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, one, + $ work, ldwork ) + END IF +* +* W := W * T**H or W * T +* + CALL ztrmm( 'Right', 'Upper', transt, 'Non-unit', n, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - V**H * W**H +* + IF( m.GT.k ) THEN +* +* C2 := C2 - V2**H * W**H +* + CALL zgemm( 'Conjugate transpose', + $ 'Conjugate transpose', m-k, n, k, -one, + $ v( 1, k+1 ), ldv, work, ldwork, one, + $ c( k+1, 1 ), ldc ) + END IF +* +* W := W * V1 +* + CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', n, + $ k, one, v, ldv, work, ldwork ) +* +* C1 := C1 - W**H +* + DO 150 j = 1, k + DO 140 i = 1, n + c( j, i ) = c( j, i ) - dconjg( work( i, j ) ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( lsame( side, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* +* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) +* +* W := C1 +* + DO 160 j = 1, k + CALL zcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + 160 CONTINUE +* +* W := W * V1**H +* + CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', m, k, one, v, ldv, work, ldwork ) + IF( n.GT.k ) THEN +* +* W := W + C2 * V2**H +* + CALL zgemm( 'No transpose', 'Conjugate transpose', m, + $ k, n-k, one, c( 1, k+1 ), ldc, + $ v( 1, k+1 ), ldv, one, work, ldwork ) + END IF +* +* W := W * T or W * T**H +* + CALL ztrmm( 'Right', 'Upper', trans, 'Non-unit', m, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - W * V +* + IF( n.GT.k ) THEN +* +* C2 := C2 - W * V2 +* + CALL zgemm( 'No transpose', 'No transpose', m, n-k, k, + $ -one, work, ldwork, v( 1, k+1 ), ldv, one, + $ c( 1, k+1 ), ldc ) + END IF +* +* W := W * V1 +* + CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', m, + $ k, one, v, ldv, work, ldwork ) +* +* C1 := C1 - W +* + DO 180 j = 1, k + DO 170 i = 1, m + c( i, j ) = c( i, j ) - work( i, j ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( lsame( side, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* +* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) +* +* W := C2**H +* + DO 190 j = 1, k + CALL zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + CALL zlacgv( n, work( 1, j ), 1 ) + 190 CONTINUE +* +* W := W * V2**H +* + CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', n, k, one, v( 1, m-k+1 ), ldv, work, + $ ldwork ) + IF( m.GT.k ) THEN +* +* W := W + C1**H * V1**H +* + CALL zgemm( 'Conjugate transpose', + $ 'Conjugate transpose', n, k, m-k, one, c, + $ ldc, v, ldv, one, work, ldwork ) + END IF +* +* W := W * T**H or W * T +* + CALL ztrmm( 'Right', 'Lower', transt, 'Non-unit', n, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - V**H * W**H +* + IF( m.GT.k ) THEN +* +* C1 := C1 - V1**H * W**H +* + CALL zgemm( 'Conjugate transpose', + $ 'Conjugate transpose', m-k, n, k, -one, v, + $ ldv, work, ldwork, one, c, ldc ) + END IF +* +* W := W * V2 +* + CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', n, + $ k, one, v( 1, m-k+1 ), ldv, work, ldwork ) +* +* C2 := C2 - W**H +* + DO 210 j = 1, k + DO 200 i = 1, n + c( m-k+j, i ) = c( m-k+j, i ) - + $ dconjg( work( i, j ) ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( lsame( side, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* +* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) +* +* W := C2 +* + DO 220 j = 1, k + CALL zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + 220 CONTINUE +* +* W := W * V2**H +* + CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', m, k, one, v( 1, n-k+1 ), ldv, work, + $ ldwork ) + IF( n.GT.k ) THEN +* +* W := W + C1 * V1**H +* + CALL zgemm( 'No transpose', 'Conjugate transpose', m, + $ k, n-k, one, c, ldc, v, ldv, one, work, + $ ldwork ) + END IF +* +* W := W * T or W * T**H +* + CALL ztrmm( 'Right', 'Lower', trans, 'Non-unit', m, k, + $ one, t, ldt, work, ldwork ) +* +* C := C - W * V +* + IF( n.GT.k ) THEN +* +* C1 := C1 - W * V1 +* + CALL zgemm( 'No transpose', 'No transpose', m, n-k, k, + $ -one, work, ldwork, v, ldv, one, c, ldc ) + END IF +* +* W := W * V2 +* + CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', m, + $ k, one, v( 1, n-k+1 ), ldv, work, ldwork ) +* +* C1 := C1 - W +* + DO 240 j = 1, k + DO 230 i = 1, m + c( i, n-k+j ) = c( i, n-k+j ) - work( i, j ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of ZLARFB +* + END +C +C====================================================================== +C +*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* COMPLEX*16 TAU +* .. +* .. Array Arguments .. +* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARF applies a complex elementary reflector H to a complex M-by-N +*> matrix C, from either the left or the right. H is represented in the +*> form +*> +*> H = I - tau * v * v**H +*> +*> where tau is a complex scalar and v is a complex vector. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> To apply H**H, supply conjg(tau) instead +*> tau. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zlarf( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( ldc, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + parameter( one = ( 1.0d+0, 0.0d+0 ), + $ zero = ( 0.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL zgemv, zgerc +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAZLR, ILAZLC + EXTERNAL lsame, ilazlr, ilazlc +* .. +* .. Executable Statements .. +* + applyleft = lsame( side, 'L' ) + lastv = 0 + lastc = 0 + IF( tau.NE.zero ) THEN +* Set up variables for scanning V. LASTV begins pointing to the end +* of V. + IF( applyleft ) THEN + lastv = m + ELSE + lastv = n + END IF + IF( incv.GT.0 ) THEN + i = 1 + (lastv-1) * incv + ELSE + i = 1 + END IF +* Look for the last non-zero row in V. + DO WHILE( lastv.GT.0 .AND. v( i ).EQ.zero ) + lastv = lastv - 1 + i = i - incv + END DO + IF( applyleft ) THEN +* Scan for the last non-zero column in C(1:lastv,:). + lastc = ilazlc(lastv, n, c, ldc) + ELSE +* Scan for the last non-zero row in C(:,1:lastv). + lastc = ilazlr(m, lastv, c, ldc) + END IF + END IF +* Note that lastc.eq.0 renders the BLAS operations null; no special +* case is needed at this level. + IF( applyleft ) THEN +* +* Form H * C +* + IF( lastv.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) +* + CALL zgemv( 'Conjugate transpose', lastv, lastc, one, + $ c, ldc, v, incv, zero, work, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H +* + CALL zgerc( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + END IF + ELSE +* +* Form C * H +* + IF( lastv.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL zgemv( 'No transpose', lastc, lastv, one, c, ldc, + $ v, incv, zero, work, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H +* + CALL zgerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + END IF + END IF + RETURN +* +* End of ZLARF +* + END +C +C====================================================================== +C +*> \brief \b ZLARFG generates an elementary reflector (Householder matrix). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* COMPLEX*16 ALPHA, TAU +* .. +* .. Array Arguments .. +* COMPLEX*16 X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARFG generates a complex elementary reflector H of order n, such +*> that +*> +*> H**H * ( alpha ) = ( beta ), H**H * H = I. +*> ( x ) ( 0 ) +*> +*> where alpha and beta are scalars, with beta real, and x is an +*> (n-1)-element complex vector. H is represented in the form +*> +*> H = I - tau * ( 1 ) * ( 1 v**H ) , +*> ( v ) +*> +*> where tau is a complex scalar and v is a complex (n-1)-element +*> vector. Note that H is not hermitian. +*> +*> If the elements of x are all zero and alpha is real, then tau = 0 +*> and H is taken to be the unit matrix. +*> +*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the elementary reflector. +*> \endverbatim +*> +*> \param[in,out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, the value alpha. +*> On exit, it is overwritten with the value beta. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension +*> (1+(N-2)*abs(INCX)) +*> On entry, the vector x. +*> On exit, it is overwritten with the vector v. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between elements of X. INCX > 0. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 +*> The value tau. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zlarfg( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.8.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX, N + COMPLEX*16 ALPHA, TAU +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + parameter( one = 1.0d+0, zero = 0.0d+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 + COMPLEX*16 ZLADIV + EXTERNAL dlamch, dlapy3, dznrm2, zladiv +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dimag, sign +* .. +* .. External Subroutines .. + EXTERNAL zdscal, zscal +* .. +* .. Executable Statements .. +* + IF( n.LE.0 ) THEN + tau = zero + RETURN + END IF +* + xnorm = dznrm2( n-1, x, incx ) + alphr = dble( alpha ) + alphi = dimag( alpha ) +* + IF( xnorm.EQ.zero .AND. alphi.EQ.zero ) THEN +* +* H = I +* + tau = zero + ELSE +* +* general case +* + beta = -sign( dlapy3( alphr, alphi, xnorm ), alphr ) + safmin = dlamch( 'S' ) / dlamch( 'E' ) + rsafmn = one / safmin +* + knt = 0 + IF( abs( beta ).LT.safmin ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + 10 CONTINUE + knt = knt + 1 + CALL zdscal( n-1, rsafmn, x, incx ) + beta = beta*rsafmn + alphi = alphi*rsafmn + alphr = alphr*rsafmn + IF( (abs( beta ).LT.safmin) .AND. (knt .LT. 20) ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + xnorm = dznrm2( n-1, x, incx ) + alpha = dcmplx( alphr, alphi ) + beta = -sign( dlapy3( alphr, alphi, xnorm ), alphr ) + END IF + tau = dcmplx( ( beta-alphr ) / beta, -alphi / beta ) + alpha = zladiv( dcmplx( one ), alpha-beta ) + CALL zscal( n-1, alpha, x, incx ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 j = 1, knt + beta = beta*safmin + 20 CONTINUE + alpha = beta + END IF +* + RETURN +* +* End of ZLARFG +* + END +C +C====================================================================== +C +*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, STOREV +* INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. +* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARFT forms the triangular factor T of a complex block reflector H +*> of order n, which is defined as a product of k elementary reflectors. +*> +*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +*> +*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +*> +*> If STOREV = 'C', the vector which defines the elementary reflector +*> H(i) is stored in the i-th column of the array V, and +*> +*> H = I - V * T * V**H +*> +*> If STOREV = 'R', the vector which defines the elementary reflector +*> H(i) is stored in the i-th row of the array V, and +*> +*> H = I - V**H * T * V +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is CHARACTER*1 +*> Specifies the order in which the elementary reflectors are +*> multiplied to form the block reflector: +*> = 'F': H = H(1) H(2) . . . H(k) (Forward) +*> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Specifies how the vectors which define the elementary +*> reflectors are stored (see also Further Details): +*> = 'C': columnwise +*> = 'R': rowwise +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the block reflector H. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the triangular factor T (= the number of +*> elementary reflectors). K >= 1. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension +*> (LDV,K) if STOREV = 'C' +*> (LDV,N) if STOREV = 'R' +*> The matrix V. See further details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,K) +*> The k by k triangular factor T of the block reflector. +*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +*> lower triangular. The rest of the array is not used. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The shape of the matrix V and the storage of the vectors which define +*> the H(i) is best illustrated by the following example with n = 5 and +*> k = 3. The elements equal to 1 are not stored. +*> +*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +*> +*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +*> ( v1 1 ) ( 1 v2 v2 v2 ) +*> ( v1 v2 1 ) ( 1 v3 v3 ) +*> ( v1 v2 v3 ) +*> ( v1 v2 v3 ) +*> +*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +*> +*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) +*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +*> ( 1 v3 ) +*> ( 1 ) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zlarft( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + COMPLEX*16 T( ldt, * ), TAU( * ), V( ldv, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + parameter( one = ( 1.0d+0, 0.0d+0 ), + $ zero = ( 0.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV +* .. +* .. External Subroutines .. + EXTERNAL zgemv, ztrmv, zgemm +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( n.EQ.0 ) + $ RETURN +* + IF( lsame( direct, 'F' ) ) THEN + prevlastv = n + DO i = 1, k + prevlastv = max( prevlastv, i ) + IF( tau( i ).EQ.zero ) THEN +* +* H(i) = I +* + DO j = 1, i + t( j, i ) = zero + END DO + ELSE +* +* general case +* + IF( lsame( storev, 'C' ) ) THEN +* Skip any trailing zeros. + DO lastv = n, i+1, -1 + IF( v( lastv, i ).NE.zero ) EXIT + END DO + DO j = 1, i-1 + t( j, i ) = -tau( i ) * conjg( v( i , j ) ) + END DO + j = min( lastv, prevlastv ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) +* + CALL zgemv( 'Conjugate transpose', j-i, i-1, + $ -tau( i ), v( i+1, 1 ), ldv, + $ v( i+1, i ), 1, one, t( 1, i ), 1 ) + ELSE +* Skip any trailing zeros. + DO lastv = n, i+1, -1 + IF( v( i, lastv ).NE.zero ) EXIT + END DO + DO j = 1, i-1 + t( j, i ) = -tau( i ) * v( j , i ) + END DO + j = min( lastv, prevlastv ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H +* + CALL zgemm( 'N', 'C', i-1, 1, j-i, -tau( i ), + $ v( 1, i+1 ), ldv, v( i, i+1 ), ldv, + $ one, t( 1, i ), ldt ) + END IF +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL ztrmv( 'Upper', 'No transpose', 'Non-unit', i-1, t, + $ ldt, t( 1, i ), 1 ) + t( i, i ) = tau( i ) + IF( i.GT.1 ) THEN + prevlastv = max( prevlastv, lastv ) + ELSE + prevlastv = lastv + END IF + END IF + END DO + ELSE + prevlastv = 1 + DO i = k, 1, -1 + IF( tau( i ).EQ.zero ) THEN +* +* H(i) = I +* + DO j = i, k + t( j, i ) = zero + END DO + ELSE +* +* general case +* + IF( i.LT.k ) THEN + IF( lsame( storev, 'C' ) ) THEN +* Skip any leading zeros. + DO lastv = 1, i-1 + IF( v( lastv, i ).NE.zero ) EXIT + END DO + DO j = i+1, k + t( j, i ) = -tau( i ) * conjg( v( n-k+i , j ) ) + END DO + j = max( lastv, prevlastv ) +* +* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) +* + CALL zgemv( 'Conjugate transpose', n-k+i-j, k-i, + $ -tau( i ), v( j, i+1 ), ldv, v( j, i ), + $ 1, one, t( i+1, i ), 1 ) + ELSE +* Skip any leading zeros. + DO lastv = 1, i-1 + IF( v( i, lastv ).NE.zero ) EXIT + END DO + DO j = i+1, k + t( j, i ) = -tau( i ) * v( j, n-k+i ) + END DO + j = max( lastv, prevlastv ) +* +* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H +* + CALL zgemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ), + $ v( i+1, j ), ldv, v( i, j ), ldv, + $ one, t( i+1, i ), ldt ) + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL ztrmv( 'Lower', 'No transpose', 'Non-unit', k-i, + $ t( i+1, i+1 ), ldt, t( i+1, i ), 1 ) + IF( i.GT.1 ) THEN + prevlastv = min( prevlastv, lastv ) + ELSE + prevlastv = lastv + END IF + END IF + t( i, i ) = tau( i ) + END IF + END DO + END IF + RETURN +* +* End of ZLARFT +* + END +C +C====================================================================== +C +*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLARTG( F, G, CS, SN, R ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION CS +* COMPLEX*16 F, G, R, SN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARTG generates a plane rotation so that +*> +*> [ CS SN ] [ F ] [ R ] +*> [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. +*> [ -SN CS ] [ G ] [ 0 ] +*> +*> This is a faster version of the BLAS1 routine ZROTG, except for +*> the following differences: +*> F and G are unchanged on return. +*> If G=0, then CS=1 and SN=0. +*> If F=0, then CS=0 and SN is chosen so that R is real. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] F +*> \verbatim +*> F is COMPLEX*16 +*> The first component of vector to be rotated. +*> \endverbatim +*> +*> \param[in] G +*> \verbatim +*> G is COMPLEX*16 +*> The second component of vector to be rotated. +*> \endverbatim +*> +*> \param[out] CS +*> \verbatim +*> CS is DOUBLE PRECISION +*> The cosine of the rotation. +*> \endverbatim +*> +*> \param[out] SN +*> \verbatim +*> SN is COMPLEX*16 +*> The sine of the rotation. +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is COMPLEX*16 +*> The nonzero component of the rotated vector. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel +*> +*> This version has a few statements commented out for thread safety +*> (machine parameters are computed on each entry). 10 feb 03, SJH. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zlartg( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS + COMPLEX*16 F, G, R, SN +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION TWO, ONE, ZERO + parameter( two = 2.0d+0, one = 1.0d+0, zero = 0.0d+0 ) + COMPLEX*16 CZERO + parameter( czero = ( 0.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, + $ safmn2, safmx2, scale + COMPLEX*16 FF, FS, GS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + LOGICAL DISNAN + EXTERNAL dlamch, dlapy2, disnan +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dconjg, dimag, int, log, + $ max, sqrt +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1, ABSSQ +* .. +* .. Statement Function definitions .. + abs1( ff ) = max( abs( dble( ff ) ), abs( dimag( ff ) ) ) + abssq( ff ) = dble( ff )**2 + dimag( ff )**2 +* .. +* .. Executable Statements .. +* + safmin = dlamch( 'S' ) + eps = dlamch( 'E' ) + safmn2 = dlamch( 'B' )**int( log( safmin / eps ) / + $ log( dlamch( 'B' ) ) / two ) + safmx2 = one / safmn2 + scale = max( abs1( f ), abs1( g ) ) + fs = f + gs = g + count = 0 + IF( scale.GE.safmx2 ) THEN + 10 CONTINUE + count = count + 1 + fs = fs*safmn2 + gs = gs*safmn2 + scale = scale*safmn2 + IF( scale.GE.safmx2 ) + $ GO TO 10 + ELSE IF( scale.LE.safmn2 ) THEN + IF( g.EQ.czero.OR.disnan( abs( g ) ) ) THEN + cs = one + sn = czero + r = f + RETURN + END IF + 20 CONTINUE + count = count - 1 + fs = fs*safmx2 + gs = gs*safmx2 + scale = scale*safmx2 + IF( scale.LE.safmn2 ) + $ GO TO 20 + END IF + f2 = abssq( fs ) + g2 = abssq( gs ) + IF( f2.LE.max( g2, one )*safmin ) THEN +* +* This is a rare case: F is very small. +* + IF( f.EQ.czero ) THEN + cs = zero + r = dlapy2( dble( g ), dimag( g ) ) +* Do complex/real division explicitly with two real divisions + d = dlapy2( dble( gs ), dimag( gs ) ) + sn = dcmplx( dble( gs ) / d, -dimag( gs ) / d ) + RETURN + END IF + f2s = dlapy2( dble( fs ), dimag( fs ) ) +* G2 and G2S are accurate +* G2 is at least SAFMIN, and G2S is at least SAFMN2 + g2s = sqrt( g2 ) +* Error in CS from underflow in F2S is at most +* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS +* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, +* and so CS .lt. sqrt(SAFMIN) +* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN +* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) +* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S + cs = f2s / g2s +* Make sure abs(FF) = 1 +* Do complex/real division explicitly with 2 real divisions + IF( abs1( f ).GT.one ) THEN + d = dlapy2( dble( f ), dimag( f ) ) + ff = dcmplx( dble( f ) / d, dimag( f ) / d ) + ELSE + dr = safmx2*dble( f ) + di = safmx2*dimag( f ) + d = dlapy2( dr, di ) + ff = dcmplx( dr / d, di / d ) + END IF + sn = ff*dcmplx( dble( gs ) / g2s, -dimag( gs ) / g2s ) + r = cs*f + sn*g + ELSE +* +* This is the most common case. +* Neither F2 nor F2/G2 are less than SAFMIN +* F2S cannot overflow, and it is accurate +* + f2s = sqrt( one+g2 / f2 ) +* Do the F2S(real)*FS(complex) multiply with two real multiplies + r = dcmplx( f2s*dble( fs ), f2s*dimag( fs ) ) + cs = one / f2s + d = f2 + g2 +* Do complex/real division explicitly with two real divisions + sn = dcmplx( dble( r ) / d, dimag( r ) / d ) + sn = sn*dconjg( gs ) + IF( count.NE.0 ) THEN + IF( count.GT.0 ) THEN + DO 30 i = 1, count + r = r*safmx2 + 30 CONTINUE + ELSE + DO 40 i = 1, -count + r = r*safmn2 + 40 CONTINUE + END IF + END IF + END IF + RETURN +* +* End of ZLARTG +* + END +C +C====================================================================== +C +*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TYPE +* INTEGER INFO, KL, KU, LDA, M, N +* DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLASCL multiplies the M by N complex matrix A by the real scalar +*> CTO/CFROM. This is done without over/underflow as long as the final +*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +*> A may be full, upper triangular, lower triangular, upper Hessenberg, +*> or banded. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TYPE +*> \verbatim +*> TYPE is CHARACTER*1 +*> TYPE indices the storage type of the input matrix. +*> = 'G': A is a full matrix. +*> = 'L': A is a lower triangular matrix. +*> = 'U': A is an upper triangular matrix. +*> = 'H': A is an upper Hessenberg matrix. +*> = 'B': A is a symmetric band matrix with lower bandwidth KL +*> and upper bandwidth KU and with the only the lower +*> half stored. +*> = 'Q': A is a symmetric band matrix with lower bandwidth KL +*> and upper bandwidth KU and with the only the upper +*> half stored. +*> = 'Z': A is a band matrix with lower bandwidth KL and upper +*> bandwidth KU. See ZGBTRF for storage details. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The lower bandwidth of A. Referenced only if TYPE = 'B', +*> 'Q' or 'Z'. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The upper bandwidth of A. Referenced only if TYPE = 'B', +*> 'Q' or 'Z'. +*> \endverbatim +*> +*> \param[in] CFROM +*> \verbatim +*> CFROM is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] CTO +*> \verbatim +*> CTO is DOUBLE PRECISION +*> +*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed +*> without over/underflow if the final result CTO*A(I,J)/CFROM +*> can be represented without over/underflow. CFROM must be +*> nonzero. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The matrix to be multiplied by CTO/CFROM. See TYPE for the +*> storage type. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 0 - successful exit +*> <0 - if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zlascl( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + parameter( zero = 0.0d0, one = 1.0d0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL lsame, dlamch, disnan +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, max, min +* .. +* .. External Subroutines .. + EXTERNAL xerbla +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 +* + IF( lsame( TYPE, 'G' ) ) then + itype = 0 + ELSE IF( lsame( TYPE, 'L' ) ) then + itype = 1 + ELSE IF( lsame( TYPE, 'U' ) ) then + itype = 2 + ELSE IF( lsame( TYPE, 'H' ) ) then + itype = 3 + ELSE IF( lsame( TYPE, 'B' ) ) then + itype = 4 + ELSE IF( lsame( TYPE, 'Q' ) ) then + itype = 5 + ELSE IF( lsame( TYPE, 'Z' ) ) then + itype = 6 + ELSE + itype = -1 + END IF +* + IF( itype.EQ.-1 ) THEN + info = -1 + ELSE IF( cfrom.EQ.zero .OR. disnan(cfrom) ) THEN + info = -4 + ELSE IF( disnan(cto) ) THEN + info = -5 + ELSE IF( m.LT.0 ) THEN + info = -6 + ELSE IF( n.LT.0 .OR. ( itype.EQ.4 .AND. n.NE.m ) .OR. + $ ( itype.EQ.5 .AND. n.NE.m ) ) THEN + info = -7 + ELSE IF( itype.LE.3 .AND. lda.LT.max( 1, m ) ) THEN + info = -9 + ELSE IF( itype.GE.4 ) THEN + IF( kl.LT.0 .OR. kl.GT.max( m-1, 0 ) ) THEN + info = -2 + ELSE IF( ku.LT.0 .OR. ku.GT.max( n-1, 0 ) .OR. + $ ( ( itype.EQ.4 .OR. itype.EQ.5 ) .AND. kl.NE.ku ) ) + $ THEN + info = -3 + ELSE IF( ( itype.EQ.4 .AND. lda.LT.kl+1 ) .OR. + $ ( itype.EQ.5 .AND. lda.LT.ku+1 ) .OR. + $ ( itype.EQ.6 .AND. lda.LT.2*kl+ku+1 ) ) THEN + info = -9 + END IF + END IF +* + IF( info.NE.0 ) THEN + CALL xerbla( 'ZLASCL', -info ) + RETURN + END IF +* +* Quick return if possible +* + IF( n.EQ.0 .OR. m.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + smlnum = dlamch( 'S' ) + bignum = one / smlnum +* + cfromc = cfrom + ctoc = cto +* + 10 CONTINUE + cfrom1 = cfromc*smlnum + IF( cfrom1.EQ.cfromc ) THEN +! CFROMC is an inf. Multiply by a correctly signed zero for +! finite CTOC, or a NaN if CTOC is infinite. + mul = ctoc / cfromc + done = .true. + cto1 = ctoc + ELSE + cto1 = ctoc / bignum + IF( cto1.EQ.ctoc ) THEN +! CTOC is either 0 or an inf. In both cases, CTOC itself +! serves as the correct multiplication factor. + mul = ctoc + done = .true. + cfromc = one + ELSE IF( abs( cfrom1 ).GT.abs( ctoc ) .AND. ctoc.NE.zero ) THEN + mul = smlnum + done = .false. + cfromc = cfrom1 + ELSE IF( abs( cto1 ).GT.abs( cfromc ) ) THEN + mul = bignum + done = .false. + ctoc = cto1 + ELSE + mul = ctoc / cfromc + done = .true. + END IF + END IF +* + IF( itype.EQ.0 ) THEN +* +* Full matrix +* + DO 30 j = 1, n + DO 20 i = 1, m + a( i, j ) = a( i, j )*mul + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( itype.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 j = 1, n + DO 40 i = j, m + a( i, j ) = a( i, j )*mul + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( itype.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 j = 1, n + DO 60 i = 1, min( j, m ) + a( i, j ) = a( i, j )*mul + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( itype.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 j = 1, n + DO 80 i = 1, min( j+1, m ) + a( i, j ) = a( i, j )*mul + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( itype.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + k3 = kl + 1 + k4 = n + 1 + DO 110 j = 1, n + DO 100 i = 1, min( k3, k4-j ) + a( i, j ) = a( i, j )*mul + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( itype.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + k1 = ku + 2 + k3 = ku + 1 + DO 130 j = 1, n + DO 120 i = max( k1-j, 1 ), k3 + a( i, j ) = a( i, j )*mul + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( itype.EQ.6 ) THEN +* +* Band matrix +* + k1 = kl + ku + 2 + k2 = kl + 1 + k3 = 2*kl + ku + 1 + k4 = kl + ku + 1 + m + DO 150 j = 1, n + DO 140 i = max( k1-j, k2 ), min( k3, k4-j ) + a( i, j ) = a( i, j )*mul + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.done ) + $ GO TO 10 +* + RETURN +* +* End of ZLASCL +* + END +C +C====================================================================== +C +*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, M, N +* COMPLEX*16 ALPHA, BETA +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLASET initializes a 2-D array A to BETA on the diagonal and +*> ALPHA on the offdiagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies the part of the matrix A to be set. +*> = 'U': Upper triangular part is set. The lower triangle +*> is unchanged. +*> = 'L': Lower triangular part is set. The upper triangle +*> is unchanged. +*> Otherwise: All of the matrix A is set. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of A. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> All the offdiagonal array elements are set to ALPHA. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> All the diagonal array elements are set to BETA. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; +*> A(i,i) = BETA , 1 <= i <= min(m,n) +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zlaset( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + COMPLEX*16 ALPHA, BETA +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. Intrinsic Functions .. + INTRINSIC min +* .. +* .. Executable Statements .. +* + IF( lsame( uplo, 'U' ) ) THEN +* +* Set the diagonal to BETA and the strictly upper triangular +* part of the array to ALPHA. +* + DO 20 j = 2, n + DO 10 i = 1, min( j-1, m ) + a( i, j ) = alpha + 10 CONTINUE + 20 CONTINUE + DO 30 i = 1, min( n, m ) + a( i, i ) = beta + 30 CONTINUE +* + ELSE IF( lsame( uplo, 'L' ) ) THEN +* +* Set the diagonal to BETA and the strictly lower triangular +* part of the array to ALPHA. +* + DO 50 j = 1, min( m, n ) + DO 40 i = j + 1, m + a( i, j ) = alpha + 40 CONTINUE + 50 CONTINUE + DO 60 i = 1, min( n, m ) + a( i, i ) = beta + 60 CONTINUE +* + ELSE +* +* Set the array to BETA on the diagonal and ALPHA on the +* offdiagonal. +* + DO 80 j = 1, n + DO 70 i = 1, m + a( i, j ) = alpha + 70 CONTINUE + 80 CONTINUE + DO 90 i = 1, min( m, n ) + a( i, i ) = beta + 90 CONTINUE + END IF +* + RETURN +* +* End of ZLASET +* + END +C +C====================================================================== +C +*> \brief \b ZLASSQ updates a sum of squares represented in scaled form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. +* COMPLEX*16 X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLASSQ returns the values scl and ssq such that +*> +*> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, +*> +*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is +*> assumed to be at least unity and the value of ssq will then satisfy +*> +*> 1.0 .le. ssq .le. ( sumsq + 2*n ). +*> +*> scale is assumed to be non-negative and scl returns the value +*> +*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), +*> i +*> +*> scale and sumsq must be supplied in SCALE and SUMSQ respectively. +*> SCALE and SUMSQ are overwritten by scl and ssq respectively. +*> +*> The routine makes only one pass through the vector X. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of elements to be used from the vector X. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (N) +*> The vector x as described above. +*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive values of the vector X. +*> INCX > 0. +*> \endverbatim +*> +*> \param[in,out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> On entry, the value scale in the equation above. +*> On exit, SCALE is overwritten with the value scl . +*> \endverbatim +*> +*> \param[in,out] SUMSQ +*> \verbatim +*> SUMSQ is DOUBLE PRECISION +*> On entry, the value sumsq in the equation above. +*> On exit, SUMSQ is overwritten with the value ssq . +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zlassq( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + parameter( zero = 0.0d+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION TEMP1 +* .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL disnan +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dimag +* .. +* .. Executable Statements .. +* + IF( n.GT.0 ) THEN + DO 10 ix = 1, 1 + ( n-1 )*incx, incx + temp1 = abs( dble( x( ix ) ) ) + IF( temp1.GT.zero.OR.disnan( temp1 ) ) THEN + IF( scale.LT.temp1 ) THEN + sumsq = 1 + sumsq*( scale / temp1 )**2 + scale = temp1 + ELSE + sumsq = sumsq + ( temp1 / scale )**2 + END IF + END IF + temp1 = abs( dimag( x( ix ) ) ) + IF( temp1.GT.zero.OR.disnan( temp1 ) ) THEN + IF( scale.LT.temp1 ) THEN + sumsq = 1 + sumsq*( scale / temp1 )**2 + scale = temp1 + ELSE + sumsq = sumsq + ( temp1 / scale )**2 + END IF + END IF + 10 CONTINUE + END IF +* + RETURN +* +* End of ZLASSQ +* + END +C +C====================================================================== +C +*> \brief \b ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLATRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, +* CNORM, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, NORMIN, TRANS, UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. +* DOUBLE PRECISION CNORM( * ) +* COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLATRS solves one of the triangular systems +*> +*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b, +*> +*> with scaling to prevent overflow. Here A is an upper or lower +*> triangular matrix, A**T denotes the transpose of A, A**H denotes the +*> conjugate transpose of A, x and b are n-element vectors, and s is a +*> scaling factor, usually less than or equal to 1, chosen so that the +*> components of x will be less than the overflow threshold. If the +*> unscaled problem will not cause overflow, the Level 2 BLAS routine +*> ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), +*> then s is set to 0 and a non-trivial solution to A*x = 0 is returned. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the matrix A is upper or lower triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation applied to A. +*> = 'N': Solve A * x = s*b (No transpose) +*> = 'T': Solve A**T * x = s*b (Transpose) +*> = 'C': Solve A**H * x = s*b (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the matrix A is unit triangular. +*> = 'N': Non-unit triangular +*> = 'U': Unit triangular +*> \endverbatim +*> +*> \param[in] NORMIN +*> \verbatim +*> NORMIN is CHARACTER*1 +*> Specifies whether CNORM has been set or not. +*> = 'Y': CNORM contains the column norms on entry +*> = 'N': CNORM is not set on entry. On exit, the norms will +*> be computed and stored in CNORM. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The triangular matrix A. If UPLO = 'U', the leading n by n +*> upper triangular part of the array A contains the upper +*> triangular matrix, and the strictly lower triangular part of +*> A is not referenced. If UPLO = 'L', the leading n by n lower +*> triangular part of the array A contains the lower triangular +*> matrix, and the strictly upper triangular part of A is not +*> referenced. If DIAG = 'U', the diagonal elements of A are +*> also not referenced and are assumed to be 1. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max (1,N). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (N) +*> On entry, the right hand side b of the triangular system. +*> On exit, X is overwritten by the solution vector x. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> The scaling factor s for the triangular system +*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b. +*> If SCALE = 0, the matrix A is singular or badly scaled, and +*> the vector x is an exact or approximate solution to A*x = 0. +*> \endverbatim +*> +*> \param[in,out] CNORM +*> \verbatim +*> CNORM is DOUBLE PRECISION array, dimension (N) +*> +*> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) +*> contains the norm of the off-diagonal part of the j-th column +*> of A. If TRANS = 'N', CNORM(j) must be greater than or equal +*> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) +*> must be greater than or equal to the 1-norm. +*> +*> If NORMIN = 'N', CNORM is an output argument and CNORM(j) +*> returns the 1-norm of the offdiagonal part of the j-th column +*> of A. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> A rough bound on x is computed; if that is less than overflow, ZTRSV +*> is called, otherwise, specific code is used which checks for possible +*> overflow or divide-by-zero at every operation. +*> +*> A columnwise scheme is used for solving A*x = b. The basic algorithm +*> if A is lower triangular is +*> +*> x[1:n] := b[1:n] +*> for j = 1, ..., n +*> x(j) := x(j) / A(j,j) +*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] +*> end +*> +*> Define bounds on the components of x after j iterations of the loop: +*> M(j) = bound on x[1:j] +*> G(j) = bound on x[j+1:n] +*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. +*> +*> Then for iteration j+1 we have +*> M(j+1) <= G(j) / | A(j+1,j+1) | +*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | +*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) +*> +*> where CNORM(j+1) is greater than or equal to the infinity-norm of +*> column j+1 of A, not counting the diagonal. Hence +*> +*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) +*> 1<=i<=j +*> and +*> +*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) +*> 1<=i< j +*> +*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the +*> reciprocal of the largest M(j), j=1,..,n, is larger than +*> max(underflow, 1/overflow). +*> +*> The bound on x(j) is also used to determine when a step in the +*> columnwise method can be performed without fear of overflow. If +*> the computed bound is greater than a large constant, x is scaled to +*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to +*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. +*> +*> Similarly, a row-wise scheme is used to solve A**T *x = b or +*> A**H *x = b. The basic algorithm for A upper triangular is +*> +*> for j = 1, ..., n +*> x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) +*> end +*> +*> We simultaneously compute two bounds +*> G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j +*> M(j) = bound on x(i), 1<=i<=j +*> +*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we +*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. +*> Then the bound on x(j) is +*> +*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | +*> +*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) +*> 1<=i<=j +*> +*> and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater +*> than max(underflow, 1/overflow). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zlatrs( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, + $ CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.8.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION CNORM( * ) + COMPLEX*16 A( lda, * ), X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO + parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0, + $ two = 2.0d+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + INTEGER I, IMAX, J, JFIRST, JINC, JLAST + DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, + $ xbnd, xj, xmax + COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + COMPLEX*16 ZDOTC, ZDOTU, ZLADIV + EXTERNAL lsame, idamax, izamax, dlamch, dzasum, zdotc, + $ zdotu, zladiv +* .. +* .. External Subroutines .. + EXTERNAL dscal, xerbla, zaxpy, zdscal, ztrsv, dlabad +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1, CABS2 +* .. +* .. Statement Function definitions .. + cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) ) + cabs2( zdum ) = abs( dble( zdum ) / 2.d0 ) + + $ abs( dimag( zdum ) / 2.d0 ) +* .. +* .. Executable Statements .. +* + info = 0 + upper = lsame( uplo, 'U' ) + notran = lsame( trans, 'N' ) + nounit = lsame( diag, 'N' ) +* +* Test the input parameters. +* + IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN + info = -1 + ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. + $ lsame( trans, 'C' ) ) THEN + info = -2 + ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN + info = -3 + ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT. + $ lsame( normin, 'N' ) ) THEN + info = -4 + ELSE IF( n.LT.0 ) THEN + info = -5 + ELSE IF( lda.LT.max( 1, n ) ) THEN + info = -7 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZLATRS', -info ) + RETURN + END IF +* +* Quick return if possible +* + IF( n.EQ.0 ) + $ RETURN +* +* Determine machine dependent parameters to control overflow. +* + smlnum = dlamch( 'Safe minimum' ) + bignum = one / smlnum + CALL dlabad( smlnum, bignum ) + smlnum = smlnum / dlamch( 'Precision' ) + bignum = one / smlnum + scale = one +* + IF( lsame( normin, 'N' ) ) THEN +* +* Compute the 1-norm of each column, not including the diagonal. +* + IF( upper ) THEN +* +* A is upper triangular. +* + DO 10 j = 1, n + cnorm( j ) = dzasum( j-1, a( 1, j ), 1 ) + 10 CONTINUE + ELSE +* +* A is lower triangular. +* + DO 20 j = 1, n - 1 + cnorm( j ) = dzasum( n-j, a( j+1, j ), 1 ) + 20 CONTINUE + cnorm( n ) = zero + END IF + END IF +* +* Scale the column norms by TSCAL if the maximum element in CNORM is +* greater than BIGNUM/2. +* + imax = idamax( n, cnorm, 1 ) + tmax = cnorm( imax ) + IF( tmax.LE.bignum*half ) THEN + tscal = one + ELSE + tscal = half / ( smlnum*tmax ) + CALL dscal( n, tscal, cnorm, 1 ) + END IF +* +* Compute a bound on the computed solution vector to see if the +* Level 2 BLAS routine ZTRSV can be used. +* + xmax = zero + DO 30 j = 1, n + xmax = max( xmax, cabs2( x( j ) ) ) + 30 CONTINUE + xbnd = xmax +* + IF( notran ) THEN +* +* Compute the growth in A * x = b. +* + IF( upper ) THEN + jfirst = n + jlast = 1 + jinc = -1 + ELSE + jfirst = 1 + jlast = n + jinc = 1 + END IF +* + IF( tscal.NE.one ) THEN + grow = zero + GO TO 60 + END IF +* + IF( nounit ) THEN +* +* A is non-unit triangular. +* +* Compute GROW = 1/G(j) and XBND = 1/M(j). +* Initially, G(0) = max{x(i), i=1,...,n}. +* + grow = half / max( xbnd, smlnum ) + xbnd = grow + DO 40 j = jfirst, jlast, jinc +* +* Exit the loop if the growth factor is too small. +* + IF( grow.LE.smlnum ) + $ GO TO 60 +* + tjjs = a( j, j ) + tjj = cabs1( tjjs ) +* + IF( tjj.GE.smlnum ) THEN +* +* M(j) = G(j-1) / abs(A(j,j)) +* + xbnd = min( xbnd, min( one, tjj )*grow ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + xbnd = zero + END IF +* + IF( tjj+cnorm( j ).GE.smlnum ) THEN +* +* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) +* + grow = grow*( tjj / ( tjj+cnorm( j ) ) ) + ELSE +* +* G(j) could overflow, set GROW to 0. +* + grow = zero + END IF + 40 CONTINUE + grow = xbnd + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + grow = min( one, half / max( xbnd, smlnum ) ) + DO 50 j = jfirst, jlast, jinc +* +* Exit the loop if the growth factor is too small. +* + IF( grow.LE.smlnum ) + $ GO TO 60 +* +* G(j) = G(j-1)*( 1 + CNORM(j) ) +* + grow = grow*( one / ( one+cnorm( j ) ) ) + 50 CONTINUE + END IF + 60 CONTINUE +* + ELSE +* +* Compute the growth in A**T * x = b or A**H * x = b. +* + IF( upper ) THEN + jfirst = 1 + jlast = n + jinc = 1 + ELSE + jfirst = n + jlast = 1 + jinc = -1 + END IF +* + IF( tscal.NE.one ) THEN + grow = zero + GO TO 90 + END IF +* + IF( nounit ) THEN +* +* A is non-unit triangular. +* +* Compute GROW = 1/G(j) and XBND = 1/M(j). +* Initially, M(0) = max{x(i), i=1,...,n}. +* + grow = half / max( xbnd, smlnum ) + xbnd = grow + DO 70 j = jfirst, jlast, jinc +* +* Exit the loop if the growth factor is too small. +* + IF( grow.LE.smlnum ) + $ GO TO 90 +* +* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) +* + xj = one + cnorm( j ) + grow = min( grow, xbnd / xj ) +* + tjjs = a( j, j ) + tjj = cabs1( tjjs ) +* + IF( tjj.GE.smlnum ) THEN +* +* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) +* + IF( xj.GT.tjj ) + $ xbnd = xbnd*( tjj / xj ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + xbnd = zero + END IF + 70 CONTINUE + grow = min( grow, xbnd ) + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + grow = min( one, half / max( xbnd, smlnum ) ) + DO 80 j = jfirst, jlast, jinc +* +* Exit the loop if the growth factor is too small. +* + IF( grow.LE.smlnum ) + $ GO TO 90 +* +* G(j) = ( 1 + CNORM(j) )*G(j-1) +* + xj = one + cnorm( j ) + grow = grow / xj + 80 CONTINUE + END IF + 90 CONTINUE + END IF +* + IF( ( grow*tscal ).GT.smlnum ) THEN +* +* Use the Level 2 BLAS solve if the reciprocal of the bound on +* elements of X is not too small. +* + CALL ztrsv( uplo, trans, diag, n, a, lda, x, 1 ) + ELSE +* +* Use a Level 1 BLAS solve, scaling intermediate results. +* + IF( xmax.GT.bignum*half ) THEN +* +* Scale X so that its components are less than or equal to +* BIGNUM in absolute value. +* + scale = ( bignum*half ) / xmax + CALL zdscal( n, scale, x, 1 ) + xmax = bignum + ELSE + xmax = xmax*two + END IF +* + IF( notran ) THEN +* +* Solve A * x = b +* + DO 120 j = jfirst, jlast, jinc +* +* Compute x(j) = b(j) / A(j,j), scaling x if necessary. +* + xj = cabs1( x( j ) ) + IF( nounit ) THEN + tjjs = a( j, j )*tscal + ELSE + tjjs = tscal + IF( tscal.EQ.one ) + $ GO TO 110 + END IF + tjj = cabs1( tjjs ) + IF( tjj.GT.smlnum ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( tjj.LT.one ) THEN + IF( xj.GT.tjj*bignum ) THEN +* +* Scale x by 1/b(j). +* + rec = one / xj + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + END IF + x( j ) = zladiv( x( j ), tjjs ) + xj = cabs1( x( j ) ) + ELSE IF( tjj.GT.zero ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( xj.GT.tjj*bignum ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM +* to avoid overflow when dividing by A(j,j). +* + rec = ( tjj*bignum ) / xj + IF( cnorm( j ).GT.one ) THEN +* +* Scale by 1/CNORM(j) to avoid overflow when +* multiplying x(j) times column j. +* + rec = rec / cnorm( j ) + END IF + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + x( j ) = zladiv( x( j ), tjjs ) + xj = cabs1( x( j ) ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0, and compute a solution to A*x = 0. +* + DO 100 i = 1, n + x( i ) = zero + 100 CONTINUE + x( j ) = one + xj = one + scale = zero + xmax = zero + END IF + 110 CONTINUE +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j of A. +* + IF( xj.GT.one ) THEN + rec = one / xj + IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN +* +* Scale x by 1/(2*abs(x(j))). +* + rec = rec*half + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + END IF + ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN +* +* Scale x by 1/2. +* + CALL zdscal( n, half, x, 1 ) + scale = scale*half + END IF +* + IF( upper ) THEN + IF( j.GT.1 ) THEN +* +* Compute the update +* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) +* + CALL zaxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x, + $ 1 ) + i = izamax( j-1, x, 1 ) + xmax = cabs1( x( i ) ) + END IF + ELSE + IF( j.LT.n ) THEN +* +* Compute the update +* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) +* + CALL zaxpy( n-j, -x( j )*tscal, a( j+1, j ), 1, + $ x( j+1 ), 1 ) + i = j + izamax( n-j, x( j+1 ), 1 ) + xmax = cabs1( x( i ) ) + END IF + END IF + 120 CONTINUE +* + ELSE IF( lsame( trans, 'T' ) ) THEN +* +* Solve A**T * x = b +* + DO 170 j = jfirst, jlast, jinc +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + xj = cabs1( x( j ) ) + uscal = tscal + rec = one / max( xmax, one ) + IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + rec = rec*half + IF( nounit ) THEN + tjjs = a( j, j )*tscal + ELSE + tjjs = tscal + END IF + tjj = cabs1( tjjs ) + IF( tjj.GT.one ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + rec = min( one, rec*tjj ) + uscal = zladiv( uscal, tjjs ) + END IF + IF( rec.LT.one ) THEN + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + END IF +* + csumj = zero + IF( uscal.EQ.dcmplx( one ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTU to perform the dot product. +* + IF( upper ) THEN + csumj = zdotu( j-1, a( 1, j ), 1, x, 1 ) + ELSE IF( j.LT.n ) THEN + csumj = zdotu( n-j, a( j+1, j ), 1, x( j+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( upper ) THEN + DO 130 i = 1, j - 1 + csumj = csumj + ( a( i, j )*uscal )*x( i ) + 130 CONTINUE + ELSE IF( j.LT.n ) THEN + DO 140 i = j + 1, n + csumj = csumj + ( a( i, j )*uscal )*x( i ) + 140 CONTINUE + END IF + END IF +* + IF( uscal.EQ.dcmplx( tscal ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + x( j ) = x( j ) - csumj + xj = cabs1( x( j ) ) + IF( nounit ) THEN + tjjs = a( j, j )*tscal + ELSE + tjjs = tscal + IF( tscal.EQ.one ) + $ GO TO 160 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + tjj = cabs1( tjjs ) + IF( tjj.GT.smlnum ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( tjj.LT.one ) THEN + IF( xj.GT.tjj*bignum ) THEN +* +* Scale X by 1/abs(x(j)). +* + rec = one / xj + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + END IF + x( j ) = zladiv( x( j ), tjjs ) + ELSE IF( tjj.GT.zero ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( xj.GT.tjj*bignum ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + rec = ( tjj*bignum ) / xj + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + x( j ) = zladiv( x( j ), tjjs ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0 and compute a solution to A**T *x = 0. +* + DO 150 i = 1, n + x( i ) = zero + 150 CONTINUE + x( j ) = one + scale = zero + xmax = zero + END IF + 160 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + x( j ) = zladiv( x( j ), tjjs ) - csumj + END IF + xmax = max( xmax, cabs1( x( j ) ) ) + 170 CONTINUE +* + ELSE +* +* Solve A**H * x = b +* + DO 220 j = jfirst, jlast, jinc +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + xj = cabs1( x( j ) ) + uscal = tscal + rec = one / max( xmax, one ) + IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + rec = rec*half + IF( nounit ) THEN + tjjs = dconjg( a( j, j ) )*tscal + ELSE + tjjs = tscal + END IF + tjj = cabs1( tjjs ) + IF( tjj.GT.one ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + rec = min( one, rec*tjj ) + uscal = zladiv( uscal, tjjs ) + END IF + IF( rec.LT.one ) THEN + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + END IF +* + csumj = zero + IF( uscal.EQ.dcmplx( one ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTC to perform the dot product. +* + IF( upper ) THEN + csumj = zdotc( j-1, a( 1, j ), 1, x, 1 ) + ELSE IF( j.LT.n ) THEN + csumj = zdotc( n-j, a( j+1, j ), 1, x( j+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( upper ) THEN + DO 180 i = 1, j - 1 + csumj = csumj + ( dconjg( a( i, j ) )*uscal )* + $ x( i ) + 180 CONTINUE + ELSE IF( j.LT.n ) THEN + DO 190 i = j + 1, n + csumj = csumj + ( dconjg( a( i, j ) )*uscal )* + $ x( i ) + 190 CONTINUE + END IF + END IF +* + IF( uscal.EQ.dcmplx( tscal ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + x( j ) = x( j ) - csumj + xj = cabs1( x( j ) ) + IF( nounit ) THEN + tjjs = dconjg( a( j, j ) )*tscal + ELSE + tjjs = tscal + IF( tscal.EQ.one ) + $ GO TO 210 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + tjj = cabs1( tjjs ) + IF( tjj.GT.smlnum ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( tjj.LT.one ) THEN + IF( xj.GT.tjj*bignum ) THEN +* +* Scale X by 1/abs(x(j)). +* + rec = one / xj + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + END IF + x( j ) = zladiv( x( j ), tjjs ) + ELSE IF( tjj.GT.zero ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( xj.GT.tjj*bignum ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + rec = ( tjj*bignum ) / xj + CALL zdscal( n, rec, x, 1 ) + scale = scale*rec + xmax = xmax*rec + END IF + x( j ) = zladiv( x( j ), tjjs ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0 and compute a solution to A**H *x = 0. +* + DO 200 i = 1, n + x( i ) = zero + 200 CONTINUE + x( j ) = one + scale = zero + xmax = zero + END IF + 210 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + x( j ) = zladiv( x( j ), tjjs ) - csumj + END IF + xmax = max( xmax, cabs1( x( j ) ) ) + 220 CONTINUE + END IF + scale = scale / tscal + END IF +* +* Scale the column norms by 1/TSCAL for return. +* + IF( tscal.NE.one ) THEN + CALL dscal( n, one / tscal, cnorm, 1 ) + END IF +* + RETURN +* +* End of ZLATRS +* + END +C +C====================================================================== +C +*> \brief \b ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZROT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) +* +* .. Scalar Arguments .. +* INTEGER INCX, INCY, N +* DOUBLE PRECISION C +* COMPLEX*16 S +* .. +* .. Array Arguments .. +* COMPLEX*16 CX( * ), CY( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZROT applies a plane rotation, where the cos (C) is real and the +*> sin (S) is complex, and the vectors CX and CY are complex. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of elements in the vectors CX and CY. +*> \endverbatim +*> +*> \param[in,out] CX +*> \verbatim +*> CX is COMPLEX*16 array, dimension (N) +*> On input, the vector X. +*> On output, CX is overwritten with C*X + S*Y. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive values of CY. INCX <> 0. +*> \endverbatim +*> +*> \param[in,out] CY +*> \verbatim +*> CY is COMPLEX*16 array, dimension (N) +*> On input, the vector Y. +*> On output, CY is overwritten with -CONJG(S)*X + C*Y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> The increment between successive values of CY. INCX <> 0. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is COMPLEX*16 +*> C and S define a rotation +*> [ C S ] +*> [ -conjg(S) C ] +*> where C*C + S*CONJG(S) = 1.0. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + SUBROUTINE zrot( N, CX, INCX, CY, INCY, C, S ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C + COMPLEX*16 S +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ), CY( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IX, IY + COMPLEX*16 STEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg +* .. +* .. Executable Statements .. +* + IF( n.LE.0 ) + $ RETURN + IF( incx.EQ.1 .AND. incy.EQ.1 ) + $ GO TO 20 +* +* Code for unequal increments or equal increments not equal to 1 +* + ix = 1 + iy = 1 + IF( incx.LT.0 ) + $ ix = ( -n+1 )*incx + 1 + IF( incy.LT.0 ) + $ iy = ( -n+1 )*incy + 1 + DO 10 i = 1, n + stemp = c*cx( ix ) + s*cy( iy ) + cy( iy ) = c*cy( iy ) - dconjg( s )*cx( ix ) + cx( ix ) = stemp + ix = ix + incx + iy = iy + incy + 10 CONTINUE + RETURN +* +* Code for both increments equal to 1 +* + 20 CONTINUE + DO 30 i = 1, n + stemp = c*cx( i ) + s*cy( i ) + cy( i ) = c*cy( i ) - dconjg( s )*cx( i ) + cx( i ) = stemp + 30 CONTINUE + RETURN + END +C +C====================================================================== +C +*> \brief \b ZTREVC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZTREVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, +* LDVR, MM, M, WORK, RWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTREVC computes some or all of the right and/or left eigenvectors of +*> a complex upper triangular matrix T. +*> Matrices of this type are produced by the Schur factorization of +*> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. +*> +*> The right eigenvector x and the left eigenvector y of T corresponding +*> to an eigenvalue w are defined by: +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of the vector y. +*> The eigenvalues are not input to this routine, but are read directly +*> from the diagonal of T. +*> +*> This routine returns the matrices X and/or Y of right and left +*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +*> input matrix. If Q is the unitary factor that reduces a matrix A to +*> Schur form T, then Q*X and Q*Y are the matrices of right and left +*> eigenvectors of A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute all right and/or left eigenvectors; +*> = 'B': compute all right and/or left eigenvectors, +*> backtransformed using the matrices supplied in +*> VR and/or VL; +*> = 'S': compute selected right and/or left eigenvectors, +*> as indicated by the logical array SELECT. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +*> computed. +*> The eigenvector corresponding to the j-th eigenvalue is +*> computed if SELECT(j) = .TRUE.. +*> Not referenced if HOWMNY = 'A' or 'B'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,N) +*> The upper triangular matrix T. T is modified, but restored +*> on exit. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is COMPLEX*16 array, dimension (LDVL,MM) +*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by ZHSEQR). +*> On exit, if SIDE = 'L' or 'B', VL contains: +*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*Y; +*> if HOWMNY = 'S', the left eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VL, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1, and if +*> SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is COMPLEX*16 array, dimension (LDVR,MM) +*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by ZHSEQR). +*> On exit, if SIDE = 'R' or 'B', VR contains: +*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*X; +*> if HOWMNY = 'S', the right eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VR, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'L'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1, and if +*> SIDE = 'R' or 'B'; LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR actually +*> used to store the eigenvectors. If HOWMNY = 'A' or 'B', M +*> is set to N. Each selected eigenvector occupies one +*> column. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm used in this program is basically backward (forward) +*> substitution, with scaling to make the the code robust against +*> possible overflow. +*> +*> Each eigenvector is normalized so that the element of largest +*> magnitude has magnitude 1; here the magnitude of a complex number +*> (x,y) is taken to be |x| + |y|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ztrevc( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, RWORK, INFO ) +* +* -- LAPACK computational routine (version 3.8.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 T( ldt, * ), VL( ldvl, * ), VR( ldvr, * ), + $ work( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + parameter( zero = 0.0d+0, one = 1.0d+0 ) + COMPLEX*16 CMZERO, CMONE + parameter( cmzero = ( 0.0d+0, 0.0d+0 ), + $ cmone = ( 1.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV + INTEGER I, II, IS, J, K, KI + DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL lsame, izamax, dlamch, dzasum +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zcopy, zdscal, zgemv, zlatrs, dlabad +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, dconjg, dimag, max +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + bothv = lsame( side, 'B' ) + rightv = lsame( side, 'R' ) .OR. bothv + leftv = lsame( side, 'L' ) .OR. bothv +* + allv = lsame( howmny, 'A' ) + over = lsame( howmny, 'B' ) + somev = lsame( howmny, 'S' ) +* +* Set M to the number of columns required to store the selected +* eigenvectors. +* + IF( somev ) THEN + m = 0 + DO 10 j = 1, n + IF( SELECT( j ) ) + $ m = m + 1 + 10 CONTINUE + ELSE + m = n + END IF +* + info = 0 + IF( .NOT.rightv .AND. .NOT.leftv ) THEN + info = -1 + ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN + info = -2 + ELSE IF( n.LT.0 ) THEN + info = -4 + ELSE IF( ldt.LT.max( 1, n ) ) THEN + info = -6 + ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN + info = -8 + ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN + info = -10 + ELSE IF( mm.LT.m ) THEN + info = -11 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZTREVC', -info ) + RETURN + END IF +* +* Quick return if possible. +* + IF( n.EQ.0 ) + $ RETURN +* +* Set the constants to control overflow. +* + unfl = dlamch( 'Safe minimum' ) + ovfl = one / unfl + CALL dlabad( unfl, ovfl ) + ulp = dlamch( 'Precision' ) + smlnum = unfl*( n / ulp ) +* +* Store the diagonal elements of T in working array WORK. +* + DO 20 i = 1, n + work( i+n ) = t( i, i ) + 20 CONTINUE +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + rwork( 1 ) = zero + DO 30 j = 2, n + rwork( j ) = dzasum( j-1, t( 1, j ), 1 ) + 30 CONTINUE +* + IF( rightv ) THEN +* +* Compute right eigenvectors. +* + is = m + DO 80 ki = n, 1, -1 +* + IF( somev ) THEN + IF( .NOT.SELECT( ki ) ) + $ GO TO 80 + END IF + smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum ) +* + work( 1 ) = cmone +* +* Form right-hand side. +* + DO 40 k = 1, ki - 1 + work( k ) = -t( k, ki ) + 40 CONTINUE +* +* Solve the triangular system: +* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. +* + DO 50 k = 1, ki - 1 + t( k, k ) = t( k, k ) - t( ki, ki ) + IF( cabs1( t( k, k ) ).LT.smin ) + $ t( k, k ) = smin + 50 CONTINUE +* + IF( ki.GT.1 ) THEN + CALL zlatrs( 'Upper', 'No transpose', 'Non-unit', 'Y', + $ ki-1, t, ldt, work( 1 ), scale, rwork, + $ info ) + work( ki ) = scale + END IF +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.over ) THEN + CALL zcopy( ki, work( 1 ), 1, vr( 1, is ), 1 ) +* + ii = izamax( ki, vr( 1, is ), 1 ) + remax = one / cabs1( vr( ii, is ) ) + CALL zdscal( ki, remax, vr( 1, is ), 1 ) +* + DO 60 k = ki + 1, n + vr( k, is ) = cmzero + 60 CONTINUE + ELSE + IF( ki.GT.1 ) + $ CALL zgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ), + $ 1, dcmplx( scale ), vr( 1, ki ), 1 ) +* + ii = izamax( n, vr( 1, ki ), 1 ) + remax = one / cabs1( vr( ii, ki ) ) + CALL zdscal( n, remax, vr( 1, ki ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 70 k = 1, ki - 1 + t( k, k ) = work( k+n ) + 70 CONTINUE +* + is = is - 1 + 80 CONTINUE + END IF +* + IF( leftv ) THEN +* +* Compute left eigenvectors. +* + is = 1 + DO 130 ki = 1, n +* + IF( somev ) THEN + IF( .NOT.SELECT( ki ) ) + $ GO TO 130 + END IF + smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum ) +* + work( n ) = cmone +* +* Form right-hand side. +* + DO 90 k = ki + 1, n + work( k ) = -dconjg( t( ki, k ) ) + 90 CONTINUE +* +* Solve the triangular system: +* (T(KI+1:N,KI+1:N) - T(KI,KI))**H * X = SCALE*WORK. +* + DO 100 k = ki + 1, n + t( k, k ) = t( k, k ) - t( ki, ki ) + IF( cabs1( t( k, k ) ).LT.smin ) + $ t( k, k ) = smin + 100 CONTINUE +* + IF( ki.LT.n ) THEN + CALL zlatrs( 'Upper', 'Conjugate transpose', 'Non-unit', + $ 'Y', n-ki, t( ki+1, ki+1 ), ldt, + $ work( ki+1 ), scale, rwork, info ) + work( ki ) = scale + END IF +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.over ) THEN + CALL zcopy( n-ki+1, work( ki ), 1, vl( ki, is ), 1 ) +* + ii = izamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + remax = one / cabs1( vl( ii, is ) ) + CALL zdscal( n-ki+1, remax, vl( ki, is ), 1 ) +* + DO 110 k = 1, ki - 1 + vl( k, is ) = cmzero + 110 CONTINUE + ELSE + IF( ki.LT.n ) + $ CALL zgemv( 'N', n, n-ki, cmone, vl( 1, ki+1 ), ldvl, + $ work( ki+1 ), 1, dcmplx( scale ), + $ vl( 1, ki ), 1 ) +* + ii = izamax( n, vl( 1, ki ), 1 ) + remax = one / cabs1( vl( ii, ki ) ) + CALL zdscal( n, remax, vl( 1, ki ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 120 k = ki + 1, n + t( k, k ) = work( k+n ) + 120 CONTINUE +* + is = is + 1 + 130 CONTINUE + END IF +* + RETURN +* +* End of ZTREVC +* + END +C +C====================================================================== +C +*> \brief \b ZTREXC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZTREXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ +* INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. +* COMPLEX*16 Q( LDQ, * ), T( LDT, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTREXC reorders the Schur factorization of a complex matrix +*> A = Q*T*Q**H, so that the diagonal element of T with row index IFST +*> is moved to row ILST. +*> +*> The Schur form T is reordered by a unitary similarity transformation +*> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by +*> postmultplying it with Z. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'V': update the matrix Q of Schur vectors; +*> = 'N': do not update Q. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> If N == 0 arguments ILST and IFST may be any value. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,N) +*> On entry, the upper triangular matrix T. +*> On exit, the reordered upper triangular matrix. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is COMPLEX*16 array, dimension (LDQ,N) +*> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. +*> On exit, if COMPQ = 'V', Q has been postmultiplied by the +*> unitary transformation matrix Z which reorders T. +*> If COMPQ = 'N', Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= 1, and if +*> COMPQ = 'V', LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in] IFST +*> \verbatim +*> IFST is INTEGER +*> \endverbatim +*> +*> \param[in] ILST +*> \verbatim +*> ILST is INTEGER +*> +*> Specify the reordering of the diagonal elements of T: +*> The element with row index IFST is moved to row ILST by a +*> sequence of transpositions between adjacent elements. +*> 1 <= IFST <= N; 1 <= ILST <= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE ztrexc( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + COMPLEX*16 Q( ldq, * ), T( ldt, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER K, M1, M2, M3 + DOUBLE PRECISION CS + COMPLEX*16 SN, T11, T22, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zlartg, zrot +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg, max +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + info = 0 + wantq = lsame( compq, 'V' ) + IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN + info = -1 + ELSE IF( n.LT.0 ) THEN + info = -2 + ELSE IF( ldt.LT.max( 1, n ) ) THEN + info = -4 + ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.max( 1, n ) ) ) THEN + info = -6 + ELSE IF(( ifst.LT.1 .OR. ifst.GT.n ).AND.( n.GT.0 )) THEN + info = -7 + ELSE IF(( ilst.LT.1 .OR. ilst.GT.n ).AND.( n.GT.0 )) THEN + info = -8 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZTREXC', -info ) + RETURN + END IF +* +* Quick return if possible +* + IF( n.LE.1 .OR. ifst.EQ.ilst ) + $ RETURN +* + IF( ifst.LT.ilst ) THEN +* +* Move the IFST-th diagonal element forward down the diagonal. +* + m1 = 0 + m2 = -1 + m3 = 1 + ELSE +* +* Move the IFST-th diagonal element backward up the diagonal. +* + m1 = -1 + m2 = 0 + m3 = -1 + END IF +* + DO 10 k = ifst + m1, ilst + m2, m3 +* +* Interchange the k-th and (k+1)-th diagonal elements. +* + t11 = t( k, k ) + t22 = t( k+1, k+1 ) +* +* Determine the transformation to perform the interchange. +* + CALL zlartg( t( k, k+1 ), t22-t11, cs, sn, temp ) +* +* Apply transformation to the matrix T. +* + IF( k+2.LE.n ) + $ CALL zrot( n-k-1, t( k, k+2 ), ldt, t( k+1, k+2 ), ldt, cs, + $ sn ) + CALL zrot( k-1, t( 1, k ), 1, t( 1, k+1 ), 1, cs, + $ dconjg( sn ) ) +* + t( k, k ) = t22 + t( k+1, k+1 ) = t11 +* + IF( wantq ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL zrot( n, q( 1, k ), 1, q( 1, k+1 ), 1, cs, + $ dconjg( sn ) ) + END IF +* + 10 CONTINUE +* + RETURN +* +* End of ZTREXC +* + END +C +C====================================================================== +C +*> \brief \b ZUNG2R +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns, +*> which is defined as the first n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by ZGEQRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by ZGEQRF in the first k columns of its array +*> argument A. +*> On exit, the m by n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE zung2r( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + parameter( one = ( 1.0d+0, 0.0d+0 ), + $ zero = ( 0.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zlarf, zscal +* .. +* .. Intrinsic Functions .. + INTRINSIC max +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 + IF( m.LT.0 ) THEN + info = -1 + ELSE IF( n.LT.0 .OR. n.GT.m ) THEN + info = -2 + ELSE IF( k.LT.0 .OR. k.GT.n ) THEN + info = -3 + ELSE IF( lda.LT.max( 1, m ) ) THEN + info = -5 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZUNG2R', -info ) + RETURN + END IF +* +* Quick return if possible +* + IF( n.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 j = k + 1, n + DO 10 l = 1, m + a( l, j ) = zero + 10 CONTINUE + a( j, j ) = one + 20 CONTINUE +* + DO 40 i = k, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( i.LT.n ) THEN + a( i, i ) = one + CALL zlarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ), + $ a( i, i+1 ), lda, work ) + END IF + IF( i.LT.m ) + $ CALL zscal( m-i, -tau( i ), a( i+1, i ), 1 ) + a( i, i ) = one - tau( i ) +* +* Set A(1:i-1,i) to zero +* + DO 30 l = 1, i - 1 + a( l, i ) = zero + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNG2R +* + END +C +C====================================================================== +C +*> \brief \b ZUNGHR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNGHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNGHR generates a complex unitary matrix Q which is defined as the +*> product of IHI-ILO elementary reflectors of order N, as returned by +*> ZGEHRD: +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix Q. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI must have the same values as in the previous call +*> of ZGEHRD. Q is equal to the unit matrix except in the +*> submatrix Q(ilo+1:ihi,ilo+1:ihi). +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the vectors which define the elementary reflectors, +*> as returned by ZGEHRD. +*> On exit, the N-by-N unitary matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (N-1) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEHRD. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= IHI-ILO. +*> For optimum performance LWORK >= (IHI-ILO)*NB, where NB is +*> the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE zunghr( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + parameter( zero = ( 0.0d+0, 0.0d+0 ), + $ one = ( 1.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zungqr +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ilaenv +* .. +* .. Intrinsic Functions .. + INTRINSIC max, min +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 + nh = ihi - ilo + lquery = ( lwork.EQ.-1 ) + IF( n.LT.0 ) THEN + info = -1 + ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN + info = -2 + ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN + info = -3 + ELSE IF( lda.LT.max( 1, n ) ) THEN + info = -5 + ELSE IF( lwork.LT.max( 1, nh ) .AND. .NOT.lquery ) THEN + info = -8 + END IF +* + IF( info.EQ.0 ) THEN + nb = ilaenv( 1, 'ZUNGQR', ' ', nh, nh, nh, -1 ) + lwkopt = max( 1, nh )*nb + work( 1 ) = lwkopt + END IF +* + IF( info.NE.0 ) THEN + CALL xerbla( 'ZUNGHR', -info ) + RETURN + ELSE IF( lquery ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( n.EQ.0 ) THEN + work( 1 ) = 1 + RETURN + END IF +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first ilo and the last n-ihi +* rows and columns to those of the unit matrix +* + DO 40 j = ihi, ilo + 1, -1 + DO 10 i = 1, j - 1 + a( i, j ) = zero + 10 CONTINUE + DO 20 i = j + 1, ihi + a( i, j ) = a( i, j-1 ) + 20 CONTINUE + DO 30 i = ihi + 1, n + a( i, j ) = zero + 30 CONTINUE + 40 CONTINUE + DO 60 j = 1, ilo + DO 50 i = 1, n + a( i, j ) = zero + 50 CONTINUE + a( j, j ) = one + 60 CONTINUE + DO 80 j = ihi + 1, n + DO 70 i = 1, n + a( i, j ) = zero + 70 CONTINUE + a( j, j ) = one + 80 CONTINUE +* + IF( nh.GT.0 ) THEN +* +* Generate Q(ilo+1:ihi,ilo+1:ihi) +* + CALL zungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ), + $ work, lwork, iinfo ) + END IF + work( 1 ) = lwkopt + RETURN +* +* End of ZUNGHR +* + END +C +C====================================================================== +C +*> \brief \b ZUNGQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, +*> which is defined as the first N columns of a product of K elementary +*> reflectors of order M +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by ZGEQRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by ZGEQRF in the first k columns of its array +*> argument A. +*> On exit, the M-by-N matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,N). +*> For optimum performance LWORK >= N*NB, where NB is the +*> optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE zungqr( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + parameter( zero = ( 0.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ lwkopt, nb, nbmin, nx +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zlarfb, zlarft, zung2r +* .. +* .. Intrinsic Functions .. + INTRINSIC max, min +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ilaenv +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 + nb = ilaenv( 1, 'ZUNGQR', ' ', m, n, k, -1 ) + lwkopt = max( 1, n )*nb + work( 1 ) = lwkopt + lquery = ( lwork.EQ.-1 ) + IF( m.LT.0 ) THEN + info = -1 + ELSE IF( n.LT.0 .OR. n.GT.m ) THEN + info = -2 + ELSE IF( k.LT.0 .OR. k.GT.n ) THEN + info = -3 + ELSE IF( lda.LT.max( 1, m ) ) THEN + info = -5 + ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN + info = -8 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZUNGQR', -info ) + RETURN + ELSE IF( lquery ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( n.LE.0 ) THEN + work( 1 ) = 1 + RETURN + END IF +* + nbmin = 2 + nx = 0 + iws = n + IF( nb.GT.1 .AND. nb.LT.k ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + nx = max( 0, ilaenv( 3, 'ZUNGQR', ' ', m, n, k, -1 ) ) + IF( nx.LT.k ) THEN +* +* Determine if workspace is large enough for blocked code. +* + ldwork = n + iws = ldwork*nb + IF( lwork.LT.iws ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + nb = lwork / ldwork + nbmin = max( 2, ilaenv( 2, 'ZUNGQR', ' ', m, n, k, -1 ) ) + END IF + END IF + END IF +* + IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + ki = ( ( k-nx-1 ) / nb )*nb + kk = min( k, ki+nb ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 j = kk + 1, n + DO 10 i = 1, kk + a( i, j ) = zero + 10 CONTINUE + 20 CONTINUE + ELSE + kk = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( kk.LT.n ) + $ CALL zung2r( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda, + $ tau( kk+1 ), work, iinfo ) +* + IF( kk.GT.0 ) THEN +* +* Use blocked code +* + DO 50 i = ki + 1, 1, -nb + ib = min( nb, k-i+1 ) + IF( i+ib.LE.n ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL zlarft( 'Forward', 'Columnwise', m-i+1, ib, + $ a( i, i ), lda, tau( i ), work, ldwork ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL zlarfb( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', m-i+1, n-i-ib+1, ib, + $ a( i, i ), lda, work, ldwork, a( i, i+ib ), + $ lda, work( ib+1 ), ldwork ) + END IF +* +* Apply H to rows i:m of current block +* + CALL zung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work, + $ iinfo ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 j = i, i + ib - 1 + DO 30 l = 1, i - 1 + a( l, j ) = zero + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + work( 1 ) = iws + RETURN +* +* End of ZUNGQR +* + END +C +C====================================================================== +C +*> \brief \b DLABAD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLABAD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLABAD( SMALL, LARGE ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION LARGE, SMALL +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLABAD takes as input the values computed by DLAMCH for underflow and +*> overflow, and returns the square root of each of these values if the +*> log of LARGE is sufficiently large. This subroutine is intended to +*> identify machines with a large exponent range, such as the Crays, and +*> redefine the underflow and overflow limits to be the square roots of +*> the values computed by DLAMCH. This subroutine is needed because +*> DLAMCH does not compensate for poor arithmetic in the upper half of +*> the exponent range, as is found on a Cray. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] SMALL +*> \verbatim +*> SMALL is DOUBLE PRECISION +*> On entry, the underflow threshold as computed by DLAMCH. +*> On exit, if LOG10(LARGE) is sufficiently large, the square +*> root of SMALL, otherwise unchanged. +*> \endverbatim +*> +*> \param[in,out] LARGE +*> \verbatim +*> LARGE is DOUBLE PRECISION +*> On entry, the overflow threshold as computed by DLAMCH. +*> On exit, if LOG10(LARGE) is sufficiently large, the square +*> root of LARGE, otherwise unchanged. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + SUBROUTINE dlabad( SMALL, LARGE ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION LARGE, SMALL +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC log10, sqrt +* .. +* .. Executable Statements .. +* +* If it looks like we're on a Cray, take the square root of +* SMALL and LARGE to avoid overflow and underflow problems. +* + IF( log10( large ).GT.2000.d0 ) THEN + small = sqrt( small ) + large = sqrt( large ) + END IF +* + RETURN +* +* End of DLABAD +* + END +C +C====================================================================== +C +*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLADIV performs complex division in real arithmetic +*> +*> a + i*b +*> p + i*q = --------- +*> c + i*d +*> +*> The algorithm is due to Michael Baudin and Robert L. Smith +*> and can be found in the paper +*> "A Robust Complex Division in Scilab" +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION +*> The scalars a, b, c, and d in the above expression. +*> \endverbatim +*> +*> \param[out] P +*> \verbatim +*> P is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION +*> The scalars p and q in the above expression. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2013 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE dladiv( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION BS + parameter( bs = 2.0d0 ) + DOUBLE PRECISION HALF + parameter( half = 0.5d0 ) + DOUBLE PRECISION TWO + parameter( two = 2.0d0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL dlamch +* .. +* .. External Subroutines .. + EXTERNAL dladiv1 +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, max +* .. +* .. Executable Statements .. +* + aa = a + bb = b + cc = c + dd = d + ab = max( abs(a), abs(b) ) + cd = max( abs(c), abs(d) ) + s = 1.0d0 + + ov = dlamch( 'Overflow threshold' ) + un = dlamch( 'Safe minimum' ) + eps = dlamch( 'Epsilon' ) + be = bs / (eps*eps) + + IF( ab >= half*ov ) THEN + aa = half * aa + bb = half * bb + s = two * s + END IF + IF( cd >= half*ov ) THEN + cc = half * cc + dd = half * dd + s = half * s + END IF + IF( ab <= un*bs/eps ) THEN + aa = aa * be + bb = bb * be + s = s / be + END IF + IF( cd <= un*bs/eps ) THEN + cc = cc * be + dd = dd * be + s = s * be + END IF + IF( abs( d ).LE.abs( c ) ) THEN + CALL dladiv1(aa, bb, cc, dd, p, q) + ELSE + CALL dladiv1(bb, aa, dd, cc, p, q) + q = -q + END IF + p = p * s + q = q * s +* + RETURN +* +* End of DLADIV +* + END + +*> \ingroup doubleOTHERauxiliary + + + SUBROUTINE dladiv1( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + parameter( one = 1.0d0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION R, T +* .. +* .. External Functions .. + DOUBLE PRECISION DLADIV2 + EXTERNAL dladiv2 +* .. +* .. Executable Statements .. +* + r = d / c + t = one / (c + d * r) + p = dladiv2(a, b, c, d, r, t) + a = -a + q = dladiv2(b, a, c, d, r, t) +* + RETURN +* +* End of DLADIV1 +* + END + +*> \ingroup doubleOTHERauxiliary + + DOUBLE PRECISION FUNCTION dladiv2( A, B, C, D, R, T ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, R, T +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + parameter( zero = 0.0d0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION BR +* .. +* .. Executable Statements .. +* + IF( r.NE.zero ) THEN + br = b * r + IF( br.NE.zero ) THEN + dladiv2 = (a + br) * t + ELSE + dladiv2 = a * t + (b * t) * r + END IF + ELSE + dladiv2 = (a + d * (b / c)) * t + END IF +* + RETURN +* +* End of DLADIV12 +* + END +C +C====================================================================== +C +*> \brief \b DLAPY2 returns sqrt(x2+y2). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION X, Y +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +*> overflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> X and Y specify the values x and y. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION dlapy2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + parameter( zero = 0.0d0 ) + DOUBLE PRECISION ONE + parameter( one = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z + LOGICAL X_IS_NAN, Y_IS_NAN +* .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL disnan +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, max, min, sqrt +* .. +* .. Executable Statements .. +* + x_is_nan = disnan( x ) + y_is_nan = disnan( y ) + IF ( x_is_nan ) dlapy2 = x + IF ( y_is_nan ) dlapy2 = y +* + IF ( .NOT.( x_is_nan.OR.y_is_nan ) ) THEN + xabs = abs( x ) + yabs = abs( y ) + w = max( xabs, yabs ) + z = min( xabs, yabs ) + IF( z.EQ.zero ) THEN + dlapy2 = w + ELSE + dlapy2 = w*sqrt( one+( z / w )**2 ) + END IF + END IF + RETURN +* +* End of DLAPY2 +* + END +C +C====================================================================== +C +*> \brief \b DLAPY3 returns sqrt(x2+y2+z2). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPY3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION X, Y, Z +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause +*> unnecessary overflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION +*> X, Y and Z specify the values x, y and z. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION dlapy3( X, Y, Z ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y, Z +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + parameter( zero = 0.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, ZABS +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, max, sqrt +* .. +* .. Executable Statements .. +* + xabs = abs( x ) + yabs = abs( y ) + zabs = abs( z ) + w = max( xabs, yabs, zabs ) + IF( w.EQ.zero ) THEN +* W can be zero for max(0,nan,0) +* adding all three entries together will make sure +* NaN will not disappear. + dlapy3 = xabs + yabs + zabs + ELSE + dlapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+ + $ ( zabs / w )**2 ) + END IF + RETURN +* +* End of DLAPY3 +* + END +* +************************************************************************ +*> \brief \b DLAMCHF77 deprecated +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMCHF77 determines double precision machine parameters. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CMACH +*> \verbatim +*> Specifies the value to be returned by DLAMCH: +*> = 'E' or 'e', DLAMCH := eps +*> = 'S' or 's , DLAMCH := sfmin +*> = 'B' or 'b', DLAMCH := base +*> = 'P' or 'p', DLAMCH := eps*base +*> = 'N' or 'n', DLAMCH := t +*> = 'R' or 'r', DLAMCH := rnd +*> = 'M' or 'm', DLAMCH := emin +*> = 'U' or 'u', DLAMCH := rmin +*> = 'L' or 'l', DLAMCH := emax +*> = 'O' or 'o', DLAMCH := rmax +*> where +*> eps = relative machine precision +*> sfmin = safe minimum, such that 1/sfmin does not overflow +*> base = base of the machine +*> prec = eps*base +*> t = number of (base) digits in the mantissa +*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +*> emin = minimum exponent before (gradual) underflow +*> rmin = underflow threshold - base**(emin-1) +*> emax = largest exponent before overflow +*> rmax = overflow threshold - (base**emax)*(1-eps) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION dlamch( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + parameter( one = 1.0d+0, zero = 0.0d+0 ) +* .. +* .. Local Scalars .. + LOGICAL FIRST, LRND + INTEGER BETA, IMAX, IMIN, IT + DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, + $ rnd, sfmin, small, t +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL dlamc2 +* .. +* .. Save statement .. + SAVE first, eps, sfmin, base, t, rnd, emin, rmin, + $ emax, rmax, prec +* .. +* .. Data statements .. + DATA first / .true. / +* .. +* .. Executable Statements .. +* + IF( first ) THEN + CALL dlamc2( beta, it, lrnd, eps, imin, rmin, imax, rmax ) + base = beta + t = it + IF( lrnd ) THEN + rnd = one + eps = ( base**( 1-it ) ) / 2 + ELSE + rnd = zero + eps = base**( 1-it ) + END IF + prec = eps*base + emin = imin + emax = imax + sfmin = rmin + small = one / rmax + IF( small.GE.sfmin ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + sfmin = small*( one+eps ) + END IF + END IF +* + IF( lsame( cmach, 'E' ) ) THEN + rmach = eps + ELSE IF( lsame( cmach, 'S' ) ) THEN + rmach = sfmin + ELSE IF( lsame( cmach, 'B' ) ) THEN + rmach = base + ELSE IF( lsame( cmach, 'P' ) ) THEN + rmach = prec + ELSE IF( lsame( cmach, 'N' ) ) THEN + rmach = t + ELSE IF( lsame( cmach, 'R' ) ) THEN + rmach = rnd + ELSE IF( lsame( cmach, 'M' ) ) THEN + rmach = emin + ELSE IF( lsame( cmach, 'U' ) ) THEN + rmach = rmin + ELSE IF( lsame( cmach, 'L' ) ) THEN + rmach = emax + ELSE IF( lsame( cmach, 'O' ) ) THEN + rmach = rmax + END IF +* + dlamch = rmach + first = .false. + RETURN +* +* End of DLAMCH +* + END +* +************************************************************************ +* +*> \brief \b DLAMC1 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC1 determines the machine parameters given by BETA, T, RND, and +*> IEEE1. +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> The number of ( BETA ) digits in the mantissa. +*> \endverbatim +*> +*> \param[out] RND +*> \verbatim +*> Specifies whether proper rounding ( RND = .TRUE. ) or +*> chopping ( RND = .FALSE. ) occurs in addition. This may not +*> be a reliable guide to the way in which the machine performs +*> its arithmetic. +*> \endverbatim +*> +*> \param[out] IEEE1 +*> \verbatim +*> Specifies whether rounding appears to be done in the IEEE +*> 'round to nearest' style. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date April 2012 +*> \ingroup auxOTHERauxiliary +*> +*> \details \b Further \b Details +*> \verbatim +*> +*> The routine is based on the routine ENVRON by Malcolm and +*> incorporates suggestions by Gentleman and Marovich. See +*> +*> Malcolm M. A. (1972) Algorithms to reveal properties of +*> floating-point arithmetic. Comms. of the ACM, 15, 949-951. +*> +*> Gentleman W. M. and Marovich S. B. (1974) More on algorithms +*> that reveal properties of floating point arithmetic units. +*> Comms. of the ACM, 17, 276-277. +*> \endverbatim +*> + SUBROUTINE dlamc1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL dlamc3 +* .. +* .. Save statement .. + SAVE first, lieee1, lbeta, lrnd, lt +* .. +* .. Data statements .. + DATA first / .true. / +* .. +* .. Executable Statements .. +* + IF( first ) THEN + one = 1 +* +* LBETA, LIEEE1, LT and LRND are the local values of BETA, +* IEEE1, T and RND. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* Compute a = 2.0**m with the smallest positive integer m such +* that +* +* fl( a + 1.0 ) = a. +* + a = 1 + c = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( c.EQ.one ) THEN + a = 2*a + c = dlamc3( a, one ) + c = dlamc3( c, -a ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + b = 1 + c = dlamc3( a, b ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( c.EQ.a ) THEN + b = 2*b + c = dlamc3( a, b ) + GO TO 20 + END IF +*+ END WHILE +* +* Now compute the base. a and c are neighbouring floating point +* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so +* their difference is beta. Adding 0.25 to c is to ensure that it +* is truncated to beta and not ( beta - 1 ). +* + qtr = one / 4 + savec = c + c = dlamc3( c, -a ) + lbeta = c + qtr +* +* Now determine whether rounding or chopping occurs, by adding a +* bit less than beta/2 and a bit more than beta/2 to a. +* + b = lbeta + f = dlamc3( b / 2, -b / 100 ) + c = dlamc3( f, a ) + IF( c.EQ.a ) THEN + lrnd = .true. + ELSE + lrnd = .false. + END IF + f = dlamc3( b / 2, b / 100 ) + c = dlamc3( f, a ) + IF( ( lrnd ) .AND. ( c.EQ.a ) ) + $ lrnd = .false. +* +* Try and decide whether rounding is done in the IEEE 'round to +* nearest' style. B/2 is half a unit in the last place of the two +* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit +* zero, and SAVEC is odd. Thus adding B/2 to A should not change +* A, but adding B/2 to SAVEC should change SAVEC. +* + t1 = dlamc3( b / 2, a ) + t2 = dlamc3( b / 2, savec ) + lieee1 = ( t1.EQ.a ) .AND. ( t2.GT.savec ) .AND. lrnd +* +* Now find the mantissa, t. It should be the integer part of +* log to the base beta of a, however it is safer to determine t +* by powering. So we find t as the smallest positive integer for +* which +* +* fl( beta**t + 1.0 ) = 1.0. +* + lt = 0 + a = 1 + c = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( c.EQ.one ) THEN + lt = lt + 1 + a = a*lbeta + c = dlamc3( a, one ) + c = dlamc3( c, -a ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + beta = lbeta + t = lt + rnd = lrnd + ieee1 = lieee1 + first = .false. + RETURN +* +* End of DLAMC1 +* + END +* +************************************************************************ +* +*> \brief \b DLAMC2 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC2 determines the machine parameters specified in its argument +*> list. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date April 2012 +*> \ingroup auxOTHERauxiliary +*> +*> \param[out] BETA +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> The number of ( BETA ) digits in the mantissa. +*> \endverbatim +*> +*> \param[out] RND +*> \verbatim +*> Specifies whether proper rounding ( RND = .TRUE. ) or +*> chopping ( RND = .FALSE. ) occurs in addition. This may not +*> be a reliable guide to the way in which the machine performs +*> its arithmetic. +*> \endverbatim +*> +*> \param[out] EPS +*> \verbatim +*> The smallest positive number such that +*> fl( 1.0 - EPS ) .LT. 1.0, +*> where fl denotes the computed value. +*> \endverbatim +*> +*> \param[out] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow occurs. +*> \endverbatim +*> +*> \param[out] RMIN +*> \verbatim +*> The smallest normalized number for the machine, given by +*> BASE**( EMIN - 1 ), where BASE is the floating point value +*> of BETA. +*> \endverbatim +*> +*> \param[out] EMAX +*> \verbatim +*> The maximum exponent before overflow occurs. +*> \endverbatim +*> +*> \param[out] RMAX +*> \verbatim +*> The largest positive number for the machine, given by +*> BASE**EMAX * ( 1 - EPS ), where BASE is the floating point +*> value of BETA. +*> \endverbatim +*> +*> \details \b Further \b Details +*> \verbatim +*> +*> The computation of EPS is based on a routine PARANOIA by +*> W. Kahan of the University of California at Berkeley. +*> \endverbatim + SUBROUTINE dlamc2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ ngnmin, ngpmin + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ sixth, small, third, two, zero +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL dlamc3 +* .. +* .. External Subroutines .. + EXTERNAL dlamc1, dlamc4, dlamc5 +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, max, min +* .. +* .. Save statement .. + SAVE first, iwarn, lbeta, lemax, lemin, leps, lrmax, + $ lrmin, lt +* .. +* .. Data statements .. + DATA first / .true. / , iwarn / .false. / +* .. +* .. Executable Statements .. +* + IF( first ) THEN + zero = 0 + one = 1 + two = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of +* BETA, T, RND, EPS, EMIN and RMIN. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. +* + CALL dlamc1( lbeta, lt, lrnd, lieee1 ) +* +* Start to find EPS. +* + b = lbeta + a = b**( -lt ) + leps = a +* +* Try some tricks to see whether or not this is the correct EPS. +* + b = two / 3 + half = one / 2 + sixth = dlamc3( b, -half ) + third = dlamc3( sixth, sixth ) + b = dlamc3( third, -half ) + b = dlamc3( b, sixth ) + b = abs( b ) + IF( b.LT.leps ) + $ b = leps +* + leps = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( leps.GT.b ) .AND. ( b.GT.zero ) ) THEN + leps = b + c = dlamc3( half*leps, ( two**5 )*( leps**2 ) ) + c = dlamc3( half, -c ) + b = dlamc3( half, c ) + c = dlamc3( half, -b ) + b = dlamc3( half, c ) + GO TO 10 + END IF +*+ END WHILE +* + IF( a.LT.leps ) + $ leps = a +* +* Computation of EPS complete. +* +* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). +* Keep dividing A by BETA until (gradual) underflow occurs. This +* is detected when we cannot recover the previous A. +* + rbase = one / lbeta + small = one + DO 20 i = 1, 3 + small = dlamc3( small*rbase, zero ) + 20 CONTINUE + a = dlamc3( one, small ) + CALL dlamc4( ngpmin, one, lbeta ) + CALL dlamc4( ngnmin, -one, lbeta ) + CALL dlamc4( gpmin, a, lbeta ) + CALL dlamc4( gnmin, -a, lbeta ) + ieee = .false. +* + IF( ( ngpmin.EQ.ngnmin ) .AND. ( gpmin.EQ.gnmin ) ) THEN + IF( ngpmin.EQ.gpmin ) THEN + lemin = ngpmin +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( gpmin-ngpmin ).EQ.3 ) THEN + lemin = ngpmin - 1 + lt + ieee = .true. +* ( Non twos-complement machines, with gradual underflow; +* e.g., IEEE standard followers ) + ELSE + lemin = min( ngpmin, gpmin ) +* ( A guess; no known machine ) + iwarn = .true. + END IF +* + ELSE IF( ( ngpmin.EQ.gpmin ) .AND. ( ngnmin.EQ.gnmin ) ) THEN + IF( abs( ngpmin-ngnmin ).EQ.1 ) THEN + lemin = max( ngpmin, ngnmin ) +* ( Twos-complement machines, no gradual underflow; +* e.g., CYBER 205 ) + ELSE + lemin = min( ngpmin, ngnmin ) +* ( A guess; no known machine ) + iwarn = .true. + END IF +* + ELSE IF( ( abs( ngpmin-ngnmin ).EQ.1 ) .AND. + $ ( gpmin.EQ.gnmin ) ) THEN + IF( ( gpmin-min( ngpmin, ngnmin ) ).EQ.3 ) THEN + lemin = max( ngpmin, ngnmin ) - 1 + lt +* ( Twos-complement machines with gradual underflow; +* no known machine ) + ELSE + lemin = min( ngpmin, ngnmin ) +* ( A guess; no known machine ) + iwarn = .true. + END IF +* + ELSE + lemin = min( ngpmin, ngnmin, gpmin, gnmin ) +* ( A guess; no known machine ) + iwarn = .true. + END IF + first = .false. +*** +* Comment out this if block if EMIN is ok + IF( iwarn ) THEN + first = .true. + WRITE( 6, fmt = 9999 )lemin + END IF +*** +* +* Assume IEEE arithmetic if we found denormalised numbers above, +* or if arithmetic seems to round in the IEEE style, determined +* in routine DLAMC1. A true IEEE machine should have both things +* true; however, faulty machines may have one or the other. +* + ieee = ieee .OR. lieee1 +* +* Compute RMIN by successive division by BETA. We could compute +* RMIN as BASE**( EMIN - 1 ), but some machines underflow during +* this computation. +* + lrmin = 1 + DO 30 i = 1, 1 - lemin + lrmin = dlamc3( lrmin*rbase, zero ) + 30 CONTINUE +* +* Finally, call DLAMC5 to compute EMAX and RMAX. +* + CALL dlamc5( lbeta, lt, lemin, ieee, lemax, lrmax ) + END IF +* + beta = lbeta + t = lt + rnd = lrnd + eps = leps + emin = lemin + rmin = lrmin + emax = lemax + rmax = lrmax +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', i8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of DLAMC2 +* + END +* +************************************************************************ +* +*> \brief \b DLAMC3 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC3 is intended to force A and B to be stored prior to doing +*> the addition of A and B , for use in situations where optimizers +*> might hold one of these in a register. +*> \endverbatim +*> +*> \param[in] A +*> +*> \param[in] B +*> \verbatim +*> The values A and B. +*> \endverbatim + + DOUBLE PRECISION FUNCTION dlamc3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* ===================================================================== +* +* .. Executable Statements .. +* + dlamc3 = a + b +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ +* +*> \brief \b DLAMC4 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC4 is a service routine for DLAMC2. +*> \endverbatim +*> +*> \param[out] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow, computed by +*> setting A = START and dividing by BASE until the previous A +*> can not be recovered. +*> \endverbatim +*> +*> \param[in] START +*> \verbatim +*> The starting point for determining EMIN. +*> \endverbatim +*> +*> \param[in] BASE +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> + SUBROUTINE dlamc4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL dlamc3 +* .. +* .. Executable Statements .. +* + a = start + one = 1 + rbase = one / base + zero = 0 + emin = 1 + b1 = dlamc3( a*rbase, zero ) + c1 = a + c2 = a + d1 = a + d2 = a +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( c1.EQ.a ) .AND. ( c2.EQ.a ) .AND. ( d1.EQ.a ) .AND. + $ ( d2.EQ.a ) ) THEN + emin = emin - 1 + a = b1 + b1 = dlamc3( a / base, zero ) + c1 = dlamc3( b1*base, zero ) + d1 = zero + DO 20 i = 1, base + d1 = d1 + b1 + 20 CONTINUE + b2 = dlamc3( a*rbase, zero ) + c2 = dlamc3( b2 / rbase, zero ) + d2 = zero + DO 30 i = 1, base + d2 = d2 + b2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of DLAMC4 +* + END +* +************************************************************************ +* +*> \brief \b DLAMC5 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC5 attempts to compute RMAX, the largest machine floating-point +*> number, without overflow. It assumes that EMAX + abs(EMIN) sum +*> approximately to a power of 2. It will fail on machines where this +*> assumption does not hold, for example, the Cyber 205 (EMIN = -28625, +*> EMAX = 28718). It will also fail if the value supplied for EMIN is +*> too large (i.e. too close to zero), probably with overflow. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> The base of floating-point arithmetic. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> The number of base BETA digits in the mantissa of a +*> floating-point value. +*> \endverbatim +*> +*> \param[in] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow. +*> \endverbatim +*> +*> \param[in] IEEE +*> \verbatim +*> A logical flag specifying whether or not the arithmetic +*> system is thought to comply with the IEEE standard. +*> \endverbatim +*> +*> \param[out] EMAX +*> \verbatim +*> The largest exponent before overflow +*> \endverbatim +*> +*> \param[out] RMAX +*> \verbatim +*> The largest machine floating-point number. +*> \endverbatim +*> + SUBROUTINE dlamc5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + parameter( zero = 0.0d0, one = 1.0d0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL dlamc3 +* .. +* .. Intrinsic Functions .. + INTRINSIC mod +* .. +* .. Executable Statements .. +* +* First compute LEXP and UEXP, two powers of 2 that bound +* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum +* approximately to the bound that is closest to abs(EMIN). +* (EMAX is the exponent of the required number RMAX). +* + lexp = 1 + exbits = 1 + 10 CONTINUE + try = lexp*2 + IF( try.LE.( -emin ) ) THEN + lexp = try + exbits = exbits + 1 + GO TO 10 + END IF + IF( lexp.EQ.-emin ) THEN + uexp = lexp + ELSE + uexp = try + exbits = exbits + 1 + END IF +* +* Now -LEXP is less than or equal to EMIN, and -UEXP is greater +* than or equal to EMIN. EXBITS is the number of bits needed to +* store the exponent. +* + IF( ( uexp+emin ).GT.( -lexp-emin ) ) THEN + expsum = 2*lexp + ELSE + expsum = 2*uexp + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + emax = expsum + emin - 1 + nbits = 1 + exbits + p +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( mod( nbits, 2 ).EQ.1 ) .AND. ( beta.EQ.2 ) ) THEN +* +* Either there are an odd number of bits used to store a +* floating-point number, which is unlikely, or some bits are +* not used in the representation of numbers, which is possible, +* (e.g. Cray machines) or the mantissa has an implicit bit, +* (e.g. IEEE machines, Dec Vax machines), which is perhaps the +* most likely. We have to assume the last alternative. +* If this is true, then we need to reduce EMAX by one because +* there must be some way of representing zero in an implicit-bit +* system. On machines like Cray, we are reducing EMAX by one +* unnecessarily. +* + emax = emax - 1 + END IF +* + IF( ieee ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + emax = emax - 1 + END IF +* +* Now create RMAX, the largest machine number, which should +* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . +* +* First compute 1.0 - BETA**(-P), being careful that the +* result is less than 1.0 . +* + recbas = one / beta + z = beta - one + y = zero + DO 20 i = 1, p + z = z*recbas + IF( y.LT.one ) + $ oldy = y + y = dlamc3( y, z ) + 20 CONTINUE + IF( y.GE.one ) + $ y = oldy +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 i = 1, emax + y = dlamc3( y*beta, zero ) + 30 CONTINUE +* + rmax = y + RETURN +* +* End of DLAMC5 +* + END +C +C====================================================================== +C +*> \brief \b DZNRM2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DZNRM2 returns the euclidean norm of a vector via the function +*> name, so that +*> +*> DZNRM2 := sqrt( x**H*x ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (N) +*> complex vector with N elements +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of X +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> -- This version written on 25-October-1982. +*> Modified on 14-October-1993 to inline the call to ZLASSQ. +*> Sven Hammarling, Nag Ltd. +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION dznrm2(N,X,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + parameter(one=1.0d+0,zero=0.0d+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION NORM,SCALE,SSQ,TEMP + INTEGER IX +* .. +* .. Intrinsic Functions .. + INTRINSIC abs,dble,dimag,sqrt +* .. + IF (n.LT.1 .OR. incx.LT.1) THEN + norm = zero + ELSE + scale = zero + ssq = one +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10 ix = 1,1 + (n-1)*incx,incx + IF (dble(x(ix)).NE.zero) THEN + temp = abs(dble(x(ix))) + IF (scale.LT.temp) THEN + ssq = one + ssq* (scale/temp)**2 + scale = temp + ELSE + ssq = ssq + (temp/scale)**2 + END IF + END IF + IF (dimag(x(ix)).NE.zero) THEN + temp = abs(dimag(x(ix))) + IF (scale.LT.temp) THEN + ssq = one + ssq* (scale/temp)**2 + scale = temp + ELSE + ssq = ssq + (temp/scale)**2 + END IF + END IF + 10 CONTINUE + norm = scale*sqrt(ssq) + END IF +* + dznrm2 = norm + RETURN +* +* End of DZNRM2. +* + END +C +C====================================================================== +C +*> \brief \b ZDSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDSCAL(N,DA,ZX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zdscal(N,DA,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC dcmplx +* .. + IF (n.LE.0 .OR. incx.LE.0) RETURN + IF (incx.EQ.1) THEN +* +* code for increment equal to 1 +* + DO i = 1,n + zx(i) = dcmplx(da,0.0d0)*zx(i) + END DO + ELSE +* +* code for increment not equal to 1 +* + nincx = n*incx + DO i = 1,nincx,incx + zx(i) = dcmplx(da,0.0d0)*zx(i) + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b DZASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and +*> returns a single precision result. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION dzasum(N,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION STEMP + INTEGER I,NINCX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL dcabs1 +* .. + dzasum = 0.0d0 + stemp = 0.0d0 + IF (n.LE.0 .OR. incx.LE.0) RETURN + IF (incx.EQ.1) THEN +* +* code for increment equal to 1 +* + DO i = 1,n + stemp = stemp + dcabs1(zx(i)) + END DO + ELSE +* +* code for increment not equal to 1 +* + nincx = n*incx + DO i = 1,nincx,incx + stemp = stemp + dcabs1(zx(i)) + END DO + END IF + dzasum = stemp + RETURN + END +C +C====================================================================== +C +*> \brief \b IDAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IDAMAX finds the index of the first element having maximum absolute value. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup aux_blas +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION idamax(N,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC dabs +* .. + idamax = 0 + IF (n.LT.1 .OR. incx.LE.0) RETURN + idamax = 1 + IF (n.EQ.1) RETURN + IF (incx.EQ.1) THEN +* +* code for increment equal to 1 +* + dmax = dabs(dx(1)) + DO i = 2,n + IF (dabs(dx(i)).GT.dmax) THEN + idamax = i + dmax = dabs(dx(i)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + ix = 1 + dmax = dabs(dx(1)) + ix = ix + incx + DO i = 2,n + IF (dabs(dx(ix)).GT.dmax) THEN + idamax = i + dmax = dabs(dx(ix)) + END IF + ix = ix + incx + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b DSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSCAL scales a vector by a constant. +*> uses unrolled loops for increment equal to 1. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE dscal(N,DA,DX,INCX) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC mod +* .. + IF (n.LE.0 .OR. incx.LE.0) RETURN + IF (incx.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + m = mod(n,5) + IF (m.NE.0) THEN + DO i = 1,m + dx(i) = da*dx(i) + END DO + IF (n.LT.5) RETURN + END IF + mp1 = m + 1 + DO i = mp1,n,5 + dx(i) = da*dx(i) + dx(i+1) = da*dx(i+1) + dx(i+2) = da*dx(i+2) + dx(i+3) = da*dx(i+3) + dx(i+4) = da*dx(i+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + nincx = n*incx + DO i = 1,nincx,incx + dx(i) = da*dx(i) + END DO + END IF + RETURN + END +C +C======================================================================= +C +*> \brief \b ZTRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*x = b, or A**H*x = b, +*> +*> where b and x are n element vectors and A is an n by n unit, or +*> non-unit, upper or lower triangular matrix. +*> +*> No test for singularity or near-singularity is included in this +*> routine. Such tests must be performed before calling this routine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the equations to be solved as +*> follows: +*> +*> TRANS = 'N' or 'n' A*x = b. +*> +*> TRANS = 'T' or 't' A**T*x = b. +*> +*> TRANS = 'C' or 'c' A**H*x = b. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit +*> triangular as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element right-hand side vector b. On exit, X is overwritten +*> with the solution vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ztrsv(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(lda,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + parameter(zero= (0.0d+0,0.0d+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg,max +* .. +* +* Test the input parameters. +* + info = 0 + IF (.NOT.lsame(uplo,'U') .AND. .NOT.lsame(uplo,'L')) THEN + info = 1 + ELSE IF (.NOT.lsame(trans,'N') .AND. .NOT.lsame(trans,'T') .AND. + + .NOT.lsame(trans,'C')) THEN + info = 2 + ELSE IF (.NOT.lsame(diag,'U') .AND. .NOT.lsame(diag,'N')) THEN + info = 3 + ELSE IF (n.LT.0) THEN + info = 4 + ELSE IF (lda.LT.max(1,n)) THEN + info = 6 + ELSE IF (incx.EQ.0) THEN + info = 8 + END IF + IF (info.NE.0) THEN + CALL xerbla('ZTRSV ',info) + RETURN + END IF +* +* Quick return if possible. +* + IF (n.EQ.0) RETURN +* + noconj = lsame(trans,'T') + nounit = lsame(diag,'N') +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF (incx.LE.0) THEN + kx = 1 - (n-1)*incx + ELSE IF (incx.NE.1) THEN + kx = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (lsame(trans,'N')) THEN +* +* Form x := inv( A )*x. +* + IF (lsame(uplo,'U')) THEN + IF (incx.EQ.1) THEN + DO 20 j = n,1,-1 + IF (x(j).NE.zero) THEN + IF (nounit) x(j) = x(j)/a(j,j) + temp = x(j) + DO 10 i = j - 1,1,-1 + x(i) = x(i) - temp*a(i,j) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + jx = kx + (n-1)*incx + DO 40 j = n,1,-1 + IF (x(jx).NE.zero) THEN + IF (nounit) x(jx) = x(jx)/a(j,j) + temp = x(jx) + ix = jx + DO 30 i = j - 1,1,-1 + ix = ix - incx + x(ix) = x(ix) - temp*a(i,j) + 30 CONTINUE + END IF + jx = jx - incx + 40 CONTINUE + END IF + ELSE + IF (incx.EQ.1) THEN + DO 60 j = 1,n + IF (x(j).NE.zero) THEN + IF (nounit) x(j) = x(j)/a(j,j) + temp = x(j) + DO 50 i = j + 1,n + x(i) = x(i) - temp*a(i,j) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + jx = kx + DO 80 j = 1,n + IF (x(jx).NE.zero) THEN + IF (nounit) x(jx) = x(jx)/a(j,j) + temp = x(jx) + ix = jx + DO 70 i = j + 1,n + ix = ix + incx + x(ix) = x(ix) - temp*a(i,j) + 70 CONTINUE + END IF + jx = jx + incx + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A**T )*x or x := inv( A**H )*x. +* + IF (lsame(uplo,'U')) THEN + IF (incx.EQ.1) THEN + DO 110 j = 1,n + temp = x(j) + IF (noconj) THEN + DO 90 i = 1,j - 1 + temp = temp - a(i,j)*x(i) + 90 CONTINUE + IF (nounit) temp = temp/a(j,j) + ELSE + DO 100 i = 1,j - 1 + temp = temp - dconjg(a(i,j))*x(i) + 100 CONTINUE + IF (nounit) temp = temp/dconjg(a(j,j)) + END IF + x(j) = temp + 110 CONTINUE + ELSE + jx = kx + DO 140 j = 1,n + ix = kx + temp = x(jx) + IF (noconj) THEN + DO 120 i = 1,j - 1 + temp = temp - a(i,j)*x(ix) + ix = ix + incx + 120 CONTINUE + IF (nounit) temp = temp/a(j,j) + ELSE + DO 130 i = 1,j - 1 + temp = temp - dconjg(a(i,j))*x(ix) + ix = ix + incx + 130 CONTINUE + IF (nounit) temp = temp/dconjg(a(j,j)) + END IF + x(jx) = temp + jx = jx + incx + 140 CONTINUE + END IF + ELSE + IF (incx.EQ.1) THEN + DO 170 j = n,1,-1 + temp = x(j) + IF (noconj) THEN + DO 150 i = n,j + 1,-1 + temp = temp - a(i,j)*x(i) + 150 CONTINUE + IF (nounit) temp = temp/a(j,j) + ELSE + DO 160 i = n,j + 1,-1 + temp = temp - dconjg(a(i,j))*x(i) + 160 CONTINUE + IF (nounit) temp = temp/dconjg(a(j,j)) + END IF + x(j) = temp + 170 CONTINUE + ELSE + kx = kx + (n-1)*incx + jx = kx + DO 200 j = n,1,-1 + ix = kx + temp = x(jx) + IF (noconj) THEN + DO 180 i = n,j + 1,-1 + temp = temp - a(i,j)*x(ix) + ix = ix - incx + 180 CONTINUE + IF (nounit) temp = temp/a(j,j) + ELSE + DO 190 i = n,j + 1,-1 + temp = temp - dconjg(a(i,j))*x(ix) + ix = ix - incx + 190 CONTINUE + IF (nounit) temp = temp/dconjg(a(j,j)) + END IF + x(jx) = temp + jx = jx - incx + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRSV . +* + END +C +C======================================================================= +C +*> \brief \b ZAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZAXPY constant times a vector plus a vector. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zaxpy(N,ZA,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL dcabs1 +* .. + IF (n.LE.0) RETURN + IF (dcabs1(za).EQ.0.0d0) RETURN + IF (incx.EQ.1 .AND. incy.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,n + zy(i) = zy(i) + za*zx(i) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + ix = 1 + iy = 1 + IF (incx.LT.0) ix = (-n+1)*incx + 1 + IF (incy.LT.0) iy = (-n+1)*incy + 1 + DO i = 1,n + zy(iy) = zy(iy) + za*zx(ix) + ix = ix + incx + iy = iy + incy + END DO + END IF +* + RETURN + END +C +C======================================================================= +C +*> \brief \b ZDOTU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTU forms the dot product of two complex vectors +*> ZDOTU = X^T * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION zdotu(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + ztemp = (0.0d0,0.0d0) + zdotu = (0.0d0,0.0d0) + IF (n.LE.0) RETURN + IF (incx.EQ.1 .AND. incy.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,n + ztemp = ztemp + zx(i)*zy(i) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + ix = 1 + iy = 1 + IF (incx.LT.0) ix = (-n+1)*incx + 1 + IF (incy.LT.0) iy = (-n+1)*incy + 1 + DO i = 1,n + ztemp = ztemp + zx(ix)*zy(iy) + ix = ix + incx + iy = iy + incy + END DO + END IF + zdotu = ztemp + RETURN + END +C +C======================================================================= +C +*> \brief \b ZDOTC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTC forms the dot product of two complex vectors +*> ZDOTC = X^H * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION zdotc(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg +* .. + ztemp = (0.0d0,0.0d0) + zdotc = (0.0d0,0.0d0) + IF (n.LE.0) RETURN + IF (incx.EQ.1 .AND. incy.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,n + ztemp = ztemp + dconjg(zx(i))*zy(i) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + ix = 1 + iy = 1 + IF (incx.LT.0) ix = (-n+1)*incx + 1 + IF (incy.LT.0) iy = (-n+1)*incy + 1 + DO i = 1,n + ztemp = ztemp + dconjg(zx(ix))*zy(iy) + ix = ix + incx + iy = iy + incy + END DO + END IF + zdotc = ztemp + RETURN + END +C +C======================================================================= +C +*> \brief \b ZCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCOPY copies a vector, x, to a vector, y. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 4/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zcopy(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine (version 3.8.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. + IF (n.LE.0) RETURN + IF (incx.EQ.1 .AND. incy.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO i = 1,n + zy(i) = zx(i) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + ix = 1 + iy = 1 + IF (incx.LT.0) ix = (-n+1)*incx + 1 + IF (incy.LT.0) iy = (-n+1)*incy + 1 + DO i = 1,n + zy(iy) = zx(ix) + ix = ix + incx + iy = iy + incy + END DO + END IF + RETURN + END +C +C======================================================================= +C +*> \brief \b ZGERC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERC performs the rank 1 operation +*> +*> A := alpha*x*y**H + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, N ) +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE zgerc(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(lda,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + parameter(zero= (0.0d+0,0.0d+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL xerbla +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg,max +* .. +* +* Test the input parameters. +* + info = 0 + IF (m.LT.0) THEN + info = 1 + ELSE IF (n.LT.0) THEN + info = 2 + ELSE IF (incx.EQ.0) THEN + info = 5 + ELSE IF (incy.EQ.0) THEN + info = 7 + ELSE IF (lda.LT.max(1,m)) THEN + info = 9 + END IF + IF (info.NE.0) THEN + CALL xerbla('ZGERC ',info) + RETURN + END IF +* +* Quick return if possible. +* + IF ((m.EQ.0) .OR. (n.EQ.0) .OR. (alpha.EQ.zero)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (incy.GT.0) THEN + jy = 1 + ELSE + jy = 1 - (n-1)*incy + END IF + IF (incx.EQ.1) THEN + DO 20 j = 1,n + IF (y(jy).NE.zero) THEN + temp = alpha*dconjg(y(jy)) + DO 10 i = 1,m + a(i,j) = a(i,j) + x(i)*temp + 10 CONTINUE + END IF + jy = jy + incy + 20 CONTINUE + ELSE + IF (incx.GT.0) THEN + kx = 1 + ELSE + kx = 1 - (m-1)*incx + END IF + DO 40 j = 1,n + IF (y(jy).NE.zero) THEN + temp = alpha*dconjg(y(jy)) + ix = kx + DO 30 i = 1,m + a(i,j) = a(i,j) + x(ix)*temp + ix = ix + incx + 30 CONTINUE + END IF + jy = jy + incy + 40 CONTINUE + END IF +* + RETURN +* +* End of ZGERC . +* + END +C +C======================================================================= +C +*> \brief \b DISNAN tests input for NaN. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* LOGICAL FUNCTION DISNAN( DIN ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION, INTENT(IN) :: DIN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. +*> otherwise. To be replaced by the Fortran 2003 intrinsic in the +*> future. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIN +*> \verbatim +*> DIN is DOUBLE PRECISION +*> Input to test for NaN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + LOGICAL FUNCTION disnan( DIN ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION, INTENT(IN) :: DIN +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL DLAISNAN + EXTERNAL dlaisnan +* .. +* .. Executable Statements .. + disnan = dlaisnan(din,din) + RETURN + END +C +C======================================================================= +C +*> \brief \b ILAZLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAZLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAZLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAZLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ilazlc( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + parameter( zero = (0.0d+0, 0.0d+0) ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( n.EQ.0 ) THEN + ilazlc = n + ELSE IF( a(1, n).NE.zero .OR. a(m, n).NE.zero ) THEN + ilazlc = n + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ilazlc = n, 1, -1 + DO i = 1, m + IF( a(i, ilazlc).NE.zero ) RETURN + END DO + END DO + END IF + RETURN + END +C +C======================================================================= +C +*> \brief \b ILAZLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAZLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAZLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAZLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ilazlr( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + parameter( zero = (0.0d+0, 0.0d+0) ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( m.EQ.0 ) THEN + ilazlr = m + ELSE IF( a(m, 1).NE.zero .OR. a(m, n).NE.zero ) THEN + ilazlr = m + ELSE +* Scan up each column tracking the last zero row seen. + ilazlr = 0 + DO j = 1, n + i=m + DO WHILE((a(max(i,1),j).EQ.zero).AND.(i.GE.1)) + i=i-1 + ENDDO + ilazlr = max( ilazlr, i ) + END DO + END IF + RETURN + END +C +C======================================================================= +C +*> \brief \b IPARMQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, ISPEC, LWORK, N +* CHARACTER NAME*( * ), OPTS*( * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever +*> IPARMQ is called with 12 <= ISPEC <= 16 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> ISPEC specifies which tunable parameter IPARMQ should +*> return. +*> +*> ISPEC=12: (INMIN) Matrices of order nmin or less +*> are sent directly to xLAHQR, the implicit +*> double shift QR algorithm. NMIN must be +*> at least 11. +*> +*> ISPEC=13: (INWIN) Size of the deflation window. +*> This is best set greater than or equal to +*> the number of simultaneous shifts NS. +*> Larger matrices benefit from larger deflation +*> windows. +*> +*> ISPEC=14: (INIBL) Determines when to stop nibbling and +*> invest in an (expensive) multi-shift QR sweep. +*> If the aggressive early deflation subroutine +*> finds LD converged eigenvalues from an order +*> NW deflation window and LD.GT.(NW*NIBBLE)/100, +*> then the next QR sweep is skipped and early +*> deflation is applied immediately to the +*> remaining active diagonal block. Setting +*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +*> multi-shift QR sweep whenever early deflation +*> finds a converged eigenvalue. Setting +*> IPARMQ(ISPEC=14) greater than or equal to 100 +*> prevents TTQRE from skipping a multi-shift +*> QR sweep. +*> +*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in +*> a multi-shift QR iteration. +*> +*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +*> following meanings. +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the +*> far-from-diagonal matrix entries. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. +*> (If xTRMM is slower than xGEMM, then +*> IPARMQ(ISPEC=16)=1 may be more efficient than +*> IPARMQ(ISPEC=16)=2 despite the greater level of +*> arithmetic work implied by the latter choice.) +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is character string +*> This is a concatenation of the string arguments to +*> TTQRE. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> N is the order of the Hessenberg matrix H. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The amount of workspace available. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Little is known about how best to choose these parameters. +*> It is possible to use different values of the parameters +*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +*> +*> It is probably best to choose different parameters for +*> different matrices and different parameters at different +*> times during the iteration, but this has not been +*> implemented --- yet. +*> +*> +*> The best choices of most of the parameters depend +*> in an ill-understood way on the relative execution +*> rate of xLAQR3 and xLAQR5 and on the nature of each +*> particular eigenvalue problem. Experiment may be the +*> only practical way to determine which choices are most +*> effective. +*> +*> Following is a list of default values supplied by IPARMQ. +*> These defaults may be adjusted in order to attain better +*> performance in any particular computational environment. +*> +*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> IPARMQ(ISPEC=13) Recommended deflation window size. +*> This depends on ILO, IHI and NS, the +*> number of simultaneous shifts returned +*> by IPARMQ(ISPEC=15). The default for +*> (IHI-ILO+1).LE.500 is NS. The default +*> for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +*> +*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +*> a multi-shift QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 0 30 NS = 2+ +*> 30 60 NS = 4+ +*> 60 150 NS = 10 +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default matrices of this order are +*> passed to the implicit double shift routine +*> xLAHQR. See IPARMQ(ISPEC=12) above. These +*> values of NS are used only in case of a rare +*> xLAHQR failure. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function increasing from 10 to 64. +*> +*> IPARMQ(ISPEC=16) Select structured matrix multiply. +*> (See ISPEC=16 above for details.) +*> Default: 3. +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION iparmq( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + parameter( inmin = 12, inwin = 13, inibl = 14, + $ ishfts = 15, iacc22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + parameter( nmin = 75, k22min = 14, kacmin = 14, + $ nibble = 14, knwswp = 500 ) + REAL TWO + parameter( two = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC log, max, mod, nint, real +* .. +* .. Executable Statements .. + IF( ( ispec.EQ.ishfts ) .OR. ( ispec.EQ.inwin ) .OR. + $ ( ispec.EQ.iacc22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + nh = ihi - ilo + 1 + ns = 2 + IF( nh.GE.30 ) + $ ns = 4 + IF( nh.GE.60 ) + $ ns = 10 + IF( nh.GE.150 ) + $ ns = max( 10, nh / nint( log( REAL( NH ) ) / log( TWO ) ) ) + IF( nh.GE.590 ) + $ ns = 64 + IF( nh.GE.3000 ) + $ ns = 128 + IF( nh.GE.6000 ) + $ ns = 256 + ns = max( 2, ns-mod( ns, 2 ) ) + END IF +* + IF( ispec.EQ.inmin ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + iparmq = nmin +* + ELSE IF( ispec.EQ.inibl ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + iparmq = nibble +* + ELSE IF( ispec.EQ.ishfts ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + iparmq = ns +* + ELSE IF( ispec.EQ.inwin ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( nh.LE.knwswp ) THEN + iparmq = ns + ELSE + iparmq = 3*ns / 2 + END IF +* + ELSE IF( ispec.EQ.iacc22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* +* +* Convert NAME to upper case if the first character is lower case. +* + iparmq = 0 + subnam = name + ic = ichar( subnam( 1: 1 ) ) + iz = ichar( 'Z' ) + IF( iz.EQ.90 .OR. iz.EQ.122 ) THEN +* +* ASCII character set +* + IF( ic.GE.97 .AND. ic.LE.122 ) THEN + subnam( 1: 1 ) = char( ic-32 ) + DO i = 2, 6 + ic = ichar( subnam( i: i ) ) + IF( ic.GE.97 .AND. ic.LE.122 ) + $ subnam( i: i ) = char( ic-32 ) + END DO + END IF +* + ELSE IF( iz.EQ.233 .OR. iz.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR. + $ ( ic.GE.145 .AND. ic.LE.153 ) .OR. + $ ( ic.GE.162 .AND. ic.LE.169 ) ) THEN + subnam( 1: 1 ) = char( ic+64 ) + DO i = 2, 6 + ic = ichar( subnam( i: i ) ) + IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR. + $ ( ic.GE.145 .AND. ic.LE.153 ) .OR. + $ ( ic.GE.162 .AND. ic.LE.169 ) )subnam( i: + $ i ) = char( ic+64 ) + END DO + END IF +* + ELSE IF( iz.EQ.218 .OR. iz.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( ic.GE.225 .AND. ic.LE.250 ) THEN + subnam( 1: 1 ) = char( ic-32 ) + DO i = 2, 6 + ic = ichar( subnam( i: i ) ) + IF( ic.GE.225 .AND. ic.LE.250 ) + $ subnam( i: i ) = char( ic-32 ) + END DO + END IF + END IF +* + IF( subnam( 2:6 ).EQ.'GGHRD' .OR. + $ subnam( 2:6 ).EQ.'GGHD3' ) THEN + iparmq = 1 + IF( nh.GE.k22min ) + $ iparmq = 2 + ELSE IF ( subnam( 4:6 ).EQ.'EXC' ) THEN + IF( nh.GE.kacmin ) + $ iparmq = 1 + IF( nh.GE.k22min ) + $ iparmq = 2 + ELSE IF ( subnam( 2:6 ).EQ.'HSEQR' .OR. + $ subnam( 2:5 ).EQ.'LAQR' ) THEN + IF( ns.GE.kacmin ) + $ iparmq = 1 + IF( ns.GE.k22min ) + $ iparmq = 2 + END IF +* + ELSE +* ===== invalid value of ispec ===== + iparmq = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END +C +C======================================================================= +C +*> \brief \b ZUNMHR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNMHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, +* LDC, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNMHR overwrites the general complex M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**H * C C * Q**H +*> +*> where Q is a complex unitary matrix of order nq, with nq = m if +*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of +*> IHI-ILO elementary reflectors, as returned by ZGEHRD: +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left; +*> = 'R': apply Q or Q**H from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'C': apply Q**H (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI must have the same values as in the previous call +*> of ZGEHRD. Q is equal to the unit matrix except in the +*> submatrix Q(ilo+1:ihi,ilo+1:ihi). +*> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and +*> ILO = 1 and IHI = 0, if M = 0; +*> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and +*> ILO = 1 and IHI = 0, if N = 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension +*> (LDA,M) if SIDE = 'L' +*> (LDA,N) if SIDE = 'R' +*> The vectors which define the elementary reflectors, as +*> returned by ZGEHRD. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension +*> (M-1) if SIDE = 'L' +*> (N-1) if SIDE = 'R' +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEHRD. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For optimum performance LWORK >= N*NB if SIDE = 'L', and +*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal +*> blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE zunmhr( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), C( ldc, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL lsame, ilaenv +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zunmqr +* .. +* .. Intrinsic Functions .. + INTRINSIC max, min +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 + nh = ihi - ilo + left = lsame( side, 'L' ) + lquery = ( lwork.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( left ) THEN + nq = m + nw = n + ELSE + nq = n + nw = m + END IF + IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN + info = -1 + ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) ) + $ THEN + info = -2 + ELSE IF( m.LT.0 ) THEN + info = -3 + ELSE IF( n.LT.0 ) THEN + info = -4 + ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, nq ) ) THEN + info = -5 + ELSE IF( ihi.LT.min( ilo, nq ) .OR. ihi.GT.nq ) THEN + info = -6 + ELSE IF( lda.LT.max( 1, nq ) ) THEN + info = -8 + ELSE IF( ldc.LT.max( 1, m ) ) THEN + info = -11 + ELSE IF( lwork.LT.max( 1, nw ) .AND. .NOT.lquery ) THEN + info = -13 + END IF +* + IF( info.EQ.0 ) THEN + IF( left ) THEN + nb = ilaenv( 1, 'ZUNMQR', side // trans, nh, n, nh, -1 ) + ELSE + nb = ilaenv( 1, 'ZUNMQR', side // trans, m, nh, nh, -1 ) + END IF + lwkopt = max( 1, nw )*nb + work( 1 ) = lwkopt + END IF +* + IF( info.NE.0 ) THEN + CALL xerbla( 'ZUNMHR', -info ) + RETURN + ELSE IF( lquery ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( m.EQ.0 .OR. n.EQ.0 .OR. nh.EQ.0 ) THEN + work( 1 ) = 1 + RETURN + END IF +* + IF( left ) THEN + mi = nh + ni = n + i1 = ilo + 1 + i2 = 1 + ELSE + mi = m + ni = nh + i1 = 1 + i2 = ilo + 1 + END IF +* + CALL zunmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda, + $ tau( ilo ), c( i1, i2 ), ldc, work, lwork, iinfo ) +* + work( 1 ) = lwkopt + RETURN +* +* End of ZUNMHR +* + END +C +C======================================================================= +C +*> \brief \b ZTREVC3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZTREVC3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, +* $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTREVC3 computes some or all of the right and/or left eigenvectors of +*> a complex upper triangular matrix T. +*> Matrices of this type are produced by the Schur factorization of +*> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. +*> +*> The right eigenvector x and the left eigenvector y of T corresponding +*> to an eigenvalue w are defined by: +*> +*> T*x = w*x, (y**H)*T = w*(y**H) +*> +*> where y**H denotes the conjugate transpose of the vector y. +*> The eigenvalues are not input to this routine, but are read directly +*> from the diagonal of T. +*> +*> This routine returns the matrices X and/or Y of right and left +*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +*> input matrix. If Q is the unitary factor that reduces a matrix A to +*> Schur form T, then Q*X and Q*Y are the matrices of right and left +*> eigenvectors of A. +*> +*> This uses a Level 3 BLAS version of the back transformation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute all right and/or left eigenvectors; +*> = 'B': compute all right and/or left eigenvectors, +*> backtransformed using the matrices supplied in +*> VR and/or VL; +*> = 'S': compute selected right and/or left eigenvectors, +*> as indicated by the logical array SELECT. +*> \endverbatim +*> +*> \param[in] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +*> computed. +*> The eigenvector corresponding to the j-th eigenvalue is +*> computed if SELECT(j) = .TRUE.. +*> Not referenced if HOWMNY = 'A' or 'B'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,N) +*> The upper triangular matrix T. T is modified, but restored +*> on exit. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is COMPLEX*16 array, dimension (LDVL,MM) +*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by ZHSEQR). +*> On exit, if SIDE = 'L' or 'B', VL contains: +*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*Y; +*> if HOWMNY = 'S', the left eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VL, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. +*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is COMPLEX*16 array, dimension (LDVR,MM) +*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +*> contain an N-by-N matrix Q (usually the unitary matrix Q of +*> Schur vectors returned by ZHSEQR). +*> On exit, if SIDE = 'R' or 'B', VR contains: +*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*X; +*> if HOWMNY = 'S', the right eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VR, in the same order as their +*> eigenvalues. +*> Not referenced if SIDE = 'L'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. +*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR actually +*> used to store the eigenvectors. +*> If HOWMNY = 'A' or 'B', M is set to N. +*> Each selected eigenvector occupies one column. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of array WORK. LWORK >= max(1,2*N). +*> For optimum performance, LWORK >= N + 2*N*NB, where NB is +*> the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (LRWORK) +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of array RWORK. LRWORK >= max(1,N). +*> +*> If LRWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the RWORK array, returns +*> this value as the first entry of the RWORK array, and no error +*> message related to LRWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2017 +* +* @precisions fortran z -> c +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm used in this program is basically backward (forward) +*> substitution, with scaling to make the the code robust against +*> possible overflow. +*> +*> Each eigenvector is normalized so that the element of largest +*> magnitude has magnitude 1; here the magnitude of a complex number +*> (x,y) is taken to be |x| + |y|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ztrevc3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) + IMPLICIT NONE +* +* -- LAPACK computational routine (version 3.8.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 T( ldt, * ), VL( ldvl, * ), VR( ldvr, * ), + $ work( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + parameter( zero = 0.0d+0, one = 1.0d+0 ) + COMPLEX*16 CZERO, CONE + parameter( czero = ( 0.0d+0, 0.0d+0 ), + $ cone = ( 1.0d+0, 0.0d+0 ) ) + INTEGER NBMIN, NBMAX + parameter( nbmin = 8, nbmax = 128 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV + INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB + DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV, IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL lsame, ilaenv, izamax, dlamch, dzasum +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zcopy, zdscal, zgemv, zlatrs, + $ zgemm, dlabad, zlaset, zlacpy +* .. +* .. Intrinsic Functions .. + INTRINSIC abs, dble, dcmplx, conjg, aimag, max +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + cabs1( cdum ) = abs( dble( cdum ) ) + abs( aimag( cdum ) ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + bothv = lsame( side, 'B' ) + rightv = lsame( side, 'R' ) .OR. bothv + leftv = lsame( side, 'L' ) .OR. bothv +* + allv = lsame( howmny, 'A' ) + over = lsame( howmny, 'B' ) + somev = lsame( howmny, 'S' ) +* +* Set M to the number of columns required to store the selected +* eigenvectors. +* + IF( somev ) THEN + m = 0 + DO 10 j = 1, n + IF( SELECT( j ) ) + $ m = m + 1 + 10 CONTINUE + ELSE + m = n + END IF +* + info = 0 + nb = ilaenv( 1, 'ZTREVC', side // howmny, n, -1, -1, -1 ) + maxwrk = n + 2*n*nb + work(1) = maxwrk + rwork(1) = n + lquery = ( lwork.EQ.-1 .OR. lrwork.EQ.-1 ) + IF( .NOT.rightv .AND. .NOT.leftv ) THEN + info = -1 + ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN + info = -2 + ELSE IF( n.LT.0 ) THEN + info = -4 + ELSE IF( ldt.LT.max( 1, n ) ) THEN + info = -6 + ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN + info = -8 + ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN + info = -10 + ELSE IF( mm.LT.m ) THEN + info = -11 + ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery ) THEN + info = -14 + ELSE IF ( lrwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN + info = -16 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZTREVC3', -info ) + RETURN + ELSE IF( lquery ) THEN + RETURN + END IF +* +* Quick return if possible. +* + IF( n.EQ.0 ) + $ RETURN +* +* Use blocked version of back-transformation if sufficient workspace. +* Zero-out the workspace to avoid potential NaN propagation. +* + IF( over .AND. lwork .GE. n + 2*n*nbmin ) THEN + nb = (lwork - n) / (2*n) + nb = min( nb, nbmax ) + CALL zlaset( 'F', n, 1+2*nb, czero, czero, work, n ) + ELSE + nb = 1 + END IF +* +* Set the constants to control overflow. +* + unfl = dlamch( 'Safe minimum' ) + ovfl = one / unfl + CALL dlabad( unfl, ovfl ) + ulp = dlamch( 'Precision' ) + smlnum = unfl*( n / ulp ) +* +* Store the diagonal elements of T in working array WORK. +* + DO 20 i = 1, n + work( i ) = t( i, i ) + 20 CONTINUE +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + rwork( 1 ) = zero + DO 30 j = 2, n + rwork( j ) = dzasum( j-1, t( 1, j ), 1 ) + 30 CONTINUE +* + IF( rightv ) THEN +* +* ============================================================ +* Compute right eigenvectors. +* +* IV is index of column in current block. +* Non-blocked version always uses IV=NB=1; +* blocked version starts with IV=NB, goes down to 1. +* (Note the "0-th" column is used to store the original diagonal.) + iv = nb + is = m + DO 80 ki = n, 1, -1 + IF( somev ) THEN + IF( .NOT.SELECT( ki ) ) + $ GO TO 80 + END IF + smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum ) +* +* -------------------------------------------------------- +* Complex right eigenvector +* + work( ki + iv*n ) = cone +* +* Form right-hand side. +* + DO 40 k = 1, ki - 1 + work( k + iv*n ) = -t( k, ki ) + 40 CONTINUE +* +* Solve upper triangular system: +* [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK. +* + DO 50 k = 1, ki - 1 + t( k, k ) = t( k, k ) - t( ki, ki ) + IF( cabs1( t( k, k ) ).LT.smin ) + $ t( k, k ) = smin + 50 CONTINUE +* + IF( ki.GT.1 ) THEN + CALL zlatrs( 'Upper', 'No transpose', 'Non-unit', 'Y', + $ ki-1, t, ldt, work( 1 + iv*n ), scale, + $ rwork, info ) + work( ki + iv*n ) = scale + END IF +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.over ) THEN +* ------------------------------ +* no back-transform: copy x to VR and normalize. + CALL zcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) +* + ii = izamax( ki, vr( 1, is ), 1 ) + remax = one / cabs1( vr( ii, is ) ) + CALL zdscal( ki, remax, vr( 1, is ), 1 ) +* + DO 60 k = ki + 1, n + vr( k, is ) = czero + 60 CONTINUE +* + ELSE IF( nb.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( ki.GT.1 ) + $ CALL zgemv( 'N', n, ki-1, cone, vr, ldvr, + $ work( 1 + iv*n ), 1, dcmplx( scale ), + $ vr( 1, ki ), 1 ) +* + ii = izamax( n, vr( 1, ki ), 1 ) + remax = one / cabs1( vr( ii, ki ) ) + CALL zdscal( n, remax, vr( 1, ki ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out below vector + DO k = ki + 1, n + work( k + iv*n ) = czero + END DO +* +* Columns IV:NB of work are valid vectors. +* When the number of vectors stored reaches NB, +* or if this was last vector, do the GEMM + IF( (iv.EQ.1) .OR. (ki.EQ.1) ) THEN + CALL zgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone, + $ vr, ldvr, + $ work( 1 + (iv)*n ), n, + $ czero, + $ work( 1 + (nb+iv)*n ), n ) +* normalize vectors + DO k = iv, nb + ii = izamax( n, work( 1 + (nb+k)*n ), 1 ) + remax = one / cabs1( work( ii + (nb+k)*n ) ) + CALL zdscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + END DO + CALL zlacpy( 'F', n, nb-iv+1, + $ work( 1 + (nb+iv)*n ), n, + $ vr( 1, ki ), ldvr ) + iv = nb + ELSE + iv = iv - 1 + END IF + END IF +* +* Restore the original diagonal elements of T. +* + DO 70 k = 1, ki - 1 + t( k, k ) = work( k ) + 70 CONTINUE +* + is = is - 1 + 80 CONTINUE + END IF +* + IF( leftv ) THEN +* +* ============================================================ +* Compute left eigenvectors. +* +* IV is index of column in current block. +* Non-blocked version always uses IV=1; +* blocked version starts with IV=1, goes up to NB. +* (Note the "0-th" column is used to store the original diagonal.) + iv = 1 + is = 1 + DO 130 ki = 1, n +* + IF( somev ) THEN + IF( .NOT.SELECT( ki ) ) + $ GO TO 130 + END IF + smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum ) +* +* -------------------------------------------------------- +* Complex left eigenvector +* + work( ki + iv*n ) = cone +* +* Form right-hand side. +* + DO 90 k = ki + 1, n + work( k + iv*n ) = -conjg( t( ki, k ) ) + 90 CONTINUE +* +* Solve conjugate-transposed triangular system: +* [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK. +* + DO 100 k = ki + 1, n + t( k, k ) = t( k, k ) - t( ki, ki ) + IF( cabs1( t( k, k ) ).LT.smin ) + $ t( k, k ) = smin + 100 CONTINUE +* + IF( ki.LT.n ) THEN + CALL zlatrs( 'Upper', 'Conjugate transpose', 'Non-unit', + $ 'Y', n-ki, t( ki+1, ki+1 ), ldt, + $ work( ki+1 + iv*n ), scale, rwork, info ) + work( ki + iv*n ) = scale + END IF +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.over ) THEN +* ------------------------------ +* no back-transform: copy x to VL and normalize. + CALL zcopy( n-ki+1, work( ki + iv*n ), 1, vl(ki,is), 1 ) +* + ii = izamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + remax = one / cabs1( vl( ii, is ) ) + CALL zdscal( n-ki+1, remax, vl( ki, is ), 1 ) +* + DO 110 k = 1, ki - 1 + vl( k, is ) = czero + 110 CONTINUE +* + ELSE IF( nb.EQ.1 ) THEN +* ------------------------------ +* version 1: back-transform each vector with GEMV, Q*x. + IF( ki.LT.n ) + $ CALL zgemv( 'N', n, n-ki, cone, vl( 1, ki+1 ), ldvl, + $ work( ki+1 + iv*n ), 1, dcmplx( scale ), + $ vl( 1, ki ), 1 ) +* + ii = izamax( n, vl( 1, ki ), 1 ) + remax = one / cabs1( vl( ii, ki ) ) + CALL zdscal( n, remax, vl( 1, ki ), 1 ) +* + ELSE +* ------------------------------ +* version 2: back-transform block of vectors with GEMM +* zero out above vector +* could go from KI-NV+1 to KI-1 + DO k = 1, ki - 1 + work( k + iv*n ) = czero + END DO +* +* Columns 1:IV of work are valid vectors. +* When the number of vectors stored reaches NB, +* or if this was last vector, do the GEMM + IF( (iv.EQ.nb) .OR. (ki.EQ.n) ) THEN + CALL zgemm( 'N', 'N', n, iv, n-ki+iv, cone, + $ vl( 1, ki-iv+1 ), ldvl, + $ work( ki-iv+1 + (1)*n ), n, + $ czero, + $ work( 1 + (nb+1)*n ), n ) +* normalize vectors + DO k = 1, iv + ii = izamax( n, work( 1 + (nb+k)*n ), 1 ) + remax = one / cabs1( work( ii + (nb+k)*n ) ) + CALL zdscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + END DO + CALL zlacpy( 'F', n, iv, + $ work( 1 + (nb+1)*n ), n, + $ vl( 1, ki-iv+1 ), ldvl ) + iv = 1 + ELSE + iv = iv + 1 + END IF + END IF +* +* Restore the original diagonal elements of T. +* + DO 120 k = ki + 1, n + t( k, k ) = work( k ) + 120 CONTINUE +* + is = is + 1 + 130 CONTINUE + END IF +* + RETURN +* +* End of ZTREVC3 +* + END +C +C======================================================================= +C +*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This routine is not for general use. It exists solely to avoid +*> over-optimization in DISNAN. +*> +*> DLAISNAN checks for NaNs by comparing its two arguments for +*> inequality. NaN is the only floating-point value where NaN != NaN +*> returns .TRUE. To check for NaNs, pass the same variable as both +*> arguments. +*> +*> A compiler must assume that the two arguments are +*> not the same variable, and the test will not be optimized away. +*> Interprocedural or whole-program optimization may delete this +*> test. The ISNAN functions will be replaced by the correct +*> Fortran 03 intrinsic once the intrinsic is widely available. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIN1 +*> \verbatim +*> DIN1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] DIN2 +*> \verbatim +*> DIN2 is DOUBLE PRECISION +*> Two numbers to compare for inequality. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2017 +* +*> \ingroup OTHERauxiliary +* +* ===================================================================== + LOGICAL FUNCTION dlaisnan( DIN1, DIN2 ) +* +* -- LAPACK auxiliary routine (version 3.7.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2017 +* +* .. Scalar Arguments .. + DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 +* .. +* +* ===================================================================== +* +* .. Executable Statements .. + dlaisnan = (din1.NE.din2) + RETURN + END +C +C======================================================================= +C +*> \brief \b ZUNMQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNMQR overwrites the general complex M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**H * C C * Q**H +*> +*> where Q is a complex unitary matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left; +*> = 'R': apply Q or Q**H from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Conjugate transpose, apply Q**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> ZGEQRF in the first k columns of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For good performance, LWORK should generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE zunmqr( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), C( ldc, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + parameter( nbmax = 64, ldt = nbmax+1, + $ tsize = ldt*nbmax ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, + $ lwkopt, mi, nb, nbmin, ni, nq, nw +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL lsame, ilaenv +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zlarfb, zlarft, zunm2r +* .. +* .. Intrinsic Functions .. + INTRINSIC max, min +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 + left = lsame( side, 'L' ) + notran = lsame( trans, 'N' ) + lquery = ( lwork.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( left ) THEN + nq = m + nw = n + ELSE + nq = n + nw = m + END IF + IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN + info = -1 + ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN + info = -2 + ELSE IF( m.LT.0 ) THEN + info = -3 + ELSE IF( n.LT.0 ) THEN + info = -4 + ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN + info = -5 + ELSE IF( lda.LT.max( 1, nq ) ) THEN + info = -7 + ELSE IF( ldc.LT.max( 1, m ) ) THEN + info = -10 + ELSE IF( lwork.LT.max( 1, nw ) .AND. .NOT.lquery ) THEN + info = -12 + END IF +* + IF( info.EQ.0 ) THEN +* +* Compute the workspace requirements +* + nb = min( nbmax, ilaenv( 1, 'ZUNMQR', side // trans, m, n, k, + $ -1 ) ) + lwkopt = max( 1, nw )*nb + tsize + work( 1 ) = lwkopt + END IF +* + IF( info.NE.0 ) THEN + CALL xerbla( 'ZUNMQR', -info ) + RETURN + ELSE IF( lquery ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) THEN + work( 1 ) = 1 + RETURN + END IF +* + nbmin = 2 + ldwork = nw + IF( nb.GT.1 .AND. nb.LT.k ) THEN + IF( lwork.LT.nw*nb+tsize ) THEN + nb = (lwork-tsize) / ldwork + nbmin = max( 2, ilaenv( 2, 'ZUNMQR', side // trans, m, n, k, + $ -1 ) ) + END IF + END IF +* + IF( nb.LT.nbmin .OR. nb.GE.k ) THEN +* +* Use unblocked code +* + CALL zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work, + $ iinfo ) + ELSE +* +* Use blocked code +* + iwt = 1 + nw*nb + IF( ( left .AND. .NOT.notran ) .OR. + $ ( .NOT.left .AND. notran ) ) THEN + i1 = 1 + i2 = k + i3 = nb + ELSE + i1 = ( ( k-1 ) / nb )*nb + 1 + i2 = 1 + i3 = -nb + END IF +* + IF( left ) THEN + ni = n + jc = 1 + ELSE + mi = m + ic = 1 + END IF +* + DO 10 i = i1, i2, i3 + ib = min( nb, k-i+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL zlarft( 'Forward', 'Columnwise', nq-i+1, ib, a( i, i ), + $ lda, tau( i ), work( iwt ), ldt ) + IF( left ) THEN +* +* H or H**H is applied to C(i:m,1:n) +* + mi = m - i + 1 + ic = i + ELSE +* +* H or H**H is applied to C(1:m,i:n) +* + ni = n - i + 1 + jc = i + END IF +* +* Apply H or H**H +* + CALL zlarfb( side, trans, 'Forward', 'Columnwise', mi, ni, + $ ib, a( i, i ), lda, work( iwt ), ldt, + $ c( ic, jc ), ldc, work, ldwork ) + 10 CONTINUE + END IF + work( 1 ) = lwkopt + RETURN +* +* End of ZUNMQR +* + END +C +C======================================================================= +C +*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNM2R overwrites the general complex m-by-n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**H* C if SIDE = 'L' and TRANS = 'C', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**H if SIDE = 'R' and TRANS = 'C', +*> +*> where Q is a complex unitary matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left +*> = 'R': apply Q or Q**H from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'C': apply Q**H (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> ZGEQRF in the first k columns of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the m-by-n matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE zunm2r( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( lda, * ), C( ldc, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + parameter( one = ( 1.0d+0, 0.0d+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + COMPLEX*16 AII, TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL lsame +* .. +* .. External Subroutines .. + EXTERNAL xerbla, zlarf +* .. +* .. Intrinsic Functions .. + INTRINSIC dconjg, max +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + info = 0 + left = lsame( side, 'L' ) + notran = lsame( trans, 'N' ) +* +* NQ is the order of Q +* + IF( left ) THEN + nq = m + ELSE + nq = n + END IF + IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN + info = -1 + ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN + info = -2 + ELSE IF( m.LT.0 ) THEN + info = -3 + ELSE IF( n.LT.0 ) THEN + info = -4 + ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN + info = -5 + ELSE IF( lda.LT.max( 1, nq ) ) THEN + info = -7 + ELSE IF( ldc.LT.max( 1, m ) ) THEN + info = -10 + END IF + IF( info.NE.0 ) THEN + CALL xerbla( 'ZUNM2R', -info ) + RETURN + END IF +* +* Quick return if possible +* + IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) + $ RETURN +* + IF( ( left .AND. .NOT.notran .OR. .NOT.left .AND. notran ) ) THEN + i1 = 1 + i2 = k + i3 = 1 + ELSE + i1 = k + i2 = 1 + i3 = -1 + END IF +* + IF( left ) THEN + ni = n + jc = 1 + ELSE + mi = m + ic = 1 + END IF +* + DO 10 i = i1, i2, i3 + IF( left ) THEN +* +* H(i) or H(i)**H is applied to C(i:m,1:n) +* + mi = m - i + 1 + ic = i + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,i:n) +* + ni = n - i + 1 + jc = i + END IF +* +* Apply H(i) or H(i)**H +* + IF( notran ) THEN + taui = tau( i ) + ELSE + taui = dconjg( tau( i ) ) + END IF + aii = a( i, i ) + a( i, i ) = one + CALL zlarf( side, mi, ni, a( i, i ), 1, taui, c( ic, jc ), ldc, + $ work ) + a( i, i ) = aii + 10 CONTINUE + RETURN +* +* End of ZUNM2R +* + END + + diff --git a/src/msspec/spec/fortran/eig/common/plotfd.f b/src/msspec/spec/fortran/eig/common/plotfd.f new file mode 100644 index 0000000..65fd858 --- /dev/null +++ b/src/msspec/spec/fortran/eig/common/plotfd.f @@ -0,0 +1,103 @@ +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 +C INCLUDE 'spec.inc' +C +C + USE APPROX_MOD + USE FDIF_MOD + USE INIT_L_MOD, L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 => + &LF2, I10 => ISTEP_LF + USE INIT_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 => NONVOL + USE VALFIN_MOD +C + DIMENSION LMX(NATM,NE_M) +C + COMPLEX FSPH,VKE +C + DATA PI,CONV/3.141593,0.512314/ +C + OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN') + IF(ISPHER.EQ.0) THEN + L=0 + LMAX=0 + ELSE + LMAX=L + ENDIF + PHITOT=360. + THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI + NPHI=(NFTHET+1)*IPHI+(1-IPHI) + NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+ + * (1-ITHETA) + NE=NFTHET*IE + (1-IE) + WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN + DO 10 JT=1,NTHT + DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1)) + RTHETA=DTHETA*PI/180. + TEST=SIN(RTHETA) + IF(TEST.GE.0.) THEN + POZ=PI + EPS=1. + ELSE + POZ=0. + EPS=-1. + ENDIF + BETA=RTHETA*EPS + IF(ABS(TEST).LT.0.0001) THEN + NPHIM=1 + ELSE + NPHIM=NPHI + ENDIF + DO 20 JP=1,NPHIM + DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1)) + RPHI=DPHI*PI/180. + GAMMA=POZ-RPHI + DO 30 JE=1,NE + IF(NE.EQ.1) THEN + ECIN=E0 + ELSE + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ENDIF + IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.) + DO 40 JAT=1,NAT + IF(L.GT.LMX(JAT,JE)) GOTO 90 + DO 50 M=-LMAX,LMAX + CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA, + & GAMMA,L,M,FSPH,JAT,JE,*60) + GOTO 70 + 60 WRITE(IUO1,80) + STOP + 70 REFTH=REAL(FSPH) + XIMFTH=AIMAG(FSPH) + WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA, + & DPHI,ECIN + 50 CONTINUE + GOTO 40 + 90 WRITE(IUO1,100) JAT + STOP + 40 CONTINUE + 30 CONTINUE + 20 CONTINUE + 10 CONTINUE + CLOSE(IUO3) + 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2) + 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2, + &1X,F8.2) + 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS + &ZERO >>>>>') + 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : + &',I2,' >>>>>') +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/acc_conv.f b/src/msspec/spec/fortran/eig/mi/acc_conv.f new file mode 100644 index 0000000..f4e9e6b --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/acc_conv.f @@ -0,0 +1,189 @@ +C +C======================================================================= +C + SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + &R_SN,SN,METH) +C +C Use of the various acceleration scheme on a scalar series +C +C AITK : Aitken, modified Aitken +C RICH : Richardson +C SALZ : Salzer +C EPSI : epsilon +C EPSG : generalized epsilon +C RHOA : rho +C THET : theta +C LEGE : Legendre-Toeplitz +C CHEB : Chebyshev-Toeplitz +C OVER : Overholt +C DURB : Durbin +C DLEV : Levin d-transform !! differ by the +C TLEV : Levin t-transform !! choice of w_n +C ULEV : Levin u-transform !! the remainder +C VLEV : Levin v-transform !! estimate given +C ELEV : Levin e-transform !! by I_WN +C EULE : generalized Euler transform +C GBWT : Germain-Bronne-Wimp transform +C VARI : various algorithms : Weniger, BDG, iterated rho +C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2 +C EALG : E-algorithm +C +C SN : series to be accelerated +C XN : auxilliary series (chosen with I_XN) : interpolation points +C GN : auxilliary series (chosen with I_GN) ---> E algorithm +C +C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1) +C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K) +C so N_DIV=2 +C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are +C meaningful. Hence the K_MAX size +C +C COL_M : type of columns meaningful in the (n,k) table (example: even columns +C for the epsilon algorithm) +C +C +C Author : D. Sebilleau +C +C Last modified : 1 Mar 2013 +C +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVACC_MOD, L => LEVIN + USE CONVTYP_MOD +C + PARAMETER (N_METH=24) +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + COMPLEX*16 ZEROC,ONEC +C + REAL*8 R2_SN(N_ORD_M),RHO +C + REAL R_SN(N_ORD_M) +C + INTEGER N_DIV(N_METH) +C + CHARACTER*3 COL_M(N_METH) + CHARACTER*4 SCHE(N_METH) + CHARACTER*10 NAME(N_METH),METH +C +C + DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE','CHEB', + & 'OVER','DURB','DLEV','TLEV','ULEV','VLEV','ELEV', + & 'EULE','GBWT','EALG','SALZ','VARI','ITHE','EPSG', + & 'NONE','NONE','NONE'/ + DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ',' RHO ', + & ' THETA ',' LEGENDRE ','CHEBYSHEV ',' OVERHOLT ', + & ' DURBIN ',' D LEVIN ',' T LEVIN ',' U LEVIN ', + & ' V LEVIN ',' E LEVIN ',' EULER ',' GBW ', + & ' E ',' SALZER ',' VARIA ','ITER THETA', + & ' EPSILON G',' ',' ',' '/ + DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL','ALL','ALL', + & 'ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL', + & 'ALL','ALL','ALL','ALL','EVE','ALL','ALL','ALL'/ + DATA N_DIV /2,1,1,2,2,1,1,1,4,1,1,1,1,1,1,1,1,1,2,4,1,1,1,1/ +C + J_NAME=0 + I_COL=0 +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + DO J=J_INI,J_FIN + R2_SN(J)=DBLE(R_SN(J)) + ENDDO +C +C Finding the name of the method +C + DO JM=1,N_METH +C + IF(METHOD.EQ.SCHE(JM)) THEN + J_NAME=JM + K_MAX=N_MAX/N_DIV(JM) + N_COEF=N_DIV(JM) + IF(COL_M(JM).EQ.'EVE') I_COL=2 + ENDIF +C + ENDDO +C +C Initialization of array SN +C + DO N=J_INI,J_FIN +C + DO K=-1,J_FIN +C + SN(N,K)=ZEROC +C + ENDDO +C + ENDDO +C +C Initialisation of the schemes : +C +C -- SN(N,0) is the series to be accelerated -- +C + SN(0,-1)=ZEROC + SN(0,0)=ONEC +C + DO N=J_INI,J_FIN +C + SN(N,-1)=ZEROC + SN(N,0)=R2_SN(N) +C + ENDDO +C + CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C Check for convergence : all results equal within ACC +C in a N_TABLE x N_TABLE square +C + IF(I_CONV.EQ.0) THEN + CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX, + & N_COEF,I_COL,ACC,RHO,SN) + ENDIF +C + IF(METHOD(2:4).EQ.'LEV') THEN + METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN) + ELSE + METH=NAME(J_NAME) + ENDIF +C +C Incrementation of the number of calls to this subroutine +C if convergence has not been achieved +C + IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN + N_CALL=N_CALL+1 + ELSE + GOTO 10 + ENDIF +C +C Printing the results in the check file +C + 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',5X,'*') + 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*') + 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*') + 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6, + &',',E12.6,')',5X,'*') + 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*') + 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <--- + &convergence',2X,'*') + 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',3X,' * <--- convergence') + 35 FORMAT(2X,'***************************************','************ + &************************') + 45 FORMAT(2X,'* ',' + & *') + 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,') + & *') + 75 FORMAT(2X,'* Order Taylor ',20X,A10,' + & *') + 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'* + & order ',60X,'*') + 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ', + &'>>>>>>>>>>',//) +C + 10 RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/acc_scal.f b/src/msspec/spec/fortran/eig/mi/acc_scal.f new file mode 100644 index 0000000..7b25042 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/acc_scal.f @@ -0,0 +1,693 @@ +C +C======================================================================= +C + SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C This subroutine computes the scalar convergence acceleration +C for various methods +C +C Note: let us consider that the (n,k) space pattern indicates +C that we need S(n,k),...,S(n+p,k) in order to compute +C S(n,k+1). We call N the maximum value of n for which +C the S(n,0) are known. Then, to compute S(n,k+1), we +C we need to know up to S(n+pk+p,0). This means that +C the value of n is limited to N-pk-p. +C +C Author : D. Sebilleau +C +C Last modified : 14 Mar 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE CONVACC_MOD, L => LEVIN +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5 + COMPLEX*16 NUM,DEN,FIR + COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK +C + REAL*8 EPS,EPSS,MUL +C + CHARACTER*4 METHOD +C + DATA EPS,EPSS /1.D-12,1.D-150/ +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + N_APP=J_FIN + N_INI=0 +C + IF(METHOD.EQ.'AITK') THEN +C +C The iterated Aitken and modified Aitken schemes +C +C H. H. H. Homeier, Num. Alg. 8, 47 (1994) +C +C I_VA = 1 : iterated Aitken (p 49 eq 5) +C I_VA = 2 : modified iterated Aitken (p 49 eq 9) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + IF(I_VA.EQ.1) THEN + XK=ONEC + ELSEIF(I_VA.EQ.2) THEN + XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1) + ENDIF +C + DO N=N_INI,N_APP-2*K-2 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + DELTA2=(SN(N+2,K)-SN(N+1,K)) + IF(CDABS(DELTA2).LT.EPSS) THEN + DELTA3=ZEROC + ELSE + DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1) + ENDIF + SN(N,K+1)=SN(N,K)-XK*DELTA3 + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RICH') THEN +C +C The Richardson scheme +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=SN(N+1,0)-SN(N,0) + DELTA2=SN(N+K+2,0)-SN(N+K+1,0) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 10 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'SALZ') THEN +C +C The Salzer scheme +C +C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=DFLOAT(N+K+2) + DELTA2=DFLOAT(N+1) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 11 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'GBWT') THEN +C +C The GBW scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C (eq 6.1-5 p33) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=XN(N) + DELTA2=XN(N+K+1) + IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 80 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSI') THEN +C +C The epsilon scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1) +C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 20 + IF(I_VA.EQ.1) THEN + VAR=ONEC + ELSEIF(I_VA.EQ.2) THEN + VAR=XN(N+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + VAR=XN(N+K+1)-XN(N+K) + ENDIF + SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1 + N_COUNT=N_COUNT+1 +C + 20 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSG') THEN +C +C The generalized epsilon scheme +C +C M. N. Barber and C. J. Hamer, +C J. Austral. Math. Soc. (Series B) 23, 229 (1982) +C +C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed) +C DELTA2 = 0 implies SN(N+1,K) = SN(N,K) +C ---> convergence achieved for (N,K) +C + N_COUNT=0 +C + DO K=0,N_APP,2 +C + IF(I_VA.EQ.1) THEN + SI(K)=ALPHA + SI(K+1)=ALPHA + ELSEIF(I_VA.EQ.2) THEN + SI(K)=ZEROC + SI(K+1)=-ONEC + ENDIF +C + ENDDO +C + VAR=ONEC +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + NK(N,-1)=ZEROC + DELTA2=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA2).LT.EPSS) GOTO 23 + NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2 + DELTA1=(NK(N,K)-NK(N-1,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 23 + SN(N,K+1)=SN(N,K)+VAR/DELTA1 + N_COUNT=N_COUNT+1 + 23 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RHOA') THEN +C +C The rho scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1) +C I_VA = 2 : Standard rho (p 34 eq 6.2-2) +C I_VA = 3 : (p 37 eq 6.3-3) ??????? +C +C ALPHA is the decay parameter. It is +C generally advised to take it as +C an integer to ensure convergence +C + IF(DREAL(ALPHA).LT.0.0D0) THEN +C +C Drummond approximation to alpha : +C +C (non valid for the Taylor expansion +C of 1/1+x as in this case the denominator +C is always zero) +C + DO N=N_INI,N_APP +C + DELTA1=SN(N+3,1)-SN(N+2,1) + DELTA2=SN(N+2,1)-SN(N+1,1) + DELTA3=SN(N+1,1)-SN(N,1) +C + NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2) + DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1 + ALPHA=NUM/DEN-ONEC +C + ENDDO +C + ENDIF +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + IF(I_VA.NE.3) THEN + DEN=(SN(N+1,K)-SN(N,K)) + ELSE + DELTA2=(SN(N+2,K)-SN(N+1,K)) + DELTA3=(SN(N+1,K)-SN(N,K)) + DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)- + & XN(N))*DELTA2 + ENDIF +C + IF(CDABS(DEN).LT.EPS) GOTO 30 + IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30 +C + IF(I_VA.EQ.1) THEN + NUM=(DFLOAT(K+1)+ALPHA) + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+K+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3 + ENDIF +C + SN(N,K+1)=SN(N+1,K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 30 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'THET') THEN +C +C The theta scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C E. Calicetti et al, Phys. Rep. 446, 1 (2007) +C +C I_VA = 1 : standard formulation (eq 71 p 19) +C I_VA = 2 : generalized formulation (eq 10.1-10 p 74) +C + KMAX2=(N_APP-2)/2 +C + N_COUNT=0 + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,KMAX2 +C + IF(I_VA.EQ.3) GOTO 51 +C + DO N=N_INI,N_APP-2*K-1 +C + DEN=SN(N+1,2*K)-SN(N,2*K) + IF(CDABS(DEN).LT.EPSS) GOTO 40 + IF(I_VA.EQ.1) THEN + NUM=1.D0 + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+2*K+1)-XN(N) + ENDIF + SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 40 CONTINUE +C + ENDDO +C + DO N=N_INI,N_APP-4*K-2 +C + DELTA2=SN(N+2,2*K)-SN(N+1,2*K) + DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1) + DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1) +C + IF(I_VA.EQ.1) THEN + NUM=DELTA2*DELTA4 + DEN=DELTA4-DELTA3 + ELSEIF(I_VA.EQ.2) THEN + NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4 + DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN( + & N))*DELTA4 + ENDIF + IF(CDABS(DEN).LT.EPSS) GOTO 50 +C + SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 50 CONTINUE +C + ENDDO + GOTO 52 +C + 51 DO N=N_INI,N_APP-4*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + DELTA4=DELTA3-DELTA2 + DELTA5=DELTA2-DELTA1 + DEN=DELTA3*DELTA5-DELTA1*DELTA4 + IF(CDABS(DEN).LT.EPSS) GOTO 53 +C + NUM=DELTA1*DELTA2*DELTA4 + SN(N,K+1)=SN(N+1,K)-NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 53 CONTINUE +C + ENDDO +C + 52 CONTINUE +C + ENDDO +C + ELSEIF(METHOD.EQ.'LEGE') THEN +C +C The Legendre-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.3), (4.4) p. 231 +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1) + DELTA2=DFLOAT(K)/DFLOAT(K+1) +C + DO N=N_INI,N_APP-K-1 + SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN( + & N,K-1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'CHEB') THEN +C +C The Chebyshev-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.4) - (4.9) p. 231 +C + SI(0)=ONEC + SI(1)=3.D0*ONEC +C + DO N=N_INI,N_APP-1 +C + TN(N,0)=SN(N,0) + TN(N,1)=SN(N,0)+2.D0*TN(N+1,0) + SN(N,0)=TN(N,0)/SI(0) + SN(N,1)=TN(N,1)/SI(1) +C + ENDDO +C + N_COUNT=0 +C + DO K=1,N_APP-1 +C + SI(K+1)=6.D0*SI(K)-SI(K-1) +C + DO N=N_INI,N_APP-K-1 +C + TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1) + SN(N,K+1)=TN(N,K+1)/SI(K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'OVER') THEN +C +C The Overholt scheme +C +C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996) +C (eq 36 p 85) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=ONEC + DELTA2=ONEC + MUL=1.D0 +C + DO I=1,K+1 +C + DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0)) + DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0)) + MUL=MUL*EPS +C + ENDDO +C + IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 60 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'DURB') THEN +C +C The Durbin scheme +C +C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007) +C (eq 25 p 185) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-4*K-4 +C + DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+ + & 3,K)+SN(N,K)*SN(N+4,K) + DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN( + & N,K)+SN(N+4,K) + IF(CDABS(DELTA2).LT.EPSS) GOTO 70 + SN(N,K+1)=DELTA1/DELTA2 + N_COUNT=N_COUNT+1 +C + 70 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD(2:4).EQ.'LEV') THEN +C +C The Levin schemes +C + CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + & METHOD(1:1)) +C + ELSEIF(METHOD.EQ.'EULE') THEN +C +C The generalized Euler scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'VARI') THEN +C +C Various schemes +C +C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1) +C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2) +C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3) +C I_VA = 4 : iterated rho scheme +C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-2*K-2 +C + IF(I_VA.EQ.1) THEN + A=BETA+DFLOAT(N) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.2) THEN + A=ALPHA+DFLOAT(N+K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.3) THEN + A=ALPHA+DFLOAT(N-K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.4) THEN + A=XN(N+2*K+2)-XN(N) + B=XN(N+2*K+1)-XN(N) + C=XN(N+2*K+2)-XN(N+1) + ELSEIF(I_VA.EQ.5) THEN + A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA) + B=ONEC + C=ONEC + ENDIF +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DEN=B*DELTA2-C*DELTA1 + IF(CDABS(DEN).LT.EPSS) GOTO 81 + SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN + N_COUNT=N_COUNT+1 +C + 81 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'ITHE') THEN +C +C Iterated theta schemes +C +C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6) +C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5) +C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-3*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + IF(I_VA.EQ.1) THEN + NUM=-DELTA1*DELTA2*(DELTA3-DELTA2) + DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.2) THEN + NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2) + DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*( + & DELTA2-DELTA1) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.3) THEN + NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2) + DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*( + & DELTA2-DELTA1) + FIR=SN(N+2,K) + ENDIF +C + IF(CDABS(DEN).LT.EPSS) GOTO 90 + SN(N,K+1)=FIR+NUM/DEN + N_COUNT=N_COUNT+1 +C + 90 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EALG') THEN +C +C E algorithm +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) + CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C Computing the GN(N,K,I) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 91 + DELTA1=GN(N,K-1,K)/DEN +C + DO I=0,N_APP +C + NUM=GN(N+1,K-1,I)-GN(N,K-1,I) + GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1 +C + ENDDO +C + 91 CONTINUE +C + ENDDO +C + ENDDO +C +C Computing SN(N,K) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP-K +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 92 + DELTA1=GN(N,K-1,K)/DEN + SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1 +C + 92 CONTINUE +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/check_conv.f b/src/msspec/spec/fortran/eig/mi/check_conv.f new file mode 100644 index 0000000..0d4ee3e --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/check_conv.f @@ -0,0 +1,96 @@ +C +C======================================================================= +C + SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC, + &K_MAX,N_COEF,I_COL,ACC,RHO,SN) +C +C This subroutine checks the convergence of the acceleration process. +C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table +C of SN(n,k)that contains equal values (SMALL being the accepted error) +C +C This way, both the column convergence (k fixed and n increasing) +C and the diagonal convergence (n=k increasing) are considered +C +C Important note: in some algorithms, such as the epsilon one, only +C odd columns are meaningful. If I_COL = 0, all +C columns are taken into account while for I_COL = 2 +C only even columns are considered +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2011 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + REAL*8 ACC,REF,COMP,RHO +C +C Step for the columns comparison and change of the size +C of the square when only even columns should be considered +C + IF(I_COL.EQ.0) THEN + I_STEP=1 + N_SQUARE=N_TABLE + N_START=N_TABLE + ELSEIF(I_COL.EQ.2) THEN + I_STEP=2 + N_SQUARE=N_TABLE+N_TABLE-1 + IF(MOD(N_SQUARE,2).EQ.0) THEN + N_START=N_SQUARE + ELSE + N_START=N_SQUARE+1 + ENDIF + ENDIF +C +C Positionning the bottom right corner of the square: (N,K), +C starting from (N_START,N_START). If only even columns +C should be considered, N_START must be even +C + K_FIN=J_FIN/N_COEF + IF(K_FIN.LT.N_START) THEN + I_CONV=0 + GOTO 10 + ENDIF +C + DO K=N_START,K_FIN+N_START-1,I_STEP + IF(K.GT.K_MAX) GOTO 20 + DO N=N_START,K_FIN-K,I_STEP +C +C Checking the values (N1,K1) in the selected square +C + REF=CDABS(SN(N,K)) + I_CONV=1 +C + DO N1=0,N_START,I_STEP + NN=N-N1 + DO K1=0,N_START,I_STEP +C + KK=K-K1 + COMP=CDABS(REF-SN(NN,KK)) + IF(COMP.GT.ACC) THEN + I_CONV=0 + ENDIF +C + ENDDO + ENDDO +C + IF(I_CONV.EQ.1) THEN +C +C All values in the square are equal (within ACC): +C Spectral radius taken as the left top corner value +C + N_ACC=N-N_START+I_STEP + K_ACC=K-N_START+I_STEP + RHO=REF + GOTO 10 + ENDIF +C + ENDDO + 20 CONTINUE + ENDDO +C + 10 RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/coefficients.f b/src/msspec/spec/fortran/eig/mi/coefficients.f new file mode 100644 index 0000000..54f36e8 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/coefficients.f @@ -0,0 +1,89 @@ +C +C======================================================================= +C + SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH) +C +C Binomial coefficients ---> ISWITCH = 1 +C Power coefficients ---> ISWITCH = 2 +C Pochhammer coefficients ---> ISWITCH = 3 +C Pochhammer coefficients ---> ISWITCH = 4 (negative argument) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Sep 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC +C + ONEC=(1.D0,0.D0) +C + COEF(0,0)=ONEC + COEF(1,0)=ONEC + COEF(1,1)=ONEC +C + IF(I_SWITCH.EQ.1) THEN +C + DO N=2,N_APP-1 +C + COEF(N,0)=ONEC + COEF(N,1)=DCMPLX(N) +C + DO K=2,N +C + COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.2) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC + COEF(N,1)=BETA+DFLOAT(N) +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.3) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.4) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/conv_series.f b/src/msspec/spec/fortran/eig/mi/conv_series.f new file mode 100644 index 0000000..82f3de7 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/conv_series.f @@ -0,0 +1,32 @@ +C +C======================================================================= +C + SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*) +C +C This subroutine checks the convergence of the power method or of +C the Rayleigh quotient method at level JORD without convergence +C acceleration. For convergence, there must be N_TABLE equal values +C (ACC being the accepted error) of SN +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + REAL ACC,COMP,R_SN(N_ORD_M) +C + NCONV=0 + DO J=JORD,JORD-N_TABLE,-1 + COMP=ABS(R_SN(J)-R_SN(J-1)) + IF(COMP.LE.ACC) THEN + NCONV=NCONV+1 + ENDIF + ENDDO +C + IF(NCONV.EQ.N_TABLE-1) RETURN 1 +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/do_main.f b/src/msspec/spec/fortran/eig/mi/do_main.f new file mode 100644 index 0000000..12d6d13 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/do_main.f @@ -0,0 +1,1557 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * EIGENVALUE CALCULATION CODE * * +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 * 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 +C INCLUDE 'spec.inc' +C + + + USE DIM_MOD + USE ADSORB_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE CLUSLIM_MOD + USE COOR_MOD + USE DEBWAL_MOD + USE INDAT_MOD + USE INIT_A_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE INIT_M_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE LIMAMA_MOD + USE LPMOY_MOD + USE MASSAT_MOD + USE MILLER_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TL_AED_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE XMRHO_MOD +C + DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3) + DIMENSION ROT(3,3),EMET(3) + DIMENSION VAL2(NATCLU_M) + DIMENSION IRE(NATCLU_M,2) + DIMENSION REL(NATCLU_M),RHOT(NATM) + DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M) + DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM) + DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M) + DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M) + DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM) +C + COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR +C +C +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 /1/ +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,* + &520,*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.'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 + IF(SPECTRO.EQ.'EIG') THEN + LE_MIN=1 + LE_MAX=1 + 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 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 + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + ENDDO + 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 +c IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN + IF(IPRINT.GE.2) 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,NAT2,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,NBTA),JT,JN,CHEM(JT) + ENDDO + ENDDO + ENDIF + ENDIF + 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN + CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) + ENDIF + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) + ENDDO + ENDIF +C + IF(SPECTRO.NE.'EIG') THEN + 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 + ENDIF +C +C.......... Loop on the electrons involved in the .......... +C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... +C.......... 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.'EIG') WRITE(IUO1,252) + 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,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.-1) THEN + WRITE(IUO1,82) LI,LI-1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 1,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,1) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.1) THEN + WRITE(IUO1,82) LI,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV.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---------- 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.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, + & NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C.......... Call of the subroutine performing either .......... +C.......... the PhD, AED, EXAFS or APECS calculation .......... +C + 566 IF(ISPIN.EQ.0) THEN + IF(SPECTRO.EQ.'EIG') THEN + CALL EIGDIF_MI + 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.'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) + ELSEIF(SPECTRO.EQ.'EIG') THEN + WRITE(IUO1,253) + ENDIF +C + CLOSE(ICOM) + IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN + WRITE(IUO1,562) + ENDIF + IF(ISOM.EQ.0) CLOSE(IUO2) +C! 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.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP) + ELSEIF(SPECTRO.EQ.'XAS') THEN +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 +C! IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) + STOP +C + 1 WRITE(IUO1,60) + STOP + 2 WRITE(IUO1,61) + STOP + 55 WRITE(IUO1,65) + STOP + 56 WRITE(IUO1,64) + STOP + 74 WRITE(IUO1,75) + STOP + 99 WRITE(IUO1,100) + STOP + 180 WRITE(IUO1,181) + STOP + 182 WRITE(IUO1,183) + STOP + 184 WRITE(IUO1,185) + STOP + 504 WRITE(IUO1,505) + STOP + 510 WRITE(IUO1,511) IUI4 + STOP + 514 WRITE(IUO1,515) + STOP + 516 WRITE(IUO1,517) + STOP + 518 WRITE(IUO1,519) + WRITE(IUO1,889) + STOP + 520 WRITE(IUO1,521) + STOP + 540 WRITE(IUO1,541) + STOP + 550 WRITE(IUO1,551) + STOP + 570 WRITE(IUO1,571) + STOP + 580 WRITE(IUO1,581) + STOP + 590 WRITE(IUO1,591) + STOP + 600 WRITE(IUO1,601) + STOP + 602 WRITE(IUO1,603) + STOP + 604 WRITE(IUO1,605) + STOP + 606 WRITE(IUO1,607) + STOP + 608 WRITE(IUO1,609) + STOP + 610 WRITE(IUO1,611) + STOP + 614 WRITE(IUO1,615) NB_AT + STOP + 620 WRITE(IUO1,621) LE_MAX + STOP + 630 WRITE(IUO1,631) + STOP + 890 WRITE(IUO1,891) + STOP + 895 WRITE(IUO1,896) JA1,JA2 +C + 3 FORMAT(5(5X,I4)) + 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) + 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',': + & (',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 + &POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', 'OF THE + &EXAFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE + &ATOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + & '++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', ' CONTENTS OF THE + &REDUCED CLUSTER ======================',///) + 41 FORMAT(///,'==================================================== + &','============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2, + &' DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE + &SURFACE)') + 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON + &DIFFRACTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', 'EXAFS + &CALCULATION ##########') + 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON + &DIFFRACTION 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 + &OSCILLATIONS 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 ', + &'CLUSTER 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 + &PRESENT 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, + &E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) + 106 FORMAT(12X,I3,12X,I3,12X,I3) + 107 FORMAT(5X,I2,5X,I2,5X,I2) + 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 109 FORMAT(5X,I2,12X,I2,11X,I2) + 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + &' :',/,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 ', + &'INVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ', + &'INVERSION)') + 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 ', + &'AND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + &'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ', + &'FILE >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX + &ELEMENTS 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 + &DIFFRACTION CALCULATION #####', '#####',/////) + 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &PHOTOELECTRON DIFFRACTION CALCULATION ','##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &AUGER DIFFRACTION CALCULATION ', '##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &APECS DIFFRACTION CALCULATION ', '##########',/////) + 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON + &DIFFRACTION CALCULATION #####','#####') + 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', 'OF THE MULTIPLE + &SCATTERING EIGENVALUE CALCULATION #####', '#####',/////) + 253 FORMAT(/////,'########## END ', 'OF THE MULTIPLE SCATTERING + &EIGENVALUE CALCULATION #####', '#####',/////) + 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 + &DIMENSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ', + &'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' + &>>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ', + &'NAT 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',' + &CONSISTENT 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 ', + &'CORRESPOND 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 ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 555 FORMAT(4(7X,I2)) + 556 FORMAT(28X,4(I2,5X)) + 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,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, + &'ATOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' + &No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL + &ATOMS : ',//) + 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 ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD + &AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT + &CONSISTENT 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 ', + &'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ', + &17X,'WITH THE INPUT DATA FILE ',16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ', + &'THE 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 + &IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','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 ''', + &'UNITS >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' + &ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' + &ARE IDENTICAL >>>>>>>>>>') +C + END diff --git a/src/msspec/spec/fortran/eig/mi/eigdif_mi.f b/src/msspec/spec/fortran/eig/mi/eigdif_mi.f new file mode 100644 index 0000000..fddcf4e --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/eigdif_mi.f @@ -0,0 +1,104 @@ +C +C======================================================================= +C + SUBROUTINE EIGDIF_MI +C +C This subroutine computes the eigenvalues of the +C multiple scattering matrix to obtain its spectral radius +C +C The eigenvalue calculation is performed using the LAPACK +C eigenvalue routines for a general complex matrix (I_PWM = 0) +C or using the power method (I_PWM > 0) +C +C Last modified : 26 Apr 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP + USE DEBWAL_MOD + USE EIGEN_MOD, NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE RESEAU_MOD + USE TESTS_MOD + USE TRANS_MOD + USE VALIN_MOD, E1 => E0, PHLUM => PHILUM +C + COMPLEX IC,ONEC + COMPLEX TLT(0:NT_M,4,NATM,NE_M) +C +C + DATA CONV /0.512314/ +C + IC=(0.,1.) + ONEC=(1.,0.) +C + OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN') +C +C Loop over the energies +C + DO JE=1,NE + IF(NE.GT.1) THEN + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ELSEIF(NE.EQ.1) THEN + ECIN=E0 + ENDIF + CALL LPM(ECIN,XLPM,*6) + XLPM1=XLPM/A + IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 + IF(ITL.EQ.0) THEN + VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC + 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_MFP.EQ.0) THEN + VK(JE)=CMPLX(REAL(VK(JE))) + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDIF + IF(I_VIB.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,I_VIB) + DO LAT=0,LMAX(JAT,JE) + TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) + ENDDO + ENDDO + ENDIF +C +C Eigenvalue calculation +C + IF(I_PWM.EQ.0) THEN + CALL EIG_MAT_MS(JE,ECIN) + ELSE + CALL SPEC_RAD_POWER(JE,ECIN) + ENDIF +C +C +C End of the loop on the energy +C + ENDDO + GOTO 7 +C + 6 WRITE(IUO1,55) +C + 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/, + &25X,' BY DEBYE UNCORRELATED MODEL:',/) + 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2') + 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',//) +C + 7 RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/interp_points.f b/src/msspec/spec/fortran/eig/mi/interp_points.f new file mode 100644 index 0000000..c8eb7f7 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/interp_points.f @@ -0,0 +1,38 @@ +C +C======================================================================= +C + SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C +C This subroutine computes the interpolation +C points used in some algorithms +C +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 ALPHA,BETA +C + DO N=0,N_APP +C + IF(I_XN.EQ.1) THEN + XN(N)=(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.2) THEN + XN(N)=BETA+DFLOAT(N) + ELSEIF(I_XN.EQ.3) THEN + XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.4) THEN + XN(N)=(BETA+DFLOAT(N))**ALPHA + ELSEIF(I_XN.EQ.5) THEN + XN(N)=((2.D0**N)/BETA)**ALPHA + ENDIF +C + ENDDO +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/levin.f b/src/msspec/spec/fortran/eig/mi/levin.f new file mode 100644 index 0000000..c7cc914 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/levin.f @@ -0,0 +1,191 @@ +C +C======================================================================= +C + SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + &OMEGA) +C +C This subroutine computes Levin-type transforms of +C a given sequence SN(N,1) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1: + &N_ORD_M) + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC + COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2 +C + CHARACTER*1 OMEGA +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Recovery of the original series elements +C + DO N=N_INI,N_APP +C + AN(N)=SN(N,0)-SN(N-1,0) +C + ENDDO +C +C +C Choice of the remainder estimate omega_n +C +C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000) +C +C + IF(OMEGA.EQ.'U') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*(DFLOAT(N)+BETA) + ENDDO +C + ELSEIF(OMEGA.EQ.'V') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1)) + ENDDO +C + ELSEIF(OMEGA.EQ.'T') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N) + ENDDO +C + ELSEIF(OMEGA.EQ.'D') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N+1) + ENDDO +C + ELSEIF(OMEGA.EQ.'E') THEN +C + MAX_N=N_APP-2 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+2)/AN(N+1) + ENDDO +C + ENDIF +C +C Choice of the Levin-type transform +C +C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10) +C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10) +C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10) +C I_WN = 4 ---> C-type (eq 3-16c p 11) +C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70) +C I_WN = 6 ---> R-type (eq 7.14-12 p 47) +C +C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004) +C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989) +C +C +C Check for the possibility of L extension (the standard case is L = 0) +C + IF(L.GT.0) THEN + IF(I_WN.EQ.1) THEN + CALL COEFFICIENTS(MAX_N,COEL,BETA,2) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.2) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,3) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.3) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,4) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ENDIF + ENDIF +C + DO N=N_INI,MAX_N +C + X=BETA+DFLOAT(N) + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + XK=DFLOAT(K) + XXK=X+XK +C + IF(I_WN.EQ.1) THEN + INC=XXK/(XXK+ONEC) + COEF(N,K)=X*(INC**K)/XXK + ELSEIF(I_WN.EQ.2) THEN + COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK)) + ELSEIF(I_WN.EQ.3) THEN + COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC) + ELSEIF(I_WN.EQ.4) THEN + SUM_1=ZEROC + SUM_2=ZEROC + DO J=0,K + SUM_1=SUM_1+ALPHA*XXK + SUM_2=SUM_2+ALPHA*(XXK+ONEC) + ENDDO + COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2) + ELSEIF(I_WN.EQ.5) THEN + COEF(N,K)=ONEC + ELSEIF(I_WN.EQ.6) THEN + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) + ENDIF +C + ENDDO +C + ENDDO +C +C Computation of the recurrence relation for numerator +C and denominator +C + DO N=N_INI,MAX_N +C +C Starting values +C + NUM(N,0)=SN(N,0)/WN(N) + DEN(N,0)=ONEC/WN(N) + SN(N,0)=NUM(N,0)/DEN(N,0) +C + ENDDO +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,MAX_N-K-1 +C + IF(I_WN.NE.6) THEN + NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K) + DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K) + ELSE + NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N)) + DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N)) + ENDIF + SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/main.f b/src/msspec/spec/fortran/eig/mi/main.f similarity index 100% rename from src/msspec/spec/fortran/main.f rename to src/msspec/spec/fortran/eig/mi/main.f diff --git a/src/msspec/spec/fortran/eig/mi/new.f.hidden b/src/msspec/spec/fortran/eig/mi/new.f.hidden new file mode 100644 index 0000000..1c93f94 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/new.f.hidden @@ -0,0 +1,3972 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * EIGENVALUE CALCULATION CODE * * +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 * 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 + PROGRAM MAIN +C +C This routine reads the various input files and calls the subroutine +C performing the requested calculation +C +C INCLUDE 'spec.inc' +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,RHOR(NE_M,NATM,0:18,2,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR +C +C +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 /1/ +C + READ(*,776) NFICHLEC + READ(*,776) ICOM + DO JF=1,NFICHLEC + READ(*,777) INDATA(JF) + ENDDO +C +C.......... Loop on the data files .......... +C + DO JFICH=1,NFICHLEC + OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD') + CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,* + &520,*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.'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 + IF(SPECTRO.EQ.'EIG') THEN + LE_MIN=1 + LE_MAX=1 + 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 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 + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + ENDDO + 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 +c IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN + IF(IPRINT.GE.2) 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,NAT2,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,NBTA),JT,JN,CHEM(JT) + ENDDO + ENDDO + ENDIF + ENDIF + 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN + CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) + ENDIF + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) + ENDDO + ENDIF +C + IF(SPECTRO.NE.'EIG') THEN + 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 + ENDIF +C +C.......... Loop on the electrons involved in the .......... +C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... +C.......... 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.'EIG') WRITE(IUO1,252) + 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,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.-1) THEN + WRITE(IUO1,82) LI,LI-1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 1,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,1) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.1) THEN + WRITE(IUO1,82) LI,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV.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---------- 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.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, + & NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C.......... Call of the subroutine performing either .......... +C.......... the PhD, AED, EXAFS or APECS calculation .......... +C + 566 IF(ISPIN.EQ.0) THEN + IF(SPECTRO.EQ.'EIG') THEN + CALL EIGDIF_MI + 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.'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) + ELSEIF(SPECTRO.EQ.'EIG') THEN + WRITE(IUO1,253) + 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.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP) + ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS(ISOM,NFICHLEC,NP) + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP) +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP) +c ENDIF + continue + ENDIF + ENDIF +C + IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) + STOP +C + 1 WRITE(IUO1,60) + STOP + 2 WRITE(IUO1,61) + STOP + 55 WRITE(IUO1,65) + STOP + 56 WRITE(IUO1,64) + STOP + 74 WRITE(IUO1,75) + STOP + 99 WRITE(IUO1,100) + STOP + 180 WRITE(IUO1,181) + STOP + 182 WRITE(IUO1,183) + STOP + 184 WRITE(IUO1,185) + STOP + 504 WRITE(IUO1,505) + STOP + 510 WRITE(IUO1,511) IUI4 + STOP + 514 WRITE(IUO1,515) + STOP + 516 WRITE(IUO1,517) + STOP + 518 WRITE(IUO1,519) + WRITE(IUO1,889) + STOP + 520 WRITE(IUO1,521) + STOP + 540 WRITE(IUO1,541) + STOP + 550 WRITE(IUO1,551) + STOP + 570 WRITE(IUO1,571) + STOP + 580 WRITE(IUO1,581) + STOP + 590 WRITE(IUO1,591) + STOP + 600 WRITE(IUO1,601) + STOP + 602 WRITE(IUO1,603) + STOP + 604 WRITE(IUO1,605) + STOP + 606 WRITE(IUO1,607) + STOP + 608 WRITE(IUO1,609) + STOP + 610 WRITE(IUO1,611) + STOP + 614 WRITE(IUO1,615) NB_AT + STOP + 620 WRITE(IUO1,621) LE_MAX + STOP + 630 WRITE(IUO1,631) + STOP + 890 WRITE(IUO1,891) + STOP + 895 WRITE(IUO1,896) JA1,JA2 +C + 3 FORMAT(5(5X,I4)) + 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) + 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',': + & (',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 + &POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', 'OF THE + &EXAFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE + &ATOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + & '++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', ' CONTENTS OF THE + &REDUCED CLUSTER ======================',///) + 41 FORMAT(///,'==================================================== + &','============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2, + &' DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE + &SURFACE)') + 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON + &DIFFRACTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', 'EXAFS + &CALCULATION ##########') + 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON + &DIFFRACTION 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 + &OSCILLATIONS 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 ', + &'CLUSTER 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 + &PRESENT 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, + &E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) + 106 FORMAT(12X,I3,12X,I3,12X,I3) + 107 FORMAT(5X,I2,5X,I2,5X,I2) + 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 109 FORMAT(5X,I2,12X,I2,11X,I2) + 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + &' :',/,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 ', + &'INVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ', + &'INVERSION)') + 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 ', + &'AND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + &'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ', + &'FILE >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX + &ELEMENTS 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 + &DIFFRACTION CALCULATION #####', '#####',/////) + 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &PHOTOELECTRON DIFFRACTION CALCULATION ','##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &AUGER DIFFRACTION CALCULATION ', '##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &APECS DIFFRACTION CALCULATION ', '##########',/////) + 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON + &DIFFRACTION CALCULATION #####','#####') + 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', 'OF THE MULTIPLE + &SCATTERING EIGENVALUE CALCULATION #####', '#####',/////) + 253 FORMAT(/////,'########## END ', 'OF THE MULTIPLE SCATTERING + &EIGENVALUE CALCULATION #####', '#####',/////) + 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 + &DIMENSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ', + &'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' + &>>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ', + &'NAT 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',' + &CONSISTENT 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 ', + &'CORRESPOND 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 ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 555 FORMAT(4(7X,I2)) + 556 FORMAT(28X,4(I2,5X)) + 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,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, + &'ATOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' + &No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL + &ATOMS : ',//) + 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 ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD + &AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT + &CONSISTENT 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 ', + &'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ', + &17X,'WITH THE INPUT DATA FILE ',16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ', + &'THE 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 + &IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','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 ''', + &'UNITS >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' + &ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' + &ARE IDENTICAL >>>>>>>>>>') +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 +C INCLUDE 'spec.inc' + USE DIM_MOD + 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 EIG_MAT_MS(JE,E_KIN) +C +C This subroutine stores the G_o T kernel matrix and computes +C its eigenvalues to check the larger ones. If one or more +C of these eigenvalues are larger than or equal to 1, no +C series expansion can converge +C +C Last modified : 20 Jul 2009 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE COOR_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE TRANS_MOD +C + PARAMETER(NLTWO=2*NL_M) +C + CHARACTER*24 OUTFILE,PATH +C + COMPLEX*16 HL1(0:NLTWO),SM(LINMAX*NATCLU_M,LINMAX*NATCLU_M) + COMPLEX*16 SUM_L,IC,ZEROC,WORK(32*LINMAX*NATCLU_M) + COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO),TLK,EXPKJ + COMPLEX*16 W(LINMAX*NATCLU_M) + COMPLEX*16 VL(1,1),VR(1,1) +C + DOUBLE PRECISION RWORK(2*LINMAX*NATCLU_M) +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ +C + REAL W1(LINMAX*NATCLU_M),W2(LINMAX*NATCLU_M) +C + DATA PI,SMALL /3.1415926535898D0,0.0001/ +C + IC=(0.D0,1.D0) + ZEROC=(0.D0,0.D0) + IBESS=3 + NPRINT=10 +C + WRITE(IUO1,5) + IF(JE.EQ.1) THEN +C +C Name of the second output file where all the eigenvalues +C will be written +C + IOUT2=55 + IOUT3=60 + N_DOT=1 + DO J_CHAR=1,24 + IF(OUTFILE2(J_CHAR:J_CHAR).EQ.'.') GOTO 888 + N_DOT=N_DOT+1 + ENDDO + 888 CONTINUE + OUTFILE=OUTFILE2(1:N_DOT)//'egv' + PATH=OUTFILE2(1:N_DOT)//'pth' + OPEN(UNIT=IOUT2, FILE=OUTFILE, STATUS='UNKNOWN') + OPEN(UNIT=IOUT3, FILE=PATH, STATUS='UNKNOWN') + ENDIF +C +C Construction of the multiple scattering kernel matrix G_o T. +C Elements are stored using a linear index LINJ +C representing (J,LJ) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + DO LJ=0,LMJ + DO MJ=-LJ,LJ + JLIN=JLIN+1 +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.NE.JATL) THEN + XKJ=DBLE(SYM_AT(1,KATL)-XJ) + YKJ=DBLE(SYM_AT(2,KATL)-YJ) + ZKJ=DBLE(SYM_AT(3,KATL)-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))* + & RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM, + & LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ, + & HL1) + ENDIF +C + DO LK=0,LMK + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + KLIN=KLIN+1 + SM(KLIN,JLIN)=ZEROC + SUM_L=ZEROC + IF(KATL.NE.JATL) THEN + CALL GAUNT2(LK,MK,LJ,MJ,GNT) +C + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L=SUM_L+(IC**L)* + & HL1(L)*YLM(L,M)*GNT(L) + ENDIF + ENDDO + SUM_L=SUM_L*ATTKJ*4.D0*PI*IC + ELSE + SUM_L=ZEROC + ENDIF +C + SM(KLIN,JLIN)=TLK*SUM_L +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + N_DIM=LINMAX*NATCLU_M +C +C Eigenvalues of the kernel multiple scattering matrix SM +C + CALL ZGEEV('N','N',JLIN,SM,N_DIM,W,VL,1,VR,1,WORK,34*N_DIM,RWORK, + &INFO) + IF(INFO.NE.0) THEN + WRITE(IUO1,*) ' ' + WRITE(IUO1,*) ' ---> WORK(1),INFO =',WORK(1),INFO + WRITE(IUO1,*) ' ' + ENDIF +C + N_EIG=0 +C + WRITE(IOUT2,75) + WRITE(IOUT2,110) + WRITE(IOUT2,80) E_KIN + WRITE(IOUT2,110) + WRITE(IOUT2,75) + WRITE(IOUT2,105) + WRITE(IOUT2,75) + XMAX_L=0. + N_XMAX=0 +C + DO LIN=1,JLIN + EIG=REAL(CDABS(W(LIN))) + WRITE(IOUT2,100) REAL(DBLE(W(LIN))),REAL(DIMAG(W(LIN))),EIG + IF((EIG-XMAX_L).GT.0.0001) N_XMAX=LIN + XMAX_L=MAX(XMAX_L,EIG) + W1(LIN)=EIG + IF(EIG.GT.1.000) THEN + N_EIG=N_EIG+1 + ENDIF + ENDDO +C + WRITE(IOUT2,75) + WRITE(IOUT2,85) XMAX_L + WRITE(IOUT2,90) N_XMAX + WRITE(IOUT2,95) W(N_XMAX) + WRITE(IOUT2,75) +C + CALL ORDRE(JLIN,W1,NFIN,W2) +C +C + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,15) W2(1) + WRITE(IUO1,20) W2(NFIN) + WRITE(IUO1,10) + WRITE(IUO1,10) + IF(N_EIG.GE.1) THEN + IF(N_EIG.EQ.1) THEN + WRITE(IUO1,25) JLIN + ELSE + WRITE(IUO1,30) N_EIG,JLIN + ENDIF + ENDIF +C + WRITE(IUO1,65) N_XMAX + WRITE(IUO1,70) W(N_XMAX) + WRITE(IUO1,10) + WRITE(IOUT3,100) REAL(DBLE(W(N_XMAX))),REAL(DIMAG(W(N_XMAX))) +C + NPR=NPRINT/5 + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,35) 5*NPR + WRITE(IUO1,10) +C + DO JP=0,NPR-1 + J=5*JP + WRITE(IUO1,40) W2(J+1),W2(J+2),W2(J+3),W2(J+4),W2(J+5) + ENDDO + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,45) W2(1) + WRITE(IUO2,*) E_KIN,W2(1) + IF(N_EIG.EQ.0) THEN + WRITE(IUO1,50) + ELSE + WRITE(IUO1,55) + ENDIF + WRITE(IUO1,10) + WRITE(IUO1,10) + WRITE(IUO1,60) +C + RETURN +C + 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','--------- + &--------') + 10 FORMAT(11X,'-',54X,'-') + 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-') + 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-') + 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-') + 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X, + &'-') + 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-') + 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-') + 45 FORMAT(11X,'-',5X,'SPECTRAL RADIUS OF THE KERNEL MATRIX :',F6.3, + &5X,'-') + 50 FORMAT(11X,'-',5X,'---> THE MULTIPLE SCATTERING SERIES ', + &'CONVERGES',4X,'-') + 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/ + &,11X,'-',18X,'SCATTERING SERIES',19X,'-') + 60 FORMAT(11X,'----------------------------------------','---------- + &------',/) + 65 FORMAT(11X,'-',5X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,'- + &') + 70 FORMAT(11X,'-',5X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.3, + &')',8X,'-') + 75 FORMAT(' ') + 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV') + 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3) + 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5) + 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,') + &') + 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3) + 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :') + 110 FORMAT(2X,'-------------------------------') +C + END +C +C======================================================================= +C + SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT, + &JE,*) +C +C This routine computes a spherical wave scattering factor +C +C Last modified : 03/04/2006 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE APPROX_MOD + USE EXPFAC_MOD + USE TRANS_MOD + USE TYPCAL_MOD I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, + &I6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST + + 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 PLOTFD(A,LMX,ITL,NL,NAT,NE) +C +C This routine prepares the output for a plot of the scattering factor +C +C INCLUDE 'spec.inc' +C +C + USE APPROX_MOD + USE FDIF_MOD + USE INIT_L_MOD L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 => + &LF2, I10 => ISTEP_LF + USE INIT_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 => NONVOL + USE VALFIN_MOD +C + DIMENSION LMX(NATM,NE_M) +C + COMPLEX FSPH,VKE +C + DATA PI,CONV/3.141593,0.512314/ +C + OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN') + IF(ISPHER.EQ.0) THEN + L=0 + LMAX=0 + ELSE + LMAX=L + ENDIF + PHITOT=360. + THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI + NPHI=(NFTHET+1)*IPHI+(1-IPHI) + NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+ + * (1-ITHETA) + NE=NFTHET*IE + (1-IE) + WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN + DO 10 JT=1,NTHT + DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1)) + RTHETA=DTHETA*PI/180. + TEST=SIN(RTHETA) + IF(TEST.GE.0.) THEN + POZ=PI + EPS=1. + ELSE + POZ=0. + EPS=-1. + ENDIF + BETA=RTHETA*EPS + IF(ABS(TEST).LT.0.0001) THEN + NPHIM=1 + ELSE + NPHIM=NPHI + ENDIF + DO 20 JP=1,NPHIM + DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1)) + RPHI=DPHI*PI/180. + GAMMA=POZ-RPHI + DO 30 JE=1,NE + IF(NE.EQ.1) THEN + ECIN=E0 + ELSE + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ENDIF + IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.) + DO 40 JAT=1,NAT + IF(L.GT.LMX(JAT,JE)) GOTO 90 + DO 50 M=-LMAX,LMAX + CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA, + & GAMMA,L,M,FSPH,JAT,JE,*60) + GOTO 70 + 60 WRITE(IUO1,80) + STOP + 70 REFTH=REAL(FSPH) + XIMFTH=AIMAG(FSPH) + WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA, + & DPHI,ECIN + 50 CONTINUE + GOTO 40 + 90 WRITE(IUO1,100) JAT + STOP + 40 CONTINUE + 30 CONTINUE + 20 CONTINUE + 10 CONTINUE + CLOSE(IUO3) + 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2) + 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2, + &1X,F8.2) + 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS + &ZERO >>>>>') + 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : + &',I2,' >>>>>') +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE EIGDIF_MI +C +C This subroutine computes the eigenvalues of the +C multiple scattering matrix to obtain its spectral radius +C +C The eigenvalue calculation is performed using the LAPACK +C eigenvalue routines for a general complex matrix (I_PWM = 0) +C or using the power method (I_PWM > 0) +C +C Last modified : 26 Apr 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD NTCLU => NATCLU, NTP => NATYP + USE DEBWAL_MOD + USE EIGEN_MOD NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE RESEAU_MOD + USE TESTS_MOD + USE TRANS_MOD + USE VALIN_MOD E1 => E0, PHLUM => PHILUM +C + COMPLEX IC,ONEC + COMPLEX TLT(0:NT_M,4,NATM,NE_M) +C +C + DATA CONV /0.512314/ +C + IC=(0.,1.) + ONEC=(1.,0.) +C + OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN') +C +C Loop over the energies +C + DO JE=1,NE + IF(NE.GT.1) THEN + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ELSEIF(NE.EQ.1) THEN + ECIN=E0 + ENDIF + CALL LPM(ECIN,XLPM,*6) + XLPM1=XLPM/A + IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 + IF(ITL.EQ.0) THEN + VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC + 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_MFP.EQ.0) THEN + VK(JE)=CMPLX(REAL(VK(JE))) + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDIF + IF(I_VIB.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,I_VIB) + DO LAT=0,LMAX(JAT,JE) + TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) + ENDDO + ENDDO + ENDIF +C +C Eigenvalue calculation +C + IF(I_PWM.EQ.0) THEN + CALL EIG_MAT_MS(JE,ECIN) + ELSE + CALL SPEC_RAD_POWER(JE,ECIN) + ENDIF +C +C +C End of the loop on the energy +C + ENDDO + GOTO 7 +C + 6 WRITE(IUO1,55) +C + 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/, + &25X,' BY DEBYE UNCORRELATED MODEL:',/) + 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2') + 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',//) +C + 7 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE SPEC_RAD_POWER(JE,E_KIN) +C +C This subroutine stores the G_o T kernel matrix and computes +C its spectral radius using the power method. In addition, +C a scalar convergence acceleration method can be used to +C refine the results. +C +C Author : D. Sebilleau +C +C Last modified : 4 Feb 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE TRANS_MOD +C +C + PARAMETER(NLTWO=2*NL_M) +C + INTEGER NN(0:N_ORD_M) +C + REAL R_SN(N_ORD_M),R_SN1(N_ORD_M),R_SN2(N_ORD_M) +C + COMPLEX*16 TLK,SUM_L,EXPKJ,ONEC,MULT + COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO) + COMPLEX*16 X(LINMAX*NATCLU_M),Y(LINMAX*NATCLU_M) + COMPLEX*16 AX(LINMAX*NATCLU_M),AY(LINMAX*NATCLU_M),SUM_AX,SUM_AY + COMPLEX*16 HL1(0:NLTWO),A(LINMAX*NATCLU_M,LINMAX*NATCLU_M) + COMPLEX*16 ZEROC,IC,JC,JMULT + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ + REAL*8 NORMX2,NORMY2,NORMAX2,NORMAY2,RLIN +C +C + CHARACTER*10 METH + CHARACTER*24 OUTFILE,PATH +C + DATA PI /3.1415926535898D0/ +C + ONEC=(1.D0,0.D0) + IC=(0.0D0,1.0D0) + ZEROC=(0.D0,0.D0) + IBESS=3 + N_CALL=0 + N_ACC=0 + K_ACC=0 + I_CONV=0 +C + IF(N_MAX.GT.N_ORD_M) THEN + WRITE(IUO1,99) N_MAX + STOP + ENDIF +C +C Starting vector for power method: +C +C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO +C + JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0) + JMULT=JC**EXPO +C + WRITE(IUO1,6) +C +C Construction of the the multiple scattering kernel matrix G_o T +C +C Elements are stored in A(KLIN,JLIN) using linear indices +C JLIN and KLIN representing (J,LJ) and (K,LK) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + DO LJ=0,LMJ + DO MJ=-LJ,LJ + JLIN=JLIN+1 +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.NE.JATL) THEN + XKJ=DBLE(SYM_AT(1,KATL)-XJ) + YKJ=DBLE(SYM_AT(2,KATL)-YJ) + ZKJ=DBLE(SYM_AT(3,KATL)-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))* + & RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM, + & LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ, + & HL1) + ENDIF +C + DO LK=0,LMK + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + KLIN=KLIN+1 + A(KLIN,JLIN)=ZEROC + SUM_L=ZEROC + IF(KATL.NE.JATL) THEN + CALL GAUNT2(LK,MK,LJ,MJ,GNT) +C + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L=SUM_L+(IC**L)* + & HL1(L)*YLM(L,M)*GNT(L) + ENDIF + ENDDO + SUM_L=SUM_L*ATTKJ*4.D0*PI*IC + ELSE + SUM_L=ZEROC + ENDIF +C + IF(KATL.NE.JATL) THEN + A(KLIN,JLIN)=TLK*SUM_L + ENDIF +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + NLIN=JLIN +C +C Power method approximation of the spectral radius : +C +C SR(A) = lim ||A x||^n / ||x||^n +C n --> +infty +C for any starting vector x +C + RLIN=DFLOAT(NLIN) +C +C Initialization the vectors and their squared norm +C + MULT=JMULT +C + AX(1)=ONEC + AY(1)=ONEC +C + NORMAX2=1.D0 + NORMAY2=1.D0 +C + DO ILIN=2,NLIN +C + AX(ILIN)=AX(ILIN-1)*MULT + AY(ILIN)=AY(ILIN-1)*MULT + NORMAX2=NORMAX2+DREAL(AX(ILIN)*DCONJG(AX(ILIN))) + NORMAY2=NORMAY2+DREAL(AY(ILIN)*DCONJG(AY(ILIN))) +C + ENDDO +C +C Computation of the vectors and their squared norm +C +C X ---> A*X +C + 120 IF(N_CALL.EQ.0) THEN + J_INI=1 + ELSE + J_INI=N_CALL*N_ITER+1 + ENDIF + J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX) +C + IF(J_INI.GT.J_FIN) GOTO 112 +C + DO JORD=J_INI,J_FIN +C + NORMX2=NORMAX2 + NORMY2=NORMAY2 +C + DO JLIN=1,NLIN +C + X(JLIN)=AX(JLIN) + Y(JLIN)=AY(JLIN) +C + ENDDO +C + NORMAX2=0.D0 + NORMAY2=0.D0 +C + DO ILIN=1,NLIN +C + SUM_AX=ZEROC + SUM_AY=ZEROC +C + DO JLIN=1,NLIN +C + SUM_AX=SUM_AX+A(ILIN,JLIN)*X(JLIN) + SUM_AY=SUM_AY+A(JLIN,ILIN)*Y(JLIN) +C + ENDDO +C + AX(ILIN)=SUM_AX + AY(ILIN)=SUM_AY + NORMAX2=NORMAX2+DREAL(SUM_AX*DCONJG(SUM_AX)) + NORMAY2=NORMAY2+DREAL(SUM_AY*DCONJG(SUM_AY)) +C + ENDDO +C + R_SN1(JORD)=SQRT(REAL(NORMAX2/NORMX2)) + R_SN2(JORD)=SQRT(REAL(NORMAY2/NORMY2)) + R_SN(JORD)=SQRT(R_SN1(JORD)*R_SN2(JORD)) +C + ENDDO +C + IF(J_INI.EQ.1) THEN + WRITE(IUO1,10) + WRITE(IUO1,46) NLIN + WRITE(IUO1,10) + WRITE(IUO1,61) + ENDIF +C + WRITE(IUO1,10) + WRITE(IUO1,44) R_SN(JORD-1) + WRITE(IUO1,47) JORD-1 +C + 112 IF(I_ACC.GE.1) THEN +C +C Convergence acceleration on the results whenever necessary +C + CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + & R_SN,SN,METH) + IF((I_CONV.EQ.1).AND.(I_ACC.EQ.1)) GOTO 111 + IF((I_CONV.EQ.0).OR.(I_ACC.EQ.2)) GOTO 120 +C + 111 WRITE(IUO1,10) + WRITE(IUO1,61) + WRITE(IUO1,10) + WRITE(IUO1,52) METH + WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC)) + WRITE(IUO1,49) N_ACC + WRITE(IUO1,51) K_ACC +C + IF(I_ACC.EQ.2) THEN + OPEN(UNIT=35, FILE='div/n_k_table.lis', STATUS='unknown') + DO L=0,K_MAX + NN(L)=L + ENDDO + WRITE(35,*) ' ' + WRITE(35,*) ' (N,K) TABLE OF ',METH,' + & METHOD' + WRITE(35,*) ' ' + WRITE(35,198) (NN(K),K=0,K_MAX) + WRITE(35,199) + WRITE(35,*) ' ' + DO N=0,K_MAX + WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N) + WRITE(35,*) ' ' + ENDDO + ENDIF +C + WRITE(IUO1,10) + WRITE(IUO1,60) + IF(I_ACC.EQ.2) THEN + WRITE(IUO1,210) + ENDIF +C + ENDIF +C + WRITE(IUO2,*) E_KIN,R_SN(JORD-1) +C + RETURN +C + 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','--------- + &--------') + 6 FORMAT(/,11X,'---------------- POWER METHOD ANALYSIS ','-------- + &--------') + 10 FORMAT(11X,'-',54X,'-') + 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-') + 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-') + 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-') + 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X, + &'-') + 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-') + 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-') + 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5, + &3X,'-') + 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5, + &3X,'-') + 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8, + &3X,'-') + 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8, + &3X,'-') + 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5, + &3X,'-') + 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8, + &3X,'-') + 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ', + &'CONVERGES ',4X,'-') + 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8, + &3X,'-') + 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10, + &1X,'-') + 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/ + &,11X,'-',18X,'SCATTERING SERIES',19X,'-') + 60 FORMAT(11X,'----------------------------------------','---------- + &------',/) + 61 FORMAT(11X,'----------------------------------------','---------- + &------') + 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X, + &'-') + 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6. + &3,')',8X,'-') + 75 FORMAT(' ') + 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV') + 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3) + 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5) + 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,') + &') + 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE',' + &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ', + &I5, 6X,' >>>>>>>>>>',///) + 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3) + 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :') + 110 FORMAT(2X,'-------------------------------') + 198 FORMAT(' K',50(I3,4X)) + 199 FORMAT(' N') + 200 FORMAT(I3,50(2X,F5.3)) + 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ', + &'IN /div/n_k_table.lis',//) +C + END +C +C======================================================================= +C + SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + &R_SN,SN,METH) +C +C Use of the various acceleration scheme on a scalar series +C +C AITK : Aitken, modified Aitken +C RICH : Richardson +C SALZ : Salzer +C EPSI : epsilon +C EPSG : generalized epsilon +C RHOA : rho +C THET : theta +C LEGE : Legendre-Toeplitz +C CHEB : Chebyshev-Toeplitz +C OVER : Overholt +C DURB : Durbin +C DLEV : Levin d-transform !! differ by the +C TLEV : Levin t-transform !! choice of w_n +C ULEV : Levin u-transform !! the remainder +C VLEV : Levin v-transform !! estimate given +C ELEV : Levin e-transform !! by I_WN +C EULE : generalized Euler transform +C GBWT : Germain-Bronne-Wimp transform +C VARI : various algorithms : Weniger, BDG, iterated rho +C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2 +C EALG : E-algorithm +C +C SN : series to be accelerated +C XN : auxilliary series (chosen with I_XN) : interpolation points +C GN : auxilliary series (chosen with I_GN) ---> E algorithm +C +C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1) +C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K) +C so N_DIV=2 +C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are +C meaningful. Hence the K_MAX size +C +C COL_M : type of columns meaningful in the (n,k) table (example: even columns +C for the epsilon algorithm) +C +C +C Author : D. Sebilleau +C +C Last modified : 1 Mar 2013 +C +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVACC_MOD L => LEVIN + USE CONVTYP_MOD +C + PARAMETER (N_METH=24) +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + COMPLEX*16 ZEROC,ONEC +C + REAL*8 R2_SN(N_ORD_M),RHO +C + REAL R_SN(N_ORD_M) +C + INTEGER N_DIV(N_METH) +C + CHARACTER*3 COL_M(N_METH) + CHARACTER*4 SCHE(N_METH) + CHARACTER*10 NAME(N_METH),METH +C +C + DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE','CHEB', + &'OVER','DURB','DLEV','TLEV','ULEV','VLEV','ELEV','EULE','GBWT', + &'EALG','SALZ','VARI','ITHE','EPSG','NONE','NONE','NONE'/ + DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ',' RHO ',' + & THETA ',' LEGENDRE ','CHEBYSHEV ',' OVERHOLT ',' DURBIN ',' + &D LEVIN ',' T LEVIN ',' U LEVIN ',' V LEVIN ',' E LEVIN ',' + & EULER ',' GBW ',' E ',' SALZER ',' VARIA ', + &'ITER THETA',' EPSILON G',' ',' ',' '/ + DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL','ALL','ALL', + &'ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL', + &'ALL','ALL','EVE','ALL','ALL','ALL'/ + DATA N_DIV /2,1,1,2,2,1,1,1,4,1,1,1,1,1,1,1,1,1,2,4,1,1,1,1/ +C + J_NAME=0 + I_COL=0 +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + DO J=J_INI,J_FIN + R2_SN(J)=DBLE(R_SN(J)) + ENDDO +C +C Finding the name of the method +C + DO JM=1,N_METH +C + IF(METHOD.EQ.SCHE(JM)) THEN + J_NAME=JM + K_MAX=N_MAX/N_DIV(JM) + N_COEF=N_DIV(JM) + IF(COL_M(JM).EQ.'EVE') I_COL=2 + ENDIF +C + ENDDO +C +C Initialization of array SN +C + DO N=J_INI,J_FIN +C + DO K=-1,J_FIN +C + SN(N,K)=ZEROC +C + ENDDO +C + ENDDO +C +C Initialisation of the schemes : +C +C -- SN(N,0) is the series to be accelerated -- +C + SN(0,-1)=ZEROC + SN(0,0)=ONEC +C + DO N=J_INI,J_FIN +C + SN(N,-1)=ZEROC + SN(N,0)=R2_SN(N) +C + ENDDO +C + CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C Check for convergence : all results equal within ACC +C in a N_TABLE x N_TABLE square +C + IF(I_CONV.EQ.0) THEN + CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX, + & N_COEF,I_COL,ACC,RHO,SN) + ENDIF +C + IF(METHOD(2:4).EQ.'LEV') THEN + METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN) + ELSE + METH=NAME(J_NAME) + ENDIF +C +C Incrementation of the number of calls to this subroutine +C if convergence has not been achieved +C + IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN + N_CALL=N_CALL+1 + ELSE + GOTO 10 + ENDIF +C +C Printing the results in the check file +C + 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',5X,'*') + 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*') + 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*') + 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6, + &',',E12.6,')',5X,'*') + 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*') + 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <--- + &convergence',2X,'*') + 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',3X,' * <--- convergence') + 35 FORMAT(2X,'***************************************','************ + &************************') + 45 FORMAT(2X,'* ',' + & *') + 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,') + & *') + 75 FORMAT(2X,'* Order Taylor ',20X,A10,' + & *') + 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'* + & order ',60X,'*') + 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ', + &'>>>>>>>>>>',//) +C + 10 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C This subroutine computes the scalar convergence acceleration +C for various methods +C +C Note: let us consider that the (n,k) space pattern indicates +C that we need S(n,k),...,S(n+p,k) in order to compute +C S(n,k+1). We call N the maximum value of n for which +C the S(n,0) are known. Then, to compute S(n,k+1), we +C we need to know up to S(n+pk+p,0). This means that +C the value of n is limited to N-pk-p. +C +C Author : D. Sebilleau +C +C Last modified : 14 Mar 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE CONVACC_MOD L => LEVIN +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5 + COMPLEX*16 NUM,DEN,FIR + COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK +C + REAL*8 EPS,EPSS,MUL +C + CHARACTER*4 METHOD +C + DATA EPS,EPSS /1.D-12,1.D-150/ +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + N_APP=J_FIN + N_INI=0 +C + IF(METHOD.EQ.'AITK') THEN +C +C The iterated Aitken and modified Aitken schemes +C +C H. H. H. Homeier, Num. Alg. 8, 47 (1994) +C +C I_VA = 1 : iterated Aitken (p 49 eq 5) +C I_VA = 2 : modified iterated Aitken (p 49 eq 9) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + IF(I_VA.EQ.1) THEN + XK=ONEC + ELSEIF(I_VA.EQ.2) THEN + XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1) + ENDIF +C + DO N=N_INI,N_APP-2*K-2 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + DELTA2=(SN(N+2,K)-SN(N+1,K)) + IF(CDABS(DELTA2).LT.EPSS) THEN + DELTA3=ZEROC + ELSE + DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1) + ENDIF + SN(N,K+1)=SN(N,K)-XK*DELTA3 + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RICH') THEN +C +C The Richardson scheme +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=SN(N+1,0)-SN(N,0) + DELTA2=SN(N+K+2,0)-SN(N+K+1,0) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 10 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'SALZ') THEN +C +C The Salzer scheme +C +C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=DFLOAT(N+K+2) + DELTA2=DFLOAT(N+1) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 11 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'GBWT') THEN +C +C The GBW scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C (eq 6.1-5 p33) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=XN(N) + DELTA2=XN(N+K+1) + IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 80 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSI') THEN +C +C The epsilon scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1) +C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 20 + IF(I_VA.EQ.1) THEN + VAR=ONEC + ELSEIF(I_VA.EQ.2) THEN + VAR=XN(N+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + VAR=XN(N+K+1)-XN(N+K) + ENDIF + SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1 + N_COUNT=N_COUNT+1 +C + 20 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSG') THEN +C +C The generalized epsilon scheme +C +C M. N. Barber and C. J. Hamer, +C J. Austral. Math. Soc. (Series B) 23, 229 (1982) +C +C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed) +C DELTA2 = 0 implies SN(N+1,K) = SN(N,K) +C ---> convergence achieved for (N,K) +C + N_COUNT=0 +C + DO K=0,N_APP,2 +C + IF(I_VA.EQ.1) THEN + SI(K)=ALPHA + SI(K+1)=ALPHA + ELSEIF(I_VA.EQ.2) THEN + SI(K)=ZEROC + SI(K+1)=-ONEC + ENDIF +C + ENDDO +C + VAR=ONEC +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + NK(N,-1)=ZEROC + DELTA2=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA2).LT.EPSS) GOTO 23 + NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2 + DELTA1=(NK(N,K)-NK(N-1,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 23 + SN(N,K+1)=SN(N,K)+VAR/DELTA1 + N_COUNT=N_COUNT+1 + 23 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RHOA') THEN +C +C The rho scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1) +C I_VA = 2 : Standard rho (p 34 eq 6.2-2) +C I_VA = 3 : (p 37 eq 6.3-3) ??????? +C +C ALPHA is the decay parameter. It is +C generally advised to take it as +C an integer to ensure convergence +C + IF(DREAL(ALPHA).LT.0.0D0) THEN +C +C Drummond approximation to alpha : +C +C (non valid for the Taylor expansion +C of 1/1+x as in this case the denominator +C is always zero) +C + DO N=N_INI,N_APP +C + DELTA1=SN(N+3,1)-SN(N+2,1) + DELTA2=SN(N+2,1)-SN(N+1,1) + DELTA3=SN(N+1,1)-SN(N,1) +C + NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2) + DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1 + ALPHA=NUM/DEN-ONEC +C + ENDDO +C + ENDIF +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + IF(I_VA.NE.3) THEN + DEN=(SN(N+1,K)-SN(N,K)) + ELSE + DELTA2=(SN(N+2,K)-SN(N+1,K)) + DELTA3=(SN(N+1,K)-SN(N,K)) + DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)- + & XN(N))*DELTA2 + ENDIF +C + IF(CDABS(DEN).LT.EPS) GOTO 30 + IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30 +C + IF(I_VA.EQ.1) THEN + NUM=(DFLOAT(K+1)+ALPHA) + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+K+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3 + ENDIF +C + SN(N,K+1)=SN(N+1,K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 30 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'THET') THEN +C +C The theta scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C E. Calicetti et al, Phys. Rep. 446, 1 (2007) +C +C I_VA = 1 : standard formulation (eq 71 p 19) +C I_VA = 2 : generalized formulation (eq 10.1-10 p 74) +C + KMAX2=(N_APP-2)/2 +C + N_COUNT=0 + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,KMAX2 +C + IF(I_VA.EQ.3) GOTO 51 +C + DO N=N_INI,N_APP-2*K-1 +C + DEN=SN(N+1,2*K)-SN(N,2*K) + IF(CDABS(DEN).LT.EPSS) GOTO 40 + IF(I_VA.EQ.1) THEN + NUM=1.D0 + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+2*K+1)-XN(N) + ENDIF + SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 40 CONTINUE +C + ENDDO +C + DO N=N_INI,N_APP-4*K-2 +C + DELTA2=SN(N+2,2*K)-SN(N+1,2*K) + DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1) + DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1) +C + IF(I_VA.EQ.1) THEN + NUM=DELTA2*DELTA4 + DEN=DELTA4-DELTA3 + ELSEIF(I_VA.EQ.2) THEN + NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4 + DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN( + & N))*DELTA4 + ENDIF + IF(CDABS(DEN).LT.EPSS) GOTO 50 +C + SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 50 CONTINUE +C + ENDDO + GOTO 52 +C + 51 DO N=N_INI,N_APP-4*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + DELTA4=DELTA3-DELTA2 + DELTA5=DELTA2-DELTA1 + DEN=DELTA3*DELTA5-DELTA1*DELTA4 + IF(CDABS(DEN).LT.EPSS) GOTO 53 +C + NUM=DELTA1*DELTA2*DELTA4 + SN(N,K+1)=SN(N+1,K)-NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 53 CONTINUE +C + ENDDO +C + 52 CONTINUE +C + ENDDO +C + ELSEIF(METHOD.EQ.'LEGE') THEN +C +C The Legendre-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.3), (4.4) p. 231 +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1) + DELTA2=DFLOAT(K)/DFLOAT(K+1) +C + DO N=N_INI,N_APP-K-1 + SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN( + & N,K-1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'CHEB') THEN +C +C The Chebyshev-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.4) - (4.9) p. 231 +C + SI(0)=ONEC + SI(1)=3.D0*ONEC +C + DO N=N_INI,N_APP-1 +C + TN(N,0)=SN(N,0) + TN(N,1)=SN(N,0)+2.D0*TN(N+1,0) + SN(N,0)=TN(N,0)/SI(0) + SN(N,1)=TN(N,1)/SI(1) +C + ENDDO +C + N_COUNT=0 +C + DO K=1,N_APP-1 +C + SI(K+1)=6.D0*SI(K)-SI(K-1) +C + DO N=N_INI,N_APP-K-1 +C + TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1) + SN(N,K+1)=TN(N,K+1)/SI(K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'OVER') THEN +C +C The Overholt scheme +C +C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996) +C (eq 36 p 85) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=ONEC + DELTA2=ONEC + MUL=1.D0 +C + DO I=1,K+1 +C + DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0)) + DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0)) + MUL=MUL*EPS +C + ENDDO +C + IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 60 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'DURB') THEN +C +C The Durbin scheme +C +C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007) +C (eq 25 p 185) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-4*K-4 +C + DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+ + & 3,K)+SN(N,K)*SN(N+4,K) + DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN( + & N,K)+SN(N+4,K) + IF(CDABS(DELTA2).LT.EPSS) GOTO 70 + SN(N,K+1)=DELTA1/DELTA2 + N_COUNT=N_COUNT+1 +C + 70 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD(2:4).EQ.'LEV') THEN +C +C The Levin schemes +C + CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + & METHOD(1:1)) +C + ELSEIF(METHOD.EQ.'EULE') THEN +C +C The generalized Euler scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'VARI') THEN +C +C Various schemes +C +C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1) +C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2) +C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3) +C I_VA = 4 : iterated rho scheme +C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-2*K-2 +C + IF(I_VA.EQ.1) THEN + A=BETA+DFLOAT(N) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.2) THEN + A=ALPHA+DFLOAT(N+K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.3) THEN + A=ALPHA+DFLOAT(N-K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.4) THEN + A=XN(N+2*K+2)-XN(N) + B=XN(N+2*K+1)-XN(N) + C=XN(N+2*K+2)-XN(N+1) + ELSEIF(I_VA.EQ.5) THEN + A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA) + B=ONEC + C=ONEC + ENDIF +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DEN=B*DELTA2-C*DELTA1 + IF(CDABS(DEN).LT.EPSS) GOTO 81 + SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN + N_COUNT=N_COUNT+1 +C + 81 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'ITHE') THEN +C +C Iterated theta schemes +C +C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6) +C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5) +C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-3*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + IF(I_VA.EQ.1) THEN + NUM=-DELTA1*DELTA2*(DELTA3-DELTA2) + DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.2) THEN + NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2) + DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*( + & DELTA2-DELTA1) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.3) THEN + NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2) + DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*( + & DELTA2-DELTA1) + FIR=SN(N+2,K) + ENDIF +C + IF(CDABS(DEN).LT.EPSS) GOTO 90 + SN(N,K+1)=FIR+NUM/DEN + N_COUNT=N_COUNT+1 +C + 90 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EALG') THEN +C +C E algorithm +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) + CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C Computing the GN(N,K,I) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 91 + DELTA1=GN(N,K-1,K)/DEN +C + DO I=0,N_APP +C + NUM=GN(N+1,K-1,I)-GN(N,K-1,I) + GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1 +C + ENDDO +C + 91 CONTINUE +C + ENDDO +C + ENDDO +C +C Computing SN(N,K) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP-K +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 92 + DELTA1=GN(N,K-1,K)/DEN + SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1 +C + 92 CONTINUE +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH) +C +C Binomial coefficients ---> ISWITCH = 1 +C Power coefficients ---> ISWITCH = 2 +C Pochhammer coefficients ---> ISWITCH = 3 +C Pochhammer coefficients ---> ISWITCH = 4 (negative argument) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Sep 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC +C + ONEC=(1.D0,0.D0) +C + COEF(0,0)=ONEC + COEF(1,0)=ONEC + COEF(1,1)=ONEC +C + IF(I_SWITCH.EQ.1) THEN +C + DO N=2,N_APP-1 +C + COEF(N,0)=ONEC + COEF(N,1)=DCMPLX(N) +C + DO K=2,N +C + COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.2) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC + COEF(N,1)=BETA+DFLOAT(N) +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.3) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.4) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + &OMEGA) +C +C This subroutine computes Levin-type transforms of +C a given sequence SN(N,1) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1: + &N_ORD_M) + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC + COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2 +C + CHARACTER*1 OMEGA +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Recovery of the original series elements +C + DO N=N_INI,N_APP +C + AN(N)=SN(N,0)-SN(N-1,0) +C + ENDDO +C +C +C Choice of the remainder estimate omega_n +C +C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000) +C +C + IF(OMEGA.EQ.'U') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*(DFLOAT(N)+BETA) + ENDDO +C + ELSEIF(OMEGA.EQ.'V') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1)) + ENDDO +C + ELSEIF(OMEGA.EQ.'T') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N) + ENDDO +C + ELSEIF(OMEGA.EQ.'D') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N+1) + ENDDO +C + ELSEIF(OMEGA.EQ.'E') THEN +C + MAX_N=N_APP-2 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+2)/AN(N+1) + ENDDO +C + ENDIF +C +C Choice of the Levin-type transform +C +C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10) +C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10) +C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10) +C I_WN = 4 ---> C-type (eq 3-16c p 11) +C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70) +C I_WN = 6 ---> R-type (eq 7.14-12 p 47) +C +C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004) +C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989) +C +C +C Check for the possibility of L extension (the standard case is L = 0) +C + IF(L.GT.0) THEN + IF(I_WN.EQ.1) THEN + CALL COEFFICIENTS(MAX_N,COEL,BETA,2) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.2) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,3) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.3) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,4) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ENDIF + ENDIF +C + DO N=N_INI,MAX_N +C + X=BETA+DFLOAT(N) + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + XK=DFLOAT(K) + XXK=X+XK +C + IF(I_WN.EQ.1) THEN + INC=XXK/(XXK+ONEC) + COEF(N,K)=X*(INC**K)/XXK + ELSEIF(I_WN.EQ.2) THEN + COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK)) + ELSEIF(I_WN.EQ.3) THEN + COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC) + ELSEIF(I_WN.EQ.4) THEN + SUM_1=ZEROC + SUM_2=ZEROC + DO J=0,K + SUM_1=SUM_1+ALPHA*XXK + SUM_2=SUM_2+ALPHA*(XXK+ONEC) + ENDDO + COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2) + ELSEIF(I_WN.EQ.5) THEN + COEF(N,K)=ONEC + ELSEIF(I_WN.EQ.6) THEN + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) + ENDIF +C + ENDDO +C + ENDDO +C +C Computation of the recurrence relation for numerator +C and denominator +C + DO N=N_INI,MAX_N +C +C Starting values +C + NUM(N,0)=SN(N,0)/WN(N) + DEN(N,0)=ONEC/WN(N) + SN(N,0)=NUM(N,0)/DEN(N,0) +C + ENDDO +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,MAX_N-K-1 +C + IF(I_WN.NE.6) THEN + NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K) + DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K) + ELSE + NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N)) + DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N)) + ENDIF + SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C +C This subroutine computes the interpolation +C points used in some algorithms +C +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 ALPHA,BETA +C + DO N=0,N_APP +C + IF(I_XN.EQ.1) THEN + XN(N)=(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.2) THEN + XN(N)=BETA+DFLOAT(N) + ELSEIF(I_XN.EQ.3) THEN + XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.4) THEN + XN(N)=(BETA+DFLOAT(N))**ALPHA + ELSEIF(I_XN.EQ.5) THEN + XN(N)=((2.D0**N)/BETA)**ALPHA + ENDIF +C + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C This subroutine computes the G_N series used to describe +C the correction on the remainder estimate +C +C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n} +C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation) +C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.) +C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n} +C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n} +C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne) +C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Computing binomial coefficients +C + IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1) +C + DO N=0,N_APP +C + GN(N,0,-1)=ZEROC + GN(N,0,0)=ONEC + MONE=-ONEC +C + DO I=1,N_APP +C + IF(I_GN.EQ.1) THEN + GN(N,0,I)=GN(N,0,I-1)*XN(N) + ELSEIF(I_GN.EQ.2) THEN + GN(N,0,I)=XN(N+I-1) + ELSEIF(I_GN.EQ.3) THEN + GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0) + ELSEIF(I_GN.EQ.4) THEN + GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N) + ELSEIF(I_GN.EQ.5) THEN + GN(N,0,I)=GN(N,0,I-1)/XN(N) + ELSEIF(I_GN.EQ.6) THEN + MONE=-MONE + SUM_J=ZEROC + ONE=-ONEC + DO J=0,I + ONE=-ONE + SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0) + ENDDO + GN(N,0,I)=MONE*SUM_J + ELSEIF(I_GN.EQ.7) THEN + IF(I.GT.1) THEN + GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0) + ELSE + GN(N,0,I)=SN(N,0) + ENDIF + ENDIF +C + ENDDO +C + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC, + &K_MAX,N_COEF,I_COL,ACC,RHO,SN) +C +C This subroutine checks the convergence of the acceleration process. +C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table +C of SN(n,k)that contains equal values (SMALL being the accepted error) +C +C This way, both the column convergence (k fixed and n increasing) +C and the diagonal convergence (n=k increasing) are considered +C +C Important note: in some algorithms, such as the epsilon one, only +C odd columns are meaningful. If I_COL = 0, all +C columns are taken into account while for I_COL = 2 +C only even columns are considered +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2011 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + REAL*8 ACC,REF,COMP,RHO +C +C Step for the columns comparison and change of the size +C of the square when only even columns should be considered +C + IF(I_COL.EQ.0) THEN + I_STEP=1 + N_SQUARE=N_TABLE + N_START=N_TABLE + ELSEIF(I_COL.EQ.2) THEN + I_STEP=2 + N_SQUARE=N_TABLE+N_TABLE-1 + IF(MOD(N_SQUARE,2).EQ.0) THEN + N_START=N_SQUARE + ELSE + N_START=N_SQUARE+1 + ENDIF + ENDIF +C +C Positionning the bottom right corner of the square: (N,K), +C starting from (N_START,N_START). If only even columns +C should be considered, N_START must be even +C + K_FIN=J_FIN/N_COEF + IF(K_FIN.LT.N_START) THEN + I_CONV=0 + GOTO 10 + ENDIF +C + DO K=N_START,K_FIN+N_START-1,I_STEP + IF(K.GT.K_MAX) GOTO 20 + DO N=N_START,K_FIN-K,I_STEP +C +C Checking the values (N1,K1) in the selected square +C + REF=CDABS(SN(N,K)) + I_CONV=1 +C + DO N1=0,N_START,I_STEP + NN=N-N1 + DO K1=0,N_START,I_STEP +C + KK=K-K1 + COMP=CDABS(REF-SN(NN,KK)) + IF(COMP.GT.ACC) THEN + I_CONV=0 + ENDIF +C + ENDDO + ENDDO +C + IF(I_CONV.EQ.1) THEN +C +C All values in the square are equal (within ACC): +C Spectral radius taken as the left top corner value +C + N_ACC=N-N_START+I_STEP + K_ACC=K-N_START+I_STEP + RHO=REF + GOTO 10 + ENDIF +C + ENDDO + 20 CONTINUE + ENDDO +C + 10 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*) +C +C This subroutine checks the convergence of the power method or of +C the Rayleigh quotient method at level JORD without convergence +C acceleration. For convergence, there must be N_TABLE equal values +C (ACC being the accepted error) of SN +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + REAL ACC,COMP,R_SN(N_ORD_M) +C + NCONV=0 + DO J=JORD,JORD-N_TABLE,-1 + COMP=ABS(R_SN(J)-R_SN(J-1)) + IF(COMP.LE.ACC) THEN + NCONV=NCONV+1 + ENDIF + ENDDO +C + IF(NCONV.EQ.N_TABLE-1) RETURN 1 +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/remain_series.f b/src/msspec/spec/fortran/eig/mi/remain_series.f new file mode 100644 index 0000000..0500645 --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/remain_series.f @@ -0,0 +1,78 @@ +C +C======================================================================= +C + SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C This subroutine computes the G_N series used to describe +C the correction on the remainder estimate +C +C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n} +C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation) +C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.) +C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n} +C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n} +C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne) +C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Computing binomial coefficients +C + IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1) +C + DO N=0,N_APP +C + GN(N,0,-1)=ZEROC + GN(N,0,0)=ONEC + MONE=-ONEC +C + DO I=1,N_APP +C + IF(I_GN.EQ.1) THEN + GN(N,0,I)=GN(N,0,I-1)*XN(N) + ELSEIF(I_GN.EQ.2) THEN + GN(N,0,I)=XN(N+I-1) + ELSEIF(I_GN.EQ.3) THEN + GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0) + ELSEIF(I_GN.EQ.4) THEN + GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N) + ELSEIF(I_GN.EQ.5) THEN + GN(N,0,I)=GN(N,0,I-1)/XN(N) + ELSEIF(I_GN.EQ.6) THEN + MONE=-MONE + SUM_J=ZEROC + ONE=-ONEC + DO J=0,I + ONE=-ONE + SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0) + ENDDO + GN(N,0,I)=MONE*SUM_J + ELSEIF(I_GN.EQ.7) THEN + IF(I.GT.1) THEN + GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0) + ELSE + GN(N,0,I)=SN(N,0) + ENDIF + ENDIF +C + ENDDO +C + ENDDO +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/mi/spec_rad_power.f b/src/msspec/spec/fortran/eig/mi/spec_rad_power.f new file mode 100644 index 0000000..a9e222a --- /dev/null +++ b/src/msspec/spec/fortran/eig/mi/spec_rad_power.f @@ -0,0 +1,348 @@ +C +C======================================================================= +C + SUBROUTINE SPEC_RAD_POWER(JE,E_KIN) +C +C This subroutine stores the G_o T kernel matrix and computes +C its spectral radius using the power method. In addition, +C a scalar convergence acceleration method can be used to +C refine the results. +C +C Author : D. Sebilleau +C +C Last modified : 4 Feb 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE TRANS_MOD +C +C +C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD +C + INTEGER NN(0:N_ORD_M) +C + REAL R_SN(N_ORD_M),R_SN1(N_ORD_M),R_SN2(N_ORD_M) +C + COMPLEX*16 TLK,SUM_L,EXPKJ,ONEC,MULT + COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO) + COMPLEX*16 X(LINMAX*NATCLU_M),Y(LINMAX*NATCLU_M) + COMPLEX*16 AX(LINMAX*NATCLU_M),AY(LINMAX*NATCLU_M),SUM_AX,SUM_AY + COMPLEX*16 HL1(0:NLTWO),A(LINMAX*NATCLU_M,LINMAX*NATCLU_M) + COMPLEX*16 ZEROC,IC,JC,JMULT + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ + REAL*8 NORMX2,NORMY2,NORMAX2,NORMAY2,RLIN +C +C + CHARACTER*10 METH + CHARACTER*24 OUTFILE,PATH +C + DATA PI /3.1415926535898D0/ +C + ONEC=(1.D0,0.D0) + IC=(0.0D0,1.0D0) + ZEROC=(0.D0,0.D0) + IBESS=3 + N_CALL=0 + N_ACC=0 + K_ACC=0 + I_CONV=0 +C + IF(N_MAX.GT.N_ORD_M) THEN + WRITE(IUO1,99) N_MAX + STOP + ENDIF +C +C Starting vector for power method: +C +C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO +C + JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0) + JMULT=JC**EXPO +C + WRITE(IUO1,6) +C +C Construction of the the multiple scattering kernel matrix G_o T +C +C Elements are stored in A(KLIN,JLIN) using linear indices +C JLIN and KLIN representing (J,LJ) and (K,LK) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + DO LJ=0,LMJ + DO MJ=-LJ,LJ + JLIN=JLIN+1 +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.NE.JATL) THEN + XKJ=DBLE(SYM_AT(1,KATL)-XJ) + YKJ=DBLE(SYM_AT(2,KATL)-YJ) + ZKJ=DBLE(SYM_AT(3,KATL)-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))* + & RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM, + & LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ, + & HL1) + ENDIF +C + DO LK=0,LMK + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + KLIN=KLIN+1 + A(KLIN,JLIN)=ZEROC + SUM_L=ZEROC + IF(KATL.NE.JATL) THEN + CALL GAUNT2(LK,MK,LJ,MJ,GNT) +C + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L=SUM_L+(IC**L)* + & HL1(L)*YLM(L,M)*GNT(L) + ENDIF + ENDDO + SUM_L=SUM_L*ATTKJ*4.D0*PI*IC + ELSE + SUM_L=ZEROC + ENDIF +C + IF(KATL.NE.JATL) THEN + A(KLIN,JLIN)=TLK*SUM_L + ENDIF +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + NLIN=JLIN +C +C Power method approximation of the spectral radius : +C +C SR(A) = lim ||A x||^n / ||x||^n +C n --> +infty +C for any starting vector x +C + RLIN=DFLOAT(NLIN) +C +C Initialization the vectors and their squared norm +C + MULT=JMULT +C + AX(1)=ONEC + AY(1)=ONEC +C + NORMAX2=1.D0 + NORMAY2=1.D0 +C + DO ILIN=2,NLIN +C + AX(ILIN)=AX(ILIN-1)*MULT + AY(ILIN)=AY(ILIN-1)*MULT + NORMAX2=NORMAX2+DREAL(AX(ILIN)*DCONJG(AX(ILIN))) + NORMAY2=NORMAY2+DREAL(AY(ILIN)*DCONJG(AY(ILIN))) +C + ENDDO +C +C Computation of the vectors and their squared norm +C +C X ---> A*X +C + 120 IF(N_CALL.EQ.0) THEN + J_INI=1 + ELSE + J_INI=N_CALL*N_ITER+1 + ENDIF + J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX) +C + IF(J_INI.GT.J_FIN) GOTO 112 +C + DO JORD=J_INI,J_FIN +C + NORMX2=NORMAX2 + NORMY2=NORMAY2 +C + DO JLIN=1,NLIN +C + X(JLIN)=AX(JLIN) + Y(JLIN)=AY(JLIN) +C + ENDDO +C + NORMAX2=0.D0 + NORMAY2=0.D0 +C + DO ILIN=1,NLIN +C + SUM_AX=ZEROC + SUM_AY=ZEROC +C + DO JLIN=1,NLIN +C + SUM_AX=SUM_AX+A(ILIN,JLIN)*X(JLIN) + SUM_AY=SUM_AY+A(JLIN,ILIN)*Y(JLIN) +C + ENDDO +C + AX(ILIN)=SUM_AX + AY(ILIN)=SUM_AY + NORMAX2=NORMAX2+DREAL(SUM_AX*DCONJG(SUM_AX)) + NORMAY2=NORMAY2+DREAL(SUM_AY*DCONJG(SUM_AY)) +C + ENDDO +C + R_SN1(JORD)=SQRT(REAL(NORMAX2/NORMX2)) + R_SN2(JORD)=SQRT(REAL(NORMAY2/NORMY2)) + R_SN(JORD)=SQRT(R_SN1(JORD)*R_SN2(JORD)) +C + ENDDO +C + IF(J_INI.EQ.1) THEN + WRITE(IUO1,10) + WRITE(IUO1,46) NLIN + WRITE(IUO1,10) + WRITE(IUO1,61) + ENDIF +C + WRITE(IUO1,10) + WRITE(IUO1,44) R_SN(JORD-1) + WRITE(IUO1,47) JORD-1 +C + 112 IF(I_ACC.GE.1) THEN +C +C Convergence acceleration on the results whenever necessary +C + CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + & R_SN,SN,METH) + IF((I_CONV.EQ.1).AND.(I_ACC.EQ.1)) GOTO 111 + IF((I_CONV.EQ.0).OR.(I_ACC.EQ.2)) GOTO 120 +C + 111 WRITE(IUO1,10) + WRITE(IUO1,61) + WRITE(IUO1,10) + WRITE(IUO1,52) METH + WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC)) + WRITE(IUO1,49) N_ACC + WRITE(IUO1,51) K_ACC +C + IF(I_ACC.EQ.2) THEN + OPEN(UNIT=35, FILE='div/n_k_table.lis', STATUS='unknown') + DO L=0,K_MAX + NN(L)=L + ENDDO + WRITE(35,*) ' ' + WRITE(35,*) ' (N,K) TABLE OF ',METH,' + & METHOD' + WRITE(35,*) ' ' + WRITE(35,198) (NN(K),K=0,K_MAX) + WRITE(35,199) + WRITE(35,*) ' ' + DO N=0,K_MAX + WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N) + WRITE(35,*) ' ' + ENDDO + ENDIF +C + WRITE(IUO1,10) + WRITE(IUO1,60) + IF(I_ACC.EQ.2) THEN + WRITE(IUO1,210) + ENDIF +C + ENDIF +C + WRITE(IUO2,*) E_KIN,R_SN(JORD-1) +C + RETURN +C + 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','--------- + &--------') + 6 FORMAT(/,11X,'---------------- POWER METHOD ANALYSIS ','-------- + &--------') + 10 FORMAT(11X,'-',54X,'-') + 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-') + 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-') + 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-') + 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X, + &'-') + 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-') + 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-') + 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5, + &3X,'-') + 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5, + &3X,'-') + 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8, + &3X,'-') + 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8, + &3X,'-') + 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5, + &3X,'-') + 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8, + &3X,'-') + 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ', + &'CONVERGES ',4X,'-') + 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8, + &3X,'-') + 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10, + &1X,'-') + 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/ + &,11X,'-',18X,'SCATTERING SERIES',19X,'-') + 60 FORMAT(11X,'----------------------------------------','---------- + &------',/) + 61 FORMAT(11X,'----------------------------------------','---------- + &------') + 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X, + &'-') + 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6. + &3,')',8X,'-') + 75 FORMAT(' ') + 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV') + 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3) + 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5) + 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,') + &') + 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE',' + &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ', + &I5, 6X,' >>>>>>>>>>',///) + 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3) + 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :') + 110 FORMAT(2X,'-------------------------------') + 198 FORMAT(' K',50(I3,4X)) + 199 FORMAT(' N') + 200 FORMAT(I3,50(2X,F5.3)) + 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ', + &'IN /div/n_k_table.lis',//) +C + END diff --git a/src/msspec/spec/fortran/eig/pw/acc_conv.f b/src/msspec/spec/fortran/eig/pw/acc_conv.f new file mode 100644 index 0000000..5466ae0 --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/acc_conv.f @@ -0,0 +1,194 @@ +C +C======================================================================= +C + SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + &R_SN,SN,METH) +C +C Use of the various acceleration scheme on a scalar series +C +C AITK : Aitken, modified Aitken +C RICH : Richardson +C SALZ : Salzer +C EPSI : epsilon +C EPSG : generalized epsilon +C RHOA : rho +C THET : theta +C LEGE : Legendre-Toeplitz +C CHEB : Chebyshev-Toeplitz +C OVER : Overholt +C DURB : Durbin +C DLEV : Levin d-transform !! differ by the +C TLEV : Levin t-transform !! choice of w_n +C ULEV : Levin u-transform !! the remainder +C VLEV : Levin v-transform !! estimate given +C ELEV : Levin e-transform !! by I_WN +C EULE : generalized Euler transform +C GBWT : Germain-Bronne-Wimp transform +C VARI : various algorithms : Weniger, BDG, iterated rho +C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2 +C EALG : E-algorithm +C +C SN : series to be accelerated +C XN : auxilliary series (chosen with I_XN) : interpolation points +C GN : auxilliary series (chosen with I_GN) ---> E algorithm +C +C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1) +C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K) +C so N_DIV=2 +C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are +C meaningful. Hence the K_MAX size +C +C COL_M : type of columns meaningful in the (n,k) table (example: even columns +C for the epsilon algorithm) +C +C +C Author : D. Sebilleau +C +C Last modified : 1 Mar 2013 +C +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVACC_MOD, L => LEVIN + USE CONVTYP_MOD +C + PARAMETER (N_METH=24) +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + COMPLEX*16 ZEROC,ONEC +C + REAL*8 R2_SN(N_ORD_M),RHO +C + REAL R_SN(N_ORD_M) +C + INTEGER N_DIV(N_METH) +C + CHARACTER*3 COL_M(N_METH) + CHARACTER*4 SCHE(N_METH) + CHARACTER*10 NAME(N_METH),METH +C + DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE', + 1 'CHEB','OVER','DURB','DLEV','TLEV','ULEV', + 2 'VLEV','ELEV','EULE','GBWT','EALG','SALZ', + 3 'VARI','ITHE','EPSG','NONE','NONE','NONE'/ + DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ', + 1 ' RHO ',' THETA ',' LEGENDRE ', + 2 'CHEBYSHEV ',' OVERHOLT ',' DURBIN ', + 3 ' D LEVIN ',' T LEVIN ',' U LEVIN ', + 4 ' V LEVIN ',' E LEVIN ',' EULER ', + 5 ' GBW ',' E ',' SALZER ', + 6 ' VARIA ','ITER THETA',' EPSILON G', + 7 ' ',' ',' '/ + DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL', + 1 'ALL','ALL','ALL','ALL','ALL','ALL', + 2 'ALL','ALL','ALL','ALL','ALL','ALL', + 3 'ALL','ALL','EVE','ALL','ALL','ALL'/ + DATA N_DIV /2,1,1,2,2,1, + 1 1,1,4,1,1,1, + 2 1,1,1,1,1,1, + 3 2,4,1,1,1,1/ +C + J_NAME=0 + I_COL=0 +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + DO J=J_INI,J_FIN + R2_SN(J)=DBLE(R_SN(J)) + ENDDO +C +C Finding the name of the method +C + DO JM=1,N_METH +C + IF(METHOD.EQ.SCHE(JM)) THEN + J_NAME=JM + K_MAX=N_MAX/N_DIV(JM) + N_COEF=N_DIV(JM) + IF(COL_M(JM).EQ.'EVE') I_COL=2 + ENDIF +C + ENDDO +C +C Initialization of array SN +C + DO N=J_INI,J_FIN +C + DO K=-1,J_FIN +C + SN(N,K)=ZEROC +C + ENDDO +C + ENDDO +C +C Initialisation of the schemes : +C +C -- SN(N,0) is the series to be accelerated -- +C + SN(0,-1)=ZEROC + SN(0,0)=ONEC +C + DO N=J_INI,J_FIN +C + SN(N,-1)=ZEROC + SN(N,0)=R2_SN(N) +C + ENDDO +C + CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C Check for convergence : all results equal within ACC +C in a N_TABLE x N_TABLE square +C + IF(I_CONV.EQ.0) THEN + CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX, + & N_COEF,I_COL,ACC,RHO,SN) + ENDIF +C + IF(METHOD(2:4).EQ.'LEV') THEN + METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN) + ELSE + METH=NAME(J_NAME) + ENDIF +C +C Incrementation of the number of calls to this subroutine +C if convergence has not been achieved +C + IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN + N_CALL=N_CALL+1 + ELSE + GOTO 10 + ENDIF +C +C Printing the results in the check file +C + 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',5X,'*') + 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*') + 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*') + 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6, + &',',E12.6,')',5X,'*') + 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*') + 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <--- + &convergence',2X,'*') + 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',3X,' * <--- convergence') + 35 FORMAT(2X,'***************************************','************ + &************************') + 45 FORMAT(2X,'* ',' + & *') + 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,') + & *') + 75 FORMAT(2X,'* Order Taylor ',20X,A10,' + & *') + 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'* + & order ',60X,'*') + 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ', + &'>>>>>>>>>>',//) +C + 10 RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/acc_scal.f b/src/msspec/spec/fortran/eig/pw/acc_scal.f new file mode 100644 index 0000000..7b25042 --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/acc_scal.f @@ -0,0 +1,693 @@ +C +C======================================================================= +C + SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C This subroutine computes the scalar convergence acceleration +C for various methods +C +C Note: let us consider that the (n,k) space pattern indicates +C that we need S(n,k),...,S(n+p,k) in order to compute +C S(n,k+1). We call N the maximum value of n for which +C the S(n,0) are known. Then, to compute S(n,k+1), we +C we need to know up to S(n+pk+p,0). This means that +C the value of n is limited to N-pk-p. +C +C Author : D. Sebilleau +C +C Last modified : 14 Mar 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE CONVACC_MOD, L => LEVIN +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5 + COMPLEX*16 NUM,DEN,FIR + COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK +C + REAL*8 EPS,EPSS,MUL +C + CHARACTER*4 METHOD +C + DATA EPS,EPSS /1.D-12,1.D-150/ +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + N_APP=J_FIN + N_INI=0 +C + IF(METHOD.EQ.'AITK') THEN +C +C The iterated Aitken and modified Aitken schemes +C +C H. H. H. Homeier, Num. Alg. 8, 47 (1994) +C +C I_VA = 1 : iterated Aitken (p 49 eq 5) +C I_VA = 2 : modified iterated Aitken (p 49 eq 9) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + IF(I_VA.EQ.1) THEN + XK=ONEC + ELSEIF(I_VA.EQ.2) THEN + XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1) + ENDIF +C + DO N=N_INI,N_APP-2*K-2 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + DELTA2=(SN(N+2,K)-SN(N+1,K)) + IF(CDABS(DELTA2).LT.EPSS) THEN + DELTA3=ZEROC + ELSE + DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1) + ENDIF + SN(N,K+1)=SN(N,K)-XK*DELTA3 + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RICH') THEN +C +C The Richardson scheme +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=SN(N+1,0)-SN(N,0) + DELTA2=SN(N+K+2,0)-SN(N+K+1,0) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 10 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'SALZ') THEN +C +C The Salzer scheme +C +C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=DFLOAT(N+K+2) + DELTA2=DFLOAT(N+1) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 11 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'GBWT') THEN +C +C The GBW scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C (eq 6.1-5 p33) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=XN(N) + DELTA2=XN(N+K+1) + IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 80 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSI') THEN +C +C The epsilon scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1) +C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 20 + IF(I_VA.EQ.1) THEN + VAR=ONEC + ELSEIF(I_VA.EQ.2) THEN + VAR=XN(N+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + VAR=XN(N+K+1)-XN(N+K) + ENDIF + SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1 + N_COUNT=N_COUNT+1 +C + 20 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSG') THEN +C +C The generalized epsilon scheme +C +C M. N. Barber and C. J. Hamer, +C J. Austral. Math. Soc. (Series B) 23, 229 (1982) +C +C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed) +C DELTA2 = 0 implies SN(N+1,K) = SN(N,K) +C ---> convergence achieved for (N,K) +C + N_COUNT=0 +C + DO K=0,N_APP,2 +C + IF(I_VA.EQ.1) THEN + SI(K)=ALPHA + SI(K+1)=ALPHA + ELSEIF(I_VA.EQ.2) THEN + SI(K)=ZEROC + SI(K+1)=-ONEC + ENDIF +C + ENDDO +C + VAR=ONEC +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + NK(N,-1)=ZEROC + DELTA2=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA2).LT.EPSS) GOTO 23 + NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2 + DELTA1=(NK(N,K)-NK(N-1,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 23 + SN(N,K+1)=SN(N,K)+VAR/DELTA1 + N_COUNT=N_COUNT+1 + 23 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RHOA') THEN +C +C The rho scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1) +C I_VA = 2 : Standard rho (p 34 eq 6.2-2) +C I_VA = 3 : (p 37 eq 6.3-3) ??????? +C +C ALPHA is the decay parameter. It is +C generally advised to take it as +C an integer to ensure convergence +C + IF(DREAL(ALPHA).LT.0.0D0) THEN +C +C Drummond approximation to alpha : +C +C (non valid for the Taylor expansion +C of 1/1+x as in this case the denominator +C is always zero) +C + DO N=N_INI,N_APP +C + DELTA1=SN(N+3,1)-SN(N+2,1) + DELTA2=SN(N+2,1)-SN(N+1,1) + DELTA3=SN(N+1,1)-SN(N,1) +C + NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2) + DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1 + ALPHA=NUM/DEN-ONEC +C + ENDDO +C + ENDIF +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + IF(I_VA.NE.3) THEN + DEN=(SN(N+1,K)-SN(N,K)) + ELSE + DELTA2=(SN(N+2,K)-SN(N+1,K)) + DELTA3=(SN(N+1,K)-SN(N,K)) + DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)- + & XN(N))*DELTA2 + ENDIF +C + IF(CDABS(DEN).LT.EPS) GOTO 30 + IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30 +C + IF(I_VA.EQ.1) THEN + NUM=(DFLOAT(K+1)+ALPHA) + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+K+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3 + ENDIF +C + SN(N,K+1)=SN(N+1,K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 30 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'THET') THEN +C +C The theta scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C E. Calicetti et al, Phys. Rep. 446, 1 (2007) +C +C I_VA = 1 : standard formulation (eq 71 p 19) +C I_VA = 2 : generalized formulation (eq 10.1-10 p 74) +C + KMAX2=(N_APP-2)/2 +C + N_COUNT=0 + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,KMAX2 +C + IF(I_VA.EQ.3) GOTO 51 +C + DO N=N_INI,N_APP-2*K-1 +C + DEN=SN(N+1,2*K)-SN(N,2*K) + IF(CDABS(DEN).LT.EPSS) GOTO 40 + IF(I_VA.EQ.1) THEN + NUM=1.D0 + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+2*K+1)-XN(N) + ENDIF + SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 40 CONTINUE +C + ENDDO +C + DO N=N_INI,N_APP-4*K-2 +C + DELTA2=SN(N+2,2*K)-SN(N+1,2*K) + DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1) + DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1) +C + IF(I_VA.EQ.1) THEN + NUM=DELTA2*DELTA4 + DEN=DELTA4-DELTA3 + ELSEIF(I_VA.EQ.2) THEN + NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4 + DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN( + & N))*DELTA4 + ENDIF + IF(CDABS(DEN).LT.EPSS) GOTO 50 +C + SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 50 CONTINUE +C + ENDDO + GOTO 52 +C + 51 DO N=N_INI,N_APP-4*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + DELTA4=DELTA3-DELTA2 + DELTA5=DELTA2-DELTA1 + DEN=DELTA3*DELTA5-DELTA1*DELTA4 + IF(CDABS(DEN).LT.EPSS) GOTO 53 +C + NUM=DELTA1*DELTA2*DELTA4 + SN(N,K+1)=SN(N+1,K)-NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 53 CONTINUE +C + ENDDO +C + 52 CONTINUE +C + ENDDO +C + ELSEIF(METHOD.EQ.'LEGE') THEN +C +C The Legendre-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.3), (4.4) p. 231 +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1) + DELTA2=DFLOAT(K)/DFLOAT(K+1) +C + DO N=N_INI,N_APP-K-1 + SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN( + & N,K-1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'CHEB') THEN +C +C The Chebyshev-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.4) - (4.9) p. 231 +C + SI(0)=ONEC + SI(1)=3.D0*ONEC +C + DO N=N_INI,N_APP-1 +C + TN(N,0)=SN(N,0) + TN(N,1)=SN(N,0)+2.D0*TN(N+1,0) + SN(N,0)=TN(N,0)/SI(0) + SN(N,1)=TN(N,1)/SI(1) +C + ENDDO +C + N_COUNT=0 +C + DO K=1,N_APP-1 +C + SI(K+1)=6.D0*SI(K)-SI(K-1) +C + DO N=N_INI,N_APP-K-1 +C + TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1) + SN(N,K+1)=TN(N,K+1)/SI(K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'OVER') THEN +C +C The Overholt scheme +C +C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996) +C (eq 36 p 85) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=ONEC + DELTA2=ONEC + MUL=1.D0 +C + DO I=1,K+1 +C + DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0)) + DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0)) + MUL=MUL*EPS +C + ENDDO +C + IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 60 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'DURB') THEN +C +C The Durbin scheme +C +C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007) +C (eq 25 p 185) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-4*K-4 +C + DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+ + & 3,K)+SN(N,K)*SN(N+4,K) + DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN( + & N,K)+SN(N+4,K) + IF(CDABS(DELTA2).LT.EPSS) GOTO 70 + SN(N,K+1)=DELTA1/DELTA2 + N_COUNT=N_COUNT+1 +C + 70 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD(2:4).EQ.'LEV') THEN +C +C The Levin schemes +C + CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + & METHOD(1:1)) +C + ELSEIF(METHOD.EQ.'EULE') THEN +C +C The generalized Euler scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'VARI') THEN +C +C Various schemes +C +C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1) +C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2) +C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3) +C I_VA = 4 : iterated rho scheme +C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-2*K-2 +C + IF(I_VA.EQ.1) THEN + A=BETA+DFLOAT(N) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.2) THEN + A=ALPHA+DFLOAT(N+K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.3) THEN + A=ALPHA+DFLOAT(N-K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.4) THEN + A=XN(N+2*K+2)-XN(N) + B=XN(N+2*K+1)-XN(N) + C=XN(N+2*K+2)-XN(N+1) + ELSEIF(I_VA.EQ.5) THEN + A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA) + B=ONEC + C=ONEC + ENDIF +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DEN=B*DELTA2-C*DELTA1 + IF(CDABS(DEN).LT.EPSS) GOTO 81 + SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN + N_COUNT=N_COUNT+1 +C + 81 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'ITHE') THEN +C +C Iterated theta schemes +C +C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6) +C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5) +C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-3*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + IF(I_VA.EQ.1) THEN + NUM=-DELTA1*DELTA2*(DELTA3-DELTA2) + DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.2) THEN + NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2) + DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*( + & DELTA2-DELTA1) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.3) THEN + NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2) + DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*( + & DELTA2-DELTA1) + FIR=SN(N+2,K) + ENDIF +C + IF(CDABS(DEN).LT.EPSS) GOTO 90 + SN(N,K+1)=FIR+NUM/DEN + N_COUNT=N_COUNT+1 +C + 90 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EALG') THEN +C +C E algorithm +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) + CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C Computing the GN(N,K,I) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 91 + DELTA1=GN(N,K-1,K)/DEN +C + DO I=0,N_APP +C + NUM=GN(N+1,K-1,I)-GN(N,K-1,I) + GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1 +C + ENDDO +C + 91 CONTINUE +C + ENDDO +C + ENDDO +C +C Computing SN(N,K) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP-K +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 92 + DELTA1=GN(N,K-1,K)/DEN + SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1 +C + 92 CONTINUE +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/check_conv.f b/src/msspec/spec/fortran/eig/pw/check_conv.f new file mode 100644 index 0000000..2553cbf --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/check_conv.f @@ -0,0 +1,97 @@ +C +C======================================================================= +C + SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC, + &K_MAX,N_COEF,I_COL,ACC,RHO,SN) +C +C This subroutine checks the convergence of the acceleration process. +C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table +C of SN(n,k)that contains equal values (SMALL being the accepted error) +C +C This way, both the column convergence (k fixed and n increasing) +C and the diagonal convergence (n=k increasing) are considered +C +C Important note: in some algorithms, such as the epsilon one, only +C odd columns are meaningful. If I_COL = 0, all +C columns are taken into account while for I_COL = 2 +C only even columns are considered +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2011 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + REAL*8 ACC,REF,COMP,RHO +C +C Step for the columns comparison and change of the size +C of the square when only even columns should be considered +C + IF(I_COL.EQ.0) THEN + I_STEP=1 + N_SQUARE=N_TABLE + N_START=N_TABLE + ELSEIF(I_COL.EQ.2) THEN + I_STEP=2 + N_SQUARE=N_TABLE+N_TABLE-1 + IF(MOD(N_SQUARE,2).EQ.0) THEN + N_START=N_SQUARE + ELSE + N_START=N_SQUARE+1 + ENDIF + ENDIF +C +C Positionning the bottom right corner of the square: (N,K), +C starting from (N_START,N_START). If only even columns +C should be considered, N_START must be even +C + K_FIN=J_FIN/N_COEF + IF(K_FIN.LT.N_START) THEN + I_CONV=0 + GOTO 10 + ENDIF +C + DO K=N_START,K_FIN+N_START-1,I_STEP + IF(K.GT.K_MAX) GOTO 20 + DO N=N_START,K_FIN-K,I_STEP +C +C Checking the values (N1,K1) in the selected square +C + REF=CDABS(SN(N,K)) + I_CONV=1 +C + DO N1=0,N_START,I_STEP + NN=N-N1 + DO K1=0,N_START,I_STEP +C + KK=K-K1 + COMP=CDABS(REF-SN(NN,KK)) + IF(COMP.GT.ACC) THEN + I_CONV=0 + ENDIF +C + ENDDO + ENDDO +C + IF(I_CONV.EQ.1) THEN +C +C All values in the square are equal (within ACC): +C Spectral radius taken as the left top corner value +C + N_ACC=N-N_START+I_STEP + K_ACC=K-N_START+I_STEP + RHO=REF + GOTO 10 + ENDIF +C + ENDDO + 20 CONTINUE + ENDDO +C + 10 RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/coefficients.f b/src/msspec/spec/fortran/eig/pw/coefficients.f new file mode 100644 index 0000000..5d79c8b --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/coefficients.f @@ -0,0 +1,90 @@ +C +C======================================================================= +C + SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH) +C +C Binomial coefficients ---> ISWITCH = 1 +C Power coefficients ---> ISWITCH = 2 +C Pochhammer coefficients ---> ISWITCH = 3 +C Pochhammer coefficients ---> ISWITCH = 4 (negative argument) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Sep 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC +C + ONEC=(1.D0,0.D0) +C + COEF(0,0)=ONEC + COEF(1,0)=ONEC + COEF(1,1)=ONEC +C + IF(I_SWITCH.EQ.1) THEN +C + DO N=2,N_APP-1 +C + COEF(N,0)=ONEC + COEF(N,1)=DCMPLX(N) +C + DO K=2,N +C + COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.2) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC + COEF(N,1)=BETA+DFLOAT(N) +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.3) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.4) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/conv_series.f b/src/msspec/spec/fortran/eig/pw/conv_series.f new file mode 100644 index 0000000..ead0873 --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/conv_series.f @@ -0,0 +1,33 @@ +C +C======================================================================= +C + SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*) +C +C This subroutine checks the convergence of the power method or of +C the Rayleigh quotient method at level JORD without convergence +C acceleration. For convergence, there must be N_TABLE equal values +C (ACC being the accepted error) of SN +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + REAL ACC,COMP,R_SN(N_ORD_M) +C + NCONV=0 + DO J=JORD,JORD-N_TABLE,-1 + COMP=ABS(R_SN(J)-R_SN(J-1)) + IF(COMP.LE.ACC) THEN + NCONV=NCONV+1 + ENDIF + ENDDO +C + IF(NCONV.EQ.N_TABLE-1) RETURN 1 +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/do_main.f b/src/msspec/spec/fortran/eig/pw/do_main.f new file mode 100644 index 0000000..32d8d6f --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/do_main.f @@ -0,0 +1,1558 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * EIGENVALUE CALCULATION CODE * * +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 * 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 +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE ADSORB_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE CLUSLIM_MOD + USE COOR_MOD + USE DEBWAL_MOD + USE INDAT_MOD + USE INIT_A_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE INIT_M_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE LIMAMA_MOD + USE LPMOY_MOD + USE MASSAT_MOD + USE MILLER_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TL_AED_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE XMRHO_MOD +C + DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3) + DIMENSION ROT(3,3),EMET(3) + DIMENSION VAL2(NATCLU_M) + DIMENSION IRE(NATCLU_M,2) + DIMENSION REL(NATCLU_M),RHOT(NATM) + DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M) + DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM) + DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M) + DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M) + DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM) +C + COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR +C +C +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 /1/ +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,* + &520,*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.'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 + IF(SPECTRO.EQ.'EIG') THEN + LE_MIN=1 + LE_MAX=1 + 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 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 + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + ENDDO + 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 +c IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN + IF(IPRINT.GE.2) 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,NAT2,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,NBTA),JT,JN,CHEM(JT) + ENDDO + ENDDO + ENDIF + ENDIF + 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN + CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) + ENDIF + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) + ENDDO + ENDIF +C + IF(SPECTRO.NE.'EIG') THEN + 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 + ENDIF +C +C.......... Loop on the electrons involved in the .......... +C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... +C.......... 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.'EIG') WRITE(IUO1,252) + 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,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.-1) THEN + WRITE(IUO1,82) LI,LI-1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 1,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,1) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.1) THEN + WRITE(IUO1,82) LI,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL, + & 2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE, + & NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV.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---------- 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.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, + & NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C.......... Call of the subroutine performing either .......... +C.......... the PhD, AED, EXAFS or APECS calculation .......... +C + 566 IF(ISPIN.EQ.0) THEN + IF(SPECTRO.EQ.'EIG') THEN + CALL EIGDIF_MI + 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.'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) + ELSEIF(SPECTRO.EQ.'EIG') THEN + WRITE(IUO1,253) + 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.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP) + ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS(ISOM,NFICHLEC,NP) + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP) +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP) +c ENDIF + continue + ENDIF + ENDIF +C + IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) + STOP +C + 1 WRITE(IUO1,60) + STOP + 2 WRITE(IUO1,61) + STOP + 55 WRITE(IUO1,65) + STOP + 56 WRITE(IUO1,64) + STOP + 74 WRITE(IUO1,75) + STOP + 99 WRITE(IUO1,100) + STOP + 180 WRITE(IUO1,181) + STOP + 182 WRITE(IUO1,183) + STOP + 184 WRITE(IUO1,185) + STOP + 504 WRITE(IUO1,505) + STOP + 510 WRITE(IUO1,511) IUI4 + STOP + 514 WRITE(IUO1,515) + STOP + 516 WRITE(IUO1,517) + STOP + 518 WRITE(IUO1,519) + WRITE(IUO1,889) + STOP + 520 WRITE(IUO1,521) + STOP + 540 WRITE(IUO1,541) + STOP + 550 WRITE(IUO1,551) + STOP + 570 WRITE(IUO1,571) + STOP + 580 WRITE(IUO1,581) + STOP + 590 WRITE(IUO1,591) + STOP + 600 WRITE(IUO1,601) + STOP + 602 WRITE(IUO1,603) + STOP + 604 WRITE(IUO1,605) + STOP + 606 WRITE(IUO1,607) + STOP + 608 WRITE(IUO1,609) + STOP + 610 WRITE(IUO1,611) + STOP + 614 WRITE(IUO1,615) NB_AT + STOP + 620 WRITE(IUO1,621) LE_MAX + STOP + 630 WRITE(IUO1,631) + STOP + 890 WRITE(IUO1,891) + STOP + 895 WRITE(IUO1,896) JA1,JA2 +C + 3 FORMAT(5(5X,I4)) + 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) + 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',': + & (',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 + &POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', 'OF THE + &EXAFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE + &ATOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + & '++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', ' CONTENTS OF THE + &REDUCED CLUSTER ======================',///) + 41 FORMAT(///,'==================================================== + &','============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2, + &' DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR + &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE + &SURFACE)') + 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON + &DIFFRACTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', 'EXAFS + &CALCULATION ##########') + 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON + &DIFFRACTION 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 + &OSCILLATIONS 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 ', + &'CLUSTER 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 + &PRESENT 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, + &E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) + 106 FORMAT(12X,I3,12X,I3,12X,I3) + 107 FORMAT(5X,I2,5X,I2,5X,I2) + 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 109 FORMAT(5X,I2,12X,I2,11X,I2) + 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + &' :',/,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 ', + &'INVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ', + &'INVERSION)') + 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 ', + &'AND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + &'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ', + &'FILE >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX + &ELEMENTS 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 + &DIFFRACTION CALCULATION #####', '#####',/////) + 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &PHOTOELECTRON DIFFRACTION CALCULATION ','##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &AUGER DIFFRACTION CALCULATION ', '##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE + &APECS DIFFRACTION CALCULATION ', '##########',/////) + 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON + &DIFFRACTION CALCULATION #####','#####') + 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER + &DIFFRACTION CALCULATION #####', '#####',/////) + 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS + &DIFFRACTION CALCULATION #####', '#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', 'OF THE MULTIPLE + &SCATTERING EIGENVALUE CALCULATION #####', '#####',/////) + 253 FORMAT(/////,'########## END ', 'OF THE MULTIPLE SCATTERING + &EIGENVALUE CALCULATION #####', '#####',/////) + 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 + &DIMENSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ', + &'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' + &>>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ', + &'NAT 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',' + &CONSISTENT 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 ', + &'CORRESPOND 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 ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 555 FORMAT(4(7X,I2)) + 556 FORMAT(28X,4(I2,5X)) + 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,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, + &'ATOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' + &No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL + &ATOMS : ',//) + 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 ', + &'CORRESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD + &AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT + &CONSISTENT 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 ', + &'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ', + &17X,'WITH THE INPUT DATA FILE ',16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ', + &'THE 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 + &IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','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 ''', + &'UNITS >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' + &ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' + &ARE IDENTICAL >>>>>>>>>>') +C + END +C +C======================================================================= +C diff --git a/src/msspec/spec/fortran/eig/pw/eigdif_mi.f b/src/msspec/spec/fortran/eig/pw/eigdif_mi.f new file mode 100644 index 0000000..6142624 --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/eigdif_mi.f @@ -0,0 +1,115 @@ +C +C======================================================================= +C + SUBROUTINE EIGDIF_MI +C +C This subroutine computes the eigenvalues of the +C multiple scattering matrix to obtain its spectral radius +C +C The eigenvalue calculation is performed using the LAPACK +C eigenvalue routines for a general complex matrix (I_PWM = 0) +C or using the power method (I_PWM > 0) +C +C Last modified : 26 Apr 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP + USE DEBWAL_MOD + USE EIGEN_MOD, NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE RESEAU_MOD + USE TESTS_MOD + USE TRANS_MOD + USE VALIN_MOD, E1 => E0 +C + COMPLEX IC,ONEC + COMPLEX TLT(0:NT_M,4,NATM,NE_M) +C + DATA CONV /0.512314/ +C + IC=(0.,1.) + ONEC=(1.,0.) +C + OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN') +C +C Check file to monitor the convergence of the calculation +C + OPEN(UNIT=36, FILE='div/radius_conv.lis', STATUS='unknown') +C +C Loop over the energies +C + DO JE=1,NE + IF(NE.GT.1) THEN + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ELSEIF(NE.EQ.1) THEN + ECIN=E0 + ENDIF + CALL LPM(ECIN,XLPM,*6) + XLPM1=XLPM/A + IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 + IF(ITL.EQ.0) THEN + VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC + 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_MFP.EQ.0) THEN + VK(JE)=CMPLX(REAL(VK(JE))) + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDIF + IF(I_VIB.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,I_VIB) + DO LAT=0,LMAX(JAT,JE) + TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) + ENDDO + ENDDO + ENDIF +C + IF(JE.EQ.1) WRITE(36,57) + WRITE(36,59) + WRITE(36,58) ECIN + WRITE(36,59) +C +C Eigenvalue calculation by power method +C + CALL SPEC_RAD_POWER(JE,ECIN) +C + WRITE(36,59) + WRITE(36,57) +C +C End of the loop on the energy +C + ENDDO + CLOSE(36) + GOTO 7 +C + 6 WRITE(IUO1,55) +C + 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/, + &25X,' BY DEBYE UNCORRELATED MODEL:',/) + 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2') + 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('+++++++++++++++++++++++++++++++++++++++++++++++++++++++', + &'++++') + 58 FORMAT(18X,'E_KIN = ',F8.2,1X,'eV') + 59 FORMAT(20X) +C + 7 RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/interp_points.f b/src/msspec/spec/fortran/eig/pw/interp_points.f new file mode 100644 index 0000000..cce9ee5 --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/interp_points.f @@ -0,0 +1,39 @@ +C +C======================================================================= +C + SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C +C This subroutine computes the interpolation +C points used in some algorithms +C +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 ALPHA,BETA +C + DO N=0,N_APP +C + IF(I_XN.EQ.1) THEN + XN(N)=(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.2) THEN + XN(N)=BETA+DFLOAT(N) + ELSEIF(I_XN.EQ.3) THEN + XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.4) THEN + XN(N)=(BETA+DFLOAT(N))**ALPHA + ELSEIF(I_XN.EQ.5) THEN + XN(N)=((2.D0**N)/BETA)**ALPHA + ENDIF +C + ENDDO +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/levin.f b/src/msspec/spec/fortran/eig/pw/levin.f new file mode 100644 index 0000000..852fadc --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/levin.f @@ -0,0 +1,192 @@ +C +C======================================================================= +C + SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + &OMEGA) +C +C This subroutine computes Levin-type transforms of +C a given sequence SN(N,1) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1: + &N_ORD_M) + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC + COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2 +C + CHARACTER*1 OMEGA +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Recovery of the original series elements +C + DO N=N_INI,N_APP +C + AN(N)=SN(N,0)-SN(N-1,0) +C + ENDDO +C +C +C Choice of the remainder estimate omega_n +C +C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000) +C +C + IF(OMEGA.EQ.'U') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*(DFLOAT(N)+BETA) + ENDDO +C + ELSEIF(OMEGA.EQ.'V') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1)) + ENDDO +C + ELSEIF(OMEGA.EQ.'T') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N) + ENDDO +C + ELSEIF(OMEGA.EQ.'D') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N+1) + ENDDO +C + ELSEIF(OMEGA.EQ.'E') THEN +C + MAX_N=N_APP-2 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+2)/AN(N+1) + ENDDO +C + ENDIF +C +C Choice of the Levin-type transform +C +C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10) +C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10) +C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10) +C I_WN = 4 ---> C-type (eq 3-16c p 11) +C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70) +C I_WN = 6 ---> R-type (eq 7.14-12 p 47) +C +C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004) +C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989) +C +C +C Check for the possibility of L extension (the standard case is L = 0) +C + IF(L.GT.0) THEN + IF(I_WN.EQ.1) THEN + CALL COEFFICIENTS(MAX_N,COEL,BETA,2) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.2) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,3) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.3) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,4) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ENDIF + ENDIF +C + DO N=N_INI,MAX_N +C + X=BETA+DFLOAT(N) + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + XK=DFLOAT(K) + XXK=X+XK +C + IF(I_WN.EQ.1) THEN + INC=XXK/(XXK+ONEC) + COEF(N,K)=X*(INC**K)/XXK + ELSEIF(I_WN.EQ.2) THEN + COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK)) + ELSEIF(I_WN.EQ.3) THEN + COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC) + ELSEIF(I_WN.EQ.4) THEN + SUM_1=ZEROC + SUM_2=ZEROC + DO J=0,K + SUM_1=SUM_1+ALPHA*XXK + SUM_2=SUM_2+ALPHA*(XXK+ONEC) + ENDDO + COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2) + ELSEIF(I_WN.EQ.5) THEN + COEF(N,K)=ONEC + ELSEIF(I_WN.EQ.6) THEN + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) + ENDIF +C + ENDDO +C + ENDDO +C +C Computation of the recurrence relation for numerator +C and denominator +C + DO N=N_INI,MAX_N +C +C Starting values +C + NUM(N,0)=SN(N,0)/WN(N) + DEN(N,0)=ONEC/WN(N) + SN(N,0)=NUM(N,0)/DEN(N,0) +C + ENDDO +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,MAX_N-K-1 +C + IF(I_WN.NE.6) THEN + NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K) + DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K) + ELSE + NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N)) + DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N)) + ENDIF + SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/main.f b/src/msspec/spec/fortran/eig/pw/main.f new file mode 100644 index 0000000..4bdf296 --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/main.f @@ -0,0 +1,20 @@ + 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() + + END SUBROUTINE RUN diff --git a/src/msspec/spec/fortran/eig/pw/new.f.hidden b/src/msspec/spec/fortran/eig/pw/new.f.hidden new file mode 100644 index 0000000..bdd94ee --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/new.f.hidden @@ -0,0 +1,2079 @@ +C +C======================================================================= +C + SUBROUTINE EIGDIF_MI +C +C This subroutine computes the eigenvalues of the +C multiple scattering matrix to obtain its spectral radius +C +C The eigenvalue calculation is performed using the LAPACK +C eigenvalue routines for a general complex matrix (I_PWM = 0) +C or using the power method (I_PWM > 0) +C +C Last modified : 26 Apr 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP + USE DEBWAL_MOD + USE EIGEN_MOD, NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE RESEAU_MOD + USE TESTS_MOD + USE TRANS_MOD + USE VALIN_MOD, E1 => E0 +C + COMPLEX IC,ONEC + COMPLEX TLT(0:NT_M,4,NATM,NE_M) +C + DATA CONV /0.512314/ +C + IC=(0.,1.) + ONEC=(1.,0.) +C + OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN') +C +C Check file to monitor the convergence of the calculation +C + OPEN(UNIT=36, FILE='div/radius_conv.lis', STATUS='unknown') +C +C Loop over the energies +C + DO JE=1,NE + IF(NE.GT.1) THEN + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ELSEIF(NE.EQ.1) THEN + ECIN=E0 + ENDIF + CALL LPM(ECIN,XLPM,*6) + XLPM1=XLPM/A + IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 + IF(ITL.EQ.0) THEN + VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC + 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_MFP.EQ.0) THEN + VK(JE)=CMPLX(REAL(VK(JE))) + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDIF + IF(I_VIB.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,I_VIB) + DO LAT=0,LMAX(JAT,JE) + TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) + ENDDO + ENDDO + ENDIF +C + IF(JE.EQ.1) WRITE(36,57) + WRITE(36,59) + WRITE(36,58) ECIN + WRITE(36,59) +C +C Eigenvalue calculation by power method +C + CALL SPEC_RAD_POWER(JE,ECIN) +C + WRITE(36,59) + WRITE(36,57) +C +C End of the loop on the energy +C + ENDDO + CLOSE(36) + GOTO 7 +C + 6 WRITE(IUO1,55) +C + 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/, + &25X,' BY DEBYE UNCORRELATED MODEL:',/) + 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2') + 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('+++++++++++++++++++++++++++++++++++++++++++++++++++++++', + &'++++') + 58 FORMAT(18X,'E_KIN = ',F8.2,1X,'eV') + 59 FORMAT(20X) +C + 7 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE SPEC_RAD_POWER(JE,E_KIN) +C +C This subroutine computes the spectral radius of the G_o T kernel matrix +C using the power method and the Rayleigh quotient. In addition, +C a scalar convergence acceleration method can be used to refine the results. +C +C Power method approximation of the spectral radius : +C +C SR(A) = lim ||A^{n} x|| / ||A^{n-1} x|| +C n --> +infty +C for any starting vector x +C +C Rayleigh quotient approximation of the spectral radius : +C +C SR(A) = lim ||(A^{n}x)^{+} A A^{n} x| / |(A^{n}x)^{+} A^{n} x|| +C n --> +infty +C for any starting vector x +C +C Note: a shift (= SHIFT) can be introduced in the power method. +C In this case, only the Rayleigh quotient is valid +C +C !!!!! This version does not store the G_o T matrix !!!!! +C +C Author : D. Sebilleau +C +C Last modified : 1 Mar 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE TRANS_MOD +C +C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD +C + INTEGER NN(0:N_ORD_M) +C + REAL R_SN(N_ORD_M),R_SN1(N_ORD_M) +C + COMPLEX*16 TLK,SUM_L1,SUM_L2,EXPKJ,EXPJK,ONEC,MULT + COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO) + COMPLEX*16 X(LINMAX*NATCLU_M) + COMPLEX*16 AX(LINMAX*NATCLU_M),SUM_AX,XAX,XX + COMPLEX*16 HL1(0:NLTWO) + COMPLEX*16 ZEROC,IC,JC,JMULT,IFOURPI,CHIFT + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 COEF_GAUNT(LINMAX,LINMAX,0:N_GAUNT) +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ + REAL*8 ATTJK,XJK,YJK,ZJK,RJK,ZDJK,KRJK,SMALL + REAL*8 NORMX2,NORMAX2,RLIN +C + CHARACTER*10 METH + CHARACTER*24 OUTFILE,PATH +C + DATA PI,SMALL /3.1415926535898D0,1.0D-6/ +C + ONEC=(1.D0,0.D0) + IC=(0.0D0,1.0D0) + ZEROC=(0.D0,0.D0) + IFOURPI=4.D0*PI*IC + IBESS=3 + N_CALL=0 + N_ACC=0 + K_ACC=0 + I_CONV=0 +C + CHIFT=DCMPLX(SHIFT) +C + IF(N_MAX.GT.N_ORD_M) THEN + WRITE(IUO1,99) N_MAX + STOP + ENDIF +C +C Computing the size NLIN of the vectors A x +C + LMAXJ=0 + NLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + LMAXJ=MAX(LMAXJ,LMJ) + DO JNUM=1,NBTYPJ + DO LJ=0,LMJ + DO MJ=-LJ,LJ + NLIN=NLIN+1 + ENDDO + ENDDO + ENDDO + ENDDO +C +C Storage of the modified Gaunt coefficients +C + LIN1=0 + DO L1=0,LMAXJ + DO M1=-L1,L1 + LIN1=LIN1+1 + LIN2=0 + DO L2=0,LMAXJ + L_MIN=ABS(L2-L1) + L_MAX=L1+L2 + DO M2=-L2,L2 + LIN2=LIN2+1 + CALL GAUNT2(L1,M1,L2,M2,GNT) + DO L=L_MIN,L_MAX,2 + M=M1-M2 + COEF_GAUNT(LIN1,LIN2,L)=IFOURPI*GNT(L)*(IC** + & L) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +C +C Starting vector for power method: +C +C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO +C + JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0) + JMULT=JC**EXPO +C + WRITE(IUO1,6) +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(36,76) + ELSE + WRITE(36,79) + ENDIF + WRITE(36,75) +C +C Initialization the vectors and their squared norm +C + MULT=JMULT +C + AX(1)=ONEC +C + NORMAX2=1.D0 +C + DO JLIN=2,NLIN +C + AX(JLIN)=AX(JLIN-1)*MULT + NORMAX2=NORMAX2+CDABS(AX(JLIN))*CDABS(AX(JLIN)) +C + ENDDO +C +C Computation of the vectors and their squared norm +C +C X ---> A*X +C + 120 IF(N_CALL.EQ.0) THEN + J_INI=1 + ELSE + J_INI=N_CALL*N_ITER+1 + ENDIF + J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX) +C + IF(J_INI.GT.J_FIN) GOTO 112 +C + DO JORD=J_INI,J_FIN +C + NORMX2=NORMAX2 +C + XX=ZEROC + DO JLIN=1,NLIN +C + X(JLIN)=AX(JLIN) + XX=XX+CONJG(X(JLIN))*X(JLIN) +C + ENDDO +C + NORMAX2=0.D0 + XAX=ZEROC +C +C +C Construction of the the multiple scattering kernel matrix G_o T +C times the vector x +C +C Linear indices JLIN and KLIN represent (J,LJ) and (K,LK) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + LINJ=0 + DO LJ=0,LMJ + DO MJ=-LJ,LJ + JLIN=JLIN+1 + LINJ=LINJ+1 +C + SUM_AX=ZEROC +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + XK=SYM_AT(1,KATL) + YK=SYM_AT(2,KATL) + ZK=SYM_AT(3,KATL) +C + IF(KATL.NE.JATL) THEN +C + XKJ=DBLE(XK-XJ) + YKJ=DBLE(YK-YJ) + ZKJ=DBLE(ZK-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))* + & RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM, + & LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ, + & HL1) +C + ENDIF +C + LINK=0 + DO LK=0,LMK + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=ATTKJ*DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + KLIN=KLIN+1 + LINK=LINK+1 + IF(KATL.NE.JATL) THEN +C + SUM_L1=ZEROC + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L1=SUM_L1+HL1(L)* + & COEF_GAUNT(LINJ,LINK,L)*YLM(L,M) + ENDIF + ENDDO + SUM_AX=SUM_AX+TLK*SUM_L1*X( + & KLIN) +C + ENDIF + IF(KLIN.EQ.JLIN) SUM_AX=SUM_AX- + & CHIFT*X(KLIN) +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + AX(JLIN)=SUM_AX + NORMAX2=NORMAX2+CDABS(SUM_AX)*CDABS(SUM_AX) + XAX=XAX+CONJG(X(JLIN))*SUM_AX +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C +C R_SN : power method +C R_SN1: Rayleigh quotient +C + R_SN(JORD)=SQRT(REAL(NORMAX2/NORMX2)) + R_SN1(JORD)=CDABS((XAX/XX)+SHIFT) +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(36,77) JORD,R_SN(JORD),R_SN1(JORD) + ELSE + WRITE(36,77) JORD,R_SN1(JORD) + ENDIF +C +C Check of convergence of power method series and +C Rayleigh quotient method +C +C Note: only Rayleigh quotient valid if shift +C + IF((I_PWM.EQ.2).AND.(ABS(SHIFT).LE.SMALL)) THEN + IF(JORD.GT.N_TABLE) THEN + CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN,*555) + ENDIF + ENDIF +C + IF((ABS(SHIFT).GT.SMALL).AND.(I_PWM.GT.0)) I_PWM=-I_PWM + IF(I_PWM.EQ.-2) THEN + IF(JORD.GT.N_TABLE) THEN + CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN1,*555) + ENDIF + ENDIF +C + ENDDO +C + 555 IF(J_INI.EQ.1) THEN + WRITE(IUO1,10) + WRITE(IUO1,11) SHIFT + WRITE(IUO1,46) NLIN + WRITE(IUO1,10) + WRITE(IUO1,61) + ENDIF +C + WRITE(IUO1,10) + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(IUO1,44) R_SN(JORD-1) + ENDIF + WRITE(IUO1,53) R_SN1(JORD-1) + WRITE(IUO1,47) JORD-1 + WRITE(IUO1,10) + IF(J_FIN.EQ.N_MAX) THEN + IF((I_PWM.EQ.1).OR.(I_PWM.EQ.3)) THEN + WRITE(IUO1,213) + ELSE + WRITE(IUO1,60) + ENDIF + ENDIF +C + IF(((I_ACC.EQ.1).OR.(I_ACC.EQ.2)).AND.(ABS(SHIFT).LE.SMALL)) THEN +C +C Convergence acceleration on the power method results whenever necessary +C + CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + & R_SN,SN,METH) + IF(I_ACC.EQ.1) GOTO 111 + IF((I_CONV.EQ.1).AND.(I_ACC.EQ.2)) GOTO 111 + IF((I_CONV.EQ.0).AND.(I_ACC.EQ.2)) THEN + IF(J_FIN.EQ.N_MAX) THEN + GOTO 111 + ELSE + GOTO 120 + ENDIF + ENDIF +C + 111 WRITE(IUO1,10) + WRITE(IUO1,61) + WRITE(IUO1,10) + WRITE(IUO1,52) METH + WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC)) + WRITE(IUO1,49) N_ACC + WRITE(IUO1,51) K_ACC +C + IF(I_ACC.EQ.2) THEN + OPEN(UNIT=35, FILE='div/n_k_table_pm.lis', STATUS= + & 'unknown') + K_MAX=MIN(K_MAX,J_FIN) + DO L=0,K_MAX + NN(L)=L + ENDDO + WRITE(35,*) ' ' + WRITE(35,78) E_KIN,METH + WRITE(35,*) ' ' + WRITE(35,198) (NN(K),K=0,K_MAX) + WRITE(35,199) + WRITE(35,*) ' ' + DO N=0,K_MAX + WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N) + WRITE(35,*) ' ' + ENDDO + ENDIF +C + WRITE(IUO1,10) + IF(I_ACC.GE.1) WRITE(IUO1,60) + IF(I_ACC.EQ.2) THEN + IF(I_CONV.EQ.0) WRITE(IUO1,212) + WRITE(IUO1,210) + ENDIF +C + ENDIF +C + IF((ABS(SHIFT).GT.SMALL).AND.(I_ACC.GT.0)) I_ACC=-I_ACC + IF((I_ACC.EQ.-1).OR.(I_ACC.EQ.-2))THEN +C +C Convergence acceleration on the Rayleigh quotient whenever necessary +C + CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + & R_SN1,SN,METH) + IF(I_ACC.EQ.-1) GOTO 999 + IF((I_CONV.EQ.1).AND.(I_ACC.EQ.-2)) GOTO 999 + IF((I_CONV.EQ.0).AND.(I_ACC.EQ.-2)) THEN + IF(J_FIN.EQ.N_MAX) THEN + GOTO 999 + ELSE + GOTO 120 + ENDIF + ENDIF +C + 999 WRITE(IUO1,10) + WRITE(IUO1,61) + WRITE(IUO1,10) + WRITE(IUO1,52) METH + WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC)) + WRITE(IUO1,49) N_ACC + WRITE(IUO1,51) K_ACC +C + IF(I_ACC.EQ.-2) THEN + OPEN(UNIT=35, FILE='div/n_k_table_rq.lis', STATUS= + & 'unknown') + K_MAX=MIN(K_MAX,J_FIN) + DO L=0,K_MAX + NN(L)=L + ENDDO + WRITE(35,*) ' ' + WRITE(35,78) E_KIN,METH + WRITE(35,*) ' ' + WRITE(35,198) (NN(K),K=0,K_MAX) + WRITE(35,199) + WRITE(35,*) ' ' + DO N=0,K_MAX + WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N) + WRITE(35,*) ' ' + ENDDO + ENDIF +C + WRITE(IUO1,10) + IF(ABS(I_ACC).GE.1) WRITE(IUO1,60) + IF(I_ACC.EQ.-2) THEN + IF(I_CONV.EQ.0) WRITE(IUO1,215) + WRITE(IUO1,214) + ENDIF +C + ENDIF +C +C Writing the results: +C + IF(ABS(I_ACC).LT.2) THEN +C +C No convergence acceleration: power method and Rayleigh quotient +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1) + ELSE + WRITE(IUO2,*) E_KIN,R_SN1(JORD-1) + ENDIF +C + ELSE +C + IF(I_CONV.EQ.1) THEN +C +C Convergence acceleration has succeeded: +C + WRITE(IUO2,*) E_KIN,REAL(CDABS(SN(N_ACC,K_ACC))) +C + ELSEIF(I_CONV.EQ.0) THEN +C +C Convergence acceleration has failed: power method and +C Rayleigh quotient used instead +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1) + ELSE + WRITE(IUO2,*) E_KIN,R_SN1(JORD-1) + ENDIF +C + ENDIF + ENDIF +C + 112 WRITE(IUO1,211) +C + RETURN +C + 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','--------- + &--------') + 6 FORMAT(/,11X,'----------- SHIFTED POWER METHOD ANALYSIS ',' ---- + &--------') + 10 FORMAT(11X,'-',54X,'-') + 11 FORMAT(11X,'-',4X,'SHIFT ',20X,': ',F6.3,3X,'-') + 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-') + 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-') + 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-') + 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X, + &'-') + 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-') + 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-') + 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5, + &3X,'-') + 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5, + &3X,'-') + 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8, + &3X,'-') + 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8, + &3X,'-') + 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5, + &3X,'-') + 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8, + &3X,'-') + 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ', + &'CONVERGES ',4X,'-') + 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8, + &3X,'-') + 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10, + &1X,'-') + 53 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY RAYLEIGH QUOTIENT : ',F8.5, + &3X,'-') + 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/ + &,11X,'-',18X,'SCATTERING SERIES',19X,'-') + 60 FORMAT(11X,'----------------------------------------','---------- + &------',/) + 61 FORMAT(11X,'----------------------------------------','---------- + &------') + 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X, + &'-') + 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6. + &3,')',8X,'-') + 75 FORMAT(' ') + 76 FORMAT(2X,'ITERATION: SPECTRAL RADIUS:',' RAYLEIGH + "IENT:') + 77 FORMAT(2X,I6,15X,F6.3,15X,F6.3) + 78 FORMAT(10X,' E_KIN = ',F6.2,' eV -- (N,K) TABLE OF ',A10,' + &METHOD') + 79 FORMAT(2X,'ITERATION: RAYLEIGH QUOTIENT:') + 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV') + 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3) + 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5) + 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,') + &') + 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE',' + &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ', + &I5, 6X,' >>>>>>>>>>',///) + 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3) + 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :') + 110 FORMAT(2X,'-------------------------------') + 198 FORMAT(' K',50(I3,4X)) + 199 FORMAT(' N') + 200 FORMAT(I3,50(2X,F5.3)) + 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/ + &n_k_table_pm.lis',//) + 211 FORMAT(//,' ---> THE EVOLUTION OF THE SPECTRAL RADIUS ','HAS + &BEEN WRITTEN IN /div/radius_conv.lis',//) + 212 FORMAT(//,10X,' !!!!! THE POWER METHOD HAS NOT CONVERGED YET + &','!!!!!') + 213 FORMAT(11X,'------------ NO CONVERGENCE CHECK WAS MADE ','------ + &------') + 214 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/ + &n_k_table_rq.lis',//) + 215 FORMAT(//,8X,' !!!!! THE RAYLEIGH QUOTIENT HAS NOT CONVERGED', + &' YET !!!!!') +C + END +C +C======================================================================= +C + SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + &R_SN,SN,METH) +C +C Use of the various acceleration scheme on a scalar series +C +C AITK : Aitken, modified Aitken +C RICH : Richardson +C SALZ : Salzer +C EPSI : epsilon +C EPSG : generalized epsilon +C RHOA : rho +C THET : theta +C LEGE : Legendre-Toeplitz +C CHEB : Chebyshev-Toeplitz +C OVER : Overholt +C DURB : Durbin +C DLEV : Levin d-transform !! differ by the +C TLEV : Levin t-transform !! choice of w_n +C ULEV : Levin u-transform !! the remainder +C VLEV : Levin v-transform !! estimate given +C ELEV : Levin e-transform !! by I_WN +C EULE : generalized Euler transform +C GBWT : Germain-Bronne-Wimp transform +C VARI : various algorithms : Weniger, BDG, iterated rho +C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2 +C EALG : E-algorithm +C +C SN : series to be accelerated +C XN : auxilliary series (chosen with I_XN) : interpolation points +C GN : auxilliary series (chosen with I_GN) ---> E algorithm +C +C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1) +C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K) +C so N_DIV=2 +C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are +C meaningful. Hence the K_MAX size +C +C COL_M : type of columns meaningful in the (n,k) table (example: even columns +C for the epsilon algorithm) +C +C +C Author : D. Sebilleau +C +C Last modified : 1 Mar 2013 +C +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVACC_MOD, L => LEVIN + USE CONVTYP_MOD +C + PARAMETER (N_METH=24) +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + COMPLEX*16 ZEROC,ONEC +C + REAL*8 R2_SN(N_ORD_M),RHO +C + REAL R_SN(N_ORD_M) +C + INTEGER N_DIV(N_METH) +C + CHARACTER*3 COL_M(N_METH) + CHARACTER*4 SCHE(N_METH) + CHARACTER*10 NAME(N_METH),METH +C + DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE', + 1 'CHEB','OVER','DURB','DLEV','TLEV','ULEV', + 2 'VLEV','ELEV','EULE','GBWT','EALG','SALZ', + 3 'VARI','ITHE','EPSG','NONE','NONE','NONE'/ + DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ', + 1 ' RHO ',' THETA ',' LEGENDRE ', + 2 'CHEBYSHEV ',' OVERHOLT ',' DURBIN ', + 3 ' D LEVIN ',' T LEVIN ',' U LEVIN ', + 4 ' V LEVIN ',' E LEVIN ',' EULER ', + 5 ' GBW ',' E ',' SALZER ', + 6 ' VARIA ','ITER THETA',' EPSILON G', + 7 ' ',' ',' '/ + DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL', + 1 'ALL','ALL','ALL','ALL','ALL','ALL', + 2 'ALL','ALL','ALL','ALL','ALL','ALL', + 3 'ALL','ALL','EVE','ALL','ALL','ALL'/ + DATA N_DIV /2,1,1,2,2,1, + 1 1,1,4,1,1,1, + 2 1,1,1,1,1,1, + 3 2,4,1,1,1,1/ +C + J_NAME=0 + I_COL=0 +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + DO J=J_INI,J_FIN + R2_SN(J)=DBLE(R_SN(J)) + ENDDO +C +C Finding the name of the method +C + DO JM=1,N_METH +C + IF(METHOD.EQ.SCHE(JM)) THEN + J_NAME=JM + K_MAX=N_MAX/N_DIV(JM) + N_COEF=N_DIV(JM) + IF(COL_M(JM).EQ.'EVE') I_COL=2 + ENDIF +C + ENDDO +C +C Initialization of array SN +C + DO N=J_INI,J_FIN +C + DO K=-1,J_FIN +C + SN(N,K)=ZEROC +C + ENDDO +C + ENDDO +C +C Initialisation of the schemes : +C +C -- SN(N,0) is the series to be accelerated -- +C + SN(0,-1)=ZEROC + SN(0,0)=ONEC +C + DO N=J_INI,J_FIN +C + SN(N,-1)=ZEROC + SN(N,0)=R2_SN(N) +C + ENDDO +C + CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C Check for convergence : all results equal within ACC +C in a N_TABLE x N_TABLE square +C + IF(I_CONV.EQ.0) THEN + CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX, + & N_COEF,I_COL,ACC,RHO,SN) + ENDIF +C + IF(METHOD(2:4).EQ.'LEV') THEN + METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN) + ELSE + METH=NAME(J_NAME) + ENDIF +C +C Incrementation of the number of calls to this subroutine +C if convergence has not been achieved +C + IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN + N_CALL=N_CALL+1 + ELSE + GOTO 10 + ENDIF +C +C Printing the results in the check file +C + 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',5X,'*') + 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*') + 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*') + 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6, + &',',E12.6,')',5X,'*') + 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*') + 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <--- + &convergence',2X,'*') + 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',', + &E12.6,')',3X,' * <--- convergence') + 35 FORMAT(2X,'***************************************','************ + &************************') + 45 FORMAT(2X,'* ',' + & *') + 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,') + & *') + 75 FORMAT(2X,'* Order Taylor ',20X,A10,' + & *') + 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'* + & order ',60X,'*') + 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ', + &'>>>>>>>>>>',//) +C + 10 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN) +C +C This subroutine computes the scalar convergence acceleration +C for various methods +C +C Note: let us consider that the (n,k) space pattern indicates +C that we need S(n,k),...,S(n+p,k) in order to compute +C S(n,k+1). We call N the maximum value of n for which +C the S(n,0) are known. Then, to compute S(n,k+1), we +C we need to know up to S(n+pk+p,0). This means that +C the value of n is limited to N-pk-p. +C +C Author : D. Sebilleau +C +C Last modified : 14 Mar 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD + USE CONVACC_MOD, L => LEVIN +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5 + COMPLEX*16 NUM,DEN,FIR + COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK +C + REAL*8 EPS,EPSS,MUL +C + CHARACTER*4 METHOD +C + DATA EPS,EPSS /1.D-12,1.D-150/ +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C + N_APP=J_FIN + N_INI=0 +C + IF(METHOD.EQ.'AITK') THEN +C +C The iterated Aitken and modified Aitken schemes +C +C H. H. H. Homeier, Num. Alg. 8, 47 (1994) +C +C I_VA = 1 : iterated Aitken (p 49 eq 5) +C I_VA = 2 : modified iterated Aitken (p 49 eq 9) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + IF(I_VA.EQ.1) THEN + XK=ONEC + ELSEIF(I_VA.EQ.2) THEN + XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1) + ENDIF +C + DO N=N_INI,N_APP-2*K-2 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + DELTA2=(SN(N+2,K)-SN(N+1,K)) + IF(CDABS(DELTA2).LT.EPSS) THEN + DELTA3=ZEROC + ELSE + DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1) + ENDIF + SN(N,K+1)=SN(N,K)-XK*DELTA3 + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RICH') THEN +C +C The Richardson scheme +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=SN(N+1,0)-SN(N,0) + DELTA2=SN(N+K+2,0)-SN(N+K+1,0) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 10 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'SALZ') THEN +C +C The Salzer scheme +C +C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=DFLOAT(N+K+2) + DELTA2=DFLOAT(N+1) + IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11 + SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 11 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'GBWT') THEN +C +C The GBW scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C (eq 6.1-5 p33) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=XN(N) + DELTA2=XN(N+K+1) + IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 80 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSI') THEN +C +C The epsilon scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1) +C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + DELTA1=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 20 + IF(I_VA.EQ.1) THEN + VAR=ONEC + ELSEIF(I_VA.EQ.2) THEN + VAR=XN(N+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + VAR=XN(N+K+1)-XN(N+K) + ENDIF + SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1 + N_COUNT=N_COUNT+1 +C + 20 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EPSG') THEN +C +C The generalized epsilon scheme +C +C M. N. Barber and C. J. Hamer, +C J. Austral. Math. Soc. (Series B) 23, 229 (1982) +C +C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed) +C DELTA2 = 0 implies SN(N+1,K) = SN(N,K) +C ---> convergence achieved for (N,K) +C + N_COUNT=0 +C + DO K=0,N_APP,2 +C + IF(I_VA.EQ.1) THEN + SI(K)=ALPHA + SI(K+1)=ALPHA + ELSEIF(I_VA.EQ.2) THEN + SI(K)=ZEROC + SI(K+1)=-ONEC + ENDIF +C + ENDDO +C + VAR=ONEC +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + NK(N,-1)=ZEROC + DELTA2=(SN(N+1,K)-SN(N,K)) + IF(CDABS(DELTA2).LT.EPSS) GOTO 23 + NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2 + DELTA1=(NK(N,K)-NK(N-1,K)) + IF(CDABS(DELTA1).LT.EPSS) GOTO 23 + SN(N,K+1)=SN(N,K)+VAR/DELTA1 + N_COUNT=N_COUNT+1 + 23 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'RHOA') THEN +C +C The rho scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1) +C I_VA = 2 : Standard rho (p 34 eq 6.2-2) +C I_VA = 3 : (p 37 eq 6.3-3) ??????? +C +C ALPHA is the decay parameter. It is +C generally advised to take it as +C an integer to ensure convergence +C + IF(DREAL(ALPHA).LT.0.0D0) THEN +C +C Drummond approximation to alpha : +C +C (non valid for the Taylor expansion +C of 1/1+x as in this case the denominator +C is always zero) +C + DO N=N_INI,N_APP +C + DELTA1=SN(N+3,1)-SN(N+2,1) + DELTA2=SN(N+2,1)-SN(N+1,1) + DELTA3=SN(N+1,1)-SN(N,1) +C + NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2) + DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1 + ALPHA=NUM/DEN-ONEC +C + ENDDO +C + ENDIF +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + IF(I_VA.NE.3) THEN + DEN=(SN(N+1,K)-SN(N,K)) + ELSE + DELTA2=(SN(N+2,K)-SN(N+1,K)) + DELTA3=(SN(N+1,K)-SN(N,K)) + DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)- + & XN(N))*DELTA2 + ENDIF +C + IF(CDABS(DEN).LT.EPS) GOTO 30 + IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30 +C + IF(I_VA.EQ.1) THEN + NUM=(DFLOAT(K+1)+ALPHA) + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+K+1)-XN(N) + ELSEIF(I_VA.EQ.3) THEN + NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3 + ENDIF +C + SN(N,K+1)=SN(N+1,K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 30 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'THET') THEN +C +C The theta scheme +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C E. Calicetti et al, Phys. Rep. 446, 1 (2007) +C +C I_VA = 1 : standard formulation (eq 71 p 19) +C I_VA = 2 : generalized formulation (eq 10.1-10 p 74) +C + KMAX2=(N_APP-2)/2 +C + N_COUNT=0 + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,KMAX2 +C + IF(I_VA.EQ.3) GOTO 51 +C + DO N=N_INI,N_APP-2*K-1 +C + DEN=SN(N+1,2*K)-SN(N,2*K) + IF(CDABS(DEN).LT.EPSS) GOTO 40 + IF(I_VA.EQ.1) THEN + NUM=1.D0 + ELSEIF(I_VA.EQ.2) THEN + NUM=XN(N+2*K+1)-XN(N) + ENDIF + SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN + N_COUNT=N_COUNT+1 +C + 40 CONTINUE +C + ENDDO +C + DO N=N_INI,N_APP-4*K-2 +C + DELTA2=SN(N+2,2*K)-SN(N+1,2*K) + DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1) + DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1) +C + IF(I_VA.EQ.1) THEN + NUM=DELTA2*DELTA4 + DEN=DELTA4-DELTA3 + ELSEIF(I_VA.EQ.2) THEN + NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4 + DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN( + & N))*DELTA4 + ENDIF + IF(CDABS(DEN).LT.EPSS) GOTO 50 +C + SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 50 CONTINUE +C + ENDDO + GOTO 52 +C + 51 DO N=N_INI,N_APP-4*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + DELTA4=DELTA3-DELTA2 + DELTA5=DELTA2-DELTA1 + DEN=DELTA3*DELTA5-DELTA1*DELTA4 + IF(CDABS(DEN).LT.EPSS) GOTO 53 +C + NUM=DELTA1*DELTA2*DELTA4 + SN(N,K+1)=SN(N+1,K)-NUM/DEN +C + N_COUNT=N_COUNT+1 +C + 53 CONTINUE +C + ENDDO +C + 52 CONTINUE +C + ENDDO +C + ELSEIF(METHOD.EQ.'LEGE') THEN +C +C The Legendre-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.3), (4.4) p. 231 +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1) + DELTA2=DFLOAT(K)/DFLOAT(K+1) +C + DO N=N_INI,N_APP-K-1 + SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN( + & N,K-1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'CHEB') THEN +C +C The Chebyshev-Toeplitz scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C eq. (4.4) - (4.9) p. 231 +C + SI(0)=ONEC + SI(1)=3.D0*ONEC +C + DO N=N_INI,N_APP-1 +C + TN(N,0)=SN(N,0) + TN(N,1)=SN(N,0)+2.D0*TN(N+1,0) + SN(N,0)=TN(N,0)/SI(0) + SN(N,1)=TN(N,1)/SI(1) +C + ENDDO +C + N_COUNT=0 +C + DO K=1,N_APP-1 +C + SI(K+1)=6.D0*SI(K)-SI(K-1) +C + DO N=N_INI,N_APP-K-1 +C + TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1) + SN(N,K+1)=TN(N,K+1)/SI(K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'OVER') THEN +C +C The Overholt scheme +C +C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996) +C (eq 36 p 85) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-2 +C + DELTA1=ONEC + DELTA2=ONEC + MUL=1.D0 +C + DO I=1,K+1 +C + DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0)) + DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0)) + MUL=MUL*EPS +C + ENDDO +C + IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60 +C + SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1- + & DELTA2) + N_COUNT=N_COUNT+1 +C + 60 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'DURB') THEN +C +C The Durbin scheme +C +C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007) +C (eq 25 p 185) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-4*K-4 +C + DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+ + & 3,K)+SN(N,K)*SN(N+4,K) + DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN( + & N,K)+SN(N+4,K) + IF(CDABS(DELTA2).LT.EPSS) GOTO 70 + SN(N,K+1)=DELTA1/DELTA2 + N_COUNT=N_COUNT+1 +C + 70 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD(2:4).EQ.'LEV') THEN +C +C The Levin schemes +C + CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + & METHOD(1:1)) +C + ELSEIF(METHOD.EQ.'EULE') THEN +C +C The generalized Euler scheme +C +C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-K-1 +C + SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'VARI') THEN +C +C Various schemes +C +C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1) +C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2) +C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3) +C I_VA = 4 : iterated rho scheme +C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-2*K-2 +C + IF(I_VA.EQ.1) THEN + A=BETA+DFLOAT(N) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.2) THEN + A=ALPHA+DFLOAT(N+K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.3) THEN + A=ALPHA+DFLOAT(N-K) + B=A+ONEC + C=A + ELSEIF(I_VA.EQ.4) THEN + A=XN(N+2*K+2)-XN(N) + B=XN(N+2*K+1)-XN(N) + C=XN(N+2*K+2)-XN(N+1) + ELSEIF(I_VA.EQ.5) THEN + A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA) + B=ONEC + C=ONEC + ENDIF +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DEN=B*DELTA2-C*DELTA1 + IF(CDABS(DEN).LT.EPSS) GOTO 81 + SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN + N_COUNT=N_COUNT+1 +C + 81 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'ITHE') THEN +C +C Iterated theta schemes +C +C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6) +C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5) +C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12) +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,N_APP-3*K-3 +C + DELTA1=SN(N+1,K)-SN(N,K) + DELTA2=SN(N+2,K)-SN(N+1,K) + DELTA3=SN(N+3,K)-SN(N+2,K) + IF(I_VA.EQ.1) THEN + NUM=-DELTA1*DELTA2*(DELTA3-DELTA2) + DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.2) THEN + NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2) + DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*( + & DELTA2-DELTA1) + FIR=SN(N+1,K) + ELSEIF(I_VA.EQ.3) THEN + NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2) + DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*( + & DELTA2-DELTA1) + FIR=SN(N+2,K) + ENDIF +C + IF(CDABS(DEN).LT.EPSS) GOTO 90 + SN(N,K+1)=FIR+NUM/DEN + N_COUNT=N_COUNT+1 +C + 90 CONTINUE +C + ENDDO +C + ENDDO +C + ELSEIF(METHOD.EQ.'EALG') THEN +C +C E algorithm +C + N_COUNT=0 +C + CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN) + CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C Computing the GN(N,K,I) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 91 + DELTA1=GN(N,K-1,K)/DEN +C + DO I=0,N_APP +C + NUM=GN(N+1,K-1,I)-GN(N,K-1,I) + GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1 +C + ENDDO +C + 91 CONTINUE +C + ENDDO +C + ENDDO +C +C Computing SN(N,K) +C + DO K=1,N_APP +C + DO N=N_INI,N_APP-K +C + DEN=GN(N+1,K-1,K)-GN(N,K-1,K) + IF(CDABS(DEN).LT.EPSS) GOTO 92 + DELTA1=GN(N,K-1,K)/DEN + SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1 +C + 92 CONTINUE +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH) +C +C Binomial coefficients ---> ISWITCH = 1 +C Power coefficients ---> ISWITCH = 2 +C Pochhammer coefficients ---> ISWITCH = 3 +C Pochhammer coefficients ---> ISWITCH = 4 (negative argument) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Sep 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC +C + ONEC=(1.D0,0.D0) +C + COEF(0,0)=ONEC + COEF(1,0)=ONEC + COEF(1,1)=ONEC +C + IF(I_SWITCH.EQ.1) THEN +C + DO N=2,N_APP-1 +C + COEF(N,0)=ONEC + COEF(N,1)=DCMPLX(N) +C + DO K=2,N +C + COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.2) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC + COEF(N,1)=BETA+DFLOAT(N) +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.3) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ELSEIF(I_SWITCH.EQ.4) THEN +C + DO N=0,N_APP +C + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1)) +C + ENDDO +C + ENDDO +C + ENDIF +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT, + &OMEGA) +C +C This subroutine computes Levin-type transforms of +C a given sequence SN(N,1) +C +C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1: + &N_ORD_M) + COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC + COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2 +C + CHARACTER*1 OMEGA +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Recovery of the original series elements +C + DO N=N_INI,N_APP +C + AN(N)=SN(N,0)-SN(N-1,0) +C + ENDDO +C +C +C Choice of the remainder estimate omega_n +C +C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000) +C +C + IF(OMEGA.EQ.'U') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*(DFLOAT(N)+BETA) + ENDDO +C + ELSEIF(OMEGA.EQ.'V') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1)) + ENDDO +C + ELSEIF(OMEGA.EQ.'T') THEN +C + MAX_N=N_APP +C + DO N=N_INI,MAX_N + WN(N)=AN(N) + ENDDO +C + ELSEIF(OMEGA.EQ.'D') THEN +C + MAX_N=N_APP-1 +C + DO N=N_INI,MAX_N + WN(N)=AN(N+1) + ENDDO +C + ELSEIF(OMEGA.EQ.'E') THEN +C + MAX_N=N_APP-2 +C + DO N=N_INI,MAX_N + WN(N)=AN(N)*AN(N+2)/AN(N+1) + ENDDO +C + ENDIF +C +C Choice of the Levin-type transform +C +C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10) +C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10) +C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10) +C I_WN = 4 ---> C-type (eq 3-16c p 11) +C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70) +C I_WN = 6 ---> R-type (eq 7.14-12 p 47) +C +C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004) +C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989) +C +C +C Check for the possibility of L extension (the standard case is L = 0) +C + IF(L.GT.0) THEN + IF(I_WN.EQ.1) THEN + CALL COEFFICIENTS(MAX_N,COEL,BETA,2) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.2) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,3) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ELSEIF(I_WN.EQ.3) THEN + CALL COEFFICIENTS(N_APP,COEL,BETA,4) + DO N=N_INI,MAX_N + WN(N)=WN(N)*COEL(N,L) + ENDDO + ENDIF + ENDIF +C + DO N=N_INI,MAX_N +C + X=BETA+DFLOAT(N) + COEF(N,0)=ONEC +C + DO K=1,N_APP +C + XK=DFLOAT(K) + XXK=X+XK +C + IF(I_WN.EQ.1) THEN + INC=XXK/(XXK+ONEC) + COEF(N,K)=X*(INC**K)/XXK + ELSEIF(I_WN.EQ.2) THEN + COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK)) + ELSEIF(I_WN.EQ.3) THEN + COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC) + ELSEIF(I_WN.EQ.4) THEN + SUM_1=ZEROC + SUM_2=ZEROC + DO J=0,K + SUM_1=SUM_1+ALPHA*XXK + SUM_2=SUM_2+ALPHA*(XXK+ONEC) + ENDDO + COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2) + ELSEIF(I_WN.EQ.5) THEN + COEF(N,K)=ONEC + ELSEIF(I_WN.EQ.6) THEN + CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) + ENDIF +C + ENDDO +C + ENDDO +C +C Computation of the recurrence relation for numerator +C and denominator +C + DO N=N_INI,MAX_N +C +C Starting values +C + NUM(N,0)=SN(N,0)/WN(N) + DEN(N,0)=ONEC/WN(N) + SN(N,0)=NUM(N,0)/DEN(N,0) +C + ENDDO +C + N_COUNT=0 +C + DO K=0,N_APP-1 +C + DO N=N_INI,MAX_N-K-1 +C + IF(I_WN.NE.6) THEN + NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K) + DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K) + ELSE + NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N)) + DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N)) + ENDIF + SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1) + N_COUNT=N_COUNT+1 +C + ENDDO +C + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN) +C +C This subroutine computes the interpolation +C points used in some algorithms +C +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 ALPHA,BETA +C + DO N=0,N_APP +C + IF(I_XN.EQ.1) THEN + XN(N)=(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.2) THEN + XN(N)=BETA+DFLOAT(N) + ELSEIF(I_XN.EQ.3) THEN + XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0)) + ELSEIF(I_XN.EQ.4) THEN + XN(N)=(BETA+DFLOAT(N))**ALPHA + ELSEIF(I_XN.EQ.5) THEN + XN(N)=((2.D0**N)/BETA)**ALPHA + ENDIF +C + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C This subroutine computes the G_N series used to describe +C the correction on the remainder estimate +C +C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n} +C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation) +C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.) +C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n} +C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n} +C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne) +C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Computing binomial coefficients +C + IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1) +C + DO N=0,N_APP +C + GN(N,0,-1)=ZEROC + GN(N,0,0)=ONEC + MONE=-ONEC +C + DO I=1,N_APP +C + IF(I_GN.EQ.1) THEN + GN(N,0,I)=GN(N,0,I-1)*XN(N) + ELSEIF(I_GN.EQ.2) THEN + GN(N,0,I)=XN(N+I-1) + ELSEIF(I_GN.EQ.3) THEN + GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0) + ELSEIF(I_GN.EQ.4) THEN + GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N) + ELSEIF(I_GN.EQ.5) THEN + GN(N,0,I)=GN(N,0,I-1)/XN(N) + ELSEIF(I_GN.EQ.6) THEN + MONE=-MONE + SUM_J=ZEROC + ONE=-ONEC + DO J=0,I + ONE=-ONE + SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0) + ENDDO + GN(N,0,I)=MONE*SUM_J + ELSEIF(I_GN.EQ.7) THEN + IF(I.GT.1) THEN + GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0) + ELSE + GN(N,0,I)=SN(N,0) + ENDIF + ENDIF +C + ENDDO +C + ENDDO +C + RETURN +C + END +C +C======================================================================= +C + SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC, + &K_MAX,N_COEF,I_COL,ACC,RHO,SN) +C +C This subroutine checks the convergence of the acceleration process. +C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table +C of SN(n,k)that contains equal values (SMALL being the accepted error) +C +C This way, both the column convergence (k fixed and n increasing) +C and the diagonal convergence (n=k increasing) are considered +C +C Important note: in some algorithms, such as the epsilon one, only +C odd columns are meaningful. If I_COL = 0, all +C columns are taken into account while for I_COL = 2 +C only even columns are considered +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2011 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) +C + REAL*8 ACC,REF,COMP,RHO +C +C Step for the columns comparison and change of the size +C of the square when only even columns should be considered +C + IF(I_COL.EQ.0) THEN + I_STEP=1 + N_SQUARE=N_TABLE + N_START=N_TABLE + ELSEIF(I_COL.EQ.2) THEN + I_STEP=2 + N_SQUARE=N_TABLE+N_TABLE-1 + IF(MOD(N_SQUARE,2).EQ.0) THEN + N_START=N_SQUARE + ELSE + N_START=N_SQUARE+1 + ENDIF + ENDIF +C +C Positionning the bottom right corner of the square: (N,K), +C starting from (N_START,N_START). If only even columns +C should be considered, N_START must be even +C + K_FIN=J_FIN/N_COEF + IF(K_FIN.LT.N_START) THEN + I_CONV=0 + GOTO 10 + ENDIF +C + DO K=N_START,K_FIN+N_START-1,I_STEP + IF(K.GT.K_MAX) GOTO 20 + DO N=N_START,K_FIN-K,I_STEP +C +C Checking the values (N1,K1) in the selected square +C + REF=CDABS(SN(N,K)) + I_CONV=1 +C + DO N1=0,N_START,I_STEP + NN=N-N1 + DO K1=0,N_START,I_STEP +C + KK=K-K1 + COMP=CDABS(REF-SN(NN,KK)) + IF(COMP.GT.ACC) THEN + I_CONV=0 + ENDIF +C + ENDDO + ENDDO +C + IF(I_CONV.EQ.1) THEN +C +C All values in the square are equal (within ACC): +C Spectral radius taken as the left top corner value +C + N_ACC=N-N_START+I_STEP + K_ACC=K-N_START+I_STEP + RHO=REF + GOTO 10 + ENDIF +C + ENDDO + 20 CONTINUE + ENDDO +C + 10 RETURN +C + END +C +C======================================================================= +C + SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*) +C +C This subroutine checks the convergence of the power method or of +C the Rayleigh quotient method at level JORD without convergence +C acceleration. For convergence, there must be N_TABLE equal values +C (ACC being the accepted error) of SN +C +C Author : D. Sebilleau +C +C Last modified : 27 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + REAL ACC,COMP,R_SN(N_ORD_M) +C + NCONV=0 + DO J=JORD,JORD-N_TABLE,-1 + COMP=ABS(R_SN(J)-R_SN(J-1)) + IF(COMP.LE.ACC) THEN + NCONV=NCONV+1 + ENDIF + ENDDO +C + IF(NCONV.EQ.N_TABLE-1) RETURN 1 +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/remain_series.f b/src/msspec/spec/fortran/eig/pw/remain_series.f new file mode 100644 index 0000000..7c9ae61 --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/remain_series.f @@ -0,0 +1,79 @@ +C +C======================================================================= +C + SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN) +C +C This subroutine computes the G_N series used to describe +C the correction on the remainder estimate +C +C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n} +C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation) +C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.) +C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n} +C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n} +C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne) +C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process) +C +C +C Author : D. Sebilleau +C +C Last modified : 28 Feb 2013 +C +C INCLUDE 'spec.inc' +C + USE DIM_MOD +C + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M) + COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M) + COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC +C + ZEROC=(0.D0,0.D0) + ONEC=(1.D0,0.D0) +C +C Computing binomial coefficients +C + IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1) +C + DO N=0,N_APP +C + GN(N,0,-1)=ZEROC + GN(N,0,0)=ONEC + MONE=-ONEC +C + DO I=1,N_APP +C + IF(I_GN.EQ.1) THEN + GN(N,0,I)=GN(N,0,I-1)*XN(N) + ELSEIF(I_GN.EQ.2) THEN + GN(N,0,I)=XN(N+I-1) + ELSEIF(I_GN.EQ.3) THEN + GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0) + ELSEIF(I_GN.EQ.4) THEN + GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N) + ELSEIF(I_GN.EQ.5) THEN + GN(N,0,I)=GN(N,0,I-1)/XN(N) + ELSEIF(I_GN.EQ.6) THEN + MONE=-MONE + SUM_J=ZEROC + ONE=-ONEC + DO J=0,I + ONE=-ONE + SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0) + ENDDO + GN(N,0,I)=MONE*SUM_J + ELSEIF(I_GN.EQ.7) THEN + IF(I.GT.1) THEN + GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0) + ELSE + GN(N,0,I)=SN(N,0) + ENDIF + ENDIF +C + ENDDO +C + ENDDO +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/eig/pw/spec_rad_power.f b/src/msspec/spec/fortran/eig/pw/spec_rad_power.f new file mode 100644 index 0000000..b5746fb --- /dev/null +++ b/src/msspec/spec/fortran/eig/pw/spec_rad_power.f @@ -0,0 +1,547 @@ +C +C======================================================================= +C + SUBROUTINE SPEC_RAD_POWER(JE,E_KIN) +C +C This subroutine computes the spectral radius of the G_o T kernel matrix +C using the power method and the Rayleigh quotient. In addition, +C a scalar convergence acceleration method can be used to refine the results. +C +C Power method approximation of the spectral radius : +C +C SR(A) = lim ||A^{n} x|| / ||A^{n-1} x|| +C n --> +infty +C for any starting vector x +C +C Rayleigh quotient approximation of the spectral radius : +C +C SR(A) = lim ||(A^{n}x)^{+} A A^{n} x| / |(A^{n}x)^{+} A^{n} x|| +C n --> +infty +C for any starting vector x +C +C Note: a shift (= SHIFT) can be introduced in the power method. +C In this case, only the Rayleigh quotient is valid +C +C !!!!! This version does not store the G_o T matrix !!!!! +C +C Author : D. Sebilleau +C +C Last modified : 1 Mar 2013 +C +C INCLUDE 'spec.inc' + USE DIM_MOD + USE CONVTYP_MOD + USE COOR_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE TRANS_MOD +C +C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD +C + INTEGER NN(0:N_ORD_M) +C + REAL R_SN(N_ORD_M),R_SN1(N_ORD_M) +C + COMPLEX*16 TLK,SUM_L1,SUM_L2,EXPKJ,EXPJK,ONEC,MULT + COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO) + COMPLEX*16 X(LINMAX*NATCLU_M) + COMPLEX*16 AX(LINMAX*NATCLU_M),SUM_AX,XAX,XX + COMPLEX*16 HL1(0:NLTWO) + COMPLEX*16 ZEROC,IC,JC,JMULT,IFOURPI,CHIFT + COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M) + COMPLEX*16 COEF_GAUNT(LINMAX,LINMAX,0:N_GAUNT) +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ + REAL*8 ATTJK,XJK,YJK,ZJK,RJK,ZDJK,KRJK,SMALL + REAL*8 NORMX2,NORMAX2,RLIN +C + CHARACTER*10 METH + CHARACTER*24 OUTFILE,PATH +C + DATA PI,SMALL /3.1415926535898D0,1.0D-6/ +C + ONEC=(1.D0,0.D0) + IC=(0.0D0,1.0D0) + ZEROC=(0.D0,0.D0) + IFOURPI=4.D0*PI*IC + IBESS=3 + N_CALL=0 + N_ACC=0 + K_ACC=0 + I_CONV=0 +C + CHIFT=DCMPLX(SHIFT) +C + IF(N_MAX.GT.N_ORD_M) THEN + WRITE(IUO1,99) N_MAX + STOP + ENDIF +C +C Computing the size NLIN of the vectors A x +C + LMAXJ=0 + NLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + LMAXJ=MAX(LMAXJ,LMJ) + DO JNUM=1,NBTYPJ + DO LJ=0,LMJ + DO MJ=-LJ,LJ + NLIN=NLIN+1 + ENDDO + ENDDO + ENDDO + ENDDO +C +C Storage of the modified Gaunt coefficients +C + LIN1=0 + DO L1=0,LMAXJ + DO M1=-L1,L1 + LIN1=LIN1+1 + LIN2=0 + DO L2=0,LMAXJ + L_MIN=ABS(L2-L1) + L_MAX=L1+L2 + DO M2=-L2,L2 + LIN2=LIN2+1 + CALL GAUNT2(L1,M1,L2,M2,GNT) + DO L=L_MIN,L_MAX,2 + M=M1-M2 + COEF_GAUNT(LIN1,LIN2,L)=IFOURPI*GNT(L)*(IC** + & L) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +C +C Starting vector for power method: +C +C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO +C + JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0) + JMULT=JC**EXPO +C + WRITE(IUO1,6) +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(36,76) + ELSE + WRITE(36,79) + ENDIF + WRITE(36,75) +C +C Initialization the vectors and their squared norm +C + MULT=JMULT +C + AX(1)=ONEC +C + NORMAX2=1.D0 +C + DO JLIN=2,NLIN +C + AX(JLIN)=AX(JLIN-1)*MULT + NORMAX2=NORMAX2+CDABS(AX(JLIN))*CDABS(AX(JLIN)) +C + ENDDO +C +C Computation of the vectors and their squared norm +C +C X ---> A*X +C + 120 IF(N_CALL.EQ.0) THEN + J_INI=1 + ELSE + J_INI=N_CALL*N_ITER+1 + ENDIF + J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX) +C + IF(J_INI.GT.J_FIN) GOTO 112 +C + DO JORD=J_INI,J_FIN +C + NORMX2=NORMAX2 +C + XX=ZEROC + DO JLIN=1,NLIN +C + X(JLIN)=AX(JLIN) + XX=XX+CONJG(X(JLIN))*X(JLIN) +C + ENDDO +C + NORMAX2=0.D0 + XAX=ZEROC +C +C +C Construction of the the multiple scattering kernel matrix G_o T +C times the vector x +C +C Linear indices JLIN and KLIN represent (J,LJ) and (K,LK) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + LINJ=0 + DO LJ=0,LMJ + DO MJ=-LJ,LJ + JLIN=JLIN+1 + LINJ=LINJ+1 +C + SUM_AX=ZEROC +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + XK=SYM_AT(1,KATL) + YK=SYM_AT(2,KATL) + ZK=SYM_AT(3,KATL) +C + IF(KATL.NE.JATL) THEN +C + XKJ=DBLE(XK-XJ) + YKJ=DBLE(YK-YJ) + ZKJ=DBLE(ZK-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))* + & RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM, + & LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ, + & HL1) +C + ENDIF +C + LINK=0 + DO LK=0,LMK + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=ATTKJ*DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + KLIN=KLIN+1 + LINK=LINK+1 + IF(KATL.NE.JATL) THEN +C + SUM_L1=ZEROC + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L1=SUM_L1+HL1(L)* + & COEF_GAUNT(LINJ,LINK,L)*YLM(L,M) + ENDIF + ENDDO + SUM_AX=SUM_AX+TLK*SUM_L1*X( + & KLIN) +C + ENDIF + IF(KLIN.EQ.JLIN) SUM_AX=SUM_AX- + & CHIFT*X(KLIN) +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + AX(JLIN)=SUM_AX + NORMAX2=NORMAX2+CDABS(SUM_AX)*CDABS(SUM_AX) + XAX=XAX+CONJG(X(JLIN))*SUM_AX +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C +C R_SN : power method +C R_SN1: Rayleigh quotient +C + R_SN(JORD)=SQRT(REAL(NORMAX2/NORMX2)) + R_SN1(JORD)=CDABS((XAX/XX)+SHIFT) +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(36,77) JORD,R_SN(JORD),R_SN1(JORD) + ELSE + WRITE(36,77) JORD,R_SN1(JORD) + ENDIF +C +C Check of convergence of power method series and +C Rayleigh quotient method +C +C Note: only Rayleigh quotient valid if shift +C + IF((I_PWM.EQ.2).AND.(ABS(SHIFT).LE.SMALL)) THEN + IF(JORD.GT.N_TABLE) THEN + CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN,*555) + ENDIF + ENDIF +C + IF((ABS(SHIFT).GT.SMALL).AND.(I_PWM.GT.0)) I_PWM=-I_PWM + IF(I_PWM.EQ.-2) THEN + IF(JORD.GT.N_TABLE) THEN + CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN1,*555) + ENDIF + ENDIF +C + ENDDO +C + 555 IF(J_INI.EQ.1) THEN + WRITE(IUO1,10) + WRITE(IUO1,11) SHIFT + WRITE(IUO1,46) NLIN + WRITE(IUO1,10) + WRITE(IUO1,61) + ENDIF +C + WRITE(IUO1,10) + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(IUO1,44) R_SN(JORD-1) + ENDIF + WRITE(IUO1,53) R_SN1(JORD-1) + WRITE(IUO1,47) JORD-1 + WRITE(IUO1,10) + IF(J_FIN.EQ.N_MAX) THEN + IF((I_PWM.EQ.1).OR.(I_PWM.EQ.3)) THEN + WRITE(IUO1,213) + ELSE + WRITE(IUO1,60) + ENDIF + ENDIF +C + IF(((I_ACC.EQ.1).OR.(I_ACC.EQ.2)).AND.(ABS(SHIFT).LE.SMALL)) THEN +C +C Convergence acceleration on the power method results whenever necessary +C + CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + & R_SN,SN,METH) + IF(I_ACC.EQ.1) GOTO 111 + IF((I_CONV.EQ.1).AND.(I_ACC.EQ.2)) GOTO 111 + IF((I_CONV.EQ.0).AND.(I_ACC.EQ.2)) THEN + IF(J_FIN.EQ.N_MAX) THEN + GOTO 111 + ELSE + GOTO 120 + ENDIF + ENDIF +C + 111 WRITE(IUO1,10) + WRITE(IUO1,61) + WRITE(IUO1,10) + WRITE(IUO1,52) METH + WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC)) + WRITE(IUO1,49) N_ACC + WRITE(IUO1,51) K_ACC +C + IF(I_ACC.EQ.2) THEN + OPEN(UNIT=35, FILE='div/n_k_table_pm.lis', STATUS= + & 'unknown') + K_MAX=MIN(K_MAX,J_FIN) + DO L=0,K_MAX + NN(L)=L + ENDDO + WRITE(35,*) ' ' + WRITE(35,78) E_KIN,METH + WRITE(35,*) ' ' + WRITE(35,198) (NN(K),K=0,K_MAX) + WRITE(35,199) + WRITE(35,*) ' ' + DO N=0,K_MAX + WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N) + WRITE(35,*) ' ' + ENDDO + ENDIF +C + WRITE(IUO1,10) + IF(I_ACC.GE.1) WRITE(IUO1,60) + IF(I_ACC.EQ.2) THEN + IF(I_CONV.EQ.0) WRITE(IUO1,212) + WRITE(IUO1,210) + ENDIF +C + ENDIF +C + IF((ABS(SHIFT).GT.SMALL).AND.(I_ACC.GT.0)) I_ACC=-I_ACC + IF((I_ACC.EQ.-1).OR.(I_ACC.EQ.-2))THEN +C +C Convergence acceleration on the Rayleigh quotient whenever necessary +C + CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV, + & R_SN1,SN,METH) + IF(I_ACC.EQ.-1) GOTO 999 + IF((I_CONV.EQ.1).AND.(I_ACC.EQ.-2)) GOTO 999 + IF((I_CONV.EQ.0).AND.(I_ACC.EQ.-2)) THEN + IF(J_FIN.EQ.N_MAX) THEN + GOTO 999 + ELSE + GOTO 120 + ENDIF + ENDIF +C + 999 WRITE(IUO1,10) + WRITE(IUO1,61) + WRITE(IUO1,10) + WRITE(IUO1,52) METH + WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC)) + WRITE(IUO1,49) N_ACC + WRITE(IUO1,51) K_ACC +C + IF(I_ACC.EQ.-2) THEN + OPEN(UNIT=35, FILE='div/n_k_table_rq.lis', STATUS= + & 'unknown') + K_MAX=MIN(K_MAX,J_FIN) + DO L=0,K_MAX + NN(L)=L + ENDDO + WRITE(35,*) ' ' + WRITE(35,78) E_KIN,METH + WRITE(35,*) ' ' + WRITE(35,198) (NN(K),K=0,K_MAX) + WRITE(35,199) + WRITE(35,*) ' ' + DO N=0,K_MAX + WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N) + WRITE(35,*) ' ' + ENDDO + ENDIF +C + WRITE(IUO1,10) + IF(ABS(I_ACC).GE.1) WRITE(IUO1,60) + IF(I_ACC.EQ.-2) THEN + IF(I_CONV.EQ.0) WRITE(IUO1,215) + WRITE(IUO1,214) + ENDIF +C + ENDIF +C +C Writing the results: +C + IF(ABS(I_ACC).LT.2) THEN +C +C No convergence acceleration: power method and Rayleigh quotient +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1) + ELSE + WRITE(IUO2,*) E_KIN,R_SN1(JORD-1) + ENDIF +C + ELSE +C + IF(I_CONV.EQ.1) THEN +C +C Convergence acceleration has succeeded: +C + WRITE(IUO2,*) E_KIN,REAL(CDABS(SN(N_ACC,K_ACC))) +C + ELSEIF(I_CONV.EQ.0) THEN +C +C Convergence acceleration has failed: power method and +C Rayleigh quotient used instead +C + IF(ABS(SHIFT).LE.SMALL) THEN + WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1) + ELSE + WRITE(IUO2,*) E_KIN,R_SN1(JORD-1) + ENDIF +C + ENDIF + ENDIF +C + 112 WRITE(IUO1,211) +C + RETURN +C + 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','--------- + &--------') + 6 FORMAT(/,11X,'----------- SHIFTED POWER METHOD ANALYSIS ',' ---- + &--------') + 10 FORMAT(11X,'-',54X,'-') + 11 FORMAT(11X,'-',4X,'SHIFT ',20X,': ',F6.3,3X,'-') + 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-') + 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-') + 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-') + 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X, + &'-') + 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-') + 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-') + 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5, + &3X,'-') + 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5, + &3X,'-') + 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8, + &3X,'-') + 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8, + &3X,'-') + 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5, + &3X,'-') + 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8, + &3X,'-') + 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ', + &'CONVERGES ',4X,'-') + 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8, + &3X,'-') + 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10, + &1X,'-') + 53 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY RAYLEIGH QUOTIENT : ',F8.5, + &3X,'-') + 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/ + &,11X,'-',18X,'SCATTERING SERIES',19X,'-') + 60 FORMAT(11X,'----------------------------------------','---------- + &------',/) + 61 FORMAT(11X,'----------------------------------------','---------- + &------') + 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X, + &'-') + 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6. + &3,')',8X,'-') + 75 FORMAT(' ') + 76 FORMAT(2X,'ITERATION: SPECTRAL RADIUS:',' RAYLEIGH + "IENT:') + 77 FORMAT(2X,I6,15X,F6.3,15X,F6.3) + 78 FORMAT(10X,' E_KIN = ',F6.2,' eV -- (N,K) TABLE OF ',A10,' + &METHOD') + 79 FORMAT(2X,'ITERATION: RAYLEIGH QUOTIENT:') + 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV') + 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3) + 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5) + 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,') + &') + 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE',' + &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ', + &I5, 6X,' >>>>>>>>>>',///) + 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3) + 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :') + 110 FORMAT(2X,'-------------------------------') + 198 FORMAT(' K',50(I3,4X)) + 199 FORMAT(' N') + 200 FORMAT(I3,50(2X,F5.3)) + 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/ + &n_k_table_pm.lis',//) + 211 FORMAT(//,' ---> THE EVOLUTION OF THE SPECTRAL RADIUS ','HAS + &BEEN WRITTEN IN /div/radius_conv.lis',//) + 212 FORMAT(//,10X,' !!!!! THE POWER METHOD HAS NOT CONVERGED YET + &','!!!!!') + 213 FORMAT(11X,'------------ NO CONVERGENCE CHECK WAS MADE ','------ + &------') + 214 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/ + &n_k_table_rq.lis',//) + 215 FORMAT(//,8X,' !!!!! THE RAYLEIGH QUOTIENT HAS NOT CONVERGED', + &' YET !!!!!') +C + END diff --git a/src/msspec/spec/fortran/allocation.f b/src/msspec/spec/fortran/memalloc/allocation.f similarity index 95% rename from src/msspec/spec/fortran/allocation.f rename to src/msspec/spec/fortran/memalloc/allocation.f index 0237aa0..dd8a841 100644 --- a/src/msspec/spec/fortran/allocation.f +++ b/src/msspec/spec/fortran/memalloc/allocation.f @@ -10,7 +10,6 @@ USE BASES_MOD USE CLUSLIM_MOD USE COOR_MOD - USE C_RENORM_MOD USE DEBWAL_MOD USE INDAT_MOD USE INIT_A_MOD @@ -28,7 +27,6 @@ USE PARCAL_A_MOD USE RELADS_MOD USE RELAX_MOD - USE RENORM_MOD USE RESEAU_MOD USE SPIN_MOD USE TESTS_MOD @@ -76,7 +74,13 @@ USE DIRECT_MOD USE DIRECT_A_MOD USE PATH_MOD + USE RENORM_MOD + USE C_RENORM_MOD USE ROT_MOD + USE ROT_CUB_MOD + USE SYMMOP_MOD + USE TAU_PROT_MOD + USE TAUSYMMOP_MOD USE TESTPA_MOD USE TESTPB_MOD USE TLDW_MOD @@ -182,6 +186,10 @@ CALL ALLOC_DIRECT_A() CALL ALLOC_PATH() CALL ALLOC_ROT() + CALL ALLOC_ROT_CUB() + CALL ALLOC_SYMMOP() + CALL ALLOC_TAU_PROT() + CALL ALLOC_TAUSYMMOP() CALL ALLOC_TESTPA() CALL ALLOC_TESTPB() CALL ALLOC_TLDW() diff --git a/src/msspec/spec/fortran/dim_mod.f b/src/msspec/spec/fortran/memalloc/dim_mod.f similarity index 96% rename from src/msspec/spec/fortran/dim_mod.f rename to src/msspec/spec/fortran/memalloc/dim_mod.f index 97f43bf..b09db08 100644 --- a/src/msspec/spec/fortran/dim_mod.f +++ b/src/msspec/spec/fortran/memalloc/dim_mod.f @@ -30,6 +30,7 @@ C =============================================================== INTEGER NT_M INTEGER NCG_M INTEGER N_BESS, N_GAUNT + INTEGER NLTWO C =============================================================== CONTAINS SUBROUTINE INIT_DIM() @@ -56,5 +57,7 @@ C =============================================================== N_BESS=100*NL_M N_GAUNT=5*NL_M + + NLTWO=2*NL_M END SUBROUTINE INIT_DIM END MODULE DIM_MOD diff --git a/src/msspec/spec/fortran/modules.f b/src/msspec/spec/fortran/memalloc/modules.f similarity index 90% rename from src/msspec/spec/fortran/modules.f rename to src/msspec/spec/fortran/memalloc/modules.f index a9a40cd..3362336 100644 --- a/src/msspec/spec/fortran/modules.f +++ b/src/msspec/spec/fortran/memalloc/modules.f @@ -1416,6 +1416,134 @@ C======================================================================= ALLOCATE(JPON(NPATH_M,NDIF_M)) END SUBROUTINE ALLOC_PRINTP END MODULE PRINTP_MOD +C======================================================================= + MODULE ROT_CUB_MOD + IMPLICIT NONE + REAL*4, ALLOCATABLE, DIMENSION(:,:,:) :: R_PIS2 + CONTAINS + SUBROUTINE ALLOC_ROT_CUB() + USE DIM_MOD + IF (ALLOCATED(R_PIS2)) THEN + DEALLOCATE(R_PIS2) + ENDIF + ALLOCATE(R_PIS2(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)) + END SUBROUTINE ALLOC_ROT_CUB + END MODULE ROT_CUB_MOD +C======================================================================= + MODULE SYMMOP_MOD + IMPLICIT NONE + REAL*4, ALLOCATABLE, DIMENSION(:) :: ZL + COMPLEX, ALLOCATABLE, DIMENSION(:) :: ZM1 + COMPLEX, ALLOCATABLE, DIMENSION(:) :: ZM2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IZ + CONTAINS + SUBROUTINE ALLOC_SYMMOP() + USE DIM_MOD + IF (ALLOCATED(ZL)) THEN + DEALLOCATE(ZL) + ENDIF + ALLOCATE(ZL(64)) + IF (ALLOCATED(ZM1)) THEN + DEALLOCATE(ZM1) + ENDIF + ALLOCATE(ZM1(64)) + IF (ALLOCATED(ZM2)) THEN + DEALLOCATE(ZM2) + ENDIF + ALLOCATE(ZM2(64)) + IF (ALLOCATED(IZ)) THEN + DEALLOCATE(IZ) + ENDIF + ALLOCATE(IZ(64)) + END SUBROUTINE ALLOC_SYMMOP + END MODULE SYMMOP_MOD +C======================================================================= + MODULE TAU_PROT_MOD + IMPLICIT NONE + REAL*4, ALLOCATABLE, DIMENSION(:) :: Z_L_P + COMPLEX, ALLOCATABLE, DIMENSION(:) :: Z_M_P + INTEGER, ALLOCATABLE, DIMENSION(:) :: I_Z_P + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTEP_L + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTEP_M + INTEGER, ALLOCATABLE, DIMENSION(:) :: I_LM + INTEGER, ALLOCATABLE, DIMENSION(:) :: I_REL_MP + CONTAINS + SUBROUTINE ALLOC_TAU_PROT() + USE DIM_MOD + IF (ALLOCATED(Z_L_P)) THEN + DEALLOCATE(Z_L_P) + ENDIF + ALLOCATE(Z_L_P(NATP_M)) + IF (ALLOCATED(Z_M_P)) THEN + DEALLOCATE(Z_M_P) + ENDIF + ALLOCATE(Z_M_P(NATP_M)) + IF (ALLOCATED(I_Z_P)) THEN + DEALLOCATE(I_Z_P) + ENDIF + ALLOCATE(I_Z_P(NATP_M)) + IF (ALLOCATED(ISTEP_L)) THEN + DEALLOCATE(ISTEP_L) + ENDIF + ALLOCATE(ISTEP_L(NATP_M)) + IF (ALLOCATED(ISTEP_M)) THEN + DEALLOCATE(ISTEP_M) + ENDIF + ALLOCATE(ISTEP_M(NATP_M)) + IF (ALLOCATED(I_LM)) THEN + DEALLOCATE(I_LM) + ENDIF + ALLOCATE(I_LM(NATP_M)) + IF (ALLOCATED(I_REL_MP)) THEN + DEALLOCATE(I_REL_MP) + ENDIF + ALLOCATE(I_REL_MP(NATP_M)) + END SUBROUTINE ALLOC_TAU_PROT + END MODULE TAU_PROT_MOD +C======================================================================= + MODULE TAUSYMMOP_MOD + IMPLICIT NONE + REAL*4, ALLOCATABLE, DIMENSION(:,:) :: Z_L + COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: Z_M1 + COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: Z_M2 + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: I_Z + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISYM + INTEGER, ALLOCATABLE, DIMENSION(:) :: NSYM_G + INTEGER :: NSIZE_GR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: S_INV + CONTAINS + SUBROUTINE ALLOC_TAUSYMMOP() + USE DIM_MOD + IF (ALLOCATED(Z_L)) THEN + DEALLOCATE(Z_L) + ENDIF + ALLOCATE(Z_L(NAT_EQ_M,NATP_M)) + IF (ALLOCATED(Z_M1)) THEN + DEALLOCATE(Z_M1) + ENDIF + ALLOCATE(Z_M1(NAT_EQ_M,NATP_M)) + IF (ALLOCATED(Z_M2)) THEN + DEALLOCATE(Z_M2) + ENDIF + ALLOCATE(Z_M2(NAT_EQ_M,NATP_M)) + IF (ALLOCATED(I_Z)) THEN + DEALLOCATE(I_Z) + ENDIF + ALLOCATE(I_Z(NAT_EQ_M,NATP_M)) + IF (ALLOCATED(ISYM)) THEN + DEALLOCATE(ISYM) + ENDIF + ALLOCATE(ISYM(NAT_EQ_M,NATP_M)) + IF (ALLOCATED(NSYM_G)) THEN + DEALLOCATE(NSYM_G) + ENDIF + ALLOCATE(NSYM_G(48)) + IF (ALLOCATED(S_INV)) THEN + DEALLOCATE(S_INV) + ENDIF + ALLOCATE(S_INV(64,3,3)) + END SUBROUTINE ALLOC_TAUSYMMOP + END MODULE TAUSYMMOP_MOD C======================================================================= MODULE RENORM_MOD IMPLICIT NONE diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f new file mode 100644 index 0000000..bb376de --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f @@ -0,0 +1,121 @@ +C +C======================================================================= +C + SUBROUTINE COUMAT(ITL,MI,LF,MF,DELTA,RADIAL,MATRIX) +C +C This routine calculates the spin-independent PhD optical matrix +C elements for dipolar excitations. It is stored in +C MATRIX(JDIR,JPOL) +C +C Here, the conventions are : +C +C IPOL=1 : linearly polarized light +C IPOL=2 : circularly polarized light +C +C JPOL=1 : +/x polarization for circular/linear light +C JPOL=2 : -/y polarization for circular/linear light +C +C When IDICHR=0, JDIR = 1,2 and 3 correspond respectively to the x,y +C and z directions for the linear polarization. But for IDICHR=1, +C these basis directions are those of the position of the light. +C +C Last modified : 8 Dec 2008 +C + USE DIM_MOD +C + USE INIT_L_MOD , L2 => NNL, L3 => LF1, L4 => LF2, L5 => ISTEP_LF + USE SPIN_MOD , I1 => ISPIN, N1 => NSPIN, N2 => NSPIN2, I2 => ISFLI + &P, I8 => IR_DIA, N3 => NSTEP + USE TYPCAL_MOD , I3 => IPHI, I4 => IE, I5 => ITHETA, I6 => IFTHET, + & I7 => IMOD, I9 => I_CP, I10 => I_EXT +C + COMPLEX MATRIX(3,2),SUM_1,SUM_2,DELTA,YLM(3,-1:1),RADIAL + COMPLEX ONEC,IC,IL,COEF,PROD +C + REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1),GNT(0:N_GAUNT) + REAL THETA(3),PHI(3) +C + DATA PI4S3,C_LIN,SQR2 /4.188790,1.447202,1.414214/ + DATA PIS2 /1.570796/ +C + ONEC=(1.,0.) + IC=(0.,1.) +C + IF(INITL.EQ.0) GOTO 2 +C + M=MF-MI +C + IF(MOD(LF,4).EQ.0) THEN + IL=ONEC + ELSEIF(MOD(LF,4).EQ.1) THEN + IL=IC + ELSEIF(MOD(LF,4).EQ.2) THEN + IL=-ONEC + ELSEIF(MOD(LF,4).EQ.3) THEN + IL=-IC + ENDIF +C + CALL GAUNT(LI,MI,LF,MF,GNT) +C + IF(ITL.EQ.0) THEN +c COEF=CEXP(IC*DELTA)*CONJG(IL) + COEF=CEXP(IC*DELTA)*IL + ELSE + IF(IDICHR.EQ.0) THEN +c COEF=PI4S3*CONJG(IL) + COEF=PI4S3*IL + ELSE +c COEF=C_LIN*CONJG(IL) + COEF=C_LIN*IL + ENDIF + ENDIF +C + PROD=COEF*RADIAL*GNT(1) +C + IF(IDICHR.EQ.0) THEN + YLM(1,-1)=(0.345494,0.) + YLM(1,0)=(0.,0.) + YLM(1,1)=(-0.345494,0.) + YLM(2,-1)=(0.,-0.345494) + YLM(2,0)=(0.,0.) + YLM(2,1)=(0.,-0.345494) + YLM(3,-1)=(0.,0.) + YLM(3,0)=(0.488602,0.) + YLM(3,1)=(0.,0.) +C + DO JDIR=1,3 + MATRIX(JDIR,1)=PROD*CONJG(YLM(JDIR,M)) + ENDDO +C + ELSEIF(IDICHR.GE.1) THEN +C + THETA(1)=PIS2 + PHI(1)=0. + THETA(2)=PIS2 + PHI(2)=PIS2 + THETA(3)=0. + PHI(3)=0. +C + DO JDIR=1,3 + CALL DJMN(THETA(JDIR),RLM,1) + SUM_1=RLM(-1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR)) + SUM_2=RLM(1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR)) + IF(IPOL.EQ.2) THEN + MATRIX(JDIR,1)=SQR2*SUM_1 + MATRIX(JDIR,2)=SQR2*SUM_2 + ELSEIF(ABS(IPOL).EQ.1) THEN + MATRIX(JDIR,1)=(SUM_2-SUM_1) + MATRIX(JDIR,2)=(SUM_2+SUM_1)*IC + ENDIF + ENDDO + ENDIF + GOTO 1 +C + 2 DO JDIR=1,3 + MATRIX(JDIR,1)=ONEC + MATRIX(JDIR,2)=ONEC + ENDDO +C + 1 RETURN +C + END diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f new file mode 100644 index 0000000..e9dea7a --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f @@ -0,0 +1,1654 @@ +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 + 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) +C! 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 +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f new file mode 100644 index 0000000..6d48a79 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f @@ -0,0 +1,85 @@ +C +C======================================================================= +C + SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED) +C +C This routine recomputes the T-matrix elements taking into account the +C mean square displacements. +C +C When the argument X is tiny, no vibrations are taken into account +C +C Last modified : 25 Apr 2013 +C + USE DIM_MOD +C + USE TRANS_MOD +C + DIMENSION GNT(0:N_GAUNT) +C + COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC +C + COMPLEX*16 FFL(0:2*NL_M) +C + DATA PI4,EPS /12.566371,1.0E-10/ +C + ZEROC=(0.,0.) +C + IF(X.GT.EPS) THEN +C +C Standard case: vibrations +C + IF(ISPEED.LT.0) THEN + NSUM_LB=ABS(ISPEED) + ENDIF +C + COEF=PI4*EXP(-X) + NL2=2*LMAX(JTYP,JE)+2 + IBESP=5 + MG1=0 + MG2=0 +C + CALL BESPHE(NL2,IBESP,X,FFL) +C + DO L=0,LMAX(JTYP,JE) + XL=FLOAT(L+L+1) + SL1=ZEROC +C + DO L1=0,LMAX(JTYP,JE) + XL1=FLOAT(L1+L1+1) + CALL GAUNT(L,MG1,L1,MG2,GNT) + L2MIN=ABS(L1-L) + IF(ISPEED.GE.0) THEN + L2MAX=L1+L + ELSEIF(ISPEED.LT.0) THEN + L2MAX=L2MIN+2*(NSUM_LB-1) + ENDIF + SL2=0. +C + DO L2=L2MIN,L2MAX,2 + XL2=FLOAT(L2+L2+1) + C=SQRT(XL1*XL2/(PI4*XL)) + SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2))) + ENDDO +C + SL1=SL1+SL2*TL(L1,1,JTYP,JE) + ENDDO +C + TLT(L,1,JTYP,JE)=COEF*SL1 +C + ENDDO +C + ELSE +C +C Argument X tiny: no vibrations +C + DO L=0,LMAX(JTYP,JE) +C + TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE) +C + ENDDO +C + ENDIF +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f new file mode 100644 index 0000000..2ac7683 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f @@ -0,0 +1,26 @@ +C +C======================================================================= +C + SUBROUTINE FACDIF(COSTH,JAT,JE,FTHETA) +C +C This routine computes the plane wave scattering factor +C + USE DIM_MOD +C + USE TRANS_MOD +C + DIMENSION PL(0:100) +C + COMPLEX FTHETA +C + FTHETA=(0.,0.) + NL=LMAX(JAT,JE)+1 + CALL POLLEG(NL,COSTH,PL) + DO 20 L=0,NL-1 + FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L) + 20 CONTINUE + FTHETA=FTHETA/VK(JE) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f new file mode 100644 index 0000000..62ac3f8 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f @@ -0,0 +1,113 @@ +C +C======================================================================= +C + SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J + &E,*) +C +C This routine computes a spherical wave scattering factor +C +C Last modified : 03/04/2006 +C + USE DIM_MOD + USE APPROX_MOD + USE EXPFAC_MOD + USE TRANS_MOD + USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I + &6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST +C + DIMENSION PLMM(0:100,0:100) + DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ + COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE + COMPLEX RHOJK +C +C + DATA PI/3.141593/ +C + A=1. + INTER=0 + IF(ITL.EQ.1) VKE=VK(JE) + RHOJ=VKE*RJ + RHOJK=VKE*RJK + HLM1=(1.,0.) + HLM2=(1.,0.) + HLM3=(1.,0.) + HLM4=(1.,0.) + IEM=1 + CSTH=COS(BETA) + IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN + INTER=1 + BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI)) + ENDIF + CALL PLM(CSTH,PLMM,LMAX(JAT,JE)) + IF(ISPHER.EQ.0) NO1=0 + IF(ISPHER.EQ.1) THEN + IF(NO.EQ.8) THEN + NO1=LMAX(JAT,JE)+1 + ELSE + NO1=NO + ENDIF + CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM) + IF(IEM.EQ.0) THEN + HLM4=HLM(0,L) + ENDIF + IF(RJK.GT.0.0001) THEN + NDUM=0 + CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN) + ENDIF + CALL DJMN(THRJ,D,L) + A1=ABS(D(0,M,L)) + IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1 + & + ENDIF + MUMAX=MIN0(L,NO1) + SMU=(0.,0.) + DO 10 MU=0,MUMAX + IF(MOD(MU,2).EQ.0) THEN + B=1. + ELSE + B=-1. + IF(SIN(BETA).LT.0.) THEN + A=-1. + ENDIF + ENDIF + IF(ISPHER.LE.1) THEN + ALMU=(1.,0.) + C=1. + ENDIF + IF(ISPHER.EQ.0) GOTO 40 + IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L)) + IF(MU.GT.0) THEN + C=B*FLOAT(L+L+1)/EXPF(MU,L) + ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B* + * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU + ELSE + C=1. + ALMU=CMPLX(D(M,0,L))/BLMU + ENDIF + 40 SNU=(0.,0.) + NU1=INT(0.5*(NO1-MU)+0.0001) + NUMAX=MIN0(NU1,L-MU) + DO 20 NU=0,NUMAX + SLP=(0.,0.) + LPMIN=MAX0(MU,NU) + DO 30 LP=LPMIN,LMAX(JAT,JE) + IF(ISPHER.EQ.1) THEN + HLM1=HLM(NU,LP) + IF(RJK.GT.0.0001) HLM3=HLN(0,LP) + ENDIF + SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3 + 30 CONTINUE + IF(ISPHER.EQ.1) THEN + HLM2=HLM(MU+NU,L) + ENDIF + SNU=SNU+SLP*HLM2 + 20 CONTINUE + SMU=SMU+SNU*C*ALMU*A*B + 10 CONTINUE + FSPH=SMU/(VKE*HLM4) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f new file mode 100644 index 0000000..51c2687 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f @@ -0,0 +1,366 @@ +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f new file mode 100644 index 0000000..79aa914 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f @@ -0,0 +1,367 @@ +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f new file mode 100644 index 0000000..e6c82e0 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f @@ -0,0 +1,367 @@ +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths4.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths4.f new file mode 100644 index 0000000..7e0f563 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths4.f @@ -0,0 +1,367 @@ +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths5.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths5.f new file mode 100644 index 0000000..b379ca1 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths5.f @@ -0,0 +1,367 @@ +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/main.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/main.f new file mode 100644 index 0000000..4bdf296 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/main.f @@ -0,0 +1,20 @@ + 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() + + END SUBROUTINE RUN diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/matdif.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/matdif.f new file mode 100644 index 0000000..e78ac1f --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/matdif.f @@ -0,0 +1,344 @@ +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f new file mode 100644 index 0000000..e07d33d --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f @@ -0,0 +1,550 @@ +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 C_RENORM_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 RENORM_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 Renormalization of the path +C + IF(I_REN.GE.1) THEN + COEF=COEF*C_REN(JORDP) + write(354,*) JORDP,C_REN(JORDP) + ENDIF +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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/phddif_se.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/phddif_se.f new file mode 100644 index 0000000..5433418 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/phddif_se.f @@ -0,0 +1,1306 @@ +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 C_RENORM_MOD + 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 RENORM_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 + IF(I_REN.GE.1) R2=R2*C_REN(0) + 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 diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/plotfd.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/plotfd.f new file mode 100644 index 0000000..bc73cf4 --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/plotfd.f @@ -0,0 +1,106 @@ +C +C======================================================================= +C + SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE) +C +C This routine prepares the output for a plot of the scattering factor +C + USE DIM_MOD +C + USE APPROX_MOD + USE FDIF_MOD + USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 => + & LF2, I10 => ISTEP_LF + USE INIT_J_MOD + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS + USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP + &, I13 => I_EXT, I14 => I_TEST + USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO + &L + USE VALFIN_MOD +C +C +C + DIMENSION LMX(NATM,NE_M) +C + COMPLEX FSPH,VKE +C +C +C + DATA PI,CONV/3.141593,0.512314/ +C + OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN') + IF(ISPHER.EQ.0) THEN + L=0 + LMAX=0 + ELSE + LMAX=L + ENDIF + PHITOT=360. + THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI + NPHI=(NFTHET+1)*IPHI+(1-IPHI) + NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+ + * (1-ITHETA) + NE=NFTHET*IE + (1-IE) + WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN + DO 10 JT=1,NTHT + DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1)) + RTHETA=DTHETA*PI/180. + TEST=SIN(RTHETA) + IF(TEST.GE.0.) THEN + POZ=PI + EPS=1. + ELSE + POZ=0. + EPS=-1. + ENDIF + BETA=RTHETA*EPS + IF(ABS(TEST).LT.0.0001) THEN + NPHIM=1 + ELSE + NPHIM=NPHI + ENDIF + DO 20 JP=1,NPHIM + DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1)) + RPHI=DPHI*PI/180. + GAMMA=POZ-RPHI + DO 30 JE=1,NE + IF(NE.EQ.1) THEN + ECIN=E0 + ELSE + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ENDIF + IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.) + DO 40 JAT=1,NAT + IF(L.GT.LMX(JAT,JE)) GOTO 90 + DO 50 M=-LMAX,LMAX + CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J + &AT,JE,*60) + GOTO 70 + 60 WRITE(IUO1,80) + STOP + 70 REFTH=REAL(FSPH) + XIMFTH=AIMAG(FSPH) + WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN + 50 CONTINUE + GOTO 40 + 90 WRITE(IUO1,100) JAT + STOP + 40 CONTINUE + 30 CONTINUE + 20 CONTINUE + 10 CONTINUE + CLOSE(IUO3) + 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2) + 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X, + &F8.2) + 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z + &ERO >>>>>') + 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : ' + &,I2,' >>>>>') +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/treat_phd.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/treat_phd.f new file mode 100644 index 0000000..a76a31e --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/treat_phd.f @@ -0,0 +1,769 @@ +C +C======================================================================= +C + SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP) +C +C This routine sums up the calculations corresponding to different +C absorbers or different planes when this has to be done +C (parameter ISOM in the input data file). +C +C Last modified : 24 Jan 2013 +C + USE DIM_MOD + USE OUTUNITS_MOD + USE TYPEXP_MOD , DUMMY => SPECTRO + USE VALIN_MOD + USE VALFIN_MOD +C + PARAMETER(N_HEAD=5000,N_FILES=1000) +C + CHARACTER*3 SPECTRO +C + CHARACTER*13 OUTDATA + CHARACTER*72 HEAD(N_HEAD,N_FILES) +C + REAL TAB(NDIM_M,4) + REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M) +C +C + DATA JVOL,JTOT/0,-1/ +C + REWIND IUO2 +C +C Reading and storing the headers: +C + NHEAD=0 + DO JLINE=1,N_HEAD + READ(IUO2,888) HEAD(JLINE,JFICH) + NHEAD=NHEAD+1 + IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333 + ENDDO +C + 333 CONTINUE +C + READ(IUO2,15) SPECTRO,OUTDATA + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IPH_1 + &,I_EXT +C + IF(I_EXT.EQ.2) THEN + IPH_1=0 + ENDIF +C + IF(ISOM.EQ.0) THEN +C +C........ ISOM = 0 : case of independent input files ................. +C + READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE +C + IF(IPH_1.EQ.1) THEN + N_FIXED=NPHI + FIX0=PHI0 + FIX1=PHI1 + N_SCAN=NTHETA + ELSE + N_FIXED=NTHETA + FIX0=THETA0 + FIX1=THETA1 + IF(STEREO.EQ.'YES') THEN + NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001) + &+1 + IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 + ENDIF + N_SCAN=NPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + N_SCAN=2*N_SCAN + ENDIF +C + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + NDP=NEMET*NTHETA*NPHI*NE + ELSEIF(I_EXT.EQ.-1) THEN + NDP=NEMET*NTHETA*NPHI*NE*2 + ELSEIF(I_EXT.EQ.2) THEN + NDP=NEMET*NTHETA*NE + N_FIXED=NTHETA + N_SCAN=NPHI + IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 + ENDIF +C + NTT=NPLAN*NDP + IF(NTT.GT.NDIM_M) GOTO 5 +C + DO JPLAN=1,NPLAN + DO JEMET=1,NEMET + DO JE=1,NE +C + DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1) + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(IPH_1.EQ.1) THEN + JPHI=J_FIXED + ELSE + THETA=THETA0+XINCRF + JTHETA=J_FIXED + IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11 + ENDIF + IF(STEREO.EQ.' NO') THEN + N_SCAN_R=N_SCAN + ELSE + RTHETA=THETA*0.017453 + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + ENDIF +C + DO J_SCAN=1,N_SCAN_R + IF(IPH_1.EQ.1) THEN + JTHETA=J_SCAN + ELSE + JPHI=J_SCAN + ENDIF +C + JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN + (JE-1)*N + &_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI +C + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF +C + READ(IUO2,2) JPL + IF(JPLAN.EQ.JPL) THEN + BACKSPACE IUO2 + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN + &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ELSE + BACKSPACE IUO2 + DO JL=JLIN,JPLAN*NDP + TAB(JL,1)=0.0 + TAB(JL,2)=0.0 + TAB(JL,3)=0.0 + TAB(JL,4)=0.0 + ENDDO + GOTO 10 + ENDIF + ENDDO + ENDDO + 11 CONTINUE + ENDDO + ENDDO + 10 CONTINUE + ENDDO +C + REWIND IUO2 +C +C Skipping the NHEAD lines of headers before rewriting: +C + DO JLINE=1,NHEAD + READ(IUO2,888) HEAD(JLINE,JFICH) + ENDDO +C + WRITE(IUO2,15) SPECTRO,OUTDATA + WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM +C + DO JE=1,NE + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R + TOTDIF_1=0. + TOTDIR_1=0. + VOLDIF_1=0. + VOLDIR_1=0. + TOTDIF_2=0. + TOTDIR_2=0. + VOLDIF_2=0. + VOLDIR_2=0. + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=0. + TOTDIR2_1=0. + VOLDIF2_1=0. + VOLDIR2_1=0. + TOTDIF2_2=0. + TOTDIR2_2=0. + VOLDIF2_2=0. + VOLDIR2_2=0. + ENDIF +C + DO JPLAN=1,NPLAN +C + SF_1=0. + SR_1=0. + SF_2=0. + SR_2=0. + IF(I_EXT.EQ.-1) THEN + SF2_1=0. + SR2_1=0. + SF2_2=0. + SR2_2=0. + ENDIF +C + DO JEMET=1,NEMET + JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (JE-1)*NTHE + &TA*NPHI +(JTHETA-1)*NPHI + JPHI + SF_1=SF_1+TAB(JLIN,2) + SR_1=SR_1+TAB(JLIN,1) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=SF2_1+TAB(JLIN2,2) + SR2_1=SR2_1+TAB(JLIN2,1) + ENDIF + IF(IDICHR.GE.1) THEN + SF_2=SF_2+TAB(JLIN,4) + SR_2=SR_2+TAB(JLIN,3) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=SF2_2+TAB(JLIN2,4) + SR2_2=SR2_2+TAB(JLIN2,3) + ENDIF + ENDIF + ENDDO + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR + &_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &SR2_1,SF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S + &R_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + IF(JPLAN.GT.NONVOL(JFICH)) THEN + VOLDIF_1=VOLDIF_1+SF_1 + VOLDIR_1=VOLDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_1=VOLDIF2_1+SF2_1 + VOLDIR2_1=VOLDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + VOLDIF_2=VOLDIF_2+SF_2 + VOLDIR_2=VOLDIR_1+SR_2 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_2=VOLDIF2_2+SF2_2 + VOLDIR2_2=VOLDIR2_1+SR2_2 + ENDIF + ENDIF + ENDIF + TOTDIF_1=TOTDIF_1+SF_1 + TOTDIR_1=TOTDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=TOTDIF2_1+SF2_1 + TOTDIR2_1=TOTDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + TOTDIF_2=TOTDIF_2+SF_2 + TOTDIR_2=TOTDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_2=TOTDIF2_2+SF2_2 + TOTDIR2_2=TOTDIR2_2+SR2_2 + ENDIF + ENDIF + ENDDO + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOLD + &IR_1,VOLDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO + &LDIR2_1,VOLDIF2_1 + ENDIF + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOTD + &IR_1,TOTDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO + &TDIR2_1,TOTDIF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOL + &DIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V + &OLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2 + ENDIF + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOT + &DIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T + &OTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +C + ELSE +C +C........ ISOM not= 0 : multiple input files to be summed up .......... +C + READ(IUO2,7) NTHETA,NPHI,NE +C + IF(IPH_1.EQ.1) THEN + N_FIXED=NPHI + FIX0=PHI0 + FIX1=PHI1 + N_SCAN=NTHETA + ELSE + N_FIXED=NTHETA + FIX0=THETA0 + FIX1=THETA1 + IF(STEREO.EQ.'YES') THEN + NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001) + &+1 + IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 + ENDIF + N_SCAN=NPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + N_SCAN=2*N_SCAN + ENDIF +C + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + NDP=NTHETA*NPHI*NE + ELSEIF(I_EXT.EQ.-1) THEN + NDP=NTHETA*NPHI*NE*2 + ELSEIF(I_EXT.EQ.2) THEN + NDP=NTHETA*NE + N_FIXED=NTHETA + N_SCAN=NPHI + IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 + ENDIF +C + NTT=NFICHLEC*NDP + IF(NTT.GT.NDIM_M) GOTO 5 +C + IF(ISOM.EQ.1) THEN + NPLAN=NP + NF=NP + ELSEIF(ISOM.EQ.2) THEN + NEMET=NFICHLEC + NF=NFICHLEC + NPLAN=1 + ENDIF +C + DO JF=1,NF +C +C Reading the headers for each file: +C + IF(JF.GT.1) THEN + DO JLINE=1,NHEAD + READ(IUO2,888) HEAD(JLINE,JF) + ENDDO + ENDIF +C + DO JE=1,NE +C + DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1) + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(IPH_1.EQ.1) THEN + JPHI=J_FIXED + ELSE + THETA=THETA0+XINCRF + JTHETA=J_FIXED + IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12 + ENDIF + IF(STEREO.EQ.' NO') THEN + N_SCAN_R=N_SCAN + ELSE + RTHETA=THETA*0.017453 + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + ENDIF +C + DO J_SCAN=1,N_SCAN_R + IF(IPH_1.EQ.1) THEN + JTHETA=J_SCAN + ELSE + JPHI=J_SCAN + ENDIF +C + JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI + + &JPHI + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF +C + IF(ISOM.EQ.1) THEN + READ(IUO2,2) JPL + IF(JF.EQ.JPL) THEN + BACKSPACE IUO2 + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN( + &JE),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN + &(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),EC + &IN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ELSE + BACKSPACE IUO2 + DO JLINE=1,NHEAD + BACKSPACE IUO2 + ENDDO + DO JL=JLIN,JF*NDP + TAB(JL,1)=0.0 + TAB(JL,2)=0.0 + TAB(JL,3)=0.0 + TAB(JL,4)=0.0 + ENDDO + GOTO 13 + ENDIF + ELSEIF(ISOM.EQ.2) THEN + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN + &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ENDIF + ENDDO + 12 CONTINUE + ENDDO + ENDDO + 13 CONTINUE + ENDDO +C + REWIND IUO2 +C +C Writing the headers: +C + DO JLINE=1,2 + WRITE(IUO2,888) HEAD(JLINE,1) + ENDDO + DO JF=1,NFICHLEC + DO JLINE=3,6 + WRITE(IUO2,888) HEAD(JLINE,JF) + ENDDO + WRITE(IUO2,888) HEAD(2,JF) + ENDDO + DO JLINE=7,NHEAD + WRITE(IUO2,888) HEAD(JLINE,1) + ENDDO +C + WRITE(IUO2,15) SPECTRO,OUTDATA + WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM +C + IF(ISOM.EQ.1) THEN +C + DO JE=1,NE +C + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R +C + TOTDIF_1=0. + TOTDIR_1=0. + VOLDIF_1=0. + VOLDIR_1=0. + TOTDIF_2=0. + TOTDIR_2=0. + VOLDIF_2=0. + VOLDIR_2=0. + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=0. + TOTDIR2_1=0. + VOLDIF2_1=0. + VOLDIR2_1=0. + TOTDIF2_2=0. + TOTDIR2_2=0. + VOLDIF2_2=0. + VOLDIR2_2=0. + ENDIF +C + DO JPLAN=1,NPLAN + JF=JPLAN +C + JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JP + &HI +C + SR_1=TAB(JLIN,1) + SF_1=TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=TAB(JLIN2,2) + SR2_1=TAB(JLIN2,1) + ENDIF + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &SR_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),SR2_1,SF2_1 + ENDIF + ELSE + SR_2=TAB(JLIN,3) + SF_2=TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=TAB(JLIN2,4) + SR2_2=TAB(JLIN2,3) + ENDIF + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,SR_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + IF(NONVOL(JPLAN).EQ.0) THEN + VOLDIF_1=VOLDIF_1+SF_1 + VOLDIR_1=VOLDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_1=VOLDIF2_1+SF2_1 + VOLDIR2_1=VOLDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + VOLDIF_2=VOLDIF_2+SF_2 + VOLDIR_2=VOLDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_2=VOLDIF2_2+SF2_2 + VOLDIR2_2=VOLDIR2_1+SR2_2 + ENDIF + ENDIF + ENDIF + TOTDIF_1=TOTDIF_1+SF_1 + TOTDIR_1=TOTDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=TOTDIF2_1+SF2_1 + TOTDIR2_1=TOTDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + TOTDIF_2=TOTDIF_2+SF_2 + TOTDIR_2=TOTDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_2=TOTDIF2_2+SF2_2 + TOTDIR2_2=TOTDIR2_2+SR2_2 + ENDIF + ENDIF + ENDDO +C + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO + &LDIR_1,VOLDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &VOLDIR2_1,VOLDIF2_1 + ENDIF + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO + &TDIR_1,TOTDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + &TOTDIR2_1,TOTDIF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V + &OLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2 + ENDIF + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T + &OTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) + &,TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2 + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO + ELSEIF(ISOM.EQ.2) THEN + DO JE=1,NE +C + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R +C + SF_1=0. + SR_1=0. + SF_2=0. + SR_2=0. + IF(I_EXT.EQ.-1) THEN + SF2_1=0. + SR2_1=0. + SF2_2=0. + SR2_2=0. + ENDIF +C + DO JEMET=1,NEMET + JF=JEMET +C + JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + J + &PHI +C + SF_1=SF_1+TAB(JLIN,2) + SR_1=SR_1+TAB(JLIN,1) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=SF2_1+TAB(JLIN2,2) + SR2_1=SR2_1+TAB(JLIN2,1) + ENDIF + IF(IDICHR.GE.1) THEN + SF_2=SF_2+TAB(JLIN,4) + SR_2=SR_2+TAB(JLIN,3) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=SF2_2+TAB(JLIN2,4) + SR2_2=SR2_2+TAB(JLIN2,3) + ENDIF + ENDIF + ENDDO + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR + &_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE + &),SR2_1,SF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S + &R_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J + &E),SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +C + GOTO 6 +C + 5 WRITE(IUO1,4) + STOP + 35 WRITE(IUO1,36) N_FIXED + STOP + 37 WRITE(IUO1,38) NTHETA*NPHI + STOP +C + 1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4) + 2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN + &THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>') + 7 FORMAT(I4,2X,I4,2X,I4) + 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 9 FORMAT(9(2X,I1),2X,I2) + 15 FORMAT(2X,A3,11X,A13) + 22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1 + &2.6,2X,E12.6) + 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) + 25 FORMAT(37X,E12.6,2X,E12.6) + 36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL ', + &'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<< + &SHOULD BE AT LEAST ',I6,' >>>>>>>>>>') + 38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE I + &NCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE AT + &LEAST ',I6,' >>>>>>>>>>') + 888 FORMAT(A72) +C + 6 RETURN +C + END diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/weight_sum.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/weight_sum.f new file mode 100644 index 0000000..0db9ffc --- /dev/null +++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/weight_sum.f @@ -0,0 +1,335 @@ +C +C======================================================================= +C + SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL) +C +C This subroutine performs a weighted sum of the results +C corresponding to different directions of the detector. +C The directions and weights are read from an external input file +C +C JEL is the electron undetected (i.e. for which the outgoing +C directions are integrated over the unit sphere). It is always +C 1 for one electron spectroscopies (PHD). For APECS, It can be +C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron +C detected) +C +C Last modified : 31 Jan 2007 +C + USE DIM_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE OUTUNITS_MOD +C +C + PARAMETER(N_MAX=5810,NPM=20) +C + REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M) + REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX) + REAL*4 SR_1,SF_1,SR_2,SF_2 + REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX) + REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX) +C + CHARACTER*3 SPECTRO,SPECTRO2 + CHARACTER*5 LIKE + CHARACTER*13 OUTDATA +C +C +C +C + DATA JVOL,JTOT/0,-1/ + DATA LIKE /'-like'/ +C + REWIND IUO2 +C + READ(IUO2,15) SPECTRO,OUTDATA + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + SPECTRO2='XAS' + ELSE + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I + &THETA_A,IE_A + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + READ(IUO2,8) NPHI_A,NTHETA_A + IF(JEL.EQ.1) THEN + SPECTRO2='AED' + ELSEIF(JEL.EQ.2) THEN + SPECTRO2='PHD' + ELSEIF(JEL.EQ.0) THEN + SPECTRO2='XAS' + ENDIF + ENDIF +C + IF(NPLAN.GT.NPM) THEN + WRITE(IUO1,4) NPLAN+2 + STOP + ENDIF +C +C Reading the number of angular points +C + IF(SPECTRO.NE.'APC') THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + N_POINTS_A=1 + ELSE + IF(JEL.EQ.1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT_A.EQ.0) THEN + N_POINTS_A=NTHETA_A*NPHI_A + ELSE + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA_A + NPHI0=NPHI_A + ELSEIF(JEL.EQ.2) THEN + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT.EQ.0) THEN + N_POINTS=NTHETA*NPHI + ELSE + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA + NPHI0=NPHI + ELSEIF(JEL.EQ.0) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI9,1) N_POINTS_A + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + ENDIF +C + IF(SPECTRO.NE.'APC') THEN + NANGLE=1 + ELSE + IF(JEL.EQ.1) THEN + NANGLE=N_POINTS_A + ELSEIF(JEL.EQ.2) THEN + NANGLE=N_POINTS + ELSEIF(JEL.EQ.0) THEN + NANGLE=1 + ENDIF + ENDIF +C +C Initialization of the arrays +C + DO JE=1,NE + DO JANGLE=1,NANGLE + DO JPLAN=1,NPLAN+2 + SUMR_1(JPLAN,JE,JANGLE)=0. + SUMF_1(JPLAN,JE,JANGLE)=0. + IF(IDICHR.GT.0) THEN + SUMR_2(JPLAN,JE,JANGLE)=0. + SUMF_2(JPLAN,JE,JANGLE)=0. + ENDIF + ENDDO + ENDDO + ENDDO +C +C Reading of the data to be angle integrated +C + DO JE=1,NE +C + DO JANGLE=1,N_POINTS + IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE) + DO JANGLE_A=1,N_POINTS_A + IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN + READ(IUI9,2) THA,PHA,W_A(JANGLE_A) + ENDIF +C + DO JPLAN=1,NPLAN+2 +C + IF(IDICHR.EQ.0) THEN + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE) + &,SR_1,SF_1 + ELSE + READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1 + ENDIF + ELSE + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),SR_1,SF_1,SR_2,SF_2 + ELSE + READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2 + ENDIF + ENDIF +C + IF(JEL.EQ.1) THEN + SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1 + &*W(JANGLE) + SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1 + &*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A + &(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A + &(JANGLE_A) + ENDIF + IF(IDICHR.GT.0) THEN + IF(JEL.EQ.1) THEN + SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR + &_2*W(JANGLE) + SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF + &_2*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W + &_A(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W + &_A(JANGLE_A) + ENDIF + ENDIF +C + ENDDO +C + ENDDO + IF(I_EXT_A.NE.0) THEN + REWIND IUI9 + READ(IUI9,1) NDUM + READ(IUI9,1) NDUM + ENDIF + ENDDO +C + IF(I_EXT.NE.0) THEN + REWIND IUI6 + READ(IUI6,1) NDUM + READ(IUI6,1) NDUM + ENDIF + ENDDO +C + CLOSE(IUI6) + CLOSE(IUI9) + REWIND IUO2 +C + WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP + WRITE(IUO2,18) NE,NPLAN,ISOM + ELSEIF(JEL.EQ.1) THEN + WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A + &,ITHETA_A,IE_A + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ELSEIF(JEL.EQ.2) THEN + WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ENDIF +C + DO JE=1,NE + DO JANGLE=1,NANGLE + IF(SPECTRO.EQ.'APC') THEN + IF(JEL.EQ.1) THEN + THETA=DTHETAA(JANGLE) + PHI=DPHIA(JANGLE) + ELSEIF(JEL.EQ.2) THEN + THETA=DTHETA(JANGLE) + PHI=DPHI(JANGLE) + ENDIF + ENDIF +C + DO JPLAN=1,NPLAN + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE) + ELSE + WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG + &LE) + ELSE + WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL + &AN,JE,JANGLE) + ENDIF + ENDIF + ENDDO +C + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE) + ELSE + WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE + &,JANGLE) + WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE + &,JANGLE) + ELSE + WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2( + &NPLAN+1,JE,JANGLE) + WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2( + &NPLAN+2,JE,JANGLE) + ENDIF + ENDIF +C + ENDDO + ENDDO +C + 1 FORMAT(13X,I4) + 2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6) + 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN + &THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>') + 5 FORMAT(6X,I1,1X,I3,3X,I3) + 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 9 FORMAT(9(2X,I1),2X,I2) + 13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6) + 15 FORMAT(2X,A3,11X,A13) + 16 FORMAT(2X,A3,A5,1X,A3,2X,A13) + 18 FORMAT(I4,2X,I3,2X,I1) + 19 FORMAT(4(2X,I1)) + 20 FORMAT(8(2X,I1)) + 21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) + 24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6,2X,E12.6,2X,E12.6) + 33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6) + 34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6) + 44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/prog.f b/src/msspec/spec/fortran/prog.f deleted file mode 100644 index 0a2de49..0000000 --- a/src/msspec/spec/fortran/prog.f +++ /dev/null @@ -1,13 +0,0 @@ - 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/renormalization.f b/src/msspec/spec/fortran/renormalization/renormalization.f similarity index 100% rename from src/msspec/spec/fortran/renormalization.f rename to src/msspec/spec/fortran/renormalization/renormalization.f diff --git a/src/msspec/spec/fortran/spec.f b/src/msspec/spec/fortran/spec.f deleted file mode 100644 index 681b1d5..0000000 --- a/src/msspec/spec/fortran/spec.f +++ /dev/null @@ -1,13322 +0,0 @@ -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) -C! 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 -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 RENORM_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 - READ(ICOM,50) I_REN,N_REN,REN_R,REN_I -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 - WRITE(IUO1,150) I_REN,N_REN,REN_R,REN_I -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 Computing the renormalization coefficients -C - IF(I_REN.LE.4) THEN - CALL COEF_RENORM(NDIF) - ELSEIF(I_REN.EQ.5) THEN - CALL COEF_LOEWDIN(NDIF) - 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) - 50 FORMAT(9X,I1,9X,I1,6X,F8.3,2X,F8.3) -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') - 150 FORMAT(12X,I1,9X,I1,6X,F8.3,2X,F8.3,5X,'I_REN,N_REN,REN_R,REN_I') -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 C_RENORM_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 RENORM_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 Renormalization of the path -C - IF(I_REN.GE.1) THEN - COEF=COEF*C_REN(JORDP) - write(354,*) JORDP,C_REN(JORDP) - ENDIF -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 C_RENORM_MOD - 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 RENORM_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 - IF(I_REN.GE.1) R2=R2*C_REN(0) - 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