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
This commit is contained in:
parent
47adb16ccc
commit
93782236b0
|
|
@ -1,2 +1,18 @@
|
||||||
|
import ase
|
||||||
from .version import __version__
|
from .version import __version__
|
||||||
|
from .misc import LOGGER
|
||||||
|
|
||||||
__sha__ = "$Id$"
|
__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()
|
||||||
|
|
|
||||||
|
|
@ -678,7 +678,10 @@ class SpecIO(object):
|
||||||
else:
|
else:
|
||||||
ibwd_arr = np.zeros((nat), dtype=np.int)
|
ibwd_arr = np.zeros((nat), dtype=np.int)
|
||||||
thbwd_arr = np.ones((nat))
|
thbwd_arr = np.ones((nat))
|
||||||
|
print("nat", nat)
|
||||||
|
print("thbwd_arr", thbwd_arr)
|
||||||
for at in p.extra_atoms:
|
for at in p.extra_atoms:
|
||||||
|
print(at)
|
||||||
i = at.get('proto_index') - 1
|
i = at.get('proto_index') - 1
|
||||||
thfwd_arr[i] = at.get('forward_angle')
|
thfwd_arr[i] = at.get('forward_angle')
|
||||||
thbwd_arr[i] = at.get('backward_angle')
|
thbwd_arr[i] = at.get('backward_angle')
|
||||||
|
|
|
||||||
|
|
@ -59,42 +59,15 @@ from msspec.parameters import (PhagenParameters, PhagenMallocParameters,
|
||||||
PEDParameters, EIGParameters)
|
PEDParameters, EIGParameters)
|
||||||
from msspec.calcio import PhagenIO, SpecIO
|
from msspec.calcio import PhagenIO, SpecIO
|
||||||
|
|
||||||
from msspec.phagen.libphagen import main as do_phagen
|
from msspec.phagen.fortran.libphagen import main as do_phagen
|
||||||
from msspec.spec.libspec import run as do_spec
|
|
||||||
|
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
|
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):
|
class _MSCALCULATOR(Calculator):
|
||||||
"""
|
"""
|
||||||
This class defines an ASE calculator for doing Multiple scattering
|
This class defines an ASE calculator for doing Multiple scattering
|
||||||
|
|
@ -146,9 +119,8 @@ class _MSCALCULATOR(Calculator):
|
||||||
elif spectroscopy == 'EIG':
|
elif spectroscopy == 'EIG':
|
||||||
self.spectroscopy_parameters = EIGParameters(self.phagen_parameters,
|
self.spectroscopy_parameters = EIGParameters(self.phagen_parameters,
|
||||||
self.spec_parameters)
|
self.spec_parameters)
|
||||||
#pass
|
|
||||||
else:
|
else:
|
||||||
raise NameError('No such spectrosopy')
|
raise NameError('No such spectroscopy')
|
||||||
|
|
||||||
self.source_parameters = SourceParameters(self.global_parameters,
|
self.source_parameters = SourceParameters(self.global_parameters,
|
||||||
self.phagen_parameters,
|
self.phagen_parameters,
|
||||||
|
|
@ -210,30 +182,30 @@ class _MSCALCULATOR(Calculator):
|
||||||
|
|
||||||
#os.chdir(self.tmp_folder)
|
#os.chdir(self.tmp_folder)
|
||||||
|
|
||||||
inv = cor = 'NO'
|
#inv = cor = 'NO'
|
||||||
if algorithm == 'expansion':
|
#if algorithm == 'expansion':
|
||||||
pass
|
# pass
|
||||||
elif algorithm == 'inversion':
|
#elif algorithm == 'inversion':
|
||||||
inv = 'YES'
|
# inv = 'YES'
|
||||||
elif algorithm == 'correlation':
|
#elif algorithm == 'correlation':
|
||||||
cor = 'YES'
|
# cor = 'YES'
|
||||||
|
|
||||||
# spin orbit resolved (not yet)
|
# spin orbit resolved (not yet)
|
||||||
sorb = 'NO'
|
#sorb = 'NO'
|
||||||
|
|
||||||
# spin resolved
|
# spin resolved
|
||||||
dichro_spinpol = False
|
#dichro_spinpol = False
|
||||||
if dichroism in ('sum_over_spin', 'spin_resolved'):
|
#if dichroism in ('sum_over_spin', 'spin_resolved'):
|
||||||
dichro_spinpol = True
|
dichro_spinpol = True
|
||||||
|
|
||||||
spin = 'NO'
|
#spin = 'NO'
|
||||||
if spinpol or dichro_spinpol:
|
#if spinpol or dichro_spinpol:
|
||||||
spin = 'YES'
|
# spin = 'YES'
|
||||||
|
|
||||||
if spin == 'YES':
|
#if spin == 'YES':
|
||||||
LOGGER.error('Option not implemented!')
|
# LOGGER.error('Option not implemented!')
|
||||||
raise NotImplementedError(
|
# raise NotImplementedError(
|
||||||
'Spin polarization is not implemeted yet!')
|
# 'Spin polarization is not implemeted yet!')
|
||||||
|
|
||||||
|
|
||||||
calctype_spectro = self.spec_parameters.get_parameter('calctype_spectro')
|
calctype_spectro = self.spec_parameters.get_parameter('calctype_spectro')
|
||||||
|
|
@ -376,6 +348,29 @@ class _MSCALCULATOR(Calculator):
|
||||||
for key, value in requirements.items():
|
for key, value in requirements.items():
|
||||||
setattr(self.spec_malloc_parameters, key, value)
|
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
|
# cannot use this, unfortunately
|
||||||
#do_spec(*requirements.values())
|
#do_spec(*requirements.values())
|
||||||
do_spec(
|
do_spec(
|
||||||
|
|
@ -893,7 +888,7 @@ class _EIG(_MSCALCULATOR):
|
||||||
|
|
||||||
# update the parameters
|
# update the parameters
|
||||||
self.scan_parameters.set_parameter('kinetic_energy', kinetic_energy)
|
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):
|
if np.any(all_ke < 0):
|
||||||
LOGGER.error('Source energy is not high enough or level too deep!')
|
LOGGER.error('Source energy is not high enough or level too deep!')
|
||||||
raise ValueError('Kinetic energy is < 0! ({})'.format(
|
raise ValueError('Kinetic energy is < 0! ({})'.format(
|
||||||
|
|
|
||||||
|
|
@ -536,9 +536,9 @@ class SpecParameters(BaseParameters):
|
||||||
default=3, fmt='d'),
|
default=3, fmt='d'),
|
||||||
Parameter('eigval_ispectrum_ne', types=int, limits=[0, 1],
|
Parameter('eigval_ispectrum_ne', types=int, limits=[0, 1],
|
||||||
default=1, fmt='d'),
|
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'),
|
fmt='d'),
|
||||||
Parameter('eigval_method', types=str, default='EPSI',
|
Parameter('eigval_method', types=str, default='AITK',
|
||||||
allowed_values=['AITK', 'RICH', 'SALZ', 'EPSI', 'EPSG',
|
allowed_values=['AITK', 'RICH', 'SALZ', 'EPSI', 'EPSG',
|
||||||
'RHOA', 'THET', 'LEGE', 'CHEB', 'OVER',
|
'RHOA', 'THET', 'LEGE', 'CHEB', 'OVER',
|
||||||
'DURB', 'DLEV', 'TLEV', 'ULEV', 'VLEV',
|
'DURB', 'DLEV', 'TLEV', 'ULEV', 'VLEV',
|
||||||
|
|
@ -802,6 +802,17 @@ class GlobalParameters(BaseParameters):
|
||||||
self.phagen_parameters.calctype = phagen_calctype
|
self.phagen_parameters.calctype = phagen_calctype
|
||||||
self.spec_parameters.calctype_spectro = spec_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):
|
class MuffintinParameters(BaseParameters):
|
||||||
def __init__(self, phagen_parameters, spec_parameters):
|
def __init__(self, phagen_parameters, spec_parameters):
|
||||||
parameters = (
|
parameters = (
|
||||||
|
|
@ -1372,7 +1383,7 @@ class CalculationParameters(BaseParameters):
|
||||||
doc=textwrap.dedent("""
|
doc=textwrap.dedent("""
|
||||||
The scattering order. Only meaningful for the 'expansion' algorithm.
|
The scattering order. Only meaningful for the 'expansion' algorithm.
|
||||||
Its value is limited to 10.""")),
|
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,
|
types=(type(None), str), default=None,
|
||||||
doc=textwrap.dedent("""
|
doc=textwrap.dedent("""
|
||||||
Enable the calculation of the coefficients for the renormalization of
|
Enable the calculation of the coefficients for the renormalization of
|
||||||
|
|
@ -1512,9 +1523,9 @@ class CalculationParameters(BaseParameters):
|
||||||
if p.value is None:
|
if p.value is None:
|
||||||
self.spec_parameters.calc_iren = 0
|
self.spec_parameters.calc_iren = 0
|
||||||
else:
|
else:
|
||||||
if p.value.lower() == 'Sigma_n'.lower():
|
if p.value.lower() == 'G_n'.lower():
|
||||||
self.spec_parameters.calc_iren = 1
|
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
|
self.spec_parameters.calc_iren = 2
|
||||||
LOGGER.info("Renormalization activated with \'{}\' method".format(p.value))
|
LOGGER.info("Renormalization activated with \'{}\' method".format(p.value))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -17,13 +17,13 @@ endif
|
||||||
|
|
||||||
.PHONY: clean
|
.PHONY: clean
|
||||||
|
|
||||||
pybinding: libphagen.so
|
pybinding: libphagen
|
||||||
|
|
||||||
libphagen.so: $(objects) main.f
|
libphagen: $(objects) main.f
|
||||||
@echo "building Python binding..."
|
@echo "building Python binding..."
|
||||||
@$(F2PY) -I. $(objects) $(F2PY_OPTS)-c -m libphagen main.f
|
@$(F2PY) -I. $(objects) $(F2PY_OPTS)-c -m libphagen main.f
|
||||||
@cp libphagen.cpython*.so ../
|
# @cp libphagen.cpython*.so ../
|
||||||
@mv libphagen.cpython*.so libphagen.so
|
# @mv libphagen.cpython*.so libphagen.so
|
||||||
|
|
||||||
$(objects): $(objects_src)
|
$(objects): $(objects_src)
|
||||||
@echo "compiling subroutines and functions for phagen..."
|
@echo "compiling subroutines and functions for phagen..."
|
||||||
|
|
@ -31,5 +31,4 @@ $(objects): $(objects_src)
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
@echo "cleaning..."
|
@echo "cleaning..."
|
||||||
@rm -rf *.so *.o *.mod
|
@rm -rf *.o *.mod
|
||||||
@rm -rf ../*.so
|
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,37 @@ F2PY_OPTS:=
|
||||||
|
|
||||||
DEBUG:=0
|
DEBUG:=0
|
||||||
|
|
||||||
objects_src := dim_mod.f modules.f renormalization.f allocation.f spec.f
|
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))
|
objects:=$(patsubst %.f,%.o, $(objects_src))
|
||||||
|
|
||||||
EXE=prog
|
EXE=prog
|
||||||
|
|
@ -16,32 +46,35 @@ ifeq ($(DEBUG),1)
|
||||||
F2PY_OPTS:=$(F2PY_OPTS) --debug-capi --debug
|
F2PY_OPTS:=$(F2PY_OPTS) --debug-capi --debug
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
export COMP
|
||||||
|
export COMP_OPTS
|
||||||
|
|
||||||
|
|
||||||
.PHONY: clean
|
.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..."
|
@echo "building Python binding..."
|
||||||
@$(F2PY) -I. $(objects) $(F2PY_OPTS) -c -m libspec main.f
|
@$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ phd_se_noso_nosp_nosym/main.f
|
||||||
@cp libspec.cpython*.so ../
|
# @cp $@.cpython*.so ../
|
||||||
@mv libspec.cpython*.so libspec.so
|
|
||||||
|
|
||||||
exe: $(objects) prog.f
|
eig_mi: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(eig_common_obj) $(eig_mi_obj)
|
||||||
@$(COMP) -c main.f
|
@echo "building Python binding..."
|
||||||
@$(COMP) -c prog.f
|
@$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ eig/mi/main.f
|
||||||
@$(COMP) -o $(EXE) $(objects) main.o prog.o
|
# @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)
|
%.o: %.f
|
||||||
@echo "compiling subroutines and functions for spec..."
|
@echo "compiling $@..."
|
||||||
# $(COMP) -cpp -fPIC -O2 -ffast-math -mcmodel=large -fdefault-real-4 -c $^
|
@$(COMP) $(COMP_OPTS) -I./memalloc/ -fPIC -o $@ -c $^
|
||||||
# @$(COMP) $(OPTS) -fPIC -mcmodel=large -c $^
|
|
||||||
@$(COMP) $(COMP_OPTS) -fPIC -c $^
|
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
@echo "cleaning..."
|
@echo "cleaning..."
|
||||||
@rm -rf *.so *.o *.mod
|
@rm -rf *.o *.mod
|
||||||
@rm -rf $(EXE)
|
@rm -rf $(objects)
|
||||||
@rm -rf ../*.so
|
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -10,7 +10,6 @@
|
||||||
USE BASES_MOD
|
USE BASES_MOD
|
||||||
USE CLUSLIM_MOD
|
USE CLUSLIM_MOD
|
||||||
USE COOR_MOD
|
USE COOR_MOD
|
||||||
USE C_RENORM_MOD
|
|
||||||
USE DEBWAL_MOD
|
USE DEBWAL_MOD
|
||||||
USE INDAT_MOD
|
USE INDAT_MOD
|
||||||
USE INIT_A_MOD
|
USE INIT_A_MOD
|
||||||
|
|
@ -28,7 +27,6 @@
|
||||||
USE PARCAL_A_MOD
|
USE PARCAL_A_MOD
|
||||||
USE RELADS_MOD
|
USE RELADS_MOD
|
||||||
USE RELAX_MOD
|
USE RELAX_MOD
|
||||||
USE RENORM_MOD
|
|
||||||
USE RESEAU_MOD
|
USE RESEAU_MOD
|
||||||
USE SPIN_MOD
|
USE SPIN_MOD
|
||||||
USE TESTS_MOD
|
USE TESTS_MOD
|
||||||
|
|
@ -76,7 +74,13 @@
|
||||||
USE DIRECT_MOD
|
USE DIRECT_MOD
|
||||||
USE DIRECT_A_MOD
|
USE DIRECT_A_MOD
|
||||||
USE PATH_MOD
|
USE PATH_MOD
|
||||||
|
USE RENORM_MOD
|
||||||
|
USE C_RENORM_MOD
|
||||||
USE ROT_MOD
|
USE ROT_MOD
|
||||||
|
USE ROT_CUB_MOD
|
||||||
|
USE SYMMOP_MOD
|
||||||
|
USE TAU_PROT_MOD
|
||||||
|
USE TAUSYMMOP_MOD
|
||||||
USE TESTPA_MOD
|
USE TESTPA_MOD
|
||||||
USE TESTPB_MOD
|
USE TESTPB_MOD
|
||||||
USE TLDW_MOD
|
USE TLDW_MOD
|
||||||
|
|
@ -182,6 +186,10 @@
|
||||||
CALL ALLOC_DIRECT_A()
|
CALL ALLOC_DIRECT_A()
|
||||||
CALL ALLOC_PATH()
|
CALL ALLOC_PATH()
|
||||||
CALL ALLOC_ROT()
|
CALL ALLOC_ROT()
|
||||||
|
CALL ALLOC_ROT_CUB()
|
||||||
|
CALL ALLOC_SYMMOP()
|
||||||
|
CALL ALLOC_TAU_PROT()
|
||||||
|
CALL ALLOC_TAUSYMMOP()
|
||||||
CALL ALLOC_TESTPA()
|
CALL ALLOC_TESTPA()
|
||||||
CALL ALLOC_TESTPB()
|
CALL ALLOC_TESTPB()
|
||||||
CALL ALLOC_TLDW()
|
CALL ALLOC_TLDW()
|
||||||
|
|
@ -30,6 +30,7 @@ C ===============================================================
|
||||||
INTEGER NT_M
|
INTEGER NT_M
|
||||||
INTEGER NCG_M
|
INTEGER NCG_M
|
||||||
INTEGER N_BESS, N_GAUNT
|
INTEGER N_BESS, N_GAUNT
|
||||||
|
INTEGER NLTWO
|
||||||
C ===============================================================
|
C ===============================================================
|
||||||
CONTAINS
|
CONTAINS
|
||||||
SUBROUTINE INIT_DIM()
|
SUBROUTINE INIT_DIM()
|
||||||
|
|
@ -56,5 +57,7 @@ C ===============================================================
|
||||||
|
|
||||||
N_BESS=100*NL_M
|
N_BESS=100*NL_M
|
||||||
N_GAUNT=5*NL_M
|
N_GAUNT=5*NL_M
|
||||||
|
|
||||||
|
NLTWO=2*NL_M
|
||||||
END SUBROUTINE INIT_DIM
|
END SUBROUTINE INIT_DIM
|
||||||
END MODULE DIM_MOD
|
END MODULE DIM_MOD
|
||||||
|
|
@ -1416,6 +1416,134 @@ C=======================================================================
|
||||||
ALLOCATE(JPON(NPATH_M,NDIF_M))
|
ALLOCATE(JPON(NPATH_M,NDIF_M))
|
||||||
END SUBROUTINE ALLOC_PRINTP
|
END SUBROUTINE ALLOC_PRINTP
|
||||||
END MODULE PRINTP_MOD
|
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=======================================================================
|
C=======================================================================
|
||||||
MODULE RENORM_MOD
|
MODULE RENORM_MOD
|
||||||
IMPLICIT NONE
|
IMPLICIT NONE
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue