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

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:
Sylvain Tricot 2019-12-05 18:26:41 +01:00
parent 47adb16ccc
commit 93782236b0
112 changed files with 50652 additions and 13420 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/msspec/__init__.py
View File

@ -1,2 +1,18 @@
import ase
from .version import __version__
from .misc import LOGGER
__sha__ = "$Id$"
def init_msspec():
LOGGER.debug('Initialization of the msspec module')
ase.atom.names['mt_radius'] = ('mt_radii', 0.)
ase.atom.names['mt_radius_scale'] = ('mt_radii_scale', 1.)
ase.atom.names['proto_index'] = ('proto_indices', 1)
ase.atom.names['mean_square_vibration'] = ('mean_square_vibrations', 0.)
ase.atom.names['forward_angle'] = ('forward_angles', 20.)
ase.atom.names['backward_angle'] = ('backward_angles', 20.)
ase.atom.names['RA_cut_off'] = ('RA_cuts_off', 1)
ase.atoms.Atoms.absorber = None
init_msspec()

3
src/msspec/calcio.py
View File

@ -678,7 +678,10 @@ class SpecIO(object):
else:
ibwd_arr = np.zeros((nat), dtype=np.int)
thbwd_arr = np.ones((nat))
print("nat", nat)
print("thbwd_arr", thbwd_arr)
for at in p.extra_atoms:
print(at)
i = at.get('proto_index') - 1
thfwd_arr[i] = at.get('forward_angle')
thbwd_arr[i] = at.get('backward_angle')

99
src/msspec/calculator.py
View File

@ -59,42 +59,15 @@ from msspec.parameters import (PhagenParameters, PhagenMallocParameters,
PEDParameters, EIGParameters)
from msspec.calcio import PhagenIO, SpecIO
from msspec.phagen.libphagen import main as do_phagen
from msspec.spec.libspec import run as do_spec
from msspec.phagen.fortran.libphagen import main as do_phagen
from msspec.spec.fortran import phd_se_noso_nosp_nosym
from msspec.spec.fortran import eig_mi
from msspec.spec.fortran import eig_pw
from terminaltables.ascii_table import AsciiTable
#try:
# MSSPEC_ROOT = os.environ['MSSPEC_ROOT']
#except KeyError:
# cfg = Config()
# MSSPEC_ROOT = cfg.get('path')
#if MSSPEC_ROOT == str(None):
# raise NameError('No path to the MsSpec distribution found !!')
def init_msspec():
LOGGER.debug('Initialization of the msspec module')
ase.atom.names['mt_radius'] = ('mt_radii', 0.)
ase.atom.names['mt_radius_scale'] = ('mt_radii_scale', 1.)
ase.atom.names['proto_index'] = ('proto_indices', 1)
ase.atom.names['mean_square_vibration'] = ('mean_square_vibrations', 0.)
ase.atom.names['forward_angle'] = ('forward_angles', 20.)
ase.atom.names['backward_angle'] = ('backward_angles', 20.)
ase.atom.names['RA_cut_off'] = ('RA_cuts_off', 1)
ase.atoms.Atoms.absorber = None
init_msspec()
class _MSCALCULATOR(Calculator):
"""
This class defines an ASE calculator for doing Multiple scattering
@ -146,9 +119,8 @@ class _MSCALCULATOR(Calculator):
elif spectroscopy == 'EIG':
self.spectroscopy_parameters = EIGParameters(self.phagen_parameters,
self.spec_parameters)
#pass
else:
raise NameError('No such spectrosopy')
raise NameError('No such spectroscopy')
self.source_parameters = SourceParameters(self.global_parameters,
self.phagen_parameters,
@ -210,30 +182,30 @@ class _MSCALCULATOR(Calculator):
#os.chdir(self.tmp_folder)
inv = cor = 'NO'
if algorithm == 'expansion':
pass
elif algorithm == 'inversion':
inv = 'YES'
elif algorithm == 'correlation':
cor = 'YES'
#inv = cor = 'NO'
#if algorithm == 'expansion':
# pass
#elif algorithm == 'inversion':
# inv = 'YES'
#elif algorithm == 'correlation':
# cor = 'YES'
# spin orbit resolved (not yet)
sorb = 'NO'
#sorb = 'NO'
# spin resolved
dichro_spinpol = False
if dichroism in ('sum_over_spin', 'spin_resolved'):
#dichro_spinpol = False
#if dichroism in ('sum_over_spin', 'spin_resolved'):
dichro_spinpol = True
spin = 'NO'
if spinpol or dichro_spinpol:
spin = 'YES'
#spin = 'NO'
#if spinpol or dichro_spinpol:
# spin = 'YES'
if spin == 'YES':
LOGGER.error('Option not implemented!')
raise NotImplementedError(
'Spin polarization is not implemeted yet!')
#if spin == 'YES':
# LOGGER.error('Option not implemented!')
# raise NotImplementedError(
# 'Spin polarization is not implemeted yet!')
calctype_spectro = self.spec_parameters.get_parameter('calctype_spectro')
@ -376,6 +348,29 @@ class _MSCALCULATOR(Calculator):
for key, value in requirements.items():
setattr(self.spec_malloc_parameters, key, value)
# Get the spec function to launch
if self.global_parameters.spectroscopy == 'PED':
if self.global_parameters.algorithm == 'expansion':
do_spec = phd_se_noso_nosp_nosym.run
else:
LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not "
"an allowed combination.".format(self.global_parameters.spectroscopy,
self.global_parameters.algorithm))
raise ValueError
elif self.global_parameters.spectroscopy == 'EIG':
if self.global_parameters.algorithm == 'inversion':
do_spec = eig_mi.run
elif self.global_parameters.algorithm == 'power':
do_spec = eig_pw.run
else:
LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not "
"an allowed combination.".format(self.global_parameters.spectroscopy,
self.global_parameters.algorithm))
raise ValueError
else:
LOGGER.error("\'{}\' spectroscopy is not supported yet.".format(self.global_parameters.spectroscopy))
raise NotImplementedError
# cannot use this, unfortunately
#do_spec(*requirements.values())
do_spec(
@ -893,7 +888,7 @@ class _EIG(_MSCALCULATOR):
# update the parameters
self.scan_parameters.set_parameter('kinetic_energy', kinetic_energy)
all_ke = self.scan_parameters.get_parameter('ke_array')
all_ke = self.scan_parameters.get_parameter('ke_array').value
if np.any(all_ke < 0):
LOGGER.error('Source energy is not high enough or level too deep!')
raise ValueError('Kinetic energy is < 0! ({})'.format(

21
src/msspec/parameters.py
View File

@ -536,9 +536,9 @@ class SpecParameters(BaseParameters):
default=3, fmt='d'),
Parameter('eigval_ispectrum_ne', types=int, limits=[0, 1],
default=1, fmt='d'),
Parameter('eigval_ipwm', types=int, limits=[-4, 4], default=1,
Parameter('eigval_ipwm', types=int, limits=[-4, 4], default=0,
fmt='d'),
Parameter('eigval_method', types=str, default='EPSI',
Parameter('eigval_method', types=str, default='AITK',
allowed_values=['AITK', 'RICH', 'SALZ', 'EPSI', 'EPSG',
'RHOA', 'THET', 'LEGE', 'CHEB', 'OVER',
'DURB', 'DLEV', 'TLEV', 'ULEV', 'VLEV',
@ -802,6 +802,17 @@ class GlobalParameters(BaseParameters):
self.phagen_parameters.calctype = phagen_calctype
self.spec_parameters.calctype_spectro = spec_calctype
def bind_spinpol(self, p):
if p.value == True:
LOGGER.error('Spin polarization is not yet enabled in the Python version.')
raise NotImplementedError
def bind_dichroism(self, p):
if p.value is not None:
LOGGER.error('Dichroism is not yet enabled in the Python version.')
raise NotImplemented
class MuffintinParameters(BaseParameters):
def __init__(self, phagen_parameters, spec_parameters):
parameters = (
@ -1372,7 +1383,7 @@ class CalculationParameters(BaseParameters):
doc=textwrap.dedent("""
The scattering order. Only meaningful for the 'expansion' algorithm.
Its value is limited to 10.""")),
Parameter('renormalization_mode', allowed_values=(None, 'Sigma_n', 'G_n'),
Parameter('renormalization_mode', allowed_values=(None, 'G_n', 'Sigma_n'),
types=(type(None), str), default=None,
doc=textwrap.dedent("""
Enable the calculation of the coefficients for the renormalization of
@ -1512,9 +1523,9 @@ class CalculationParameters(BaseParameters):
if p.value is None:
self.spec_parameters.calc_iren = 0
else:
if p.value.lower() == 'Sigma_n'.lower():
if p.value.lower() == 'G_n'.lower():
self.spec_parameters.calc_iren = 1
elif p.value.lower() == 'G_n'.lower():
elif p.value.lower() == 'Sigma_n'.lower():
self.spec_parameters.calc_iren = 2
LOGGER.info("Renormalization activated with \'{}\' method".format(p.value))

11
src/msspec/phagen/fortran/Makefile
View File

@ -17,13 +17,13 @@ endif
.PHONY: clean
pybinding: libphagen.so
pybinding: libphagen
libphagen.so: $(objects) main.f
libphagen: $(objects) main.f
@echo "building Python binding..."
@$(F2PY) -I. $(objects) $(F2PY_OPTS)-c -m libphagen main.f
@cp libphagen.cpython*.so ../
@mv libphagen.cpython*.so libphagen.so
# @cp libphagen.cpython*.so ../
# @mv libphagen.cpython*.so libphagen.so
$(objects): $(objects_src)
@echo "compiling subroutines and functions for phagen..."
@ -31,5 +31,4 @@ $(objects): $(objects_src)
clean:
@echo "cleaning..."
@rm -rf *.so *.o *.mod
@rm -rf ../*.so
@rm -rf *.o *.mod

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

@ -6,7 +6,37 @@ F2PY_OPTS:=
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))
EXE=prog
@ -16,32 +46,35 @@ ifeq ($(DEBUG),1)
F2PY_OPTS:=$(F2PY_OPTS) --debug-capi --debug
endif
export COMP
export COMP_OPTS
.PHONY: clean
pybinding: libspec.so
libspec.so: $(objects) main.f
pybinding: phd_se_noso_nosp_nosym eig_mi eig_pw
phd_se_noso_nosp_nosym: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(phd_se_noso_nosp_nosym_obj)
@echo "building Python binding..."
@$(F2PY) -I. $(objects) $(F2PY_OPTS) -c -m libspec main.f
@cp libspec.cpython*.so ../
@mv libspec.cpython*.so libspec.so
@$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ phd_se_noso_nosp_nosym/main.f
# @cp $@.cpython*.so ../
exe: $(objects) prog.f
@$(COMP) -c main.f
@$(COMP) -c prog.f
@$(COMP) -o $(EXE) $(objects) main.o prog.o
eig_mi: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(eig_common_obj) $(eig_mi_obj)
@echo "building Python binding..."
@$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ eig/mi/main.f
# @cp $@.cpython*.so ../
eig_pw: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(eig_common_obj) $(eig_pw_obj)
@echo "building Python binding..."
@$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ eig/pw/main.f
# @cp $@.cpython*.so ../
$(objects): $(objects_src)
@echo "compiling subroutines and functions for spec..."
# $(COMP) -cpp -fPIC -O2 -ffast-math -mcmodel=large -fdefault-real-4 -c $^
# @$(COMP) $(OPTS) -fPIC -mcmodel=large -c $^
@$(COMP) $(COMP_OPTS) -fPIC -c $^
%.o: %.f
@echo "compiling $@..."
@$(COMP) $(COMP_OPTS) -I./memalloc/ -fPIC -o $@ -c $^
clean:
@echo "cleaning..."
@rm -rf *.so *.o *.mod
@rm -rf $(EXE)
@rm -rf ../*.so
@rm -rf *.o *.mod
@rm -rf $(objects)

142
src/msspec/spec/fortran/cluster_gen/amas.f Normal file
View File

@ -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

130
src/msspec/spec/fortran/cluster_gen/base.f Normal file
View File

@ -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

61
src/msspec/spec/fortran/cluster_gen/centre.f Normal file
View File

@ -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

30
src/msspec/spec/fortran/cluster_gen/chbase.f Normal file
View File

@ -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

18
src/msspec/spec/fortran/cluster_gen/chnot.f Normal file
View File

@ -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

43
src/msspec/spec/fortran/cluster_gen/invmat.f Normal file
View File

@ -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

30
src/msspec/spec/fortran/cluster_gen/mulmat.f Normal file
View File

@ -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

44
src/msspec/spec/fortran/cluster_gen/numat.f Normal file
View File

@ -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

220
src/msspec/spec/fortran/cluster_gen/rela.f Normal file
View File

@ -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

132
src/msspec/spec/fortran/cluster_gen/rotbas.f Normal file
View File

@ -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

22
src/msspec/spec/fortran/cluster_gen/rzb110.f Normal file
View File

@ -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

22
src/msspec/spec/fortran/cluster_gen/test.f Normal file
View File

@ -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

43
src/msspec/spec/fortran/cluster_gen/test1.f Normal file
View File

@ -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

28
src/msspec/spec/fortran/common_sub/arcsin.f Normal file
View File

@ -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

51
src/msspec/spec/fortran/common_sub/atdata.f Normal file
View File

@ -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

39
src/msspec/spec/fortran/common_sub/auger_mult.f Normal file
View File

@ -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

159
src/msspec/spec/fortran/common_sub/besphe.f Normal file
View File

@ -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

156
src/msspec/spec/fortran/common_sub/besphe2.f Normal file
View File

@ -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

97
src/msspec/spec/fortran/common_sub/check_vib.f Normal file
View File

@ -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

190
src/msspec/spec/fortran/common_sub/diran.f Normal file
View File

@ -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

171
src/msspec/spec/fortran/common_sub/djmn.f Normal file
View File

@ -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

191
src/msspec/spec/fortran/common_sub/djmn2.f Normal file
View File

@ -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

52
src/msspec/spec/fortran/common_sub/emett.f Normal file
View File

@ -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

50
src/msspec/spec/fortran/common_sub/euler.f Normal file
View File

@ -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

108
src/msspec/spec/fortran/common_sub/gaunt.f Normal file
View File

@ -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

108
src/msspec/spec/fortran/common_sub/gaunt2.f Normal file
View File

@ -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

61
src/msspec/spec/fortran/common_sub/harsph.f Normal file
View File

@ -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

34
src/msspec/spec/fortran/common_sub/harsph2.f Normal file
View File

@ -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

70
src/msspec/spec/fortran/common_sub/harsph3.f Normal file
View File

@ -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

250
src/msspec/spec/fortran/common_sub/headers.f Normal file
View File

@ -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

25
src/msspec/spec/fortran/common_sub/ig.f Normal file
View File

@ -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

37
src/msspec/spec/fortran/common_sub/locate.f Normal file
View File

@ -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

59
src/msspec/spec/fortran/common_sub/lpm.f Normal file
View File

@ -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

340
src/msspec/spec/fortran/common_sub/n_j.f Normal file
View File

@ -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

48
src/msspec/spec/fortran/common_sub/ordre.f Normal file
View File

@ -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

47
src/msspec/spec/fortran/common_sub/ordre2.f Normal file
View File

@ -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

43
src/msspec/spec/fortran/common_sub/plm.f Normal file
View File

@ -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

49
src/msspec/spec/fortran/common_sub/polhan.f Normal file
View File

@ -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

21
src/msspec/spec/fortran/common_sub/polleg.f Normal file
View File

@ -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

14
src/msspec/spec/fortran/common_sub/prscal.f Normal file
View File

@ -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

17
src/msspec/spec/fortran/common_sub/prvect.f Normal file
View File

@ -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

1932
src/msspec/spec/fortran/common_sub/read_data.f Normal file
View File

File diff suppressed because it is too large Load Diff

29
src/msspec/spec/fortran/common_sub/refrac.f Normal file
View File

@ -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

48
src/msspec/spec/fortran/common_sub/sig2.f Normal file
View File

@ -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

82
src/msspec/spec/fortran/common_sub/sixj_in.f Normal file
View File

@ -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

61
src/msspec/spec/fortran/common_sub/sph_har.f Normal file
View File

@ -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

67
src/msspec/spec/fortran/common_sub/sph_har2.f Normal file
View File

@ -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

59
src/msspec/spec/fortran/common_sub/stop_ext.f Normal file
View File

@ -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

197
src/msspec/spec/fortran/common_sub/stop_treat.f Normal file
View File

@ -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

72
src/msspec/spec/fortran/common_sub/sup_zeros.f Normal file
View File

@ -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

1850
src/msspec/spec/fortran/common_sub/sym_clus.f Normal file
View File

File diff suppressed because it is too large Load Diff

79
src/msspec/spec/fortran/common_sub/uj_sq.f Normal file
View File

@ -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

85
src/msspec/spec/fortran/eig/common/dwsph.f Normal file
View File

@ -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

261
src/msspec/spec/fortran/eig/common/eig_mat_ms.f Normal file
View File

@ -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

116
src/msspec/spec/fortran/eig/common/facdif1.f Normal file
View File

@ -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

21492
src/msspec/spec/fortran/eig/common/lapack_eig.f Normal file
View File

File diff suppressed because it is too large Load Diff

103
src/msspec/spec/fortran/eig/common/plotfd.f Normal file
View File

@ -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

189
src/msspec/spec/fortran/eig/mi/acc_conv.f Normal file
View File

@ -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

693
src/msspec/spec/fortran/eig/mi/acc_scal.f Normal file
View File

@ -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

96
src/msspec/spec/fortran/eig/mi/check_conv.f Normal file
View File

@ -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

89
src/msspec/spec/fortran/eig/mi/coefficients.f Normal file
View File

@ -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

32
src/msspec/spec/fortran/eig/mi/conv_series.f Normal file
View File

@ -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

1557
src/msspec/spec/fortran/eig/mi/do_main.f Normal file
View File

File diff suppressed because it is too large Load Diff

104
src/msspec/spec/fortran/eig/mi/eigdif_mi.f Normal file
View File

@ -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

38
src/msspec/spec/fortran/eig/mi/interp_points.f Normal file
View File

@ -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

191
src/msspec/spec/fortran/eig/mi/levin.f Normal file
View File

@ -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

0
src/msspec/spec/fortran/main.f → src/msspec/spec/fortran/eig/mi/main.f
View File

3972
src/msspec/spec/fortran/eig/mi/new.f.hidden Normal file
View File

File diff suppressed because it is too large Load Diff

78
src/msspec/spec/fortran/eig/mi/remain_series.f Normal file
View File

@ -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

348
src/msspec/spec/fortran/eig/mi/spec_rad_power.f Normal file
View File

@ -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

194
src/msspec/spec/fortran/eig/pw/acc_conv.f Normal file
View File

@ -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

693
src/msspec/spec/fortran/eig/pw/acc_scal.f Normal file
View File

@ -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

97
src/msspec/spec/fortran/eig/pw/check_conv.f Normal file
View File

@ -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

90
src/msspec/spec/fortran/eig/pw/coefficients.f Normal file
View File

@ -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

33
src/msspec/spec/fortran/eig/pw/conv_series.f Normal file
View File

@ -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

1558
src/msspec/spec/fortran/eig/pw/do_main.f Normal file
View File

File diff suppressed because it is too large Load Diff

115
src/msspec/spec/fortran/eig/pw/eigdif_mi.f Normal file
View File

@ -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

39
src/msspec/spec/fortran/eig/pw/interp_points.f Normal file
View File

@ -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

192
src/msspec/spec/fortran/eig/pw/levin.f Normal file
View File

@ -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

20
src/msspec/spec/fortran/eig/pw/main.f Normal file
View File

@ -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

2079
src/msspec/spec/fortran/eig/pw/new.f.hidden Normal file
View File

File diff suppressed because it is too large Load Diff

79
src/msspec/spec/fortran/eig/pw/remain_series.f Normal file
View File

@ -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

547
src/msspec/spec/fortran/eig/pw/spec_rad_power.f Normal file
View File

@ -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
&QUOTIENT:')
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

12
src/msspec/spec/fortran/allocation.f → src/msspec/spec/fortran/memalloc/allocation.f
View File

@ -10,7 +10,6 @@
USE BASES_MOD
USE CLUSLIM_MOD
USE COOR_MOD
USE C_RENORM_MOD
USE DEBWAL_MOD
USE INDAT_MOD
USE INIT_A_MOD
@ -28,7 +27,6 @@
USE PARCAL_A_MOD
USE RELADS_MOD
USE RELAX_MOD
USE RENORM_MOD
USE RESEAU_MOD
USE SPIN_MOD
USE TESTS_MOD
@ -76,7 +74,13 @@
USE DIRECT_MOD
USE DIRECT_A_MOD
USE PATH_MOD
USE RENORM_MOD
USE C_RENORM_MOD
USE ROT_MOD
USE ROT_CUB_MOD
USE SYMMOP_MOD
USE TAU_PROT_MOD
USE TAUSYMMOP_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TLDW_MOD
@ -182,6 +186,10 @@
CALL ALLOC_DIRECT_A()
CALL ALLOC_PATH()
CALL ALLOC_ROT()
CALL ALLOC_ROT_CUB()
CALL ALLOC_SYMMOP()
CALL ALLOC_TAU_PROT()
CALL ALLOC_TAUSYMMOP()
CALL ALLOC_TESTPA()
CALL ALLOC_TESTPB()
CALL ALLOC_TLDW()

3
src/msspec/spec/fortran/dim_mod.f → src/msspec/spec/fortran/memalloc/dim_mod.f
View File

@ -30,6 +30,7 @@ C ===============================================================
INTEGER NT_M
INTEGER NCG_M
INTEGER N_BESS, N_GAUNT
INTEGER NLTWO
C ===============================================================
CONTAINS
SUBROUTINE INIT_DIM()
@ -56,5 +57,7 @@ C ===============================================================
N_BESS=100*NL_M
N_GAUNT=5*NL_M
NLTWO=2*NL_M
END SUBROUTINE INIT_DIM
END MODULE DIM_MOD

128
src/msspec/spec/fortran/modules.f → src/msspec/spec/fortran/memalloc/modules.f
View File

@ -1416,6 +1416,134 @@ C=======================================================================
ALLOCATE(JPON(NPATH_M,NDIF_M))
END SUBROUTINE ALLOC_PRINTP
END MODULE PRINTP_MOD
C=======================================================================
MODULE ROT_CUB_MOD
IMPLICIT NONE
REAL*4, ALLOCATABLE, DIMENSION(:,:,:) :: R_PIS2
CONTAINS
SUBROUTINE ALLOC_ROT_CUB()
USE DIM_MOD
IF (ALLOCATED(R_PIS2)) THEN
DEALLOCATE(R_PIS2)
ENDIF
ALLOCATE(R_PIS2(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1))
END SUBROUTINE ALLOC_ROT_CUB
END MODULE ROT_CUB_MOD
C=======================================================================
MODULE SYMMOP_MOD
IMPLICIT NONE
REAL*4, ALLOCATABLE, DIMENSION(:) :: ZL
COMPLEX, ALLOCATABLE, DIMENSION(:) :: ZM1
COMPLEX, ALLOCATABLE, DIMENSION(:) :: ZM2
INTEGER, ALLOCATABLE, DIMENSION(:) :: IZ
CONTAINS
SUBROUTINE ALLOC_SYMMOP()
USE DIM_MOD
IF (ALLOCATED(ZL)) THEN
DEALLOCATE(ZL)
ENDIF
ALLOCATE(ZL(64))
IF (ALLOCATED(ZM1)) THEN
DEALLOCATE(ZM1)
ENDIF
ALLOCATE(ZM1(64))
IF (ALLOCATED(ZM2)) THEN
DEALLOCATE(ZM2)
ENDIF
ALLOCATE(ZM2(64))
IF (ALLOCATED(IZ)) THEN
DEALLOCATE(IZ)
ENDIF
ALLOCATE(IZ(64))
END SUBROUTINE ALLOC_SYMMOP
END MODULE SYMMOP_MOD
C=======================================================================
MODULE TAU_PROT_MOD
IMPLICIT NONE
REAL*4, ALLOCATABLE, DIMENSION(:) :: Z_L_P
COMPLEX, ALLOCATABLE, DIMENSION(:) :: Z_M_P
INTEGER, ALLOCATABLE, DIMENSION(:) :: I_Z_P
INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTEP_L
INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTEP_M
INTEGER, ALLOCATABLE, DIMENSION(:) :: I_LM
INTEGER, ALLOCATABLE, DIMENSION(:) :: I_REL_MP
CONTAINS
SUBROUTINE ALLOC_TAU_PROT()
USE DIM_MOD
IF (ALLOCATED(Z_L_P)) THEN
DEALLOCATE(Z_L_P)
ENDIF
ALLOCATE(Z_L_P(NATP_M))
IF (ALLOCATED(Z_M_P)) THEN
DEALLOCATE(Z_M_P)
ENDIF
ALLOCATE(Z_M_P(NATP_M))
IF (ALLOCATED(I_Z_P)) THEN
DEALLOCATE(I_Z_P)
ENDIF
ALLOCATE(I_Z_P(NATP_M))
IF (ALLOCATED(ISTEP_L)) THEN
DEALLOCATE(ISTEP_L)
ENDIF
ALLOCATE(ISTEP_L(NATP_M))
IF (ALLOCATED(ISTEP_M)) THEN
DEALLOCATE(ISTEP_M)
ENDIF
ALLOCATE(ISTEP_M(NATP_M))
IF (ALLOCATED(I_LM)) THEN
DEALLOCATE(I_LM)
ENDIF
ALLOCATE(I_LM(NATP_M))
IF (ALLOCATED(I_REL_MP)) THEN
DEALLOCATE(I_REL_MP)
ENDIF
ALLOCATE(I_REL_MP(NATP_M))
END SUBROUTINE ALLOC_TAU_PROT
END MODULE TAU_PROT_MOD
C=======================================================================
MODULE TAUSYMMOP_MOD
IMPLICIT NONE
REAL*4, ALLOCATABLE, DIMENSION(:,:) :: Z_L
COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: Z_M1
COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: Z_M2
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: I_Z
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISYM
INTEGER, ALLOCATABLE, DIMENSION(:) :: NSYM_G
INTEGER :: NSIZE_GR
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: S_INV
CONTAINS
SUBROUTINE ALLOC_TAUSYMMOP()
USE DIM_MOD
IF (ALLOCATED(Z_L)) THEN
DEALLOCATE(Z_L)
ENDIF
ALLOCATE(Z_L(NAT_EQ_M,NATP_M))
IF (ALLOCATED(Z_M1)) THEN
DEALLOCATE(Z_M1)
ENDIF
ALLOCATE(Z_M1(NAT_EQ_M,NATP_M))
IF (ALLOCATED(Z_M2)) THEN
DEALLOCATE(Z_M2)
ENDIF
ALLOCATE(Z_M2(NAT_EQ_M,NATP_M))
IF (ALLOCATED(I_Z)) THEN
DEALLOCATE(I_Z)
ENDIF
ALLOCATE(I_Z(NAT_EQ_M,NATP_M))
IF (ALLOCATED(ISYM)) THEN
DEALLOCATE(ISYM)
ENDIF
ALLOCATE(ISYM(NAT_EQ_M,NATP_M))
IF (ALLOCATED(NSYM_G)) THEN
DEALLOCATE(NSYM_G)
ENDIF
ALLOCATE(NSYM_G(48))
IF (ALLOCATED(S_INV)) THEN
DEALLOCATE(S_INV)
ENDIF
ALLOCATE(S_INV(64,3,3))
END SUBROUTINE ALLOC_TAUSYMMOP
END MODULE TAUSYMMOP_MOD
C=======================================================================
MODULE RENORM_MOD
IMPLICIT NONE

121
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f Normal file
View File

@ -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

1654
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f Normal file
View File

File diff suppressed because it is too large Load Diff

85
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f Normal file
View File

@ -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

26
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f Normal file
View File

@ -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

113
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f Normal file
View File

@ -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

366
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f Normal file
View File

@ -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

367
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f Normal file
View File

@ -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

367
src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f Normal file
View File

@ -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