diff --git a/src/msspec/__init__.py b/src/msspec/__init__.py
index 2ebfb1e..fe5175a 100644
--- a/src/msspec/__init__.py
+++ b/src/msspec/__init__.py
@@ -1,2 +1,18 @@
+import ase
from .version import __version__
+from .misc import LOGGER
+
__sha__ = "$Id$"
+
+def init_msspec():
+ LOGGER.debug('Initialization of the msspec module')
+ ase.atom.names['mt_radius'] = ('mt_radii', 0.)
+ ase.atom.names['mt_radius_scale'] = ('mt_radii_scale', 1.)
+ ase.atom.names['proto_index'] = ('proto_indices', 1)
+ ase.atom.names['mean_square_vibration'] = ('mean_square_vibrations', 0.)
+ ase.atom.names['forward_angle'] = ('forward_angles', 20.)
+ ase.atom.names['backward_angle'] = ('backward_angles', 20.)
+ ase.atom.names['RA_cut_off'] = ('RA_cuts_off', 1)
+ ase.atoms.Atoms.absorber = None
+
+init_msspec()
diff --git a/src/msspec/calcio.py b/src/msspec/calcio.py
index 04326a9..f30ce10 100644
--- a/src/msspec/calcio.py
+++ b/src/msspec/calcio.py
@@ -678,7 +678,10 @@ class SpecIO(object):
else:
ibwd_arr = np.zeros((nat), dtype=np.int)
thbwd_arr = np.ones((nat))
+ print("nat", nat)
+ print("thbwd_arr", thbwd_arr)
for at in p.extra_atoms:
+ print(at)
i = at.get('proto_index') - 1
thfwd_arr[i] = at.get('forward_angle')
thbwd_arr[i] = at.get('backward_angle')
diff --git a/src/msspec/calculator.py b/src/msspec/calculator.py
index b9b4aca..325b384 100644
--- a/src/msspec/calculator.py
+++ b/src/msspec/calculator.py
@@ -59,42 +59,15 @@ from msspec.parameters import (PhagenParameters, PhagenMallocParameters,
PEDParameters, EIGParameters)
from msspec.calcio import PhagenIO, SpecIO
-from msspec.phagen.libphagen import main as do_phagen
-from msspec.spec.libspec import run as do_spec
+from msspec.phagen.fortran.libphagen import main as do_phagen
+
+from msspec.spec.fortran import phd_se_noso_nosp_nosym
+from msspec.spec.fortran import eig_mi
+from msspec.spec.fortran import eig_pw
from terminaltables.ascii_table import AsciiTable
-
-
-
-#try:
-# MSSPEC_ROOT = os.environ['MSSPEC_ROOT']
-#except KeyError:
-# cfg = Config()
-# MSSPEC_ROOT = cfg.get('path')
-
-#if MSSPEC_ROOT == str(None):
-# raise NameError('No path to the MsSpec distribution found !!')
-
-
-
-
-def init_msspec():
- LOGGER.debug('Initialization of the msspec module')
- ase.atom.names['mt_radius'] = ('mt_radii', 0.)
- ase.atom.names['mt_radius_scale'] = ('mt_radii_scale', 1.)
- ase.atom.names['proto_index'] = ('proto_indices', 1)
- ase.atom.names['mean_square_vibration'] = ('mean_square_vibrations', 0.)
- ase.atom.names['forward_angle'] = ('forward_angles', 20.)
- ase.atom.names['backward_angle'] = ('backward_angles', 20.)
- ase.atom.names['RA_cut_off'] = ('RA_cuts_off', 1)
- ase.atoms.Atoms.absorber = None
-init_msspec()
-
-
-
-
class _MSCALCULATOR(Calculator):
"""
This class defines an ASE calculator for doing Multiple scattering
@@ -146,9 +119,8 @@ class _MSCALCULATOR(Calculator):
elif spectroscopy == 'EIG':
self.spectroscopy_parameters = EIGParameters(self.phagen_parameters,
self.spec_parameters)
- #pass
else:
- raise NameError('No such spectrosopy')
+ raise NameError('No such spectroscopy')
self.source_parameters = SourceParameters(self.global_parameters,
self.phagen_parameters,
@@ -210,30 +182,30 @@ class _MSCALCULATOR(Calculator):
#os.chdir(self.tmp_folder)
- inv = cor = 'NO'
- if algorithm == 'expansion':
- pass
- elif algorithm == 'inversion':
- inv = 'YES'
- elif algorithm == 'correlation':
- cor = 'YES'
+ #inv = cor = 'NO'
+ #if algorithm == 'expansion':
+ # pass
+ #elif algorithm == 'inversion':
+ # inv = 'YES'
+ #elif algorithm == 'correlation':
+ # cor = 'YES'
# spin orbit resolved (not yet)
- sorb = 'NO'
+ #sorb = 'NO'
# spin resolved
- dichro_spinpol = False
- if dichroism in ('sum_over_spin', 'spin_resolved'):
+ #dichro_spinpol = False
+ #if dichroism in ('sum_over_spin', 'spin_resolved'):
dichro_spinpol = True
- spin = 'NO'
- if spinpol or dichro_spinpol:
- spin = 'YES'
+ #spin = 'NO'
+ #if spinpol or dichro_spinpol:
+ # spin = 'YES'
- if spin == 'YES':
- LOGGER.error('Option not implemented!')
- raise NotImplementedError(
- 'Spin polarization is not implemeted yet!')
+ #if spin == 'YES':
+ # LOGGER.error('Option not implemented!')
+ # raise NotImplementedError(
+ # 'Spin polarization is not implemeted yet!')
calctype_spectro = self.spec_parameters.get_parameter('calctype_spectro')
@@ -375,7 +347,30 @@ class _MSCALCULATOR(Calculator):
for key, value in requirements.items():
setattr(self.spec_malloc_parameters, key, value)
-
+
+ # Get the spec function to launch
+ if self.global_parameters.spectroscopy == 'PED':
+ if self.global_parameters.algorithm == 'expansion':
+ do_spec = phd_se_noso_nosp_nosym.run
+ else:
+ LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not "
+ "an allowed combination.".format(self.global_parameters.spectroscopy,
+ self.global_parameters.algorithm))
+ raise ValueError
+ elif self.global_parameters.spectroscopy == 'EIG':
+ if self.global_parameters.algorithm == 'inversion':
+ do_spec = eig_mi.run
+ elif self.global_parameters.algorithm == 'power':
+ do_spec = eig_pw.run
+ else:
+ LOGGER.error("\'{}\' spectroscopy with \'{}\' algorithm is not "
+ "an allowed combination.".format(self.global_parameters.spectroscopy,
+ self.global_parameters.algorithm))
+ raise ValueError
+ else:
+ LOGGER.error("\'{}\' spectroscopy is not supported yet.".format(self.global_parameters.spectroscopy))
+ raise NotImplementedError
+
# cannot use this, unfortunately
#do_spec(*requirements.values())
do_spec(
@@ -893,7 +888,7 @@ class _EIG(_MSCALCULATOR):
# update the parameters
self.scan_parameters.set_parameter('kinetic_energy', kinetic_energy)
- all_ke = self.scan_parameters.get_parameter('ke_array')
+ all_ke = self.scan_parameters.get_parameter('ke_array').value
if np.any(all_ke < 0):
LOGGER.error('Source energy is not high enough or level too deep!')
raise ValueError('Kinetic energy is < 0! ({})'.format(
diff --git a/src/msspec/parameters.py b/src/msspec/parameters.py
index eaeb91e..5537539 100644
--- a/src/msspec/parameters.py
+++ b/src/msspec/parameters.py
@@ -536,9 +536,9 @@ class SpecParameters(BaseParameters):
default=3, fmt='d'),
Parameter('eigval_ispectrum_ne', types=int, limits=[0, 1],
default=1, fmt='d'),
- Parameter('eigval_ipwm', types=int, limits=[-4, 4], default=1,
+ Parameter('eigval_ipwm', types=int, limits=[-4, 4], default=0,
fmt='d'),
- Parameter('eigval_method', types=str, default='EPSI',
+ Parameter('eigval_method', types=str, default='AITK',
allowed_values=['AITK', 'RICH', 'SALZ', 'EPSI', 'EPSG',
'RHOA', 'THET', 'LEGE', 'CHEB', 'OVER',
'DURB', 'DLEV', 'TLEV', 'ULEV', 'VLEV',
@@ -801,6 +801,17 @@ class GlobalParameters(BaseParameters):
phagen_calctype, spec_calctype = mapping[p.value]
self.phagen_parameters.calctype = phagen_calctype
self.spec_parameters.calctype_spectro = spec_calctype
+
+ def bind_spinpol(self, p):
+ if p.value == True:
+ LOGGER.error('Spin polarization is not yet enabled in the Python version.')
+ raise NotImplementedError
+
+ def bind_dichroism(self, p):
+ if p.value is not None:
+ LOGGER.error('Dichroism is not yet enabled in the Python version.')
+ raise NotImplemented
+
class MuffintinParameters(BaseParameters):
def __init__(self, phagen_parameters, spec_parameters):
@@ -1372,7 +1383,7 @@ class CalculationParameters(BaseParameters):
doc=textwrap.dedent("""
The scattering order. Only meaningful for the 'expansion' algorithm.
Its value is limited to 10.""")),
- Parameter('renormalization_mode', allowed_values=(None, 'Sigma_n', 'G_n'),
+ Parameter('renormalization_mode', allowed_values=(None, 'G_n', 'Sigma_n'),
types=(type(None), str), default=None,
doc=textwrap.dedent("""
Enable the calculation of the coefficients for the renormalization of
@@ -1512,9 +1523,9 @@ class CalculationParameters(BaseParameters):
if p.value is None:
self.spec_parameters.calc_iren = 0
else:
- if p.value.lower() == 'Sigma_n'.lower():
+ if p.value.lower() == 'G_n'.lower():
self.spec_parameters.calc_iren = 1
- elif p.value.lower() == 'G_n'.lower():
+ elif p.value.lower() == 'Sigma_n'.lower():
self.spec_parameters.calc_iren = 2
LOGGER.info("Renormalization activated with \'{}\' method".format(p.value))
diff --git a/src/msspec/phagen/fortran/Makefile b/src/msspec/phagen/fortran/Makefile
index b6b4528..6665315 100644
--- a/src/msspec/phagen/fortran/Makefile
+++ b/src/msspec/phagen/fortran/Makefile
@@ -17,13 +17,13 @@ endif
.PHONY: clean
-pybinding: libphagen.so
+pybinding: libphagen
-libphagen.so: $(objects) main.f
+libphagen: $(objects) main.f
@echo "building Python binding..."
@$(F2PY) -I. $(objects) $(F2PY_OPTS)-c -m libphagen main.f
- @cp libphagen.cpython*.so ../
- @mv libphagen.cpython*.so libphagen.so
+# @cp libphagen.cpython*.so ../
+# @mv libphagen.cpython*.so libphagen.so
$(objects): $(objects_src)
@echo "compiling subroutines and functions for phagen..."
@@ -31,5 +31,4 @@ $(objects): $(objects_src)
clean:
@echo "cleaning..."
- @rm -rf *.so *.o *.mod
- @rm -rf ../*.so
+ @rm -rf *.o *.mod
diff --git a/src/msspec/spec/fortran/Makefile b/src/msspec/spec/fortran/Makefile
index cba5c62..c8dd069 100644
--- a/src/msspec/spec/fortran/Makefile
+++ b/src/msspec/spec/fortran/Makefile
@@ -6,8 +6,38 @@ F2PY_OPTS:=
DEBUG:=0
-objects_src := dim_mod.f modules.f renormalization.f allocation.f spec.f
-objects := $(patsubst %.f,%.o, $(objects_src))
+includes := -I./memalloc/ -I./cluster_gen/ -I./common_sub -I./renormalization
+includes += -I./phd_se_noso_nosp_nosym
+includes += -I./eig/common -I./eig/new_mi -I./eig/new_pw
+
+memalloc_src:=memalloc/dim_mod.f memalloc/modules.f memalloc/allocation.f
+memalloc_obj:=$(patsubst %.f,%.o, $(memalloc_src))
+
+cluster_gen_src:=$(wildcard cluster_gen/*.f)
+cluster_gen_obj:=$(patsubst %.f,%.o, $(cluster_gen_src))
+
+common_sub_src:=$(wildcard common_sub/*.f)
+common_sub_obj:=$(patsubst %.f,%.o, $(common_sub_src))
+
+renormalization_src:=$(wildcard renormalization/*.f)
+renormalization_obj:=$(patsubst %.f,%.o, $(renormalization_src))
+
+phd_se_noso_nosp_nosym_src:=$(filter-out phd_se_noso_nosp_nosym/main.f, $(wildcard phd_se_noso_nosp_nosym/*.f))
+phd_se_noso_nosp_nosym_obj:=$(patsubst %.f,%.o, $(phd_se_noso_nosp_nosym_src))
+
+eig_common_src:=$(wildcard eig/common/*.f)
+eig_common_obj:=$(patsubst %.f,%.o, $(eig_common_src))
+
+eig_mi_src:=$(filter-out eig/mi/main.f, $(wildcard eig/mi/*.f))
+eig_mi_obj:=$(patsubst %.f,%.o, $(eig_mi_src))
+
+eig_pw_src:=$(filter-out eig/pw/main.f, $(wildcard eig/pw/*.f))
+eig_pw_obj:=$(patsubst %.f,%.o, $(eig_pw_src))
+
+objects_src := $(memalloc_src) $(cluster_gen_src) $(common_sub_src)
+objects_src += $(renormalization_src) $(phd_se_noso_nosp_nosym_src)
+objects_src += $(eig_common_src) $(eig_mi_src) $(eig_pw_src)
+objects:=$(patsubst %.f,%.o, $(objects_src))
EXE=prog
@@ -16,32 +46,35 @@ ifeq ($(DEBUG),1)
F2PY_OPTS:=$(F2PY_OPTS) --debug-capi --debug
endif
+export COMP
+export COMP_OPTS
.PHONY: clean
-pybinding: libspec.so
-libspec.so: $(objects) main.f
+pybinding: phd_se_noso_nosp_nosym eig_mi eig_pw
+
+phd_se_noso_nosp_nosym: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(phd_se_noso_nosp_nosym_obj)
@echo "building Python binding..."
- @$(F2PY) -I. $(objects) $(F2PY_OPTS) -c -m libspec main.f
- @cp libspec.cpython*.so ../
- @mv libspec.cpython*.so libspec.so
+ @$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ phd_se_noso_nosp_nosym/main.f
+# @cp $@.cpython*.so ../
-exe: $(objects) prog.f
- @$(COMP) -c main.f
- @$(COMP) -c prog.f
- @$(COMP) -o $(EXE) $(objects) main.o prog.o
+eig_mi: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(eig_common_obj) $(eig_mi_obj)
+ @echo "building Python binding..."
+ @$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ eig/mi/main.f
+# @cp $@.cpython*.so ../
+eig_pw: $(memalloc_obj) $(cluster_gen_obj) $(common_sub_obj) $(renormalization_obj) $(eig_common_obj) $(eig_pw_obj)
+ @echo "building Python binding..."
+ @$(F2PY) $(includes) $^ $(F2PY_OPTS) -c -m $@ eig/pw/main.f
+# @cp $@.cpython*.so ../
-$(objects): $(objects_src)
- @echo "compiling subroutines and functions for spec..."
-# $(COMP) -cpp -fPIC -O2 -ffast-math -mcmodel=large -fdefault-real-4 -c $^
-# @$(COMP) $(OPTS) -fPIC -mcmodel=large -c $^
- @$(COMP) $(COMP_OPTS) -fPIC -c $^
+%.o: %.f
+ @echo "compiling $@..."
+ @$(COMP) $(COMP_OPTS) -I./memalloc/ -fPIC -o $@ -c $^
clean:
@echo "cleaning..."
- @rm -rf *.so *.o *.mod
- @rm -rf $(EXE)
- @rm -rf ../*.so
+ @rm -rf *.o *.mod
+ @rm -rf $(objects)
diff --git a/src/msspec/spec/fortran/cluster_gen/amas.f b/src/msspec/spec/fortran/cluster_gen/amas.f
new file mode 100644
index 0000000..c251c27
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/amas.f
@@ -0,0 +1,142 @@
+ SUBROUTINE AMAS(NIV,ATOME,COORD,VALZ,ISURF,COUPUR,ROT,IRE,NATYP,NB
+ &Z,NAT2,NCOUCH,NMAX)
+C
+C This routine generates a cluster from the knowledge of its
+C lattice vectors
+C
+ USE DIM_MOD
+C
+ USE ADSORB_MOD , NCOUCH1 => NCOUCH
+ USE BASES_MOD
+ USE MILLER_MOD , IM1 => IH, IM2 => IK, IM3 => II, IM4 => IL
+ USE OUTUNITS_MOD
+ USE RESEAU_MOD
+C
+ DIMENSION VALZ(NATCLU_M)
+ DIMENSION ROT(3,3),IRE(NATCLU_M,2),NATYP(NATM),ITA(NATCLU_M)
+ DIMENSION ATOME(3,NATCLU_M),ATRSU(3,NATCLU_M),COORD(3,NATCLU_M)
+ DIMENSION ROTINV(3,3),XINIT(3,1),XFIN(3,1)
+C
+C
+C
+ NCOUCH=0
+ WRITE(IUO1,10) ISURF
+ 10 FORMAT(//,18X,'ATOM (0,0,0) ON THE SURFACE PLANE IS OF TYPE ',I2)
+ NBZ=0
+ CALL INVMAT(ROT,ROTINV)
+ IF(IVG0.EQ.0) THEN
+ CALL CHBASE(NATP_M,ATBAS)
+ ENDIF
+ NB1=0
+ NB2=0
+ DO NTYP=1,NAT
+ NBAT=0
+ DO NUM=1,NMAX
+ NB1=NB1+1
+ IRE(NB1,1)=0
+ IRE(NB1,2)=0
+ IF(IVG0.LE.1) THEN
+ CALL NUMAT(NUM,NIV,IA,IB,IC)
+ ELSE
+ BSURA=1.
+ CSURA=1.
+ ENDIF
+ IF(IVG0.LE.1) THEN
+ XA=FLOAT(IA)
+ XB=FLOAT(IB)
+ XC=FLOAT(IC)
+ ELSEIF(IVG0.EQ.2) THEN
+ XA=FLOAT(NUM-1)
+ XB=FLOAT(NUM-1)
+ XC=FLOAT(NUM-1)
+ ENDIF
+ IF(IVG0.EQ.1) THEN
+ IF(IVN(1).EQ.0) THEN
+ ITA(NUM)=IA
+ ELSEIF(IVN(2).EQ.0) THEN
+ ITA(NUM)=IB
+ ELSEIF(IVN(3).EQ.0) THEN
+ ITA(NUM)=IC
+ ENDIF
+ IF((ITA(NUM).EQ.ITA(NUM-1)).AND.(NUM.GT.1)) GOTO 30
+ ENDIF
+ DO J=1,3
+ K=J+3*(NTYP-1)
+ O=ATBAS(K)
+ ATOME(J,NB1)=O+XA*VECBAS(J)+XB*VECBAS(J+3)+XC*VECBAS(J+6)
+ ENDDO
+ DO I=1,3
+ M=I+3*(ISURF-1)
+ XINIT(I,1)=ATOME(I,NB1)-ATBAS(M)
+ ENDDO
+ CALL MULMAT(ROTINV,3,3,XINIT,3,1,XFIN)
+ DO I=1,3
+ ATRSU(I,NB1)=XFIN(I,1)
+ ENDDO
+ CALL TEST1(COUPUR,NB1,NB2,ATRSU,COORD,VALZ,NBAT,IRE,NBZ)
+ 30 CONTINUE
+ ENDDO
+ NATYP(NTYP)=NBAT
+ ENDDO
+ IF(IADS.GE.1) THEN
+ N0=NBZ
+ DO JADS=1,NADS1
+ NB1=NB1+1
+ DO I=1,3
+ COORD(I,NB1)=ADS(I,JADS)
+ ENDDO
+ N1=0
+ DO N=1,N0
+ D=ABS(COORD(3,NB1)-VALZ(N))
+ IF(D.LT.0.0001) N1=N1+1
+ ENDDO
+ IF(N1.EQ.0) THEN
+ N0=N0+1
+ VALZ(N0)=COORD(3,NB1)
+ ENDIF
+ ENDDO
+ NANEW1=NADS1+NADS2
+ NATYP(NAT+1)=NADS1
+ IF(NANEW1.EQ.NADS1) GOTO 99
+ DO JADS=NADS1+1,NANEW1
+ NB1=NB1+1
+ DO I=1,3
+ COORD(I,NB1)=ADS(I,JADS)
+ ENDDO
+ N1=0
+ DO N=1,N0
+ D=ABS(COORD(3,NB1)-VALZ(N))
+ IF(D.LT.0.0001) N1=N1+1
+ ENDDO
+ IF(N1.EQ.0) THEN
+ N0=N0+1
+ VALZ(N0)=COORD(3,NB1)
+ ENDIF
+ ENDDO
+ NATYP(NAT+2)=NADS2
+ NANEW2=NANEW1+NADS3
+ IF(NANEW2.EQ.NANEW1) GOTO 99
+ DO JADS=NANEW1+1,NANEW2
+ NB1=NB1+1
+ DO I=1,3
+ COORD(I,NB1)=ADS(I,JADS)
+ ENDDO
+ N1=0
+ DO N=1,N0
+ D=ABS(COORD(3,NB1)-VALZ(N))
+ IF(D.LT.0.0001) N1=N1+1
+ ENDDO
+ IF(N1.EQ.0) THEN
+ N0=N0+1
+ VALZ(N0)=COORD(3,NB1)
+ ENDIF
+ ENDDO
+ NATYP(NAT+3)=NADS3
+ 99 CONTINUE
+ NCOUCH=N0-NBZ
+ NBZ=N0
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/base.f b/src/msspec/spec/fortran/cluster_gen/base.f
new file mode 100644
index 0000000..5cbbe56
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/base.f
@@ -0,0 +1,130 @@
+C
+C=======================================================================
+C
+ SUBROUTINE BASE
+C
+C This routine generates the lattice basis vectors for a given Bravais
+C lattice NCRIST centered according to NCENTR
+C
+ USE DIM_MOD
+ USE BASES_MOD
+ USE CRANGL_MOD
+ USE OUTUNITS_MOD
+ USE RESEAU_MOD
+ USE VECSYS_MOD
+C
+ CHARACTER*15 BRAV(8),CENT(7)
+ CHARACTER*31 RESEAU
+C
+C
+ DIMENSION CUB(9),MNC(9),TCN(9),TRG(9),HEX(9)
+C
+C
+C
+ DATA CUB /1.,0.,0., 0.,1.,0., 0.,0.,1./
+ DATA MNC /1.,0.,1., 0.,1.,0., 0.,0.,1./
+ DATA TCN /1.,0.,1., 1.,1.,1., 0.,0.,1./
+ DATA TRG /0.,1.,1., -0.866025,-0.5,1., 0.866025,-0.5,1./
+ DATA HEX /1.,0.,0., -0.5,0.866025,0., 0.,0.,1./
+ DATA PIS180 /0.017453/
+ DATA BRAV /' CUBIQUE',' TETRAGONAL',' ORTHORHOMBIQUE','
+ & MONOCLINIQUE',' TRICLINIQUE',' TRIGONAL',' HEXAGO
+ &NAL',' EXTERNE'/
+ DATA CENT /' ','CENTRE',' FACES CENTREES','(RHOMBOEDRIQUE)',' FACE
+ & A CENTREE',' FACE B CENTREE',' FACE C CENTREE'/
+C
+ ALPHAR=ALPHAD*PIS180
+ BETAR=BETAD*PIS180
+ GAMMAR=GAMMAD*PIS180
+ NAT3=NAT*3
+ GO TO (1,1,1,2,3,4,5,6) NCRIST
+C
+ 1 DO I=1,9
+ VECBAS(I)=CUB(I)
+ ENDDO
+ IF(NCRIST.NE.1) THEN
+ VECBAS(9)=CSURA
+ IF(NCRIST.EQ.3) THEN
+ VECBAS(5)=BSURA
+ ENDIF
+ ENDIF
+ GO TO 6
+C
+ 2 DO I=1,9
+ VECBAS(I)=MNC(I)
+ ENDDO
+ VECBAS(1)=SIN(BETAR)
+ VECBAS(3)=COS(BETAR)
+ VECBAS(5)=BSURA
+ VECBAS(9)=CSURA
+ GO TO 6
+C
+ 3 DO I=1,9
+ VECBAS(I)=TCN(I)
+ ENDDO
+ VECBAS(1)=SIN(BETAR)
+ VECBAS(3)=COS(BETAR)
+ A2Y=(COS(GAMMAR)-COS(ALPHAR)*COS(BETAR))/SIN(BETAR)
+ VECBAS(4)=BSURA*A2Y
+ VECBAS(5)=BSURA*SQRT(SIN(ALPHAR)*SIN(ALPHAR)-A2Y*A2Y)
+ VECBAS(6)=BSURA*COS(ALPHAR)
+ VECBAS(9)=CSURA
+ GO TO 6
+C
+ 4 IF(((NCENTR.EQ.4).AND.(CSURA.NE.1.)).OR.(NCENTR.EQ.1)) GO TO 5
+ ETA=-2.*SIN(ALPHAR/2.)/SQRT(3.)
+ DZETA=SQRT(1.-ETA*ETA)
+ DO I=1,3
+ J=I+2*(I-1)
+ J1=J+1
+ J2=J+2
+ VECBAS(J)=TRG(J)*ETA
+ VECBAS(J1)=TRG(J1)*ETA
+ VECBAS(J2)=TRG(J2)*DZETA
+ ENDDO
+ GO TO 6
+C
+ 5 DO I=1,9
+ VECBAS(I)=HEX(I)
+ ENDDO
+ VECBAS(9)=CSURA
+C
+ 6 DO I=1,3
+ ASYS(I)=VECBAS(I)
+ BSYS(I)=VECBAS(I+3)
+ CSYS(I)=VECBAS(I+6)
+ ENDDO
+ DCA=ABS(CSURA-1.)
+ IF((NCRIST.EQ.6).AND.(DCA.LT.0.0001)) GO TO 8
+ IF(NCRIST.EQ.8) GO TO 8
+ IF(NCENTR.GT.1) THEN
+ CALL CENTRE(VECBAS)
+ IF(NCENTR.EQ.4) THEN
+ DO I=1,9
+ VECBAS(I)=VECBAS(I)*SQRT((1.-CSURA*CSURA)*3.)
+ ENDDO
+ DO I=1,3
+ ASYS(I)=VECBAS(I)
+ BSYS(I)=VECBAS(I+3)
+ CSYS(I)=VECBAS(I+6)
+ ENDDO
+ ENDIF
+ ENDIF
+C
+ 8 RESEAU=BRAV(NCRIST)//' '//CENT(NCENTR)
+ WRITE(IUO1,80) RESEAU,NAT
+ WRITE(IUO1,81) (VECBAS(I),I=1,9)
+ WRITE(IUO1,82)
+ WRITE(IUO1,83) (ATBAS(I),I=1,NAT3)
+C
+ 80 FORMAT(////,10X,'RESEAU CRISTALLIN DE TYPE : ',A29,/,16X,
+ * 'CONTENANT',I3,' ATOMES DANS LA MAILLE ELEMENTAIRE',//)
+ 81 FORMAT(28X,'VECTEURS GENERATEURS :',//,26X,'A1 = (',F6.3,',',
+ *F6.3,',',F6.3,')',/,26X,'A2 = (',F6.3,',',F6.3,',',F6.3,')',/,
+ *26X,'A3 = (',F6.3,',',F6.3,',',F6.3,')')
+ 82 FORMAT(/,21X,'POSITIONS DES ATOMES DANS LA MAILLE :',/)
+ 83 FORMAT(29X,'(',F6.3,',',F6.3,',',F6.3,')')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/centre.f b/src/msspec/spec/fortran/cluster_gen/centre.f
new file mode 100644
index 0000000..56de6c4
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/centre.f
@@ -0,0 +1,61 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CENTRE(VECBAS)
+C
+C This routine modifies the Bravais lattice basis vectors according to
+C the way the lattice is centered
+C
+ USE RESEAU_MOD
+C
+ DIMENSION VECBAS(9),V1(9)
+C
+C
+C
+ DO I=1,9
+ V1(I)=VECBAS(I)
+ ENDDO
+ N1=NCENTR-1
+ GO TO (2,3,4,5,6,7) N1
+C
+ 2 DO I=1,3
+ VECBAS(I)=-0.5*V1(I)+0.5*V1(I+3)+0.5*V1(I+6)
+ VECBAS(I+3)=0.5*V1(I)-0.5*V1(I+3)+0.5*V1(I+6)
+ VECBAS(I+6)=0.5*V1(I)+0.5*V1(I+3)-0.5*V1(I+6)
+ ENDDO
+ GO TO 8
+C
+ 3 DO I=1,3
+ VECBAS(I)=0.5*(V1(I+3)+V1(I+6))
+ VECBAS(I+3)=0.5*(V1(I)+V1(I+6))
+ VECBAS(I+6)=0.5*(V1(I)+V1(I+3))
+ ENDDO
+ GO TO 8
+C
+ 4 DO I=1,3
+ VECBAS(I)=(2./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6)
+ VECBAS(I+3)=(-1./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6)
+ VECBAS(I+6)=(-1./3.)*V1(I)-(2./3.)*V1(I+3)+(1./3.)*V1(I+6)
+ ENDDO
+ DO I=1,3
+ VECBAS(3*I)=VECBAS(3*I)*SQRT(3./(1.-CSURA*CSURA))
+ ENDDO
+ GO TO 8
+C
+ 5 DO I=1,3
+ VECBAS(I+6)=0.5*(V1(I+3)+V1(I+6))
+ ENDDO
+ GO TO 8
+C
+ 6 DO I=1,3
+ VECBAS(I+6)=0.5*(V1(I)+V1(I+6))
+ ENDDO
+ GO TO 8
+C
+ 7 DO I=1,3
+ VECBAS(I+3)=0.5*(V1(I)+V1(I+3))
+ ENDDO
+C
+ 8 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/chbase.f b/src/msspec/spec/fortran/cluster_gen/chbase.f
new file mode 100644
index 0000000..684b273
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/chbase.f
@@ -0,0 +1,30 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CHBASE(NAT,ATBAS)
+C
+ USE VECSYS_MOD
+C
+ DIMENSION ATBAS(3*NAT),BASVEC(3,3),BAS1(1,3),BAS2(1,3)
+C
+ DO J=1,3
+ BASVEC(1,J)=ASYS(J)
+ BASVEC(2,J)=BSYS(J)
+ BASVEC(3,J)=CSYS(J)
+ ENDDO
+C
+ DO JAT=1,NAT
+ DO J=1,3
+ K=J+3*(JAT-1)
+ BAS1(1,J)=ATBAS(K)
+ ENDDO
+ CALL MULMAT(BAS1,1,3,BASVEC,3,3,BAS2)
+ DO J=1,3
+ K=J+3*(JAT-1)
+ ATBAS(K)=BAS2(1,J)
+ ENDDO
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/chnot.f b/src/msspec/spec/fortran/cluster_gen/chnot.f
new file mode 100644
index 0000000..c352ab2
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/chnot.f
@@ -0,0 +1,18 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CHNOT(NVEC,VEC1,VEC2)
+C
+C This routine linearizes the storage of a two index array
+C
+ DIMENSION VEC1(3*NVEC),VEC2(3,NVEC)
+C
+ DO J=1,NVEC
+ DO I=1,3
+ VEC2(I,J)=VEC1(I+3*(J-1))
+ ENDDO
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/invmat.f b/src/msspec/spec/fortran/cluster_gen/invmat.f
new file mode 100644
index 0000000..359ad58
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/invmat.f
@@ -0,0 +1,43 @@
+C
+C=======================================================================
+C
+ SUBROUTINE INVMAT(B,BINV)
+C
+ USE OUTUNITS_MOD
+ DIMENSION B(3,3),BINV(3,3)
+C
+C
+ A1=B(1,1)*B(2,2)*B(3,3)
+ A2=B(2,1)*B(3,2)*B(1,3)
+ A3=B(3,1)*B(1,2)*B(2,3)
+ A4=B(1,1)*B(3,2)*B(2,3)
+ A5=B(2,1)*B(1,2)*B(3,3)
+ A6=B(3,1)*B(2,2)*B(1,3)
+ DET=A1+A2+A3-A4-A5-A6
+C
+ IF(ABS(DET).LT.0.0001) GO TO 10
+C
+ DO I=1,3
+ DO J=1,3
+ DO K=1,3
+ L=(I-J)*(I-K)*(J-K)
+ IF(L.NE.0) THEN
+ XNUM1=B(J,J)*B(K,K)-B(J,K)*B(K,J)
+ XNUM2=B(I,K)*B(K,J)-B(K,K)*B(I,J)
+ BINV(I,I)=XNUM1/DET
+ BINV(I,J)=XNUM2/DET
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ GO TO 50
+C
+ 10 WRITE(IUO1,60)
+C
+ 60 FORMAT(5X,'NON INVERTIBLE MATRIX')
+C
+ 50 CONTINUE
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/mulmat.f b/src/msspec/spec/fortran/cluster_gen/mulmat.f
new file mode 100644
index 0000000..0dc1a84
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/mulmat.f
@@ -0,0 +1,30 @@
+C
+C=======================================================================
+C
+ SUBROUTINE MULMAT(A1,IL1,IC1,A2,IL2,IC2,A3)
+C
+C This routine performs the matrix multiplication of A1(IL1,IC1) by
+C A2(IL2,IC2) with the result stored in A3(IL1,IC2)
+C
+ USE OUTUNITS_MOD
+ DIMENSION A1(IL1,IC1),A2(IL2,IC2),A3(IL1,IC2)
+C
+C
+ IF(IC1.NE.IL2) THEN
+ WRITE(IUO1,10)
+ ELSE
+ DO I=1,IL1
+ DO J=1,IC2
+ A3(I,J)=0.
+ DO K=1,IC1
+ A3(I,J)=A3(I,J)+A1(I,K)*A2(K,J)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ 10 FORMAT(5X,'THESE MATRICES CANNOT BE MULTIPLIED')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/numat.f b/src/msspec/spec/fortran/cluster_gen/numat.f
new file mode 100644
index 0000000..3f15b5f
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/numat.f
@@ -0,0 +1,44 @@
+C
+C=======================================================================
+C
+ SUBROUTINE NUMAT(NUM,NIVA,IL,IM,IN)
+C
+ USE OUTUNITS_MOD
+ DIMENSION I(100)
+C
+C
+ L=2*NIVA+1
+ IF(L.GT.100) THEN
+ WRITE(IUO1,5)
+ STOP
+ ENDIF
+ L1=NIVA+1
+C
+ DO K=1,L
+ IF(K.LE.L1) THEN
+ I(K)=K-1
+ ELSE
+ I(K)=L1-K
+ ENDIF
+ ENDDO
+C
+ Q1=FLOAT(NUM)/FLOAT(L*L)
+ JR1=NUM-L*L*INT(Q1+0.0001)
+ JS1=INT(Q1+0.9999)
+ Q2=FLOAT(JR1)/FLOAT(L)
+ JS2=INT(Q2+0.9999)
+ IF(JR1.EQ.0) JS2=L
+ Q3=FLOAT(NUM)/FLOAT(L)
+ JR3=INT(Q3+0.0001)
+ JS3=NUM-L*JR3
+ IF(JS3.EQ.0) JS3=L
+ IL=I(JS1)
+ IM=I(JS2)
+ IN=I(JS3)
+C
+ 5 FORMAT(///,'<<<<<<<<<< INCREASE THE SIZE OF I IN',' THE NUMAT SU
+ &BROUTINE >>>>>>>>>>')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/rela.f b/src/msspec/spec/fortran/cluster_gen/rela.f
new file mode 100644
index 0000000..7b9e2a3
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/rela.f
@@ -0,0 +1,220 @@
+C
+C=======================================================================
+C
+ SUBROUTINE RELA(NINI,NFIN,NAT,VALINI,VALFIN,VALFIN2,COORD,NTYP,REL
+ &,L)
+C
+ USE DIM_MOD
+C
+ USE ADSORB_MOD , I1 => IADS, N1 => NADS1, N2 => NADS2, N3 => NADS3
+ &
+ USE OUTUNITS_MOD
+ USE RELADS_MOD
+ USE RELAX_MOD
+C
+ DIMENSION VALINI(NATCLU_M),VALFIN(NATCLU_M),REL(NATCLU_M)
+ DIMENSION NTYP(NATM),COORD(3,NATCLU_M),LSP(2),DZA(2),DZB(2)
+ DIMENSION DYA(2),DYB(2),VALFIN2(NATCLU_M),KZ(1000)
+C
+ DATA SMALL /0.0001/
+C
+ IF((IREL.EQ.1).OR.((IREL.EQ.0).AND.(NRELA.GT.0))) THEN
+C
+ CALL ORDRE(NINI,VALINI,NFIN,VALFIN)
+ WRITE(IUO1,70) NFIN
+ DO JPLAN=1,NFIN
+ IF(JPLAN.LE.NRELA) THEN
+ X1=1.
+ X2=0.
+ PCADS=PCRELA(JPLAN)
+ ELSEIF((JPLAN.GT.NRELA).AND.(JPLAN.LE.L)) THEN
+ X1=0.
+ X2=0.
+ ELSE
+ X1=0.
+ X2=1.
+ PCSUBS=PCREL(JPLAN-L)
+ ENDIF
+ REL(JPLAN)=0.
+ IF(JPLAN.GT.NREL+L) GO TO 20
+ IF(JPLAN.EQ.NFIN) GO TO 20
+ DPLAN=VALFIN(JPLAN)-VALFIN(JPLAN+1)
+ REL(JPLAN)=DPLAN*(X1*PCADS+X2*PCSUBS)/100.
+ 20 DREL=VALFIN(JPLAN)+REL(JPLAN)
+ WRITE(IUO1,30) JPLAN,VALFIN(JPLAN),DREL
+ ENDDO
+C
+ NBR=0
+ DO JTYP=1,NAT
+ NBAT=NTYP(JTYP)
+ DO NUM=1,NBAT
+ NBR=NBR+1
+ DO JPLAN=1,NFIN
+ DIF=ABS(COORD(3,NBR)-VALFIN(JPLAN))
+ IF(DIF.LT.SMALL) THEN
+ COORD(3,NBR)=COORD(3,NBR)+REL(JPLAN)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ DO JPLAN=1,NFIN
+ VALFIN(JPLAN)=VALFIN(JPLAN)+REL(JPLAN)
+ ENDDO
+C
+ ELSEIF(IREL.GE.2) THEN
+C
+ IP=0
+ LSP(2)=0
+ OMEGA=OMEGA1
+ 97 XN1=1.
+ XN2=0.
+ IP=IP+1
+ CALL ORDRE(NINI,VALINI,NFIN,VALFIN)
+ ZP=VALFIN(IP)
+ CALL RZB110(OMEGA,DY1,DY2,DZ1,DZ2)
+ DZA(IP)=DZ1
+ DZB(IP)=DZ2
+ DYA(IP)=DY1
+ DYB(IP)=DY2
+ IF(ABS(OMEGA).LT.SMALL) THEN
+ LSP(IP)=1
+ ELSE
+ LSP(IP)=2
+ ENDIF
+ IF(LSP(IP).EQ.1) GOTO 95
+ NBR=0
+C
+ DO JTYP=1,NAT-NATA
+ NBAT=NTYP(JTYP)
+ XN1=XN1+1.-FLOAT(JTYP)
+ XN2=XN2-1.+FLOAT(JTYP)
+ DO JNUM=1,NBAT
+ NBR=NBR+1
+ ZAT=COORD(3,NBR)-ZP
+ IF(ABS(ZAT).LT.SMALL) THEN
+ YAT=COORD(2,NBR)
+ COORD(2,NBR)=YAT-XN1*DYA(IP)-XN2*DYB(IP)
+ COORD(3,NBR)=ZAT+ZP+XN1*DZA(IP)+XN2*DZB(IP)
+ ENDIF
+ ENDDO
+ ENDDO
+C
+ 95 OMEGA=OMEGA2
+ IF((IREL.EQ.3).AND.(IP.EQ.1)) GOTO 97
+ LS=0
+ DO I=1,IP
+ LS=LS+LSP(I)
+ ENDDO
+ NBZ1=NFIN+LS-IP
+ DO K=1,IP
+ IF(LSP(K).EQ.2) THEN
+ IF((K.EQ.2).AND.(LS.EQ.3)) THEN
+ KN=K-1
+ ELSE
+ KN=K
+ ENDIF
+ VALINI(NBZ1-KN+1)=VALFIN(L+K)+DZB(K)
+ REL(NBZ1-KN+1)=DZB(K)
+ ELSE
+ VALINI(NBZ1-K+1)=VALFIN(L+K)
+ REL(NBZ1-K+1)=0.
+ ENDIF
+ ENDDO
+C
+ IL=0
+ IR=0
+ DO J=1,NFIN
+ IS=0
+ IF(J.LE.NRELA) THEN
+ X1=1.
+ X2=0.
+ X3=0.
+ PCADS=PCRELA(J)
+ IS=1
+ ELSEIF((J.GT.NRELA).AND.(J.LE.L)) THEN
+ X1=0.
+ X2=0.
+ X3=0.
+ ELSEIF((J.GT.L).AND.(J.LE.(L+IP))) THEN
+ IR=IR+1
+ IF(LSP(IR).EQ.1) THEN
+ IF((IR.EQ.1).AND.(LSP(2).EQ.2)) GOTO 31
+ X1=0.
+ X2=1.
+ X3=0.
+ LT=MAX0(LSP(1),LSP(2))-1
+ PCSUBS=PCREL(J-L-LT)
+ IL=1
+ IS=1
+ 31 CONTINUE
+ ELSE
+ X1=0.
+ X2=0.
+ X3=1.
+ ENDIF
+ ELSEIF((J.GT.(L+IP)).AND.(J.LE.(L+IP+NREL))) THEN
+ X1=0.
+ X2=1.
+ X3=0.
+ LT=MAX0(LSP(1),LSP(2))+IP-1
+ PCSUBS=PCREL(J-L-LT+IL+1)
+ IS=1
+ ELSE
+ X1=0.
+ X2=0.
+ X3=0.
+ ENDIF
+ DPLAN=VALFIN(J)-VALFIN(J+1)
+ REL(J)=X3*DZA(IR)+DPLAN*(X1*PCADS+X2*PCSUBS)/100.
+ VALINI(J)=VALFIN(J)+REL(J)
+ IF(IS.EQ.1) THEN
+ NBR=0
+ DO JTYP=1,NAT
+ NBAT=NTYP(JTYP)
+ DO NUM=1,NBAT
+ NBR=NBR+1
+ DIF=ABS(COORD(3,NBR)-VALFIN(J))
+ IF(DIF.LT.SMALL) THEN
+ COORD(3,NBR)=VALINI(J)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+C
+ CALL ORDRE(NBZ1,VALINI,NFIN,VALFIN2)
+ WRITE(IUO1,65) NFIN
+ KZ(1)=0
+ KZ(2)=LSP(1)
+ KZ(3)=MAX0(LSP(1),LSP(2))
+ DO KK=4,NFIN
+ KZ(KK)=LS
+ ENDDO
+ DO JPLAN=1,NFIN
+ IF(JPLAN.LE.L) THEN
+ WRITE(IUO1,55) JPLAN,VALFIN(JPLAN),VALFIN2(JPLAN)
+ VALINI(JPLAN)=VALFIN(JPLAN)
+ ELSEIF((JPLAN.GT.L).AND.(JPLAN.LE.(L+LS))) THEN
+ K=KZ(JPLAN-L) - INT((JPLAN-L)/2)
+ IPLAN=JPLAN-K
+ WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN)
+ VALINI(JPLAN)=VALFIN(IPLAN)
+ ELSEIF(JPLAN.GT.(L+LS)) THEN
+ IPLAN=JPLAN-LS+IP
+ WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN)
+ VALINI(JPLAN)=VALFIN(IPLAN)
+ ENDIF
+ ENDDO
+ ENDIF
+C
+ 30 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3,
+ * ' BEFORE RELAXATION AND : ',F6.3,' AFTER')
+ 55 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3,
+ * ' BEFORE RELAXATION AND : ',F6.3,' AFTER')
+ 65 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ')
+ 70 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/rotbas.f b/src/msspec/spec/fortran/cluster_gen/rotbas.f
new file mode 100644
index 0000000..db3d62f
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/rotbas.f
@@ -0,0 +1,132 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ROTBAS(ROT)
+C
+C This routine calculates the basis vectors related to a surface
+C characterized by its Miller indices (IH,IK,II,IL)
+C
+ USE MILLER_MOD
+ USE OUTUNITS_MOD
+ USE RESEAU_MOD
+ USE VECSYS_MOD , A1 => ASYS, A2 => BSYS, A3 => CSYS
+C
+ DIMENSION ROT(3,3),VECT(3,3),A1STAR(3),A2STAR(3),A3STAR(3),B1(3)
+ DIMENSION VECT1(3),XNORM(3),CHBASE(3,3),VECT2(3,3)
+C
+C
+C
+ DATA PI /3.141593/
+C
+ IF((NCRIST.EQ.8).AND.(IVG0.GE.1)) GOTO 7
+ XH=FLOAT(IH)
+ XK=FLOAT(IK)
+ XI=FLOAT(II)
+ XL=FLOAT(IL)
+ XI1=-XH-XK
+ II1=INT(XI1)
+ IF((NCRIST.EQ.7).AND.(XI.NE.XI1)) WRITE(IUO1,5) IH,IK,II1,IL
+ 5 FORMAT(5X,'THE SURFACE INDICES ARE NOT CORRECT,',/,5X, 'FOR THE RE
+ &ST OF THE CALCULATION, THEY ARE TAKEN AS ','(',I2,1X,I2,1X,I2,1X,I
+ &2,')')
+ CPR=1.
+ CALL PRVECT(A2,A3,B1,CPR)
+ OMEGA=PRSCAL(A1,B1)/(2.*PI)
+ CALL PRVECT(A2,A3,A1STAR,OMEGA)
+ CALL PRVECT(A3,A1,A2STAR,OMEGA)
+ CALL PRVECT(A1,A2,A3STAR,OMEGA)
+ DO 10 I=1,3
+ VECT1(I)=XH*A1STAR(I)+XK*A2STAR(I)+XL*A3STAR(I)
+ 10 CONTINUE
+ DO 15 I=1,3
+ ROT(I,3)=VECT1(I)/SQRT(PRSCAL(VECT1,VECT1))
+ 15 CONTINUE
+ DO 20 I=1,3
+ CHBASE(I,1)=A1(I)
+ CHBASE(I,2)=A2(I)
+ CHBASE(I,3)=A3(I)
+ DO 25 J=1,3
+ VECT(I,J)=0.
+ 25 CONTINUE
+ 20 CONTINUE
+ XHKL=XH*XK*XL
+ XHK=XH*XK
+ XHL=XH*XL
+ XKL=XK*XL
+ IF(XHKL.NE.0.) THEN
+ VECT(1,1)=-1./XH
+ VECT(2,1)=1./XK
+ VECT(1,2)=-1./XH
+ VECT(3,2)=1./XL
+ VECT(2,3)=-1./XK
+ VECT(3,3)=1./XL
+ ELSEIF(XHK.NE.0.) THEN
+ VECT(1,1)=-1./XH
+ VECT(2,1)=1./XK
+ ELSEIF(XHL.NE.0.) THEN
+ VECT(1,2)=-1./XH
+ VECT(3,2)=1./XL
+ ELSEIF(XKL.NE.0.) THEN
+ VECT(2,3)=-1./XK
+ VECT(3,3)=1./XL
+ ELSEIF(XH.NE.0.) THEN
+ VECT(2,2)=1./XH
+ ELSEIF(XK.NE.0.) THEN
+ VECT(3,3)=1./XK
+ ELSEIF(XL.NE.0.) THEN
+ VECT(1,1)=1./XL
+ ENDIF
+ CALL MULMAT(CHBASE,3,3,VECT,3,3,VECT2)
+ DO 35 I=1,3
+ XNORM(I)=SQRT(VECT2(1,I)**2+VECT2(2,I)**2+VECT2(3,I)**2)
+ 35 CONTINUE
+ XMIN=AMIN1(XNORM(1),XNORM(2),XNORM(3))
+ XMAX=AMAX1(XNORM(1),XNORM(2),XNORM(3))
+ DO 40 I=1,3
+ IF(XHKL.NE.0.) THEN
+ IF(ABS(XMIN-XNORM(I)).LT.0.0001) THEN
+ DO 45 J=1,3
+ ROT(J,1)=VECT2(J,I)/XNORM(I)
+ 45 CONTINUE
+ ENDIF
+ ELSE
+ IF(ABS(XMAX-XNORM(I)).LT.0.0001) THEN
+ DO 50 J=1,3
+ ROT(J,1)=VECT2(J,I)/XNORM(I)
+ 50 CONTINUE
+ ENDIF
+ ENDIF
+ 40 CONTINUE
+ ROT(1,2)=ROT(2,3)*ROT(3,1)-ROT(3,3)*ROT(2,1)
+ ROT(2,2)=ROT(3,3)*ROT(1,1)-ROT(3,1)*ROT(1,3)
+ ROT(3,2)=ROT(1,3)*ROT(2,1)-ROT(2,3)*ROT(1,1)
+ IF(NCRIST.EQ.7) THEN
+ WRITE(IUO1,85) IH,IK,II1,IL
+ ELSE
+ WRITE(IUO1,80) IH,IK,IL
+ ENDIF
+ WRITE(IUO1,65) ROT(1,1),ROT(2,1),ROT(3,1)
+ WRITE(IUO1,70) ROT(1,2),ROT(2,2),ROT(3,2)
+ WRITE(IUO1,75) ROT(1,3),ROT(2,3),ROT(3,3)
+ GOTO 37
+ 7 DO 17 I=1,3
+ DO 27 J=1,3
+ ROT(I,J)=0.
+ IF(I.EQ.J) ROT(I,J)=1.
+ 27 CONTINUE
+ 17 CONTINUE
+ IF(IVG0.EQ.1) WRITE(IUO1,48)
+ IF(IVG0.EQ.2) WRITE(IUO1,47)
+ 47 FORMAT(//,25X,'LINEAR CHAIN STUDY ')
+ 48 FORMAT(//,35X,'PLANE STUDY')
+ 65 FORMAT(26X,'ISURF = (',F6.3,',',F6.3,',',F6.3,')')
+ 70 FORMAT(26X,'JSURF = (',F6.3,',',F6.3,',',F6.3,')')
+ 75 FORMAT(26X,'KSURF = (',F6.3,',',F6.3,',',F6.3,')')
+ 80 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X,
+ *I2,') :',/)
+ 85 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X,
+ *I2,1X,I2,') :',/)
+C
+ 37 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/rzb110.f b/src/msspec/spec/fortran/cluster_gen/rzb110.f
new file mode 100644
index 0000000..9961469
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/rzb110.f
@@ -0,0 +1,22 @@
+C
+C=======================================================================
+C
+ SUBROUTINE RZB110(OMEGA,DY1,DY2,DZ1,DZ2)
+C
+ A1=COS(OMEGA)
+ ALPHA=SIN(OMEGA)
+ BETA=A1-3.
+ GAMMA=SQRT(3.)*(5./3.-A1)
+ DELTA=SQRT(SQRT(3.)*(1./3.+A1)/GAMMA)
+ CSA=SQRT(3.)*(-BETA-ALPHA*DELTA)/6.
+ SNA=SQRT(1.-CSA*CSA)
+ CSB=-SQRT(3.)*BETA/3. -CSA
+ SNB=-SQRT(3.)*ALPHA/3. +SNA
+ DY1=(SQRT(3.)*CSB-1.)/4.
+ DY2=(1.-SQRT(3.)*CSA)/4.
+ DZ1=(SQRT(3.)*SNB-SQRT(2.))/4.
+ DZ2=(SQRT(3.)*SNA-SQRT(2.))/4.
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/test.f b/src/msspec/spec/fortran/cluster_gen/test.f
new file mode 100644
index 0000000..8667da0
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/test.f
@@ -0,0 +1,22 @@
+C
+C=======================================================================
+C
+ SUBROUTINE TEST(NIV,ROT,NATYP,NBZ,NAT2,ISURF,COUP,*)
+C
+ USE DIM_MOD
+C
+ DIMENSION ATOME1(3,NATCLU_M),COORD1(3,NATCLU_M)
+ DIMENSION IRE1(NATCLU_M,2),NATYP(NATM)
+ DIMENSION NATYP1(NATM),VALZ1(NATCLU_M),ROT(3,3)
+C
+ NMAX1=(2*NIV+3)**3
+ NV1=NIV+1
+ CALL AMAS(NV1,ATOME1,COORD1,VALZ1,ISURF,COUP,ROT,IRE1,NATYP1,NBZ,N
+ &AT2,NCOUCH,NMAX1)
+ DO 10 I=1,NAT2
+ IF(NATYP(I).NE.NATYP1(I)) RETURN 1
+ 10 CONTINUE
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/cluster_gen/test1.f b/src/msspec/spec/fortran/cluster_gen/test1.f
new file mode 100644
index 0000000..1372670
--- /dev/null
+++ b/src/msspec/spec/fortran/cluster_gen/test1.f
@@ -0,0 +1,43 @@
+C
+C=======================================================================
+C
+ SUBROUTINE TEST1(COUPUR,NB1,NB2,ATOME,COORD,VAL,NBAT,IRE,NBZ)
+C
+ USE DIM_MOD
+C
+ DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M),VAL(NATCLU_M)
+ DIMENSION IRE(NATCLU_M,2)
+C
+ DIST2=0.
+ DO 10 I=1,3
+ DIST2=DIST2+ATOME(I,NB1)*ATOME(I,NB1)
+ 10 CONTINUE
+ DIST=SQRT(DIST2)
+ V=0.0001
+ IF((ATOME(3,NB1).LE.V).AND.(DIST.LE.COUPUR)) THEN
+ NBAT=NBAT+1
+ NB2=NB2+1
+ IRE(NB1,1)=NB2
+ IRE(NB1,2)=NBAT
+ DO 20 I=1,3
+ COORD(I,NB2)=ATOME(I,NB1)
+ 20 CONTINUE
+ IF(NBZ.EQ.0) THEN
+ NBZ=NBZ+1
+ VAL(NBZ)=COORD(3,NB2)
+ ELSE
+ N1=0
+ DO N=1,NBZ
+ D=ABS(COORD(3,NB2)-VAL(N))
+ IF(D.LT.0.0001) N1=N1+1
+ ENDDO
+ IF(N1.EQ.0) THEN
+ NBZ=NBZ+1
+ VAL(NBZ)=COORD(3,NB2)
+ ENDIF
+ ENDIF
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/arcsin.f b/src/msspec/spec/fortran/common_sub/arcsin.f
new file mode 100644
index 0000000..3e803ba
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/arcsin.f
@@ -0,0 +1,28 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ARCSIN(U,CST,RANGLE)
+C
+C For a given complex number U, this subroutine calculates its phase
+C Warning : it is implicitely assumed that U = sin(theta) exp(i*phi)
+C with theta > or = to 0 which is always the case when theta is obtained
+C from the coordinates of a given vector r by the ACOS intrinsic function.
+C
+C When sin(theta) = 0, then phi = 0 if cos(theta) = 1 and pi if
+C cos(theta) = -1. Cos(theta) is the variable CST.
+C
+ COMPLEX U,CANGLE
+C
+ IF(CABS(U).LT.0.0001) THEN
+ IF(CST.GT.0.) THEN
+ RANGLE=0.
+ ELSEIF(CST.LT.0.) THEN
+ RANGLE=3.141593
+ ENDIF
+ ELSE
+ CANGLE=(0.,-1.)*CLOG(U/CABS(U))
+ RANGLE=REAL(CANGLE)
+ ENDIF
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/atdata.f b/src/msspec/spec/fortran/common_sub/atdata.f
new file mode 100644
index 0000000..d7616b9
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/atdata.f
@@ -0,0 +1,51 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ATDATA
+C
+C This routine contains the atomic mass and the density of all the
+C elements,and the equivalence between their atomic number and
+C chemical symbol.
+C
+C Value Z = 0 added for empty spheres. The values entered in this
+C case are arbitrary and set to the corresponding Z = 1 value
+C divided by 1836 (the ratio of the mass of the proton and electron).
+C
+C Last modified : 25 Apr 2013
+C
+ USE XMRHO_MOD , XM_AT => XMAT, RHO_AT => RHOAT
+ REAL XMAT(0:99),RHOAT(0:99)
+C
+C
+ DATA XMAT/0.00055,1.00794,4.00260,6.941,9.01218,10.81,12.011,14.00
+ &67,15.9994,18.998403,20.179,22.98977,24.305,26.98154,28.0855,30.97
+ &376,32.06,35.453,39.948,39.0983,40.08,44.9559,47.88,50.9415,51.996
+ &,54.9380,55.847,58.9332,58.69,63.546,65.38,69.72,72.59,74.9216,78.
+ &96,79.904,83.80,85.4678,87.62,88.9059,91.22,92.9064,95.94,98.,101.
+ &07,102.9055,106.42,107.8682,112.41,114.82,118.69,121.75,127.60,126
+ &.9045,131.29,132.9054,137.33,138.9055,140.12,140.9077,144.24,145.,
+ &
+ * 150.36,151.96,157.25,158.9254,162.50,164.9304,
+ * 167.26,168.9342,173.04,174.967,178.49,180.9479,
+ * 183.85,186.207,190.2,192.22,195.08,196.9665,
+ * 200.59,204.383,207.2,208.9804,209.,210.,222.,
+ * 223.,226.0254,227.0278,232.0381,231.0359,
+ * 238.0289,237.0482,244.,243.,247.,247.,251.,252./
+C
+ DATA RHOAT/0.0007,0.0708,0.122,0.533,1.845,2.34,2.26,0.81,1.14,1.1
+ &08,1.207,0.969,1.735,2.6941,2.32,1.82,2.07,1.56,1.40,0.860,1.55,2.
+ &980,4.53,6.10,7.18,7.43,7.860,8.9,8.876,8.94,7.112,5.877,5.307,5.7
+ &2,4.78,3.11,2.6,1.529,2.54,4.456,6.494,8.55,10.20,11.48,12.39,12.3
+ &9,12.00,10.48,8.63,7.30,7.30,6.679,6.23,4.92,3.52,1.870,3.5,6.127,
+ &6.637,6.761,6.994,7.20,7.51,5.228,7.8772,8.214,8.525,8.769,9.039,9
+ &.294,6.953,9.811,13.29,16.624,19.3,20.98,22.53,22.39,21.41,18.85,1
+ &3.522,11.83,11.33,
+ * 9.730,9.30,0.0,4.4,0.0,5.,10.05,11.70,15.34,
+ * 18.92,20.21,19.80,13.64,13.49,14.,0.0,0.0/
+C
+ DO J=0,99
+ XM_AT(J)=XMAT(J)
+ RHO_AT(J)=RHOAT(J)
+ ENDDO
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/auger_mult.f b/src/msspec/spec/fortran/common_sub/auger_mult.f
new file mode 100644
index 0000000..9c9fe41
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/auger_mult.f
@@ -0,0 +1,39 @@
+C
+C=======================================================================
+C
+ SUBROUTINE AUGER_MULT
+C
+C This subroutine computes all the possible multiplets that are
+C contained in a given Auger transition line. It assumes that
+C the atom has closed shells only.
+C
+C Last modified : 9 March 2006
+C
+ USE INIT_A_MOD , LI => LI_C, L2 => LI_I, L1 => LI_A
+ USE OUTUNITS_MOD
+C
+ CHARACTER*1 SC(0:1),LC(0:6),JC(0:7)
+ CHARACTER*3 MULTIPLET(112)
+C
+ DATA SC /'1','3'/
+ DATA LC /'S','P','D','F','G','H','I'/
+ DATA JC /'0','1','2','3','4','5','6','7'/
+C
+ WRITE(IUO1,10)
+ N_MULT=0
+ DO NS=0,1
+ DO L=ABS(L1-L2),L1+L2
+ DO J=ABS(L-NS),L+NS
+ N_MULT=N_MULT+1
+ MULTIPLET(N_MULT)=SC(NS)//LC(L)//JC(J)
+ WRITE(IUO1,20) MULTIPLET(N_MULT)
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ 10 FORMAT(///,26X,'THE POSSIBLE MULTIPLETS ARE :',/,' ')
+ 20 FORMAT(58X,A3)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/besphe.f b/src/msspec/spec/fortran/common_sub/besphe.f
new file mode 100644
index 0000000..3de3340
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/besphe.f
@@ -0,0 +1,159 @@
+C
+C=======================================================================
+C
+ SUBROUTINE BESPHE(NL,IBES,X1,FL)
+C
+C This routine computes the spherical Bessel functions for
+C a real argument X1.
+C
+C IBES=1 : Bessel function
+C IBES=2 : Neumann function
+C IBES=3 : Hankel function of the first kind
+C IBES=4 : Hankel function of the second kind
+C IBES=5 : Modified Bessel function
+C IBES=6 : Modified Neumann function
+C IBES=7 : Modified Hankel function
+C
+C Last modified : 8 Nov 2006
+C
+C
+ USE DIM_MOD
+ USE OUTUNITS_MOD
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2
+ COMPLEX*16 ZERO,CNORM
+C
+ DOUBLE PRECISION SCALN(0:N_BESS)
+C
+ REAL X1
+C
+C
+ ECH=37.D0
+ COMP=1.D37
+ COMM=1.D-37
+ X=DBLE(X1)
+ NX=INT(X1)
+ NREC=5*MAX0(NL-1,NX)
+ IF(NREC.GT.N_BESS) GOTO 16
+ ITEST=0
+ ZERO=(0.D0,0.D0)
+ UN=(1.D0,0.D0)
+ C1=UN
+ I=(0.D0,1.D0)
+ C2=I
+ DEB=1.D0
+ IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN
+ IBES1=1
+ IF(IBES.EQ.4) C2=-I
+ ELSEIF(IBES.EQ.7) THEN
+ IBES1=5
+ C2=-UN
+ ELSE
+ IBES1=IBES
+ ENDIF
+C
+C Case where the argument is zero
+C
+ IF(DABS(X).LT.0.000001D0) THEN
+ IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN
+ FL(0)=UN
+ DO 10 L=1,NL-1
+ FL(L)=ZERO
+ 10 CONTINUE
+ ITEST=1
+ ELSE
+ ITEST=-1
+ ENDIF
+ ENDIF
+ IF(ITEST) 11,12,13
+ 11 WRITE(IUO1,14)
+ STOP
+ 16 WRITE(IUO1,17) NREC
+ STOP
+ 15 IBES1=IBES1+1
+C
+C Initial values
+C
+ 12 A=-1.D0
+ B=1.D0
+ IF(IBES1.EQ.1) THEN
+ FL(0)=UN*DSIN(X)/X
+ FLNN(NREC)=ZERO
+ SCALN(NREC)=0.D0
+ FLNN(NREC-1)=UN*DEB
+ SCALN(NREC-1)=0.D0
+ ELSEIF(IBES1.EQ.2) THEN
+ GL(0)=-UN*DCOS(X)/X
+ GL(1)=GL(0)/X -DSIN(X)/X
+ ELSEIF(IBES1.EQ.5) THEN
+ A=1.D0
+ B=-1.D0
+ FL(0)=UN*DSINH(X)/X
+ FLNN(NREC)=ZERO
+ SCALN(NREC)=0.D0
+ FLNN(NREC-1)=UN*DEB
+ SCALN(NREC-1)=0.D0
+ ELSEIF(IBES1.EQ.6) THEN
+ A=1.D0
+ B=-1.D0
+ GL(0)=UN*DCOSH(X)/X
+ GL(1)=(DSINH(X)-GL(0))/X
+ ENDIF
+C
+C Downward reccurence for the spherical Bessel function
+C
+ IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN
+ DO 30 L=NREC-1,1,-1
+ ECHEL=0.D0
+ SCALN(L-1)=SCALN(L)
+ REN=DEXP(SCALN(L)-SCALN(L+1))
+ FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X)
+ IF(CDABS(FLNN(L-1)).GT.COMP) THEN
+ ECHEL=-ECH
+ ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN
+ ECHEL=ECH
+ ENDIF
+ IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1)
+ FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL)
+ 30 CONTINUE
+ CNORM=FL(0)/FLNN(0)
+ DO 40 L=1,NL-1
+ FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L))
+ 40 CONTINUE
+ ELSE
+C
+C Upward recurrence for the spherical Neumann function
+C
+ DO 20 L=1,NL-1
+ IF(IBES.EQ.7) C1=(-UN)**(L+2)
+ GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X
+ IF(IBES1.NE.IBES) THEN
+C
+C Calculation of the spherical Hankel function
+C
+ FL(L+1)=C1*(FL(L+1)+C2*GL(L+1))
+ ELSE
+ FL(L+1)=GL(L+1)
+ ENDIF
+ 20 CONTINUE
+ IF(IBES1.EQ.IBES) THEN
+ FL(0)=GL(0)
+ FL(1)=GL(1)
+ ELSE
+ FL(0)=C1*(FL(0)+C2*GL(0))
+ FL(1)=C1*(FL(1)+C2*GL(1))
+ ENDIF
+ IBES1=IBES
+ ENDIF
+ IF(IBES.NE.IBES1) GOTO 15
+C
+ 13 RETURN
+C
+ 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION
+ &S IS NUL >>>>>>>>>>')
+ 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR
+ &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL
+ &D BE AT LEAST : ',I5,' >>>>>>>>>>')
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/besphe2.f b/src/msspec/spec/fortran/common_sub/besphe2.f
new file mode 100644
index 0000000..1ca3d44
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/besphe2.f
@@ -0,0 +1,156 @@
+C
+C=======================================================================
+C
+ SUBROUTINE BESPHE2(NL,IBES,X,FL)
+C
+C This routine computes the spherical Bessel functions for
+C a real argument X1.
+C
+C IBES=1 : Bessel function
+C IBES=2 : Neumann function
+C IBES=3 : Hankel function of the first kind
+C IBES=4 : Hankel function of the second kind
+C IBES=5 : Modified Bessel function
+C IBES=6 : Modified Neumann function
+C IBES=7 : Modified Hankel function
+C
+C Last modified : 8 Nov 2006
+C
+C
+ USE DIM_MOD
+ USE OUTUNITS_MOD
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2
+ COMPLEX*16 ZERO,CNORM
+C
+ DOUBLE PRECISION SCALN(0:N_BESS)
+C
+C
+ ECH=37.D0
+ COMP=1.D37
+ COMM=1.D-37
+ NX=INT(X)
+ NREC=5*MAX0(NL-1,NX)
+ IF(NREC.GT.N_BESS) GOTO 16
+ ITEST=0
+ ZERO=(0.D0,0.D0)
+ UN=(1.D0,0.D0)
+ C1=UN
+ I=(0.D0,1.D0)
+ C2=I
+ DEB=1.D0
+ IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN
+ IBES1=1
+ IF(IBES.EQ.4) C2=-I
+ ELSEIF(IBES.EQ.7) THEN
+ IBES1=5
+ C2=-UN
+ ELSE
+ IBES1=IBES
+ ENDIF
+C
+C Case where the argument is zero
+C
+ IF(DABS(X).LT.0.000001D0) THEN
+ IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN
+ FL(0)=UN
+ DO 10 L=1,NL-1
+ FL(L)=ZERO
+ 10 CONTINUE
+ ITEST=1
+ ELSE
+ ITEST=-1
+ ENDIF
+ ENDIF
+ IF(ITEST) 11,12,13
+ 11 WRITE(IUO1,14)
+ STOP
+ 16 WRITE(IUO1,17) NREC
+ STOP
+ 15 IBES1=IBES1+1
+C
+C Initial values
+C
+ 12 A=-1.D0
+ B=1.D0
+ IF(IBES1.EQ.1) THEN
+ FL(0)=UN*DSIN(X)/X
+ FLNN(NREC)=ZERO
+ SCALN(NREC)=0.D0
+ FLNN(NREC-1)=UN*DEB
+ SCALN(NREC-1)=0.D0
+ ELSEIF(IBES1.EQ.2) THEN
+ GL(0)=-UN*DCOS(X)/X
+ GL(1)=GL(0)/X -DSIN(X)/X
+ ELSEIF(IBES1.EQ.5) THEN
+ A=1.D0
+ B=-1.D0
+ FL(0)=UN*DSINH(X)/X
+ FLNN(NREC)=ZERO
+ SCALN(NREC)=0.D0
+ FLNN(NREC-1)=UN*DEB
+ SCALN(NREC-1)=0.D0
+ ELSEIF(IBES1.EQ.6) THEN
+ A=1.D0
+ B=-1.D0
+ GL(0)=UN*DCOSH(X)/X
+ GL(1)=(DSINH(X)-GL(0))/X
+ ENDIF
+C
+C Downward reccurence for the spherical Bessel function
+C
+ IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN
+ DO 30 L=NREC-1,1,-1
+ ECHEL=0.D0
+ SCALN(L-1)=SCALN(L)
+ REN=DEXP(SCALN(L)-SCALN(L+1))
+ FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X)
+ IF(CDABS(FLNN(L-1)).GT.COMP) THEN
+ ECHEL=-ECH
+ ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN
+ ECHEL=ECH
+ ENDIF
+ IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1)
+ FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL)
+ 30 CONTINUE
+ CNORM=FL(0)/FLNN(0)
+ DO 40 L=1,NL-1
+ FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L))
+ 40 CONTINUE
+ ELSE
+C
+C Upward recurrence for the spherical Neumann function
+C
+ DO 20 L=1,NL-1
+ IF(IBES.EQ.7) C1=(-UN)**(L+2)
+ GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X
+ IF(IBES1.NE.IBES) THEN
+C
+C Calculation of the spherical Hankel function
+C
+ FL(L+1)=C1*(FL(L+1)+C2*GL(L+1))
+ ELSE
+ FL(L+1)=GL(L+1)
+ ENDIF
+ 20 CONTINUE
+ IF(IBES1.EQ.IBES) THEN
+ FL(0)=GL(0)
+ FL(1)=GL(1)
+ ELSE
+ FL(0)=C1*(FL(0)+C2*GL(0))
+ FL(1)=C1*(FL(1)+C2*GL(1))
+ ENDIF
+ IBES1=IBES
+ ENDIF
+ IF(IBES.NE.IBES1) GOTO 15
+C
+ 13 RETURN
+C
+ 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION
+ &S IS NUL >>>>>>>>>>')
+ 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR
+ &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL
+ &D BE AT LEAST : ',I5,' >>>>>>>>>>')
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/check_vib.f b/src/msspec/spec/fortran/common_sub/check_vib.f
new file mode 100644
index 0000000..da4abc9
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/check_vib.f
@@ -0,0 +1,97 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CHECK_VIB(NAT2)
+C
+C This subroutines checks the geometrical environment of each atom
+C to identify those which can move "freely" in one direction, in
+C order to see whether the mean square displacement in this
+C direction is of bulk type or surface type
+C
+C An atom is considered to move freely in one direction if no other
+C atom is present in the tetragonal cell of height ALENGTH * A
+C and base edge 2 * A, whose base is centered on the atom considered
+C
+C Only prototypical atoms are considered as all equivalent atoms are
+C in the same geometrical environment
+C
+C Surface-like atoms are then identified as having I_FREE = 1
+C
+C Last modified : 24 Apr 2013
+C
+ USE DIM_MOD
+C
+ USE COOR_MOD , COORD => SYM_AT
+ USE OUTUNITS_MOD
+ USE VIBRAT_MOD
+C
+ INTEGER NSUR(NATP_M)
+C
+ DATA SMALL /0.0001/
+C
+ ALENGTH=4.
+C
+C.................... Checking the z direction ....................
+C
+ WRITE(IUO1,11)
+ N_SUR=0
+C
+C Loop on the prototypical atoms
+C
+ DO JTYP=1,N_PROT
+C
+ I_FREE(JTYP)=0
+ JAT0=NCORR(1,JTYP)
+ XA=COORD(1,JAT0)
+ YA=COORD(2,JAT0)
+ ZA=COORD(3,JAT0)
+C
+C Loop on the surrounding atoms
+C
+ I_ACC=0
+C
+ DO JAT=1,NAT2
+C
+ IF(JAT.EQ.JAT0) GOTO 10
+C
+ X=COORD(1,JAT)
+ Y=COORD(2,JAT)
+ Z=COORD(3,JAT)
+C
+C Considering only atoms with Z > ZA
+C
+ IF(Z.LT.(ZA+SMALL)) GOTO 10
+C
+C Lateral and vertical distances between the two atoms
+C
+ D_LAT=(X-XA)*(X-XA)+(Y-YA)*(Y-YA)
+ D_VER=(Z-ZA)*(Z-ZA)
+C
+ IF(D_VER.LT.(ALENGTH+SMALL)) THEN
+ IF(D_LAT.LT.(1.+SMALL)) THEN
+ I_ACC=I_ACC+1
+ ENDIF
+ ENDIF
+C
+ IF(I_ACC.GE.1) GOTO 10
+C
+ 10 CONTINUE
+C
+ ENDDO
+C
+ IF(I_ACC.EQ.0) THEN
+ I_FREE(JTYP)=1
+ N_SUR=N_SUR+1
+ NSUR(N_SUR)=JTYP
+ ENDIF
+C
+ ENDDO
+C
+ WRITE(IUO1,12) (NSUR(J),J=1,N_SUR)
+C
+ 11 FORMAT(//,18X,'SURFACE-LIKE ATOMS FOR MSD CALCULATIONS: ',/)
+ 12 FORMAT(20X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/diran.f b/src/msspec/spec/fortran/common_sub/diran.f
new file mode 100644
index 0000000..20dbecc
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/diran.f
@@ -0,0 +1,190 @@
+C
+C=======================================================================
+C
+ SUBROUTINE DIRAN(VINT,ECIN,J_EL)
+C
+C This subroutine calculates the direction(s) of the analyzer with
+C or without an angular averaging.
+C
+C DIRANA is the internal direction
+C ANADIR is the external direction
+C
+C J_EL is the type of electron : 1 ---> photoelectron
+C 2 ---> Auger electron
+C
+C Last modified : 23/03/2006
+C
+C
+ USE DIRECT_MOD
+ USE DIRECT_A_MOD
+ USE MOYEN_MOD
+ USE MOYEN_A_MOD
+ USE OUTUNITS_MOD
+ USE TESTS_MOD , I1 => ITEST, I2 => ISORT1, N1 => NPATHP, I3 => ISO
+ &M
+ USE TYPCAL_MOD
+ USE TYPCAL_A_MOD
+C
+ COMPLEX COEF,IC
+ DATA PI,PIS2,PIS180 /3.141593,1.570796,0.017453/
+C
+ IC=(0.,1.)
+C
+ IF(J_EL.EQ.1) THEN
+ ANADIR(1,1)=SIN(RTHEXT)*COS(RPHI)
+ ANADIR(2,1)=SIN(RTHEXT)*SIN(RPHI)
+ ANADIR(3,1)=COS(RTHEXT)
+ IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN
+ CALL REFRAC(VINT,ECIN,RTHEXT,RTHINT)
+ ELSE
+ RTHINT=RTHEXT
+ ENDIF
+ IF((IPRINT.GT.0).AND.(I_EXT.NE.2)) THEN
+ DTHEXT=RTHEXT/PIS180
+ DTHINT=RTHINT/PIS180
+ IF(I_TEST.NE.2) WRITE(IUO1,20) DTHEXT,DTHINT
+ ENDIF
+ DIRANA(1,1)=SIN(RTHINT)*COS(RPHI)
+ DIRANA(2,1)=SIN(RTHINT)*SIN(RPHI)
+ DIRANA(3,1)=COS(RTHINT)
+ THETAR(1)=RTHINT
+ PHIR(1)=RPHI
+C
+C The change in the definition below is necessary as RPHI is
+C used to define the rotation axis of the direction of the detector
+C when doing polar variations
+C
+ IF(ITHETA.EQ.1) THEN
+ IF(RPHI.GT.PIS2) THEN
+ RTHEXT=-RTHEXT
+ RPHI=RPHI-PI
+ ELSEIF(RPHI.LT.-PIS2) THEN
+ RTHEXT=-RTHEXT
+ RPHI=RPHI+PI
+ ENDIF
+ ENDIF
+C
+ IF(IMOY.GE.1) THEN
+ N=2**(IMOY-1)
+ S=SIN(ACCEPT*PI/180.)
+ RN=FLOAT(N)
+ J=1
+ DO K1=-N,N
+ RK1=FLOAT(K1)
+ DO K2=-N,N
+ RK2=FLOAT(K2)
+ D=SQRT(RK1*RK1+RK2*RK2)
+ IF((D-RN).GT.0.000001) GOTO 10
+ IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 10
+ C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S)
+ J=J+1
+C
+ ANADIR(1,J)=(RK1*S*COS(RTHEXT)*COS(RPHI) -RK2*S*SIN(RPHI)+
+ &C*ANADIR(1,1))/RN
+ ANADIR(2,J)=(RK1*S*COS(RTHEXT)*SIN(RPHI) +RK2*S*COS(RPHI)+
+ &C*ANADIR(2,1))/RN
+ ANADIR(3,J)=(-RK1*S*SIN(RTHEXT) +C*ANADIR(3,1))/RN
+ THETA_R=ACOS(ANADIR(3,J))
+ COEF=ANADIR(1,J)+IC*ANADIR(2,J)
+ CALL ARCSIN(COEF,ANADIR(3,J),PHI_R)
+ IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN
+ CALL REFRAC(VINT,ECIN,THETA_R,THINT_R)
+ ELSE
+ THINT_R=THETA_R
+ ENDIF
+C
+ DIRANA(1,J)=SIN(THINT_R)*COS(PHI_R)
+ DIRANA(2,J)=SIN(THINT_R)*SIN(PHI_R)
+ DIRANA(3,J)=COS(THINT_R)
+C
+ THETAR(J)=THINT_R
+ PHIR(J)=PHI_R
+ 10 CONTINUE
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ ELSEIF(J_EL.EQ.2) THEN
+ ANADIR_A(1,1)=SIN(RTHEXT_A)*COS(RPHI_A)
+ ANADIR_A(2,1)=SIN(RTHEXT_A)*SIN(RPHI_A)
+ ANADIR_A(3,1)=COS(RTHEXT_A)
+ IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN
+ CALL REFRAC(VINT,ECIN,RTHEXT_A,RTHINT_A)
+ ELSE
+ RTHINT_A=RTHEXT_A
+ ENDIF
+ IF((IPRINT.GT.0).AND.(I_EXT_A.NE.2)) THEN
+ DTHEXT_A=RTHEXT_A/PIS180
+ DTHINT_A=RTHINT_A/PIS180
+ IF(I_TEST_A.NE.2) WRITE(IUO1,21) DTHEXT_A,DTHINT_A
+ ENDIF
+ DIRANA_A(1,1)=SIN(RTHINT_A)*COS(RPHI_A)
+ DIRANA_A(2,1)=SIN(RTHINT_A)*SIN(RPHI_A)
+ DIRANA_A(3,1)=COS(RTHINT_A)
+ THETAR_A(1)=RTHINT_A
+ PHIR_A(1)=RPHI_A
+C
+C The change in the definition below is necessary as RPHI is
+C used to define the rotation axis of the direction of the detector
+C when doing polar variations
+C
+ IF(ITHETA_A.EQ.1) THEN
+ IF(RPHI_A.GT.PIS2) THEN
+ RTHEXT_A=-RTHEXT_A
+ RPHI_A=RPHI_A-PI
+ ELSEIF(RPHI_A.LT.-PIS2) THEN
+ RTHEXT_A=-RTHEXT_A
+ RPHI_A=RPHI_A+PI
+ ENDIF
+ ENDIF
+C
+ IF(IMOY_A.GE.1) THEN
+ N=2**(IMOY_A-1)
+ S=SIN(ACCEPT_A*PI/180.)
+ RN=FLOAT(N)
+ J=1
+ DO K1=-N,N
+ RK1=FLOAT(K1)
+ DO K2=-N,N
+ RK2=FLOAT(K2)
+ D=SQRT(RK1*RK1+RK2*RK2)
+ IF((D-RN).GT.0.000001) GOTO 15
+ IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 15
+ C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S)
+ J=J+1
+C
+ ANADIR_A(1,J)=(RK1*S*COS(RTHEXT_A)*COS(RPHI_A) -RK2*S*SIN(
+ &RPHI_A)+C*ANADIR_A(1,1))/RN
+ ANADIR_A(2,J)=(RK1*S*COS(RTHEXT_A)*SIN(RPHI_A) +RK2*S*COS(
+ &RPHI_A)+C*ANADIR_A(2,1))/RN
+ ANADIR_A(3,J)=(-RK1*S*SIN(RTHEXT_A) +C*ANADIR_A(3,1))/RN
+ THETA_R_A=ACOS(ANADIR_A(3,J))
+ COEF=ANADIR_A(1,J)+IC*ANADIR_A(2,J)
+ CALL ARCSIN(COEF,ANADIR_A(3,J),PHI_R_A)
+ IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN
+ CALL REFRAC(VINT,ECIN,THETA_R_A,THINT_R_A)
+ ELSE
+ THINT_R_A=THETA_R_A
+ ENDIF
+C
+ DIRANA_A(1,J)=SIN(THINT_R_A)*COS(PHI_R_A)
+ DIRANA_A(2,J)=SIN(THINT_R_A)*SIN(PHI_R_A)
+ DIRANA_A(3,J)=COS(THINT_R_A)
+C
+ THETAR_A(J)=THINT_R_A
+ PHIR_A(J)=PHI_R_A
+ 15 CONTINUE
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ ENDIF
+C
+ 20 FORMAT(/,10X,'PHOTOELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T
+ &HETA =', F7.2)
+ 21 FORMAT(/,10X,'AUGER ELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T
+ &HETA =', F7.2)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/djmn.f b/src/msspec/spec/fortran/common_sub/djmn.f
new file mode 100644
index 0000000..15abcac
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/djmn.f
@@ -0,0 +1,171 @@
+C
+C=======================================================================
+C
+ SUBROUTINE DJMN(RBETA,R,LMAX)
+C
+C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to
+C order LMAX, following Messiah's convention.
+C They are stored as R(M2,M1,L).
+C
+C Last modified : 20 Oct 2006
+C
+ USE DIM_MOD
+C
+ USE COEFRLM_MOD
+ USE EXPROT_MOD
+C
+ INTEGER EPS0
+C
+ DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
+C
+ DATA SMALL,SQR2 /0.001,1.4142136/
+C
+ C=COS(RBETA)*0.5
+ S=SIN(RBETA)*0.5
+ CC=C+C
+ CMUL=-1.
+ IF(ABS(S).LT.SMALL) THEN
+ IF(C.GT.0.) EPS0=1
+ IF(C.LT.0.) EPS0=-1
+ DO L=0,LMAX
+ DO M1=-L,L
+ DO M2=-L,L
+ IF(M1.NE.M2*EPS0) THEN
+ R(M2,M1,L)=0.
+ ELSE
+ IF(EPS0.EQ.1) THEN
+ R(M2,M1,L)=1.
+ ELSE
+ IF(MOD(L+M1,2).EQ.0) THEN
+ R(M2,M1,L)=1.
+ ELSE
+ R(M2,M1,L)=-1.
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ S1=S*SQR2
+ C1=0.5+C
+ R(0,0,0)=1.0
+ R(-1,-1,1)=C1
+ R(0,-1,1)=S1
+ R(1,-1,1)=1.-C1
+ R(-1,0,1)=-S1
+ R(0,0,1)=CC
+ R(1,0,1)=S1
+ R(-1,1,1)=1.-C1
+ R(0,1,1)=-S1
+ R(1,1,1)=C1
+C
+ PRODL=-S
+ COEF=-S/C1
+ CL=-1.
+ DO L=2,LMAX
+ CL=-CL
+ L1=L-1
+ FLL1=CC*FLOAT(L+L1)
+ FLL2=1./(FLOAT(L*L1)*CC)
+ PRODL=-PRODL*S
+C
+C Case M = 0
+C
+ R_1=EXPR(0,L)*PRODL
+ R(-L,0,L)=R_1
+C
+ R(L,0,L)=R_1*CL
+ R(0,-L,L)=R_1*CL
+C
+ R(0,L,L)=R_1
+C
+ CM2=CL
+ DO M2=-L1,-1
+ CM2=CM2*CMUL
+ CF1=CF(L1,0,-M2)/FLL1
+ CF2=FLL1/CF(L,0,-M2)
+ IF(-M2.LT.L1) THEN
+ R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1)
+ ELSE
+ R_A=CF2*R(M2,0,L1)
+ ENDIF
+C
+ R(M2,0,L)=R_A
+C
+ R(-M2,0,L)=R_A*CM2
+ R(0,M2,L)=R_A*CM2
+C
+ R(0,-M2,L)=R_A
+C
+ ENDDO
+C
+ R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0
+ &,0)
+C
+C Case M > 0
+C
+ PRODM=1.
+ CM=CL
+ FLLM=0.
+ DO M=1,L1
+ CM=-CM
+ PRODM=PRODM*COEF
+ FLLM=FLLM+FLL2
+C
+ R_1=EXPR(M,L)*PRODL*PRODM
+ R_2=R_1/(PRODM*PRODM)
+C
+ R(-L,M,L)=R_1
+ R(-L,-M,L)=R_2
+C
+ R(L,-M,L)=R_1*CM
+ R(M,-L,L)=R_1*CM
+ R(L,M,L)=R_2*CM
+ R(-M,-L,L)=R_2*CM
+C
+ R(-M,L,L)=R_1
+ R(M,L,L)=R_2
+C
+ CM2=CM
+ DO M2=-L1,-M
+ CM2=-CM2
+ D0=FLOAT(M2)*FLLM
+ CF1=CF(L1,M,-M2)/FLL1
+ CF2=FLL1/CF(L,M,-M2)
+ IF((M.LT.L1).AND.(-M2.LT.L1)) THEN
+ R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1)
+ R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1)
+ ELSE
+ R_A=CF2*(1.-D0)*R(M2,M,L1)
+ R_B=CF2*(1.+D0)*R(M2,-M,L1)
+ ENDIF
+C
+ R(M2,M,L)=R_A
+ R(M2,-M,L)=R_B
+C
+ R(-M2,-M,L)=R_A*CM2
+ R(M,M2,L)=R_A*CM2
+ R(-M,M2,L)=R_B*CM2
+ R(-M2,M,L)=R_B*CM2
+C
+ R(-M,-M2,L)=R_A
+ R(M,-M2,L)=R_B
+C
+ ENDDO
+ ENDDO
+C
+ PRODM=PRODM*COEF
+ R_1=PRODL*PRODM
+ R_2=PRODL/PRODM
+ R(-L,L,L)=R_1
+ R(L,-L,L)=R_1
+ R(L,L,L)=R_2
+ R(-L,-L,L)=R_2
+C
+ ENDDO
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/djmn2.f b/src/msspec/spec/fortran/common_sub/djmn2.f
new file mode 100644
index 0000000..95c7bca
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/djmn2.f
@@ -0,0 +1,191 @@
+C
+C=======================================================================
+C
+ SUBROUTINE DJMN2(RBETA,R,LMAX,ISWITCH)
+C
+C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to
+C order LMAX, following Messiah's convention.
+C They are stored as R(M2,M1,L) and multiplied (ISWITCH=1) or divided
+C by EXPF.
+C
+C Last modified : 20 Oct 2006
+C
+ USE DIM_MOD
+C
+ USE COEFRLM_MOD
+ USE EXPFAC_MOD
+ USE EXPROT_MOD
+C
+ INTEGER EPS0
+C
+ DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
+C
+ DATA SMALL,SQR2 /0.001,1.4142136/
+C
+ C=COS(RBETA)*0.5
+ S=SIN(RBETA)*0.5
+ CC=C+C
+ CMUL=-1.
+ IF(ABS(S).LT.SMALL) THEN
+ IF(C.GT.0.) EPS0=1
+ IF(C.LT.0.) EPS0=-1
+ DO L=0,LMAX
+ DO M1=-L,L
+ DO M2=-L,L
+ IF(M1.NE.M2*EPS0) THEN
+ R(M2,M1,L)=0.
+ ELSE
+ IF(EPS0.EQ.1) THEN
+ R(M2,M1,L)=1.
+ ELSE
+ IF(MOD(L+M1,2).EQ.0) THEN
+ R(M2,M1,L)=1.
+ ELSE
+ R(M2,M1,L)=-1.
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ S1=S*SQR2
+ C1=0.5+C
+ R(0,0,0)=1.0
+ R(-1,-1,1)=C1
+ R(0,-1,1)=S1
+ R(1,-1,1)=1.-C1
+ R(-1,0,1)=-S1
+ R(0,0,1)=CC
+ R(1,0,1)=S1
+ R(-1,1,1)=1.-C1
+ R(0,1,1)=-S1
+ R(1,1,1)=C1
+C
+ PRODL=-S
+ COEF=-S/C1
+ CL=-1.
+ DO L=2,LMAX
+ CL=-CL
+ L1=L-1
+ FLL1=CC*FLOAT(L+L1)
+ FLL2=1./(FLOAT(L*L1)*CC)
+ PRODL=-PRODL*S
+C
+C Case M = 0
+C
+ R_1=EXPR(0,L)*PRODL
+ R(-L,0,L)=R_1
+C
+ R(L,0,L)=R_1*CL
+ R(0,-L,L)=R_1*CL
+C
+ R(0,L,L)=R_1
+C
+ CM2=CL
+ DO M2=-L1,-1
+ CM2=CM2*CMUL
+ CF1=CF(L1,0,-M2)/FLL1
+ CF2=FLL1/CF(L,0,-M2)
+ IF(-M2.LT.L1) THEN
+ R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1)
+ ELSE
+ R_A=CF2*R(M2,0,L1)
+ ENDIF
+C
+ R(M2,0,L)=R_A
+C
+ R(-M2,0,L)=R_A*CM2
+ R(0,M2,L)=R_A*CM2
+C
+ R(0,-M2,L)=R_A
+C
+ ENDDO
+C
+ R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0
+ &,0)
+C
+C Case M > 0
+C
+ PRODM=1.
+ CM=CL
+ FLLM=0.
+ DO M=1,L1
+ CM=-CM
+ PRODM=PRODM*COEF
+ FLLM=FLLM+FLL2
+C
+ R_1=EXPR(M,L)*PRODL*PRODM
+ R_2=R_1/(PRODM*PRODM)
+C
+ R(-L,M,L)=R_1
+ R(-L,-M,L)=R_2
+C
+ R(L,-M,L)=R_1*CM
+ R(M,-L,L)=R_1*CM
+ R(L,M,L)=R_2*CM
+ R(-M,-L,L)=R_2*CM
+C
+ R(-M,L,L)=R_1
+ R(M,L,L)=R_2
+C
+ CM2=CM
+ DO M2=-L1,-M
+ CM2=-CM2
+ D0=FLOAT(M2)*FLLM
+ CF1=CF(L1,M,-M2)/FLL1
+ CF2=FLL1/CF(L,M,-M2)
+ IF((M.LT.L1).AND.(-M2.LT.L1)) THEN
+ R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1)
+ R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1)
+ ELSE
+ R_A=CF2*(1.-D0)*R(M2,M,L1)
+ R_B=CF2*(1.+D0)*R(M2,-M,L1)
+ ENDIF
+C
+ R(M2,M,L)=R_A
+ R(M2,-M,L)=R_B
+C
+ R(-M2,-M,L)=R_A*CM2
+ R(M,M2,L)=R_A*CM2
+ R(-M,M2,L)=R_B*CM2
+ R(-M2,M,L)=R_B*CM2
+C
+ R(-M,-M2,L)=R_A
+ R(M,-M2,L)=R_B
+C
+ ENDDO
+ ENDDO
+C
+ PRODM=PRODM*COEF
+ R_1=PRODL*PRODM
+ R_2=PRODL/PRODM
+ R(-L,L,L)=R_1
+ R(L,-L,L)=R_1
+ R(L,L,L)=R_2
+ R(-L,-L,L)=R_2
+C
+ ENDDO
+ ENDIF
+C
+ IF(ISWITCH.EQ.1) THEN
+ DO L=0,LMAX
+ DO M1=-L,L
+ DO M2=-L,L
+ R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)*EXPF(ABS(M2),L)
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSEIF(ISWITCH.EQ.2) THEN
+ DO L=0,LMAX
+ DO M1=-L,L
+ DO M2=-L,L
+ R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)/EXPF(ABS(M2),L)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/emett.f b/src/msspec/spec/fortran/common_sub/emett.f
new file mode 100644
index 0000000..de45880
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/emett.f
@@ -0,0 +1,52 @@
+C
+C=======================================================================
+C
+ SUBROUTINE EMETT(JEM,IEMET,Z,COORD,NATYP,EMET,NM,JNEM,*)
+C
+C This routine looks for the position of an absorber of type IEMET(JEM)
+C situated in the plane at Z. The result is stored in EMET(3)
+C
+ USE DIM_MOD
+C
+ DIMENSION IEMET(NEMET_M)
+ DIMENSION EMET(3),DIST(NATCLU_M),COORD(3,NATCLU_M),NATYP(NATM)
+C
+ KEMET=0
+ JNT=0
+ IEM=IEMET(JEM)
+ IF(IEM.GT.1) THEN
+ DO JTP=1,IEM-1
+ JNT=JNT+NATYP(JTP)
+ ENDDO
+ ENDIF
+ NB=NATYP(IEM)
+ XMIN=1000000.
+C
+ DO J=1,NB
+ JN=J+JNT
+ DELTAZ=ABS(COORD(3,JN)-Z)
+ IF(DELTAZ.LT.0.0001) THEN
+ XX=COORD(1,JN)
+ XY=COORD(2,JN)
+ XZ=COORD(3,JN)
+ DIST(J)=SQRT(XX*XX+XY*XY+XZ*XZ)
+ IF(DIST(J).LT.XMIN) THEN
+ XMIN=DIST(J)
+ NM=IEM
+ JNEM=J
+ DO I=1,3
+ EMET(I)=COORD(I,JN)
+ ENDDO
+ ENDIF
+ KEMET=KEMET+1
+ ENDIF
+ ENDDO
+C
+ IF(KEMET.EQ.0) THEN
+ NM=IEM
+ RETURN 1
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/euler.f b/src/msspec/spec/fortran/common_sub/euler.f
new file mode 100644
index 0000000..d67b4ad
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/euler.f
@@ -0,0 +1,50 @@
+C
+C=======================================================================
+C
+ SUBROUTINE EULER(RTHETA1,RPHI1,RTHETA2,RPHI2,RALPHA,RBETA,RGAMMA,I
+ &ROT)
+C
+C This routine calculates the Euler angles RALPHA,RBETA,RGAMMA corresponding
+C to the rotation r1(RTHETA1,RPHI1) ----> r2(RTHETA2,RPHI2)
+C
+C IROT=1 : r ---> z represented by (0,RTHETA,PI-RPHI)
+C IROT=0 : r ---> z represented by (0,-RTHETA,-RPHI)
+C
+C
+ COMPLEX U1,U2
+C
+ DATA PI /3.141593/
+C
+ IF(IROT.EQ.1) THEN
+ EPS=1
+ ELSE
+ EPS=-1
+ ENDIF
+ DPHI=RPHI2-RPHI1
+ A1=SIN(RTHETA1)*COS(RTHETA2)
+ A2=COS(RTHETA1)*SIN(RTHETA2)
+ A3=COS(RTHETA1)*COS(RTHETA2)
+ A4=SIN(RTHETA1)*SIN(RTHETA2)
+ U1=A1-A2*COS(DPHI)-(0.,1.)*SIN(RTHETA2)*SIN(DPHI)
+ U2=A1*COS(DPHI)-A2+(0.,1.)*SIN(RTHETA1)*SIN(DPHI)
+ U3=A3+A4*COS(DPHI)
+ IF(U3.GT.1.) U3=1.
+ IF(U3.LT.-1.) U3=-1.
+ RBETA=ACOS(U3)
+ IF(ABS(SIN(RBETA)).GT.0.0001) THEN
+ U1=EPS*U1/SIN(RBETA)
+ U2=EPS*U2/SIN(RBETA)
+ CALL ARCSIN(U1,U3,RALPHA)
+ CALL ARCSIN(U2,U3,RGAMMA)
+ ELSE
+ RALPHA=0.
+ IF(ABS(U3-1.0).LT.0.0001) THEN
+ RGAMMA=0.
+ ELSE
+ RGAMMA=PI
+ ENDIF
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/gaunt.f b/src/msspec/spec/fortran/common_sub/gaunt.f
new file mode 100644
index 0000000..a56a2d5
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/gaunt.f
@@ -0,0 +1,108 @@
+C
+C=======================================================================
+C
+ SUBROUTINE GAUNT(L2,M2,L1,M1,GNT)
+C
+C This subroutine calculates the Gaunt coefficient G(L2,L3|L1)
+C using a downward recursion scheme due to Schulten and Gordon
+C for the Wigner's 3j symbols. The result is stored as GNT(L3),
+C making use of the selection rule M3 = M1 - M2.
+C
+C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
+C
+C Last modified : 8 Dec 2008
+C
+C
+ USE DIM_MOD
+ USE LOGAMAD_MOD
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ REAL GNT(0:N_GAUNT)
+C
+ DOUBLE PRECISION F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT)
+ DOUBLE PRECISION A1(0:N_GAUNT),B(0:N_GAUNT)
+C
+C
+ DATA PI4/12.566370614359D0/
+C
+ L12=L1+L2
+ K12=L1-L2
+C
+ DO J=1,N_GAUNT
+ GNT(J)=0.
+ ENDDO
+C
+ IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10
+C
+ M3=M1-M2
+ LM1=L1+M1
+ LM2=L2+M2
+ KM1=L1-M1
+ KM2=L2-M2
+C
+ IF(MOD(M1,2).EQ.0) THEN
+ COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
+ ELSE
+ COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
+ ENDIF
+C
+ F(L12+1)=0.D0
+ G(L12+1)=0.D0
+ A(L12+1)=0.D0
+ A1(L12+1)=0.D0
+ D1=GLD(2*L2+1,1)-GLD(2*L12+2,1)
+ D2=GLD(2*L1+1,1)-GLD(LM2+1,1)
+ D3=GLD(L12+M3+1,1)-GLD(KM2+1,1)
+ D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
+C
+ IF(MOD(KM1-KM2,2).EQ.0) THEN
+ F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
+ ELSE
+ F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
+ ENDIF
+C
+ D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1))
+ D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1)
+C
+ IF(MOD(K12,2).EQ.0) THEN
+ G(L12)=DEXP(D5+D6)
+ ELSE
+ G(L12)=-DEXP(D5+D6)
+ ENDIF
+C
+ A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3)))
+ B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1)
+ &))
+ A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12)))
+C
+ IF(ABS(M3).LE.L12) THEN
+ GNT(L12)=SNGL(COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1)))
+ ELSE
+ GNT(L12)=0.
+ ENDIF
+C
+ JMIN=MAX0(ABS(K12),ABS(M3))
+C
+ DO J=L12-1,JMIN,-1
+ J1=J+1
+ J2=J+2
+ A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL
+ &OAT(J*J-M3*M3))
+ B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1)))
+ A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J)
+ &))
+ F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1))
+ G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1))
+ GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1))
+C
+ IF(ABS(M3).LE.J) THEN
+ GNT(J)=SNGL(GND)
+ ELSE
+ GNT(J)=0.
+ ENDIF
+C
+ ENDDO
+C
+ 10 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/gaunt2.f b/src/msspec/spec/fortran/common_sub/gaunt2.f
new file mode 100644
index 0000000..3978601
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/gaunt2.f
@@ -0,0 +1,108 @@
+C
+C=======================================================================
+C
+ SUBROUTINE GAUNT2(L2,M2,L1,M1,GNT)
+C
+C This subroutine calculates the Gaunt coefficient G(L2,L3|L1)
+C using a downward recursion scheme due to Schulten and Gordon
+C for the Wigner's 3j symbols. The result is stored as GNT(L3),
+C making use of the selection rule M3 = M1 - M2.
+C
+C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
+C
+C Last modified : 8 Dec 2008
+C This is the double precision version
+C
+C
+C
+ USE DIM_MOD
+ USE LOGAMAD_MOD
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ REAL*8 F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT),A1(0:N_GAUNT)
+ REAL*8 B(0:N_GAUNT),GNT(0:N_GAUNT)
+C
+C
+ DATA PI4/12.566370614359D0/
+C
+ L12=L1+L2
+ K12=L1-L2
+C
+ DO J=1,N_GAUNT
+ GNT(J)=0.D0
+ ENDDO
+C
+ IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10
+C
+ M3=M1-M2
+ LM1=L1+M1
+ LM2=L2+M2
+ KM1=L1-M1
+ KM2=L2-M2
+C
+ IF(MOD(M1,2).EQ.0) THEN
+ COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
+ ELSE
+ COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
+ ENDIF
+C
+ F(L12+1)=0.D0
+ G(L12+1)=0.D0
+ A(L12+1)=0.D0
+ A1(L12+1)=0.D0
+ D1=GLD(2*L2+1,1)-GLD(2*L12+2,1)
+ D2=GLD(2*L1+1,1)-GLD(LM2+1,1)
+ D3=GLD(L12+M3+1,1)-GLD(KM2+1,1)
+ D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
+C
+ IF(MOD(KM1-KM2,2).EQ.0) THEN
+ F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
+ ELSE
+ F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
+ ENDIF
+C
+ D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1))
+ D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1)
+C
+ IF(MOD(K12,2).EQ.0) THEN
+ G(L12)=DEXP(D5+D6)
+ ELSE
+ G(L12)=-DEXP(D5+D6)
+ ENDIF
+C
+ A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3)))
+ B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1)
+ &))
+ A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12)))
+C
+ IF(ABS(M3).LE.L12) THEN
+ GNT(L12)=COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1))
+ ELSE
+ GNT(L12)=0.D0
+ ENDIF
+C
+ JMIN=MAX0(ABS(K12),ABS(M3))
+C
+ DO J=L12-1,JMIN,-1
+ J1=J+1
+ J2=J+2
+ A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL
+ &OAT(J*J-M3*M3))
+ B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1)))
+ A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J)
+ &))
+ F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1))
+ G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1))
+ GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1))
+C
+ IF(ABS(M3).LE.J) THEN
+ GNT(J)=GND
+ ELSE
+ GNT(J)=0.D0
+ ENDIF
+C
+ ENDDO
+C
+ 10 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/harsph.f b/src/msspec/spec/fortran/common_sub/harsph.f
new file mode 100644
index 0000000..94796e2
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/harsph.f
@@ -0,0 +1,61 @@
+C
+C=======================================================================
+C
+ SUBROUTINE HARSPH(NL,THETA,PHI,YLM,NC)
+C
+C This routine computes the complex spherical harmonics using Condon and
+C Shortley phase convention.
+C
+ USE DIM_MOD
+C
+ USE EXPFAC2_MOD
+ USE FACTSQ_MOD
+C
+ COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
+C
+ DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
+ DATA PI,SMALL /3.141593,0.0001/
+C
+ X=COS(THETA)
+ IF(ABS(X).LT.SMALL) X=0.0
+ IF(ABS(X+1.).LT.SMALL) X=-1.0
+ IF(ABS(X-1.).LT.SMALL) X=1.0
+C
+ YLM(0,0)=CMPLX(SQ4PI_INV)
+ YLM(1,0)=X*SQR3_INV
+ DO L=2,NC
+ Y=1./FLOAT(L)
+ YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
+ &-1.5))*YLM(L-2,0)
+ ENDDO
+C
+ C2=-1.
+ IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN
+ C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
+ ELSE
+ C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
+ ENDIF
+C
+ C1=1.
+ COEF=(1.,0.)
+ DO M=1,NC
+ C1=C1*C2
+ COEF=COEF*C
+ YMM=SQ4PI_INV*COEF*FSQ(M)
+ YLM(M,M)=YMM
+ YLM(M,-M)=C1*CONJG(YMM)
+ YMMP=X*SQRT(FLOAT(M+M+3))*YMM
+ YLM(M+1,M)=YMMP
+ YLM(M+1,-M)=C1*CONJG(YMMP)
+ IF(M.LT.NC-1) THEN
+ DO L=M+2,NC
+ YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
+ &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
+ YLM(L,-M)=C1*CONJG(YLM(L,M))
+ ENDDO
+ ENDIF
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/harsph2.f b/src/msspec/spec/fortran/common_sub/harsph2.f
new file mode 100644
index 0000000..0867ff3
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/harsph2.f
@@ -0,0 +1,34 @@
+C
+C=======================================================================
+C
+ SUBROUTINE HARSPH2(NL,THETA,PHI,YLM,NC)
+C
+C This routine computes the complex spherical harmonics using Condon and
+C Shortley phase convention. This version for m=0 only
+C
+ USE DIM_MOD
+C
+ USE EXPFAC2_MOD
+ USE FACTSQ_MOD
+C
+ COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
+C
+ DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
+ DATA PI,SMALL /3.141593,0.0001/
+C
+ X=COS(THETA)
+ IF(ABS(X).LT.SMALL) X=0.0
+ IF(ABS(X+1.).LT.SMALL) X=-1.0
+ IF(ABS(X-1.).LT.SMALL) X=1.0
+C
+ YLM(0,0)=CMPLX(SQ4PI_INV)
+ YLM(1,0)=X*SQR3_INV
+ DO L=2,NC
+ Y=1./FLOAT(L)
+ YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
+ &-1.5))*YLM(L-2,0)
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/harsph3.f b/src/msspec/spec/fortran/common_sub/harsph3.f
new file mode 100644
index 0000000..41ff239
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/harsph3.f
@@ -0,0 +1,70 @@
+C
+C=======================================================================
+C
+ SUBROUTINE HARSPH3(NL,THETA,PHI,YLM2,NC)
+C
+C This routine computes the complex spherical harmonics using Condon and
+C Shortley phase convention.
+C
+ USE DIM_MOD
+C
+ USE EXPFAC2_MOD
+ USE FACTSQ_MOD
+C
+ COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
+ COMPLEX YLM2(LINMAX)
+C
+ DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
+ DATA PI,SMALL /3.141593,0.0001/
+C
+ X=COS(THETA)
+ IF(ABS(X).LT.SMALL) X=0.0
+ IF(ABS(X+1.).LT.SMALL) X=-1.0
+ IF(ABS(X-1.).LT.SMALL) X=1.0
+C
+ YLM(0,0)=CMPLX(SQ4PI_INV)
+ YLM(1,0)=X*SQR3_INV
+ DO L=2,NC
+ Y=1./FLOAT(L)
+ YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
+ &-1.5))*YLM(L-2,0)
+ ENDDO
+C
+ C2=-1.
+ IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN
+ C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
+ ELSE
+ C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
+ ENDIF
+C
+ C1=1.
+ COEF=(1.,0.)
+ DO M=1,NC
+ C1=C1*C2
+ COEF=COEF*C
+ YMM=SQ4PI_INV*COEF*FSQ(M)
+ YLM(M,M)=YMM
+ YLM(M,-M)=C1*CONJG(YMM)
+ YMMP=X*SQRT(FLOAT(M+M+3))*YMM
+ YLM(M+1,M)=YMMP
+ YLM(M+1,-M)=C1*CONJG(YMMP)
+ IF(M.LT.NC-1) THEN
+ DO L=M+2,NC
+ YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
+ &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
+ YLM(L,-M)=C1*CONJG(YLM(L,M))
+ ENDDO
+ ENDIF
+ ENDDO
+C
+ DO L=0,NC
+ IL=L*L+L+1
+ DO M=-L,L
+ IND=IL+M
+ YLM2(IND)=YLM(L,M)
+ ENDDO
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/headers.f b/src/msspec/spec/fortran/common_sub/headers.f
new file mode 100644
index 0000000..8a2e9e7
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/headers.f
@@ -0,0 +1,250 @@
+C
+C=======================================================================
+C
+ SUBROUTINE HEADERS(IUO2)
+C
+C This subroutine writes headers containing the main parameters
+C of the calculation in the result file. The number of
+C lines written depends of the spectroscopy
+C
+C Last modified : 31 Jan 2013
+C
+ USE DIM_MOD
+C
+ USE ALGORITHM_MOD
+ USE APPROX_MOD
+ USE EXAFS_MOD
+ USE HEADER_MOD
+ USE INFILES_MOD
+ USE INIT_A_MOD
+ USE INIT_J_MOD
+ USE INIT_L_MOD
+ USE INIT_M_MOD
+ USE MOYEN_MOD
+ USE PARCAL_MOD
+ USE PARCAL_A_MOD
+ USE TYPCAL_MOD
+ USE TYPCAL_A_MOD
+ USE TYPEXP_MOD
+ USE VALIN_MOD
+ USE VALIN_AV_MOD
+ USE VALFIN_MOD
+ USE VALEX_A_MOD
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C
+ WRITE(IUO2,1)
+ WRITE(IUO2,2)
+C
+C Input files section:
+C
+C Checking the size of filenames
+C
+ N_CHAR1=0
+ DO J_CHAR=1,24
+ IF(INFILE1(J_CHAR:J_CHAR).EQ.' ') GOTO 500
+ N_CHAR1=N_CHAR1+1
+ ENDDO
+ 500 CONTINUE
+C
+ N_CHAR2=0
+ DO J_CHAR=1,24
+ IF(INFILE2(J_CHAR:J_CHAR).EQ.' ') GOTO 501
+ N_CHAR2=N_CHAR2+1
+ ENDDO
+ 501 CONTINUE
+C
+ N_CHAR3=0
+ DO J_CHAR=1,24
+ IF(INFILE3(J_CHAR:J_CHAR).EQ.' ') GOTO 502
+ N_CHAR3=N_CHAR3+1
+ ENDDO
+ 502 CONTINUE
+C
+ N_CHAR4=0
+ DO J_CHAR=1,24
+ IF(INFILE4(J_CHAR:J_CHAR).EQ.' ') GOTO 503
+ N_CHAR4=N_CHAR4+1
+ ENDDO
+ 503 CONTINUE
+C
+ WRITE(IUO2,3) INFILE1(6:N_CHAR1)
+ WRITE(IUO2,4) INFILE2(4:N_CHAR2)
+ IF(INTERACT.NE.'NOINTER') THEN
+ WRITE(IUO2,5) INFILE3(5:N_CHAR3)
+ ENDIF
+ WRITE(IUO2,6) INFILE4(6:N_CHAR4)
+ WRITE(IUO2,2)
+C
+C Type of calculation
+C
+ WRITE(IUO2,2)
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ WRITE(IUO2,11) SPECTRO,ALGO1
+ IF(ALGO1.EQ.'SE') THEN
+ WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
+ ELSEIF(ALGO1.EQ.'CE') THEN
+ WRITE(IUO2,13) NDIF
+ ENDIF
+ WRITE(IUO2,14) VINT
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ WRITE(IUO2,11) SPECTRO,ALGO1
+ IF(ALGO1.EQ.'SE') THEN
+ WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
+ ELSEIF(ALGO1.EQ.'CE') THEN
+ WRITE(IUO2,13) NDIF
+ ENDIF
+ WRITE(IUO2,14) VINT
+ ELSEIF(SPECTRO.EQ.'LED') THEN
+ WRITE(IUO2,11) SPECTRO,ALGO1
+ IF(ALGO1.EQ.'SE') THEN
+ WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
+ ELSEIF(ALGO1.EQ.'CE') THEN
+ WRITE(IUO2,13) NDIF
+ ENDIF
+ WRITE(IUO2,14) VINT
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ WRITE(IUO2,11) SPECTRO,ALGO2
+ IF(ALGO1.EQ.'SE') THEN
+ WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
+ ELSEIF(ALGO1.EQ.'CE') THEN
+ WRITE(IUO2,13) NDIF
+ ENDIF
+ WRITE(IUO2,14) VINT
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ WRITE(IUO2,15) SPECTRO,ALGO1,ALGO2
+ WRITE(IUO2,14) VINT
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+ WRITE(IUO2,11) SPECTRO,ALGO1
+ ELSEIF(SPECTRO.EQ.'RES') THEN
+ CONTINUE
+ ELSEIF(SPECTRO.EQ.'ELS') THEN
+ CONTINUE
+ ENDIF
+C
+ WRITE(IUO2,2)
+C
+C Initial state parameters
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ WRITE(IUO2,21) NI,NLI,S_O,INITL
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ WRITE(IUO2,22) EDGE,NEDGE,INITL
+ ELSEIF(SPECTRO.EQ.'LED') THEN
+ CONTINUE
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ WRITE(IUO2,24) AUGER,MULTIPLET
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ WRITE(IUO2,21) NI,NLI,S_O,INITL
+ WRITE(IUO2,24) AUGER,MULTIPLET
+ ELSEIF(SPECTRO.EQ.'RES') THEN
+ CONTINUE
+ ELSEIF(SPECTRO.EQ.'ELS') THEN
+ CONTINUE
+ ENDIF
+C
+ WRITE(IUO2,2)
+C
+C Angular and energy parameters
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ WRITE(IUO2,35)
+ WRITE(IUO2,34) THLUM,PHILUM,ELUM
+ WRITE(IUO2,2)
+ WRITE(IUO2,36)
+ WRITE(IUO2,31) THETA0,THETA1
+ WRITE(IUO2,32) PHI0,PHI1
+ WRITE(IUO2,33) E0,EFIN
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ WRITE(IUO2,35)
+ WRITE(IUO2,33) EK_INI,EK_FIN
+ WRITE(IUO2,34) THLUM,PHILUM,ELUM
+ ELSEIF(SPECTRO.EQ.'LED') THEN
+ WRITE(IUO2,35)
+ WRITE(IUO2,31) THLUM,PHILUM
+ WRITE(IUO2,2)
+ WRITE(IUO2,36)
+ WRITE(IUO2,31) THETA0,THETA1
+ WRITE(IUO2,32) PHI0,PHI1
+ WRITE(IUO2,2)
+ WRITE(IUO2,33) E0,EFIN
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ WRITE(IUO2,36)
+ WRITE(IUO2,31) THETA0_A,THETA1_A
+ WRITE(IUO2,32) PHI0_A,PHI1_A
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ WRITE(IUO2,35)
+ WRITE(IUO2,34) THLUM,PHILUM,ELUM
+ WRITE(IUO2,2)
+ WRITE(IUO2,37)
+ WRITE(IUO2,31) THETA0,THETA1
+ WRITE(IUO2,32) PHI0,PHI1
+ WRITE(IUO2,33) E0,EFIN
+ WRITE(IUO2,2)
+ WRITE(IUO2,38)
+ WRITE(IUO2,31) THETA0_A,THETA1_A
+ WRITE(IUO2,32) PHI0_A,PHI1_A
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+ WRITE(IUO2,33) EK_INI,EK_FIN
+ ELSEIF(SPECTRO.EQ.'RES') THEN
+ CONTINUE
+ ELSEIF(SPECTRO.EQ.'ELS') THEN
+ CONTINUE
+ ENDIF
+C
+C End of headers
+C
+ WRITE(IUO2,2)
+ WRITE(IUO2,1)
+ WRITE(IUO2,39)
+C
+C Formats
+C
+ 1 FORMAT('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!','
+ &!!!!!!!!!!!!!!!!')
+ 2 FORMAT('!',69X,'!')
+ 3 FORMAT('!',10X,'data file : ',A19,20X,'!')
+ 4 FORMAT('!',10X,'t-matrix file : ',A17,20X,'!')
+ 5 FORMAT('!',10X,'rad integral file: ',A20,20X,'!')
+ 6 FORMAT('!',10X,'cluster file : ',A19,20X,'!')
+C
+ 11 FORMAT('!',10X,'spectroscopy : ',A3,8X,'algorithm : ',A2,
+ &10X,'!')
+ 12 FORMAT('!',15X,'NO = ',I1,' NDIF = ',I2,' IFWD = ',I1,' IPW = '
+ &,I1,' ILENGTH = ',I1,5X,'!')
+ 13 FORMAT('!',15X,'NDIF = ',I2,45X,'!')
+ 14 FORMAT('!',10X,'inner potential : ',F6.2,' eV',28X,'!')
+ 15 FORMAT('!',10X,'spectroscopy: ',A3,10X,'algorithm (photo): ',A2,11
+ &X,'!',/,'!',37X,'algorithm (auger): ',A2, 11X,'!')
+C
+ 21 FORMAT('!',10X,'initial state : ',I1,A1,1X,A3,' selection rules
+ &:',' INITL = ',I2,6X,'!')
+ 22 FORMAT('!',10X,'initial state : ',A1,I1,2X,' selection rules:',
+ &' INITL = ',I2,8X,'!')
+ 24 FORMAT('!',10X,'initial state : ',A6,2X,' multiplet: ',A3,17X,'
+ &!')
+C
+ 31 FORMAT('!',10X,'THETA_INI: ',F8.2,6X,'THETA_FIN: ',F8.2,15X,'!')
+ 32 FORMAT('!',10X,'PHI_INI : ',F8.2,6X,'PHI_FIN : ',F8.2,15X,'!')
+ 33 FORMAT('!',10X,'E_INI : ',F8.2,' eV',3X,'E_FIN : ',F8.2,' eV
+ &',12X,'!')
+ 34 FORMAT('!',10X,'THETA_LUM: ',F8.2,2X,'PHI_LUM: ',F8.2,2X,'E_LUM: '
+ &,F8.2,' eV !')
+ 35 FORMAT('!',10X,'incoming beam : ',40X,'!')
+ 36 FORMAT('!',10X,'outgoing beam : ',40X,'!')
+ 37 FORMAT('!',10X,'photoelectron beam:',40X,'!')
+ 38 FORMAT('!',10X,'auger beam :',40X,'!')
+ 39 FORMAT(71X)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/ig.f b/src/msspec/spec/fortran/common_sub/ig.f
new file mode 100644
index 0000000..56cfb4f
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/ig.f
@@ -0,0 +1,25 @@
+C
+C=======================================================================
+C
+ INTEGER FUNCTION IG(J)
+C
+C This function is returns the value 1 if J is an integer
+C and 2 if it is a half-integer
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+C
+ REAL*8 J,JJ
+C
+ DATA SMALL /0.0001D0/
+C
+ JJ=ABS(J+J)
+C
+ LL=INT(JJ+SMALL)
+C
+ IF(MOD(LL,2).EQ.0) THEN
+ IG=1
+ ELSE
+ IG=2
+ ENDIF
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/locate.f b/src/msspec/spec/fortran/common_sub/locate.f
new file mode 100644
index 0000000..e6c2c46
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/locate.f
@@ -0,0 +1,37 @@
+C
+C=======================================================================
+C
+ SUBROUTINE LOCATE(XX,N,X,J)
+C
+C
+C This subroutine is taken from the book :
+C "Numerical Recipes : The Art of Scientific
+C Computing" par W.H. PRESS, B.P. FLANNERY,
+C S.A. TEUKOLSKY et W.T. VETTERLING
+C (Cambridge University Press 1992)
+C
+C It performs a search in an ordered table using a bisection method.
+C Given a monotonic array XX(1:N) and a value X, it returns J such
+C that X is between XX(J) and XX(J+1).
+C
+ INTEGER J,N
+ INTEGER JL,JM,JU
+C
+ REAL X,XX(N)
+C
+ JL=0
+ JU=N+1
+ 10 IF(JU-JL.GT.1)THEN
+ JM=(JU+JL)/2
+ IF((XX(N).GT.XX(1)).EQV.(X.GT.XX(JM)))THEN
+ JL=JM
+ ELSE
+ JU=JM
+ ENDIF
+ GOTO 10
+ ENDIF
+ J=JL
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/lpm.f b/src/msspec/spec/fortran/common_sub/lpm.f
new file mode 100644
index 0000000..09c1f48
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/lpm.f
@@ -0,0 +1,59 @@
+C
+C=======================================================================
+C
+ SUBROUTINE LPM(E,XLPM,*)
+C
+C This routine generates the electron mean free path
+C
+C ILPM=-1: XLPM is set to 1.E+30
+C ILPM=0 : XLPM is the value given in the input data file
+C ILPM=1 : XLPM computed from Tokutaka et al, Surf. Sci. 149,349 (1985)
+C ILPM=2 : XLPM computed from the Seah and Dench expression
+C
+C Last modified : 15 Sep 2009
+C
+ USE LPMOY_MOD , NZ => NZA, XMAT => XMTA, RHO => RHOTA
+ USE OUTUNITS_MOD
+ USE TESTS_MOD
+ USE VALIN_MOD
+C
+ E=E+VINT
+C
+ IF(ILPM.EQ.-1) THEN
+ XLPM=1.E+30
+ ELSEIF(ILPM.EQ.0) THEN
+ XLPM=XLPM0
+ ELSEIF(ILPM.EQ.1) THEN
+ Q=FLOAT(NZ)*RHO/XMAT
+ CSTE1=ALOG(Q/4.50)/(ALOG(7.74/4.50))
+ CSTE2=ALOG(Q/3.32)/(ALOG(7.74/3.32))
+ CSTE3=ALOG(Q/3.32)/(ALOG(4.50/3.32))
+ A1=0.7271+0.2595*ALOG(E)
+ A2=-3.2563+0.9395*ALOG(E)
+ A3=-2.5716+0.8226*ALOG(E)
+ IF(E.GE.350.) GO TO 10
+ XLN=CSTE1*(0.0107-0.0083*ALOG(E))+A1
+ GO TO 20
+ 10 IF((NZ.GE.24).AND.(NZ.LE.74)) GO TO 30
+ XLN=CSTE2*(1.6551-0.2890*ALOG(E))+A2
+ GO TO 20
+ 30 IF(NZ.GE.42) GO TO 40
+ XLN=CSTE3*(0.6847-0.1169*ALOG(E))+A2
+ GO TO 20
+ 40 XLN=CSTE1*(0.9704-0.1721*ALOG(E))+A3
+ 20 XLPM=EXP(XLN)
+ ELSEIF(ILPM.EQ.2) THEN
+ XLPM=1430./(E**2)+0.54*SQRT(E)
+ ELSE
+ RETURN 1
+ ENDIF
+C
+ E=E-VINT
+ IF(IPRINT.GT.0) WRITE(IUO1,80) E,XLPM
+C
+ 80 FORMAT(/////,2X,'========= E = ',F7.2,' eV',5X,'MEAN',' FREE PATH
+ & = ',F6.3,' ANGSTROEMS ','=========')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/n_j.f b/src/msspec/spec/fortran/common_sub/n_j.f
new file mode 100644
index 0000000..0e608db
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/n_j.f
@@ -0,0 +1,340 @@
+C
+C=======================================================================
+C
+ SUBROUTINE N_J(J1,MJ1,J2,MJ2,MJ6,NJ,I_INT,N_IN)
+C
+C This subroutine calculates Wigner's 3j and 6j coefficients
+C using a downward recursion scheme due to Schulten and Gordon.
+C The 3j are defined as (J1 J2 J) where in fact L1=MJ1, etc are
+C (L1 L2 L)
+C azimuthal quantum numbers, and the 6j as {J1 J2 J} where now
+C {L1 L2 L}
+C J1, L1, etc are the same kind of orbital quantum numbers.
+C The result is stored as NJ(J).
+C
+C The parameter N allows to choose between 3j and 6j calculation, and
+C Clebsch-Gordan. It can take the values :
+C
+C N = 2 ----> Clebsch-Gordan
+C N = 3 ----> Wigner's 3j
+C N = 6 ----> Wigner's 6j
+C
+C The Clebsch-Gordan coefficients are related to Wigner's 3j through :
+C
+C CG(J1,M1,J2,M2|J,MJ) = ( J1 J2 J )*sqrt(2*J+1)*(-1)**(J1-J2+MJ)
+C ( M1 M2 -MJ )
+C I_INT is a flag that returns 1 if the index J of the nj symbol
+C is integer and 0 if it is a half integer.
+C
+C Note : For 3j, MJ6 is ignored while for 6j, we have :
+C
+C J1=J1 MJ1=L1 J2=J2 MJ2=L2 MJ6=L
+C
+C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
+C
+C Last modified : 8 Dec 2008 ----> D. Sebilleau
+C
+C
+ USE DIM_MOD
+ USE LOGAMAD_MOD
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ REAL*4 NJ(0:N_GAUNT)
+C
+ REAL*8 J1,J2,J,MJ1,MJ2,MJ,JP1,JP2
+ REAL*8 F(0:N_GAUNT),A(0:N_GAUNT),B(0:N_GAUNT)
+ REAL*8 JL12,JK12,MJ6,SIG
+ REAL*8 JJ1,JJ2,JL1,JL2,JL3,JJ12,JJ_MIN,JJ_MAX
+C
+C
+ DATA SMALL /0.0001D0/
+C
+ IS=0
+C
+ IF(N_IN.EQ.2) THEN
+ N_OU=3
+ I_CG=1
+ ELSE
+ N_OU=N_IN
+ I_CG=0
+ ENDIF
+C
+ IF(N_OU.EQ.3) THEN
+C
+C------------------------------ 3j case ---------------------------------
+C
+C
+C Test to check if J1 and J2 are integer or semi-integer
+C
+C Integer : IG=1
+C Half-integer : IG=2
+C
+C Each angular momentum J is represented by the integer index L and
+C the corresponding MJ by M
+C
+ L1=INT(J1+SMALL)
+ L2=INT(J2+SMALL)
+ M1=INT(MJ1+SIGN(SMALL,MJ1))
+ M2=INT(MJ2+SIGN(SMALL,MJ2))
+ DIF1=J1-DFLOAT(L1)
+ DIF2=J2-DFLOAT(L2)
+C
+C IGx is a flag telling the code which case of Gamma function to use :
+C
+C IGx = 1 : integer case
+C IGx = 2 : half-integer case
+C
+ IF(ABS(DIF1).LT.SMALL) THEN
+ IG1=1
+ ELSE
+ IG1=2
+ ENDIF
+ IF(ABS(DIF2).LT.SMALL) THEN
+ IG2=1
+ ELSE
+ IG2=2
+ ENDIF
+ IF(IG1.EQ.IG2) THEN
+ IGG=1
+ IF(IG1.EQ.2) IS=1
+ ELSE
+ IGG=2
+ ENDIF
+C
+C Here, we assume that (J1,J2) are both either integer or half-integer
+C If J is integer, the corresponding index is L = j (for loops or storage)
+C while if J is an half-integer, this index is L= j - 1/2 = int(j)
+C
+C Integer indices are used for loops and for storage while true values
+C are used for the initial values. When J1 and J2 are both half-integers,
+C the values of J are integer and L should be increased by 1
+C
+ JL12=J1+J2
+ JK12=J1-J2
+C
+ L12=INT(JL12 + SIGN(SMALL,JL12))
+ K12=INT(JK12 + SIGN(SMALL,JK12))
+C
+ LM1=INT(J1+MJ1 + SIGN(SMALL,J1+MJ1))
+ LM2=INT(J2+MJ2 + SIGN(SMALL,J2+MJ2))
+ KM1=INT(J1-MJ1 + SIGN(SMALL,J1-MJ1))
+ KM2=INT(J2-MJ2 + SIGN(SMALL,J2-MJ2))
+C
+ MJ=-MJ1-MJ2
+C
+ M=INT(MJ+SIGN(SMALL,MJ))
+ L12M=INT(JL12+MJ+SIGN(SMALL,JL12+MJ))
+ K12M=INT(JL12-MJ+SIGN(SMALL,JL12-MJ))
+ L1_2=INT(J1+J1+SIGN(SMALL,J1))
+ L2_2=INT(J2+J2+SIGN(SMALL,J2))
+ L12_2=INT(JL12+JL12+SIGN(SMALL,JL12))
+C
+ IF(IG(JL12).EQ.1) THEN
+ I_INT=1
+ ELSE
+ I_INT=0
+ ENDIF
+C
+C Initialisation of the 3j symbol NJ(J) = (J1 J2 J)
+C (MJ1 MJ2 MJ)
+C
+ DO L=0,L12
+ NJ(L)=0.
+ ENDDO
+C
+ IF((ABS(MJ1).GT.J1).OR.(ABS(MJ2).GT.J2)) GOTO 10
+C
+C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward
+C recursion scheme. This scheme writes as
+C
+C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0
+C
+ F(L12+1)=0.D0
+ A(L12+1)=0.D0
+ D1=GLD(L2_2+1,1)-GLD(L12_2+2,1)
+ D2=GLD(L1_2+1,1)-GLD(LM2+1,1)
+ D3=GLD(L12M+1,1)-GLD(KM2+1,1)
+ D4=GLD(K12M+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
+C
+ N12=INT(JK12-MJ + SIGN(SMALL,JK12-MJ))
+C
+ IF(I_CG.EQ.1) THEN
+ IF(MOD(N12,2).EQ.0) THEN
+ SIG=1.D0
+ ELSE
+ SIG=-1.D0
+ ENDIF
+ ENDIF
+C
+ IF(MOD(N12,2).EQ.0) THEN
+ F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
+ ELSE
+ F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
+ ENDIF
+C
+ A(L12)=2.D0*DSQRT(J1*J2*(1.D0+2.D0*JL12)*(JL12*JL12-MJ*MJ))
+ B(L12)=-(2.D0*JL12+1.D0)*((J1*J1-J2*J2+JK12)*MJ-JL12*(JL12+1.D0)
+ &*(MJ2-MJ1))
+C
+ IF(ABS(M).LE.L12) THEN
+ IF(I_CG.EQ.0) THEN
+ NJ(L12)=SNGL(F(L12))
+ ELSE
+ NJ(L12)=SNGL(F(L12)*SIG*DSQRT(JL12+JL12+1.D0))
+ ENDIF
+ ELSE
+ NJ(L12)=0.
+ ENDIF
+C
+ LMIN=MAX0(ABS(K12),ABS(M))
+C
+C Downward recursion for NJ(J)
+C
+ DO L=L12-1,LMIN,-1
+ LP1=L+1
+ LP2=L+2
+C
+C Value of the angular momentum J corresponding to the loop index L
+C
+ IF(IGG.EQ.1) THEN
+ J=DFLOAT(L)
+ JP1=DFLOAT(LP1)
+ JP2=DFLOAT(LP2)
+ ELSE
+ J=DFLOAT(L) + 0.5D0
+ JP1=DFLOAT(LP1) + 0.5D0
+ JP2=DFLOAT(LP2) + 0.5D0
+ ENDIF
+C
+ A(L)=DSQRT((J*J-JK12*JK12)*((JL12+1.D0)*(JL12+1.D0)-J*J)*(J*J-
+ &MJ*MJ))
+ B(L)=-(2.D0*J+1.D0)*(J1*(J1+1.D0)*MJ-J2*(J2+1.D0)*MJ-J*JP1*(MJ
+ &2-MJ1))
+ F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1))
+C
+ IF(ABS(MJ).LE.J) THEN
+ IF(I_CG.EQ.0) THEN
+ NJ(L)=SNGL(F(L))
+ ELSE
+ NJ(L)=SNGL(F(L)*SIG*DSQRT(J+J+1.D0))
+ ENDIF
+ ELSE
+ NJ(L)=0.
+ ENDIF
+C
+ ENDDO
+C
+ 10 CONTINUE
+C
+ ELSEIF(N_OU.EQ.6) THEN
+C
+C------------------------------ 6j case ---------------------------------
+C
+C Change of notation for greater readability ---> NJ(JJ)
+C
+C True angular momentum value : begins with a J (JJn,JLn)
+C Corresponding integer storage and loop index : begins by L (LJn,LLn)
+C
+ JJ1=J1
+ JJ2=J2
+ JL1=MJ1
+ JL2=MJ2
+ JL3=MJ6
+C
+ LJ1=INT(JJ1+SIGN(SMALL,JJ1))
+ LJ2=INT(JJ2+SIGN(SMALL,JJ2))
+ LL1=INT(JL1+SIGN(SMALL,JL1))
+ LL2=INT(JL2+SIGN(SMALL,JL2))
+ LL3=INT(JL3+SIGN(SMALL,JL3))
+C
+ JJ12=JJ1-JJ2
+ JL12=JL1-JL2
+C
+ LJ12=INT(JJ12+SIGN(SMALL,JJ12))
+ LL12=INT(JL12+SIGN(SMALL,JL12))
+C
+ JJ_MIN=MAX(ABS(LJ12),ABS(LL12))
+ JJ_MAX=MIN(JJ1+JJ2,JL1+JL2)
+ LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN))
+ LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX))
+C
+C Initialisation of the 6j symbol NJ(J) = {J1 J2 J }
+C {L1 L2 L3}
+C
+ DO L=0,LJJ_MAX
+ NJ(L)=0.
+ ENDDO
+C
+C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward
+C recursion scheme. This scheme writes as
+C
+C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0
+C
+C There are two possible initial values as max(|J1-J2|,|L1-L2|) <= J <=
+C min(J1+J2,L1+L2) :
+C
+C {J1 J2 L1+L2} and {J1 J2 J1+J2} = {L1 L2 J1+J2}
+C {L1 L2 L3 } {L1 L2 L3 } {J1 J2 L3 }
+C
+C They can be calculated from equation (6.3.1) of Edmonds page 97
+C
+ F(LJJ_MAX+1)=0.D0
+ A(LJJ_MAX+1)=0.D0
+C
+ IF(ABS(JJ_MAX-JL1-JL2).LT.SMALL) THEN
+ F(LJJ_MAX)=SIXJ_IN(JJ1,JJ2,JL1,JL2,JL3)
+ ELSE
+ F(LJJ_MAX)=SIXJ_IN(JL1,JL2,JJ1,JJ2,JL3)
+ ENDIF
+ NJ(LJJ_MAX)=SNGL(F(LJJ_MAX))
+C
+ A(LJJ_MAX)=SQRT((JJ_MAX*JJ_MAX-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.
+ &D0)*(JJ1+JJ2+1.D0)-JJ_MAX*JJ_MAX)*(JJ_MAX*JJ_MAX-(JL1-JL2)*(JL1-JL
+ &2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)-JJ_MAX*JJ_MAX))
+ B(LJJ_MAX)=(JJ_MAX+JJ_MAX+1.D0)*(JJ_MAX*(JJ_MAX+1.D0)*(-JJ_MAX*(
+ &JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1*(JL1+1.D0)*(JJ_MAX
+ &*(JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(JJ_M
+ &AX*(JJ_MAX+1.D0)-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(JJ_MAX+JJ_MAX)*(J
+ &J_MAX+1.D0)*JL3*(JL3+1.D0))
+C
+ IF(IG(JJ_MAX).EQ.1) THEN
+ I_INT=1
+ ELSE
+ I_INT=0
+ ENDIF
+C
+C Downward recurrence relation
+C
+ DO L=LJJ_MAX-1,LJJ_MIN,-1
+ LP1=L+1
+ LP2=L+2
+C
+C Value of the angular momentum J corresponding to the loop index L
+C
+ IF(IG(JJ_MAX).EQ.1) THEN
+ J=DFLOAT(L)
+ JP1=DFLOAT(LP1)
+ JP2=DFLOAT(LP2)
+ ELSE
+ J=DFLOAT(L) + 0.5D0
+ JP1=DFLOAT(LP1) + 0.5D0
+ JP2=DFLOAT(LP2) + 0.5D0
+ ENDIF
+C
+ A(L)=SQRT((J*J-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.D0)*(JJ1+JJ2+1
+ &.D0)-J*J)*(J*J-(JL1-JL2)*(JL1-JL2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)
+ &-J*J))
+ B(L)=(J+J+1)*(J*JP1*(-J*JP1+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1
+ &*(JL1+1.D0)*(J*JP1+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(
+ &J*JP1-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(J+J)*JP1*JL3*(JL3+1.D0))
+C
+ F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1))
+ NJ(L)=SNGL(F(L))
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/ordre.f b/src/msspec/spec/fortran/common_sub/ordre.f
new file mode 100644
index 0000000..55c07fa
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/ordre.f
@@ -0,0 +1,48 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ORDRE(NINI,VALINI,NFIN,VALFIN)
+C
+C Given a set of **real** numbers VALINI, this routine orders them and
+C suppresses the values appearing more than once. The remaining
+C values are stored in VALFIN.
+C
+C VALINI(K+1).GT.VALINI(K) : decreasing order
+C VALINI(K+1).LT.VALINI(K) : increasing order
+C
+C
+ DIMENSION VALINI(NINI),VALFIN(NINI)
+C
+ LOGICAL BUBBLE
+C
+ DATA SMALL /0.00001/
+C
+ DO J=1,NINI-1
+ K=J
+ BUBBLE=.TRUE.
+150 IF(K.GE.1.AND.BUBBLE) THEN
+ IF(VALINI(K+1).GT.VALINI(K)) THEN
+ R1=VALINI(K)
+ VALINI(K)=VALINI(K+1)
+ VALINI(K+1)=R1
+ ELSE
+ BUBBLE=.FALSE.
+ END IF
+ K=K-1
+ GOTO 150
+ ENDIF
+ ENDDO
+C
+ JFIN=1
+ VALFIN(1)=VALINI(1)
+ DO J=1,NINI-1
+ IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN
+ JFIN=JFIN+1
+ VALFIN(JFIN)=VALINI(J+1)
+ ENDIF
+ ENDDO
+ NFIN=JFIN
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/ordre2.f b/src/msspec/spec/fortran/common_sub/ordre2.f
new file mode 100644
index 0000000..d2e980e
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/ordre2.f
@@ -0,0 +1,47 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ORDRE2(NINI,VALINI,NFIN,VALFIN)
+C
+C Given a set of **integer** numbers VALINI, this routine orders them
+C and suppresses the values appearing more than once. The remaining
+C values are stored in VALFIN.
+C
+C VALINI(K+1).GT.VALINI(K) : decreasing order
+C VALINI(K+1).LT.VALINI(K) : increasing order
+C
+C
+C
+ INTEGER VALINI(NINI),VALFIN(NINI),R1
+C
+ LOGICAL BUBBLE
+C
+ DO J=1,NINI-1
+ K=J
+ BUBBLE=.TRUE.
+150 IF(K.GE.1.AND.BUBBLE) THEN
+ IF(VALINI(K+1).LT.VALINI(K)) THEN
+ R1=VALINI(K)
+ VALINI(K)=VALINI(K+1)
+ VALINI(K+1)=R1
+ ELSE
+ BUBBLE=.FALSE.
+ ENDIF
+ K=K-1
+ GOTO 150
+ ENDIF
+ ENDDO
+C
+ JFIN=1
+ VALFIN(1)=VALINI(1)
+ DO J=1,NINI-1
+ IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.0) THEN
+ JFIN=JFIN+1
+ VALFIN(JFIN)=VALINI(J+1)
+ ENDIF
+ ENDDO
+ NFIN=JFIN
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/plm.f b/src/msspec/spec/fortran/common_sub/plm.f
new file mode 100644
index 0000000..b141f3e
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/plm.f
@@ -0,0 +1,43 @@
+C
+C=======================================================================
+C
+ SUBROUTINE PLM(X,PLMM,NC)
+C
+C This routine computes the Legendre functions. It is a modified version
+C of that written by W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY and
+C W.T. VETTERLING in "Numerical Recipes : The Art of Scientific
+C Computing" (Cambridge University Press 1992).
+C
+ DIMENSION PLMM(0:100,0:100)
+C
+ PLMM(0,0)=1.
+ PLMM(1,0)=X
+ DO L=2,NC
+ PLMM(L,0)=(X*(L+L-1)*PLMM(L-1,0)-(L-1)*PLMM(L-2,0))/L
+ ENDDO
+C
+ DO M=1,NC
+ PMM=1.
+ FACT=1.
+ SOMX2=SQRT(1.-X*X)
+ FACT=1.
+ DO I=1,M
+ PMM=-PMM*FACT*SOMX2
+ FACT=FACT+2.
+ ENDDO
+ PMMP1=X*FACT*PMM
+ PLMM(M,M)=PMM
+ PLMM(M+1,M)=PMMP1
+ IF(M.LT.NC-1) THEN
+ DO L=M+2,NC
+ PLL=(X*(L+L-1)*PMMP1-(L+M-1)*PMM)/(L-M)
+ PMM=PMMP1
+ PMMP1=PLL
+ PLMM(L,M)=PLL
+ ENDDO
+ ENDIF
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/polhan.f b/src/msspec/spec/fortran/common_sub/polhan.f
new file mode 100644
index 0000000..c5eb001
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/polhan.f
@@ -0,0 +1,49 @@
+C
+C=============================================================================
+C
+ SUBROUTINE POLHAN(ISPHER,NO,NC,RHO,HLM)
+C
+C This routine calculates a function HLM(L,M), related to the the Hankel
+C polynomials and their derivatives with respect to z=1/ikr,
+C necessary for the Rehr-Albers expansion of the propagator.
+C
+ USE DIM_MOD
+C
+ COMPLEX HLM(0:NO_ST_M,0:NL_M-1),RHO,Z,ONEC
+C
+ ONEC=(1.,0.)
+C
+ IF(ISPHER.GE.1) THEN
+ Z=(0.,-1.)/RHO
+C
+C Case M = 0
+C
+ HLM(0,0)=ONEC
+ HLM(0,1)=ONEC-Z
+ DO L=2,NC
+ HLM(0,L)=HLM(0,L-2)-FLOAT(L+L-1)*Z*HLM(0,L-1)
+ ENDDO
+C
+C Case M > 0
+C
+ IF(NO.GE.1) THEN
+ DO M=1,NO
+ HLM(M,M)=-Z*HLM(M-1,M-1)*FLOAT(M+M-1)
+ HLM(M,M+1)=HLM(M,M)*FLOAT(M+M+1)*(ONEC-Z*FLOAT(M+1))
+ DO L=M+2,NC
+ HLM(M,L)=HLM(M,L-2)-FLOAT(L+L-1)*Z*(HLM(M,L-1)+HLM(M-1,L-1
+ &))
+ ENDDO
+ ENDDO
+ ENDIF
+ ELSE
+ DO M=0,NO
+ DO L=M,NC
+ HLM(M,L)=ONEC
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/polleg.f b/src/msspec/spec/fortran/common_sub/polleg.f
new file mode 100644
index 0000000..4ff5c26
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/polleg.f
@@ -0,0 +1,21 @@
+C
+C=======================================================================
+C
+ SUBROUTINE POLLEG(NC,X,PL)
+C
+C This routine computes the Legendre polynomials up to order NC-1
+C
+ DIMENSION PL(0:100)
+C
+ PL(0)=1.
+ PL(1)=X
+ DO 10 L=2,NC-1
+ L1=L-1
+ L2=L-2
+ L3=2*L-1
+ PL(L)=(X*FLOAT(L3)*PL(L1)-FLOAT(L1)*PL(L2))/FLOAT(L)
+ 10 CONTINUE
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/prscal.f b/src/msspec/spec/fortran/common_sub/prscal.f
new file mode 100644
index 0000000..f364b29
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/prscal.f
@@ -0,0 +1,14 @@
+C
+C=======================================================================
+C
+ FUNCTION PRSCAL(A1,A2)
+C
+C This function computes the dot product of the two vectors A1 and A2
+C
+ DIMENSION A1(3),A2(3)
+C
+ PRSCAL=A1(1)*A2(1)+A1(2)*A2(2)+A1(3)*A2(3)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/prvect.f b/src/msspec/spec/fortran/common_sub/prvect.f
new file mode 100644
index 0000000..8a1e63d
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/prvect.f
@@ -0,0 +1,17 @@
+C
+C=======================================================================
+C
+ SUBROUTINE PRVECT(A1,A2,A3,C)
+C
+C This function computes the vector product of the two vectors A1 and A2.
+C The result is A3; C is a scaling factor
+C
+ DIMENSION A1(3),A2(3),A3(3)
+C
+ A3(1)=(A1(2)*A2(3)-A1(3)*A2(2))/C
+ A3(2)=(A1(3)*A2(1)-A1(1)*A2(3))/C
+ A3(3)=(A1(1)*A2(2)-A1(2)*A2(1))/C
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/read_data.f b/src/msspec/spec/fortran/common_sub/read_data.f
new file mode 100644
index 0000000..28d10ae
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/read_data.f
@@ -0,0 +1,1932 @@
+C
+C=======================================================================
+C
+ SUBROUTINE READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*,*,*,*,*,*,*,*,*,*
+ &,*,*,*)
+C
+C This subroutine reads the input data from unit ICOM and writes
+C them in the control file IUO1. Then, it stores the data in
+C the various COMMON blocks
+C
+C Last modified : 26 Apr 2013
+C
+ USE DIM_MOD
+C
+ USE ADSORB_MOD
+ USE AMPLI_MOD
+ USE APPROX_MOD
+ USE ATOMS_MOD
+ USE AUGER_MOD
+ USE BASES_MOD
+ USE COEFRLM_MOD
+ USE CONVACC_MOD
+ USE CONVTYP_MOD
+ USE C_G_MOD
+ USE C_G_A_MOD
+ USE C_G_M_MOD
+ USE CRANGL_MOD
+ USE DEBWAL_MOD , T => TEMP
+ USE DEXPFAC2_MOD
+ USE DFACTSQ_MOD
+ USE EIGEN_MOD
+ USE EXAFS_MOD
+ USE EXPFAC_MOD
+ USE EXPFAC2_MOD
+ USE EXPROT_MOD
+ USE FACTSQ_MOD
+ USE FDIF_MOD
+ USE FIXSCAN_MOD
+ USE FIXSCAN_A_MOD
+ USE HEADER_MOD , AUGER1 => AUGER
+ USE INDAT_MOD
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE INIT_A_MOD
+ USE INIT_J_MOD
+ USE INIT_L_MOD
+ USE INIT_M_MOD
+ USE LIMAMA_MOD
+ USE LINLBD_MOD
+ USE LOGAMAD_MOD
+ USE LPMOY_MOD , XM => XMTA, RH => RHOTA
+ USE MILLER_MOD
+ USE MOYEN_MOD
+ USE MOYEN_A_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD
+ USE PARCAL_A_MOD
+ USE RA_MOD
+ USE RELADS_MOD
+ USE RELAX_MOD
+ USE RENORM_MOD
+ USE RESEAU_MOD
+ USE SPECTRUM_MOD
+ USE SPIN_MOD
+ USE TESTS_MOD
+ USE TYPCAL_MOD
+ USE TYPCAL_A_MOD
+ USE TYPEM_MOD
+ USE TYPEXP_MOD
+ USE VALIN_MOD
+ USE VALIN_AV_MOD
+ USE VALFIN_MOD
+ USE VALEX_A_MOD
+ USE XMRHO_MOD
+C
+C
+C
+C
+ REAL*8 J1,J2,MJ1,MJ2,MJ3,JJ,DXDEN,DEXPF
+ REAL*8 JJ_MIN,JJ_MAX,JJ12,JL12,SMALL,SQPI
+C
+ REAL TEXTE1(10),TEXTE2(10),TEXTE3(10)
+ REAL TEXTE4(10),TEXTE5(10),TEXTE6(10)
+ REAL TEXTE6B(10),TEXTE7(10)
+ REAL THFWD(NATP_M),THBWD(NATP_M),GLG(0:N_GAUNT),NJ(0:N_GAUNT)
+ REAL ALPHAR,BETAR,RACC
+C
+C
+C
+ DOUBLE PRECISION FACT1L,FACT2L
+C
+C
+C
+C
+C
+ CHARACTER*7 TESLEC,RIEN
+C
+C
+ CHARACTER*3 CODRES(8),CODCTR(7),CRIST,CENTR,UNLENGTH
+C
+C
+ CHARACTER*1 EDGE_C,EDGE_I,EDGE_A,MULT
+ DATA CODRES/'CUB','TET','ORB','MNC','TCN','TRG','HEX','EXT'/
+ DATA CODCTR/'P','I','F','R','A','B','C'/
+ DATA PIS180,BOHR/0.017453,0.529177/
+ DATA SQPI,SMALL /1.772453850906D0,1.D-6/
+C
+ I_EXT=0
+ I_EXT_A=0
+ IVG0=0
+ IRET=0
+ NCRIST=0
+ NCENTR=0
+ I_SO=0
+ DO I=1,10
+ PCREL(I)=0.
+ ENDDO
+ STEREO=' NO'
+C
+C
+C.......... Reading of the input data in unit ICOM ..........
+C
+C
+ READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE1
+ READ(ICOM,1) RIEN
+ READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE2
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,3) CRIST,CENTR,IBAS,NAT
+ READ(ICOM,4) A,BSURA,CSURA,UNIT
+C
+ IF(IBAS.EQ.0) THEN
+ DO JLINE=1,100
+ READ(ICOM,5) TESLEC
+ IF(TESLEC.EQ.'SPECTRO') THEN
+ BACKSPACE ICOM
+ BACKSPACE ICOM
+ BACKSPACE ICOM
+ GOTO 600
+ ENDIF
+ ENDDO
+ ENDIF
+C
+ READ(ICOM,6) ALPHAD,BETAD,GAMMAD
+ READ(ICOM,7) IH,IK,II,IL
+ READ(ICOM,8) NIV,COUPUR,ITEST,IESURF
+ IF(NAT.GT.1) THEN
+ DO I=1,NAT
+ J=3*(I-1)
+ READ(ICOM,9) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(I)
+ ENDDO
+ ELSE
+ READ(ICOM,9) X1,Y1,Z1,CHEM(1),NZA
+ ENDIF
+C
+ READ(ICOM,5) TESLEC
+ IF(TESLEC.EQ.'VECBAS ') THEN
+ BACKSPACE ICOM
+ ELSE
+ IRET=10
+ GOTO 605
+ ENDIF
+C
+ DO I=1,8
+ IF(CRIST.EQ.CODRES(I)) NCRIST=I
+ IF(I.NE.8) THEN
+ IF(CENTR.EQ.CODCTR(I)) NCENTR=I
+ ENDIF
+ ENDDO
+ IF((NCRIST.EQ.0).OR.(NCENTR.EQ.0)) THEN
+ IRET=1
+ GOTO 605
+ ENDIF
+C
+ IF(NCRIST.EQ.8) THEN
+ DO I=1,3
+ J=3*(I-1)
+ IVN(I)=1
+ READ(ICOM,9) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J)
+ IF(ABS(VECBAS(1+J)).LT.0.0001) THEN
+ IF(ABS(VECBAS(2+J)).LT.0.0001) THEN
+ IF(ABS(VECBAS(3+J)).LT.0.0001) THEN
+ IVG0=IVG0+1
+ IVN(I)=0
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSE
+ READ(ICOM,9) X3,Y3,Z3
+ READ(ICOM,9) X4,Y4,Z4
+ READ(ICOM,9) X5,Y5,Z5
+ ENDIF
+ READ(ICOM,10) IREL,NREL,(PCREL(I),I=1,2)
+ IF(IREL.EQ.1) THEN
+ IF(NREL.GT.2) THEN
+ NLIGNE=INT(FLOAT(NREL-2)/4.)+1
+ DO J=1,NLIGNE
+ READ(ICOM,11) (PCREL(I),I=1,4)
+ ENDDO
+ ENDIF
+ IF(NREL.GT.10) THEN
+ IRET=4
+ GOTO 605
+ ENDIF
+ ELSEIF(IREL.EQ.0) THEN
+ NREL=0
+ ENDIF
+ IF(NREL.EQ.0) THEN
+ DO JREL=1,10
+ PCREL(JREL)=0.
+ ENDDO
+ ENDIF
+ READ(ICOM,12) OMEGAD1,OMEGAD2,IADS
+C
+ READ(ICOM,1) RIEN
+ 600 READ(ICOM,2) TEXTE3
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,13) SPECTRO,ISPIN,IDICHR,IPOL
+ READ(ICOM,44) I_AMP
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ INTERACT='DIPOLAR'
+ ELSEIF(SPECTRO.EQ.'LED') THEN
+ INTERACT='NOINTER'
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ INTERACT='DIPOLAR'
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ INTERACT='COULOMB'
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ INTERACT='DIPCOUL'
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+ INTERACT='DIPOLAR'
+ ENDIF
+C
+ IF((IPOL.EQ.0).AND.(IDICHR.GT.0)) THEN
+ PRINT 513
+ STOP
+ ENDIF
+ IF((IDICHR.EQ.2).AND.(ISPIN.EQ.0)) THEN
+ PRINT 514
+ STOP
+ ENDIF
+C
+ IF(ISPIN.EQ.0) THEN
+ NSPIN2=1
+ NSPIN=1
+ ELSEIF(ISPIN.EQ.1) THEN
+ NSPIN2=4
+ NSPIN=2
+ ENDIF
+C
+ IF(SPECTRO.EQ.'LED') THEN
+ DO JLINE=1,10
+ READ(ICOM,1) RIEN
+ ENDDO
+ GOTO 607
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ IF(IDICHR.GT.1) THEN
+ PRINT 512
+ STOP
+ ENDIF
+ DO JLINE=1,19
+ READ(ICOM,1) RIEN
+ ENDDO
+ GOTO 602
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ DO JLINE=1,24
+ READ(ICOM,1) RIEN
+ ENDDO
+ GOTO 603
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+ DO JLINE=1,34
+ READ(ICOM,1) RIEN
+ ENDDO
+ GOTO 608
+ ENDIF
+C
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
+ READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE4
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,20) NI,NLI,S_O,INITL,I_SO
+C
+ IF((NLI.EQ.'s').OR.(NLI.EQ.'S')) THEN
+ LI=0
+ ELSEIF((NLI.EQ.'p').OR.(NLI.EQ.'P')) THEN
+ LI=1
+ ELSEIF((NLI.EQ.'d').OR.(NLI.EQ.'D')) THEN
+ LI=2
+ ELSEIF((NLI.EQ.'f').OR.(NLI.EQ.'F')) THEN
+ LI=3
+ ELSEIF((NLI.EQ.'g').OR.(NLI.EQ.'G')) THEN
+ LI=4
+ ELSE
+ IRET=5
+ GOTO 605
+ ENDIF
+ IF(LI.GT.LI_M) THEN
+ IRET=6
+ GOTO 605
+ ENDIF
+ IF(I_SO.EQ.0) THEN
+ S_O=' '
+ ELSEIF(I_SO.EQ.1) THEN
+ IF(S_O.EQ.'1/2') THEN
+ IF(LI.GT.1) IRET=7
+ ELSEIF(S_O.EQ.'3/2') THEN
+ IF((LI.LT.1).OR.(LI.GT.2)) IRET=7
+ ELSEIF(S_O.EQ.'5/2') THEN
+ IF((LI.LT.2).OR.(LI.GT.3)) IRET=7
+ ELSEIF(S_O.EQ.'7/2') THEN
+ IF((LI.LT.3).OR.(LI.GT.4)) IRET=7
+ ELSEIF(S_O.EQ.'9/2') THEN
+ IF(LI.NE.4) IRET=7
+ ENDIF
+ ELSEIF(I_SO.EQ.2) THEN
+ S_O=' '
+ ENDIF
+C
+ READ(ICOM,14) IPHI,ITHETA,IE,IFTHET
+ READ(ICOM,15) NPHI,NTHETA,NE,NFTHET
+ READ(ICOM,16) PHI0,THETA0,E0,R1
+ READ(ICOM,16) PHI1,THETA1,EFIN,R2
+ READ(ICOM,17) THLUM,PHILUM,ELUM
+ READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR
+C
+ DO JLINE=1,9
+ READ(ICOM,1) RIEN
+ ENDDO
+ ENDIF
+C
+ 607 IF(SPECTRO.EQ.'LED') THEN
+ READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE4
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,14) IPHI,ITHETA,IE,IFTHET
+ READ(ICOM,15) NPHI,NTHETA,NE,NFTHET
+ READ(ICOM,16) PHI0,THETA0,E0,R1
+ READ(ICOM,16) PHI1,THETA1,EFIN,R2
+ READ(ICOM,17) TH_INI,PHI_INI
+ READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR
+C
+ THLUM=TH_INI
+ PHILUM=PHI_INI
+ ELUM=0.
+ IDICHR=0
+ INITL=0
+ ENDIF
+C
+ IF(SPECTRO.NE.'XAS') THEN
+ IF(IPHI.EQ.-1) THEN
+ IPHI=1
+ I_EXT=0
+ ICHKDIR=0
+ STEREO='YES'
+ IF(ABS(PHI1-PHI0).LT.0.0001) THEN
+ PHI0=0.
+ PHI1=360.
+ NPHI=361
+ ENDIF
+ IF(ABS(THETA1-THETA0).LT.0.0001) THEN
+ THETA0=0.
+ THETA1=88.
+ NTHETA=89
+ ENDIF
+ ELSEIF(IPHI.EQ.2) THEN
+ IPHI=1
+ I_EXT=1
+ ELSEIF(IPHI.EQ.3) THEN
+ IPHI=1
+ I_EXT=-1
+ ELSEIF(ITHETA.EQ.2) THEN
+ ITHETA=1
+ I_EXT=1
+ ELSEIF(ITHETA.EQ.3) THEN
+ ITHETA=1
+ I_EXT=-1
+ ELSEIF(IE.EQ.2) THEN
+ IE=1
+ I_EXT=1
+ ELSEIF(IE.EQ.3) THEN
+ IE=1
+ I_EXT=-1
+ ELSEIF(IE.EQ.4) THEN
+ IF(SPECTRO.EQ.'PHD') THEN
+ IE=1
+ I_EXT=2
+ IMOD=0
+ ELSE
+ IE=1
+ I_EXT=1
+ ENDIF
+ ENDIF
+ ENDIF
+C
+ ICALC=IPHI*IE+IPHI*ITHETA+IE*ITHETA
+ IF((ICALC.NE.0).AND.(IFTHET.EQ.0)) IRET=3
+C
+C When the direction of the analyzer might be experimentally
+C inaccurate, the calculation will be done for nine
+C direction across the one given in the data file
+C with an increment of one degree.
+C
+ IF(ICHKDIR.EQ.1) THEN
+ IF((ITHETA.EQ.1).AND.(IPHI.EQ.0)) THEN
+ NPHI=9
+ PHI0=PHI0-4.
+ PHI1=PHI0+8.
+ ELSEIF((IPHI.EQ.1).AND.(ITHETA.EQ.0)) THEN
+ NTHETA=9
+ THETA0=THETA0-4.
+ THETA1=THETA0+8.
+ ENDIF
+ ENDIF
+C
+C Initialization of the values for the scanned angle and the "fixed" one
+C
+ IF(IPHI.EQ.1) THEN
+ N_FIXED=NTHETA
+ N_SCAN=NPHI
+ FIX0=THETA0
+ FIX1=THETA1
+ SCAN0=PHI0
+ SCAN1=PHI1
+ IPH_1=0
+ ELSEIF(ITHETA.EQ.1) THEN
+ N_FIXED=NPHI
+ N_SCAN=NTHETA
+ FIX0=PHI0
+ FIX1=PHI1
+ SCAN0=THETA0
+ SCAN1=THETA1
+ IPH_1=1
+ ELSEIF(IE.EQ.1) THEN
+ IF(NTHETA.GE.NPHI) THEN
+ N_FIXED=NPHI
+ N_SCAN=NTHETA
+ FIX0=PHI0
+ FIX1=PHI1
+ SCAN0=THETA0
+ SCAN1=THETA1
+ IPH_1=1
+ ELSE
+ N_FIXED=NTHETA
+ N_SCAN=NPHI
+ FIX0=THETA0
+ FIX1=THETA1
+ SCAN0=PHI0
+ SCAN1=PHI1
+ IPH_1=0
+ ENDIF
+ ENDIF
+C
+ 602 IF(SPECTRO.EQ.'XAS') THEN
+ READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE5
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,39) EDGE,NEDGE,INITL,THLUM,PHILUM
+ READ(ICOM,19) NE_X,EK_INI,EK_FIN,EPH_INI
+C
+ LI=NEDGE/2
+ IF(NEDGE.GT.1) I_SO=2
+ IF(EDGE.EQ.'K') THEN
+ NI=1
+ ELSEIF(EDGE.EQ.'L') THEN
+ NI=2
+ ELSEIF(EDGE.EQ.'M') THEN
+ NI=3
+ ELSEIF(EDGE.EQ.'N') THEN
+ NI=4
+ ELSEIF(EDGE.EQ.'O') THEN
+ NI=5
+ ELSEIF(EDGE.EQ.'P') THEN
+ NI=6
+ ENDIF
+ ELSE
+ DO JLINE=1,5
+ READ(ICOM,1) RIEN
+ ENDDO
+ ENDIF
+C
+ 603 IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
+C
+ READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE6
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,40) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
+ READ(ICOM,42) I_MULT,IM1,MULT,IM2
+ READ(ICOM,14) IPHI_A,ITHETA_A,IFTHET_A,I_INT
+ READ(ICOM,15) NPHI_A,NTHETA_A,NFTHET_A
+ READ(ICOM,41) PHI0_A,THETA0_A,R1_A
+ READ(ICOM,41) PHI1_A,THETA1_A,R2_A
+ READ(ICOM,18) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
+C
+ LI_C=NEDGE_C/2
+ LI_I=NEDGE_I/2
+ LI_A=NEDGE_A/2
+C
+ IF((EDGE_I.EQ.EDGE_A).AND.(LI_I.EQ.LI_A)) THEN
+ I_SHELL=1
+ ELSE
+ I_SHELL=0
+ ENDIF
+C
+ IE_A=0
+ NE_A=1
+ I_CP_A=0
+C
+ IF(EDGE_C.EQ.'K') THEN
+ AUGER=' '//EDGE_C//EDGE_I//CHAR(48+NEDGE_I)//EDGE_A//CHAR(48+N
+ &EDGE_A)
+ ELSE
+ AUGER=EDGE_C//CHAR(48+NEDGE_C)//EDGE_I//CHAR(48+NEDGE_I)//EDGE
+ &_A//CHAR(48+NEDGE_A)
+ ENDIF
+ AUGER1=AUGER
+C
+ IF(IPHI_A.EQ.-1) THEN
+ IPHI_A=1
+ I_EXT_A=0
+ ICHKDIR_A=0
+ STEREO='YES'
+ IF(ABS(PHI1_A-PHI0_A).LT.0.0001) THEN
+ PHI0_A=0.
+ PHI1_A=360.
+ NPHI_A=361
+ ENDIF
+ IF(ABS(THETA1_A-THETA0_A).LT.0.0001) THEN
+ THETA0_A=0.
+ THETA1_A=88.
+ NTHETA_A=89
+ ENDIF
+ ELSEIF(IPHI_A.EQ.2) THEN
+ IPHI_A=1
+ I_EXT_A=1
+ ELSEIF(IPHI_A.EQ.3) THEN
+ IPHI_A=1
+ I_EXT_A=-1
+ ELSEIF(ITHETA_A.EQ.2) THEN
+ ITHETA_A=1
+ I_EXT_A=1
+ ELSEIF(ITHETA_A.EQ.3) THEN
+ ITHETA_A=1
+ I_EXT_A=-1
+ ENDIF
+C
+C Check for the consistency of the data for the two electrons in
+C APECS, in particular when the sample is rotated (IMOD=1)
+C
+ IF(SPECTRO.EQ.'APC') THEN
+ IF((LI_C.NE.LI).OR.(IMOD_A.NE.IMOD)) THEN
+ IRET=11
+ GOTO 605
+ ENDIF
+ DTH=THETA1-THETA0
+ DTH_A=THETA1_A-THETA0_A
+ DPH=PHI1-PHI0
+ DPH_A=PHI1_A-PHI0_A
+ IF((IMOD_A.EQ.1).AND.(IPHI_A.NE.IPHI)) IRET=13
+ IF((IMOD_A.EQ.1).AND.(ITHETA_A.NE.ITHETA)) IRET=13
+ IF((IMOD_A.EQ.1).AND.(NPHI_A.NE.NPHI)) IRET=13
+ IF((IMOD_A.EQ.1).AND.(NTHETA_A.NE.NTHETA)) IRET=13
+ IF((IMOD_A.EQ.1).AND.(DTH_A.NE.DTH)) IRET=13
+ IF((IMOD_A.EQ.1).AND.(DPH_A.NE.DPH)) IRET=13
+ ENDIF
+C
+C When the direction of the analyzer might be experimentally
+C inaccurate, the calculation will be done for nine
+C direction across the one given in the data file
+C with an increment of one degree.
+C
+ IF(ICHKDIR_A.EQ.1) THEN
+ IF((ITHETA_A.EQ.1).AND.(IPHI_A.EQ.0)) THEN
+ NPHI_A=9
+ PHI0_A=PHI0_A-4.
+ PHI1_A=PHI0_A+8.
+ ELSEIF((IPHI_A.EQ.1).AND.(ITHETA_A.EQ.0)) THEN
+ NTHETA_A=9
+ THETA0_A=THETA0_A-4.
+ THETA1_A=THETA0_A+8.
+ ENDIF
+ ENDIF
+C
+C Initialization of the values for the scanned angle and the "fixed" one
+C
+ IF(IPHI_A.EQ.1) THEN
+ N_FIXED_A=NTHETA_A
+ N_SCAN_A=NPHI_A
+ FIX0_A=THETA0_A
+ FIX1_A=THETA1_A
+ SCAN0_A=PHI0_A
+ SCAN1_A=PHI1_A
+ IPH_1_A=0
+ ELSEIF(ITHETA_A.EQ.1) THEN
+ N_FIXED_A=NPHI_A
+ N_SCAN_A=NTHETA_A
+ FIX0_A=PHI0_A
+ FIX1_A=PHI1_A
+ SCAN0_A=THETA0_A
+ SCAN1_A=THETA1_A
+ IPH_1_A=1
+ ENDIF
+C
+ ELSE
+ DO JLINE=1,10
+ READ(ICOM,1) RIEN
+ ENDDO
+ ENDIF
+C
+ IF(SPECTRO.EQ.'XAS') THEN
+ I_CP=1
+ NE=NE_X
+ ELSE
+ I_CP=0
+ ENDIF
+C
+ 608 IF(SPECTRO.EQ.'EIG') THEN
+C
+ READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE6B
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,43) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP
+C
+ NE=NE_EIG
+ N_LINE_E=INT((FLOAT(NE_EIG)-0.0001)/4.)+1
+ N_LAST=4-(4*N_LINE_E-NE_EIG)
+C
+ IF(N_LINE_E.GT.1) THEN
+ DO JLINE=1,N_LINE_E-1
+ J=(JLINE-1)*4
+ READ(ICOM,7) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3
+ &),I_SPECTRUM(J+4)
+ ENDDO
+ ENDIF
+C
+ J=4*(N_LINE_E-1)
+C
+ READ(ICOM,7) (I_SPECTRUM(J+K), K=1,N_LAST)
+C
+ READ(ICOM,46) I_PWM,METHOD,RACC,EXPO
+ READ(ICOM,47) N_MAX,N_ITER,N_TABLE,SHIFT
+ READ(ICOM,48) I_XN,I_VA,I_GN,I_WN
+ READ(ICOM,49) LEVIN,ALPHAR,BETAR
+C
+ ACC=DBLE(RACC)
+ IF(ABS(I_PWM).LE.2) THEN
+ I_ACC=0
+ N_ITER=N_MAX
+ ELSEIF(I_PWM.EQ.3) THEN
+ I_ACC=1
+ N_ITER=N_MAX
+ ELSEIF(I_PWM.EQ.-3) THEN
+ I_ACC=-1
+ N_ITER=N_MAX
+ ELSEIF(I_PWM.EQ.4) THEN
+ I_ACC=2
+ ELSEIF(I_PWM.EQ.-4) THEN
+ I_ACC=-2
+ ENDIF
+ IF(N_MAX.LT.N_ITER) N_ITER=N_MAX
+C
+ ALPHA=DCMPLX(ALPHAR)
+ BETA=DCMPLX(BETAR)
+C
+C
+ ELSE
+ DO JLINE=1,9
+ READ(ICOM,1) RIEN
+ ENDDO
+C
+ ENDIF
+C
+ 609 READ(ICOM,1) RIEN
+ READ(ICOM,2) TEXTE7
+ READ(ICOM,1) RIEN
+C
+ READ(ICOM,21) NO,NDIF,ISPHER,I_GR
+ READ(ICOM,50) I_REN,N_REN,REN_R,REN_I
+C
+ IF(ISPHER.EQ.0) THEN
+ IDWSPH=0
+ NO=0
+ ENDIF
+ IF(NO.LT.0) NO=8
+ NUMAX(1)=NO/2
+C
+ READ(ICOM,22) ISFLIP,IR_DIA,ITRTL,I_TEST
+C
+ IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) I_TEST_A=I_TEST
+ IF(I_TEST.EQ.1) THEN
+ IF(INTERACT.EQ.'DIPOLAR') THEN
+ INITL=1
+ LI=0
+ IPOL=1
+ ELSEIF(INTERACT.EQ.'COULOMB') THEN
+ LI_C=0
+ LI_I=0
+ ENDIF
+ ENDIF
+C
+ READ(ICOM,23) NEMET
+C
+ BACKSPACE ICOM
+ NLG=INT((NEMET-0.0001)/3) +1
+ DO N=1,NLG
+ NRL=3*N
+ JD=3*(N-1)+1
+ IF(N.EQ.NLG) NRL=NEMET
+ READ(ICOM,24) NEMO,(IEMET(J), J=JD, NRL)
+ IF(N.EQ.1) NEMET1=NEMO
+ ENDDO
+C
+ READ(ICOM,25) ISOM,NONVOL(JFICH),NPATHP,VINT
+C
+ IF(I_TEST.EQ.2) THEN
+ IF(ABS(IPOL).EQ.1) THEN
+ THLUM=-90.
+ PHILUM=0.
+ ELSEIF(ABS(IPOL).EQ.2) THEN
+ THLUM=0.
+ PHILUM=0.
+ ENDIF
+ IMOD=0
+ VINT=0.
+ A=1.
+ ENDIF
+C
+ IF((NFICHLEC.EQ.1).OR.(IBAS.EQ.1)) ISOM=0
+C
+ READ(ICOM,26) IFWD,NTHOUT,I_NO,I_RA
+C
+ IF(NTHOUT.EQ.NDIF-1) IFWD=0
+C
+ IF(I_RA.EQ.1) NO=0
+ DO JAT=1,NAT
+ READ(ICOM,27) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT)
+ IF(I_RA.EQ.0) THEN
+ N_RA(JAT)=NO
+ NUMAX(JAT)=NO/2
+ ELSEIF(I_RA.EQ.1) THEN
+ NUMAX(JAT)=N_RA(JAT)/2
+ NO=MAX(N_RA(JAT),NO)
+ ENDIF
+ ENDDO
+C
+ READ(ICOM,5) TESLEC
+ IF(TESLEC.EQ.'IPW,NCU') THEN
+ BACKSPACE ICOM
+ ELSE
+ IRET=8
+ GOTO 605
+ ENDIF
+C
+ READ(ICOM,28) IPW,NCUT,PCTINT,IPP
+ READ(ICOM,29) ILENGTH,RLENGTH,UNLENGTH
+ READ(ICOM,30) IDWSPH,ISPEED,IATTS,IPRINT
+C
+ IF(IDWSPH.EQ.0) ISPEED=1
+C
+ READ(ICOM,31) IDCM,TD,T,RSJ
+ READ(ICOM,32) ILPM,XLPM0
+C
+ IF((IDCM.GE.1).OR.(ILPM.EQ.1)) THEN
+ CALL ATDATA
+ ENDIF
+ NLEC=INT((NAT-0.0001)/4)+1
+C
+ DO I=1,NLEC
+ NDEB=4*(I-1) + 1
+ NFIN=MIN0(4*I,NAT)
+ READ(ICOM,33) (UJ2(J),J=NDEB,NFIN)
+ ENDDO
+C
+ DO JLINE=1,5
+ READ(ICOM,1) RIEN
+ ENDDO
+ READ(ICOM,5) TESLEC
+ IF(TESLEC.EQ.'DATA FI') THEN
+ BACKSPACE ICOM
+ ELSE
+ IRET=9
+ GOTO 605
+ ENDIF
+C
+ READ(ICOM,34) INFILE1,IUI1
+ READ(ICOM,34) INFILE2,IUI2
+ READ(ICOM,34) INFILE3,IUI3
+ READ(ICOM,34) INFILE4,IUI4
+ READ(ICOM,34) INFILE5,IUI5
+ READ(ICOM,34) INFILE6,IUI6
+C
+ IF(SPECTRO.NE.'APC') THEN
+ DO JLINE=1,9
+ READ(ICOM,1) RIEN
+ ENDDO
+ ELSE
+ DO JLINE=1,6
+ READ(ICOM,1) RIEN
+ ENDDO
+ READ(ICOM,34) INFILE7,IUI7
+ READ(ICOM,34) INFILE8,IUI8
+ READ(ICOM,34) INFILE9,IUI9
+ ENDIF
+C
+C Set up of the switch controlling external
+C reading of the detector directions and
+C averaging over them for an undetected electron
+C
+ IF(SPECTRO.EQ.'APC') THEN
+ IF((I_EXT.EQ.-1).OR.(I_EXT_A.EQ.-1)) THEN
+ IF(I_EXT*I_EXT_A.EQ.0) THEN
+ WRITE(IUO1,523)
+ I_EXT=-1
+ I_EXT_A=-1
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
+ READ(IUI6,713) IDIR,NSET
+ READ(IUI9,713) IDIR_A,NSET_A
+ IF(IDIR.EQ.2) THEN
+ IF(NSET.NE.NSET_A) WRITE(IUO1,524) NSET,NSET_A
+ STOP
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(I_INT.EQ.1) THEN
+ I_EXT=2
+ ELSEIF(I_INT.EQ.2) THEN
+ I_EXT_A=2
+ ELSEIF(I_INT.EQ.3) THEN
+ I_EXT=2
+ I_EXT_A=2
+ ENDIF
+ ENDIF
+C
+ IF(I_EXT.EQ.-1) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,701) IDIR,I_SET,N_POINTS
+ READ(IUI6,702) I_PH,N_FIXED,N_SCAN
+ DO JS=1,I_SET
+ READ(IUI6,703) TH_0(JS),PH_0(JS)
+ ENDDO
+ CLOSE(IUI6)
+ IF(IDIR.NE.2) IRET=12
+ IF(I_PH.NE.IPH_1) IPH_1=I_PH
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(I_PH.EQ.0) THEN
+ NTHETA=N_FIXED
+ NPHI=N_SCAN
+ ELSE
+ NTHETA=N_SCAN
+ NPHI=N_FIXED
+ ENDIF
+ ICHKDIR=2
+ ENDIF
+ ENDIF
+ IF(I_EXT.GE.1) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,701) IDIR,I_SET,N_POINTS
+ CLOSE(IUI6)
+ IF((IDIR.NE.1).AND.(I_EXT.EQ.2)) IRET=12
+ N_FIXED=N_POINTS
+ N_SCAN=1
+ NTHETA=N_POINTS
+ NPHI=1
+ ENDIF
+ IF(I_EXT_A.GE.1) THEN
+ IF(SPECTRO.EQ.'APC') THEN
+ OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
+ READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A
+ CLOSE(IUI9)
+ ELSE
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A
+ CLOSE(IUI6)
+ ENDIF
+ IF((IDIR_A.NE.1).AND.(I_EXT_A.EQ.2)) IRET=12
+ N_FIXED_A=N_POINTS_A
+ N_SCAN_A=1
+ NTHETA_A=N_POINTS_A
+ NPHI_A=1
+ ENDIF
+C
+ IF(I_EXT_A.EQ.-1) THEN
+ IF(SPECTRO.EQ.'APC') THEN
+ OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
+ READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A
+ READ(IUI9,702) I_PH_A,N_FIXED_A,N_SCAN_A
+ CLOSE(IUI9)
+ ELSE
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A
+ READ(IUI6,702) I_PH_A,N_FIXED_A,N_SCAN_A
+ CLOSE(IUI6)
+ ENDIF
+ IF(IDIR_A.NE.2) IRET=12
+ IF(I_PH_A.EQ.0) THEN
+ NTHETA_A=N_FIXED_A
+ NPHI_A=N_SCAN_A
+ ELSE
+ NTHETA_A=N_SCAN_A
+ NPHI_A=N_FIXED_A
+ ENDIF
+ ICHKDIR_A=2
+ ENDIF
+C
+ DO JLINE=1,5
+ READ(ICOM,1) RIEN
+ ENDDO
+C
+ READ(ICOM,34) OUTFILE1,IUO1
+ READ(ICOM,34) OUTFILE2,IUO2
+ READ(ICOM,34) OUTFILE3,IUO3
+ READ(ICOM,34) OUTFILE4,IUO4
+C
+ IUSCR=MAX0(ICOM,IUI2,IUI3,IUI4,IUI5,IUI6,IUI7,IUI8,IUI9,IUO1,IUO2,
+ &IUO3,IUO4)+1
+ IUSCR2=IUSCR+1
+C
+ IF(IADS.GE.1) THEN
+ OPEN(UNIT=IUI5, FILE=INFILE5, STATUS='OLD')
+ READ(IUI5,1) RIEN
+ READ(IUI5,12) NATA,NADS1,NADS2,NADS3
+ IF(NATA.EQ.1) THEN
+ NADS2=0
+ NADS3=0
+ ELSEIF(NATA.EQ.2) THEN
+ NADS3=0
+ ENDIF
+ READ(IUI5,35) (NZAT(I),I=NAT+1,NAT+NATA)
+ READ(IUI5,36) (CHEM(I),I=NAT+1,NAT+NATA)
+ READ(IUI5,37) (UJ2(NAT+J),J=1,NATA)
+ READ(IUI5,38) NRELA,(PCRELA(I),I=1,NRELA)
+ IF(NRELA.EQ.0) THEN
+ DO JRELA=1,3
+ PCRELA(JRELA)=0.
+ ENDDO
+ ENDIF
+ NADS=NADS1+NADS2+NADS3
+ DO JADS=1,NADS
+ READ(IUI5,9) (ADS(I,JADS),I=1,3)
+ ENDDO
+ CLOSE(IUI5)
+ ELSE
+ NATA=0
+ NRELA=0
+ ENDIF
+C
+ GOTO 601
+C
+ 605 REWIND ICOM
+ DO JLINE=1,500
+ READ(ICOM,5) TESLEC
+ IF(TESLEC.EQ.'CONTROL') THEN
+ BACKSPACE ICOM
+ READ(ICOM,34) OUTFILE1,IUO1
+ GOTO 601
+ ENDIF
+ ENDDO
+C
+ 601 IF((JFICH.EQ.1).OR.(ISOM.EQ.0)) THEN
+c LINE REMOVED BY PYMSSPEC
+ ENDIF
+ IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
+ WRITE(IUO1,105) INDATA(JFICH)
+ ENDIF
+C
+ IF(IRET.EQ.1) RETURN 1
+ IF(IRET.EQ.3) RETURN 3
+ IF(IRET.EQ.4) RETURN 4
+ IF(IRET.EQ.5) RETURN 5
+ IF(IRET.EQ.6) RETURN 6
+ IF(IRET.EQ.7) RETURN 7
+ IF(IRET.EQ.8) RETURN 8
+ IF(IRET.EQ.9) RETURN 9
+ IF(IRET.EQ.10) RETURN 10
+ IF(IRET.EQ.11) RETURN 11
+ IF(IRET.EQ.12) RETURN 12
+ IF(IRET.EQ.13) RETURN 13
+C
+C
+C.......... Writing of the input data in unit IUO1 ..........
+C
+C
+ WRITE(IUO1,100)
+ WRITE(IUO1,101)
+ WRITE(IUO1,101)
+ WRITE(IUO1,102) TEXTE1
+ WRITE(IUO1,101)
+ WRITE(IUO1,101)
+ WRITE(IUO1,203)
+C
+ IF(I_TEST.NE.2) THEN
+ WRITE(IUO1,201) TEXTE2
+ ELSE
+ IF(ABS(IPOL).EQ.1) THEN
+ WRITE(IUO1,525)
+ ELSEIF(ABS(IPOL).EQ.2) THEN
+ WRITE(IUO1,526)
+ ENDIF
+ ENDIF
+C
+ IF(NAT.GT.NATP_M) RETURN 2
+ IF(NE.GT.NE_M) RETURN 2
+ IF(NEMET.GT.NEMET_M) RETURN 2
+C
+ IF(I_TEST.EQ.2) GOTO 606
+ IF(IBAS.EQ.0) THEN
+ WRITE(IUO1,204) A,IBAS
+ GOTO 604
+ ENDIF
+ WRITE(IUO1,103) CRIST,CENTR,IBAS,NAT
+ IF(NCRIST.EQ.1) THEN
+ BSURA=1.
+ CSURA=1.
+ WRITE(IUO1,304) A
+ ELSEIF((NCRIST.EQ.2).OR.(NCRIST.EQ.7).OR.(NCRIST.EQ.6)) THEN
+ BSURA=1.
+ WRITE(IUO1,404) A,CSURA
+ IF((NCRIST.EQ.6).AND.(CSURA.EQ.1.)) THEN
+ WRITE(IUO1,206) ALPHAD
+ ELSEIF(NCRIST.EQ.4) THEN
+ WRITE(IUO1,306) BETAD
+ ENDIF
+ ELSEIF((NCRIST.EQ.3).OR.(NCRIST.EQ.5).OR.(NCRIST.EQ.8)) THEN
+ WRITE(IUO1,104) A,BSURA,CSURA
+ IF(NCRIST.NE.3) THEN
+ WRITE(IUO1,106) ALPHAD,BETAD,GAMMAD
+ ENDIF
+ ENDIF
+ IF(NCRIST.EQ.7) THEN
+ WRITE(IUO1,107) IH,IK,II,IL
+ ELSE
+ WRITE(IUO1,207) IH,IK,IL
+ ENDIF
+ WRITE(IUO1,108) NIV,COUPUR,ITEST,IESURF
+ IF(NAT.GT.1) THEN
+ DO I=1,NAT
+ J=3*(I-1)
+ WRITE(IUO1,109) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(
+ &I)
+ ENDDO
+ ENDIF
+ IF(NCRIST.EQ.8) THEN
+ DO I=1,3
+ J=3*(I-1)
+ WRITE(IUO1,209) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J)
+ ENDDO
+ ENDIF
+ IF(IREL.GE.1) THEN
+ WRITE(IUO1,110) IREL,NREL,(PCREL(I),I=1,2)
+ IF(NREL.GT.2) THEN
+ NLIGNE=INT(FLOAT(NREL-2)/4.)+1
+ DO J=1,NLIGNE
+ WRITE(IUO1,210) (PCREL(I),I=1,4)
+ ENDDO
+ ENDIF
+ IF(NREL.GT.10) RETURN 4
+ WRITE(IUO1,112) OMEGAD1,OMEGAD2,IADS
+ ENDIF
+ IF((IREL.EQ.0).AND.(IADS.EQ.1)) WRITE(IUO1,212) IADS
+ IF(IADS.GE.1) THEN
+ WRITE(IUO1,501)
+ DO JADS=1,NADS
+ IF(JADS.LE.NADS1) THEN
+ IF(JADS.EQ.1) WRITE(IUO1,303) NAT+1
+ WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
+ ELSEIF((JADS.GT.NADS1).AND.(JADS.LE.(NADS1+NADS2))) THEN
+ IF(JADS.EQ.(NADS1+1)) WRITE(IUO1,303) NAT+2
+ WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
+ ELSEIF(JADS.GT.(NADS1+NADS2)) THEN
+ IF(JADS.EQ.(NADS2+1)) WRITE(IUO1,303) NAT+3
+ WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
+ ENDIF
+ ENDDO
+ ENDIF
+ IF((IREL.GT.0).OR.(NRELA.GT.0)) WRITE(IUO1,502)
+ IF(NRELA.GT.0) THEN
+ WRITE(IUO1,311) (PCRELA(I),I=1,NRELA)
+ ENDIF
+ 604 IF(IREL.GT.0) THEN
+ WRITE(IUO1,211) (PCREL(I),I=1,NREL)
+ ENDIF
+C
+ 606 IF(SPECTRO.EQ.'APC') WRITE(IUO1,517)
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+C
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,503)
+ ELSE
+ WRITE(IUO1,527)
+ ENDIF
+ ENDIF
+ IF(IE.EQ.1) WRITE(IUO1,504)
+ IF(ITHETA.EQ.1) WRITE(IUO1,505)
+ IF(IFTHET.EQ.1) WRITE(IUO1,506)
+ IF(I_AMP.EQ.1) WRITE(IUO1,534)
+C
+ WRITE(IUO1,201) TEXTE4
+ WRITE(IUO1,113) ISPIN,IDICHR,IPOL
+ WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO
+ WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
+ WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
+C
+ IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
+ IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
+ WRITE(IUO1,508)
+ STOP
+ ENDIF
+ IF(ABS(THLUM).GT.90.0) THEN
+ WRITE(IUO1,509)
+ STOP
+ ENDIF
+ ENDIF
+C
+ WRITE(IUO1,116) PHI0,THETA0,E0,R1
+ WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
+ WRITE(IUO1,117) THLUM,PHILUM,ELUM
+ WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
+C
+ IF(IMOY.GT.3) IMOY=3
+ IF(IMOY.LT.0) IMOY=0
+ IF(IMOY.EQ.0) NDIR=1
+ IF(IMOY.EQ.1) NDIR=5
+ IF(IMOY.EQ.2) NDIR=13
+ IF(IMOY.EQ.3) NDIR=49
+ IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1
+C
+ ELSEIF(SPECTRO.EQ.'LED') THEN
+C
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,529)
+ ELSE
+ WRITE(IUO1,530)
+ ENDIF
+ ENDIF
+ IF(IE.EQ.1) WRITE(IUO1,531)
+ IF(ITHETA.EQ.1) WRITE(IUO1,532)
+ IF(IFTHET.EQ.1) WRITE(IUO1,506)
+ IF(I_AMP.EQ.1) WRITE(IUO1,534)
+C
+ WRITE(IUO1,201) TEXTE4
+ WRITE(IUO1,141) ISPIN
+ WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
+ WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
+C
+ IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
+ IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
+ WRITE(IUO1,508)
+ STOP
+ ENDIF
+ ENDIF
+C
+ WRITE(IUO1,116) PHI0,THETA0,E0,R1
+ WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
+ WRITE(IUO1,142) TH_INI,PHI_INI
+ WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
+C
+ IF(IMOY.GT.3) IMOY=3
+ IF(IMOY.LT.0) IMOY=0
+ IF(IMOY.EQ.0) NDIR=1
+ IF(IMOY.EQ.1) NDIR=5
+ IF(IMOY.EQ.2) NDIR=13
+ IF(IMOY.EQ.3) NDIR=49
+C
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+C
+ WRITE(IUO1,507)
+ IF(I_AMP.EQ.1) WRITE(IUO1,534)
+ WRITE(IUO1,201) TEXTE5
+ WRITE(IUO1,113) ISPIN,IDICHR,IPOL
+ WRITE(IUO1,134) EDGE,NEDGE,INITL,THLUM,PHILUM
+ WRITE(IUO1,119) NE_X,EK_INI,EK_FIN,EPH_INI
+C
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+C
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,515)
+ ELSE
+ WRITE(IUO1,528)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,516)
+ IF(I_AMP.EQ.1) WRITE(IUO1,534)
+ WRITE(IUO1,201) TEXTE6
+ WRITE(IUO1,113) ISPIN,IDICHR,IPOL
+ WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
+ WRITE(IUO1,140) I_MULT,IM1,MULT,IM2
+ WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT
+ WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A
+ WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A
+ WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A
+ WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
+C
+ IF(IMOY_A.GT.3) IMOY_A=3
+ IF(IMOY_A.LT.0) IMOY_A=0
+ IF(IMOY_A.EQ.0) NDIR_A=1
+ IF(IMOY_A.EQ.1) NDIR_A=5
+ IF(IMOY_A.EQ.2) NDIR_A=13
+ IF(IMOY_A.EQ.3) NDIR_A=49
+C
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+C
+ WRITE(IUO1,518)
+ IF(IPHI.EQ.1) WRITE(IUO1,503)
+ IF(ITHETA.EQ.1) WRITE(IUO1,505)
+ IF(IFTHET.EQ.1) WRITE(IUO1,506)
+ IF(I_AMP.EQ.1) WRITE(IUO1,534)
+C
+ WRITE(IUO1,201) TEXTE4
+ WRITE(IUO1,113) ISPIN,IDICHR,IPOL
+ WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO
+ WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
+ WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
+C
+ IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
+ IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
+ WRITE(IUO1,508)
+ STOP
+ ENDIF
+ IF(ABS(THLUM).GT.90.0) THEN
+ WRITE(IUO1,509)
+ STOP
+ ENDIF
+ ENDIF
+C
+ WRITE(IUO1,116) PHI0,THETA0,E0,R1
+ WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
+ WRITE(IUO1,117) THLUM,PHILUM,ELUM
+ WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
+C
+ IF(IMOY.GT.3) IMOY=3
+ IF(IMOY.LT.0) IMOY=0
+ IF(IMOY.EQ.0) NDIR=1
+ IF(IMOY.EQ.1) NDIR=5
+ IF(IMOY.EQ.2) NDIR=13
+ IF(IMOY.EQ.3) NDIR=49
+ IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1
+C
+ WRITE(IUO1,519)
+ IF(IPHI_A.EQ.1) WRITE(IUO1,515)
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,516)
+ WRITE(IUO1,201) TEXTE6
+ WRITE(IUO1,113) ISPIN,IDICHR,IPOL
+ WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
+ WRITE(IUO1,140) I_MULT,IM1,MULT,IM2
+ WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT
+ WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A
+ WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A
+ WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A
+ WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
+C
+ IF(IMOY_A.GT.3) IMOY_A=3
+ IF(IMOY_A.LT.0) IMOY_A=0
+ IF(IMOY_A.EQ.0) NDIR_A=1
+ IF(IMOY_A.EQ.1) NDIR_A=5
+ IF(IMOY_A.EQ.2) NDIR_A=13
+ IF(IMOY_A.EQ.3) NDIR_A=49
+C
+ WRITE(IUO1,520)
+C
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+C
+ WRITE(IUO1,143) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP
+ DO JLINE=1,N_LINE_E-1
+ J=(JLINE-1)*4
+ WRITE(IUO1,145) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3
+ &),I_SPECTRUM(J+4)
+ ENDDO
+ J=4*(N_LINE_E-1)
+ WRITE(IUO1,145) (I_SPECTRUM(J+K),K=1,N_LAST)
+C
+ WRITE(IUO1,146) I_PWM,METHOD,RACC,EXPO
+ WRITE(IUO1,147) N_MAX,N_ITER,N_TABLE,SHIFT
+ WRITE(IUO1,148) I_XN,I_VA,I_GN,I_WN
+ WRITE(IUO1,149) LEVIN,ALPHAR,BETAR
+ WRITE(IUO1,533)
+C
+ ENDIF
+C
+ WRITE(IUO1,201) TEXTE7
+C
+ IF(SPECTRO.NE.'EIG') THEN
+C
+ WRITE(IUO1,121) NO,NDIF,ISPHER,I_GR
+ WRITE(IUO1,150) I_REN,N_REN,REN_R,REN_I
+C
+ IF(SPECTRO.EQ.'XAS') NDIF=NDIF+1
+C
+ WRITE(IUO1,122) ISFLIP,IR_DIA,ITRTL,I_TEST
+C
+ IF(ISFLIP.EQ.0) THEN
+ NSTEP=3
+ ELSE
+ NSTEP=1
+ ENDIF
+ DO N=1,NLG
+ NRL=3*N
+ JD=3*(N-1)+1
+ IF(N.EQ.NLG) NRL=NEMET
+ IF(N.EQ.1) NEMO=NEMET1
+ IF(N.LT.NLG) THEN
+ WRITE(IUO1,123) NEMO,(IEMET(J), J=JD, NRL)
+ ELSE
+ NTE=NEMET-JD+1
+ IF(NTE.EQ.1) WRITE(IUO1,223) NEMO,(IEMET(J),J=JD,NEMET)
+ IF(NTE.EQ.2) WRITE(IUO1,323) NEMO,(IEMET(J),J=JD,NEMET)
+ IF(NTE.EQ.3) WRITE(IUO1,123) NEMO,(IEMET(J),J=JD,NEMET)
+ ENDIF
+ ENDDO
+ ENDIF
+ IF(SPECTRO.NE.'EIG') THEN
+ WRITE(IUO1,124) ISOM,NONVOL(JFICH),NPATHP,VINT
+ WRITE(IUO1,125) IFWD,NTHOUT,I_NO,I_RA
+ DO JAT=1,NAT
+ WRITE(IUO1,126) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT)
+ RTHFWD(JAT)=THFWD(JAT)*PIS180
+ RTHBWD(JAT)=THBWD(JAT)*PIS180
+ ENDDO
+ WRITE(IUO1,127) IPW,NCUT,PCTINT,IPP
+ WRITE(IUO1,128) ILENGTH,RLENGTH,UNLENGTH
+ WRITE(IUO1,129) IDWSPH,ISPEED,IATTS,IPRINT
+ ELSE
+ WRITE(IUO1,144) VINT
+ ENDIF
+ WRITE(IUO1,130) IDCM,TD,T,RSJ
+ WRITE(IUO1,131) ILPM,XLPM0
+ DO I=1,NLEC
+ NDEB=4*(I-1) + 1
+ NFIN=4*I
+ IF(I.EQ.NLEC) NFIN=NAT
+ NUJ=NFIN-NDEB+1
+ IF(NUJ.EQ.1) WRITE(IUO1,132) (UJ2(J),J=NDEB,NFIN)
+ IF(NUJ.EQ.2) WRITE(IUO1,232) (UJ2(J),J=NDEB,NFIN)
+ IF(NUJ.EQ.3) WRITE(IUO1,332) (UJ2(J),J=NDEB,NFIN)
+ IF(NUJ.EQ.4) WRITE(IUO1,432) (UJ2(J),J=NDEB,NFIN)
+ ENDDO
+ IF(IADS.EQ.1) THEN
+ IF(NATA.EQ.1) WRITE(IUO1,133) (UJ2(J),J=NAT+1,NAT+NATA)
+ IF(NATA.EQ.2) WRITE(IUO1,233) (UJ2(J),J=NAT+1,NAT+NATA)
+ IF(NATA.EQ.3) WRITE(IUO1,333) (UJ2(J),J=NAT+1,NAT+NATA)
+ ENDIF
+C
+ IF(UNLENGTH.EQ.'ATU') RLENGTH=RLENGTH*BOHR/A
+ IF(UNLENGTH.EQ.'ANG') RLENGTH=RLENGTH/A
+ IF(IBAS.GT.0) THEN
+ OMEGA1=OMEGAD1*PIS180
+ OMEGA2=OMEGAD2*PIS180
+ ENDIF
+ QD=0.
+ DO J=1,NATM
+ UJ2(J)=UJ2(J)/(A*A)
+ ENDDO
+ IF(E0.EQ.0.) E0=0.0001
+ NPOINT=NPHI*NE*NTHETA
+ ISORT1=0
+ IF(NPOINT.GT.250) THEN
+ ISORT1=1
+ WRITE(IUO1,510)
+ ENDIF
+C
+ IF(IDWSPH.EQ.1) THEN
+ NFAC=N_GAUNT
+ ELSE
+ NFAC=4*NL_M
+ ENDIF
+ IF(SPECTRO.EQ.'EIG') THEN
+C
+C Switch for including vibrational damping into the MS matrix
+C
+C I_VIB = 0 : no vibrations included
+C I_VIB = 1 : vibrations included
+C
+C and mean free path-like damping
+C
+C I_MFP = 0 : no Im(k) damping included
+C I_MFP = 1 : Im(k) damping included
+C
+ I_VIB=MOD(I_DAMP,2)
+ IF(I_VIB.EQ.1) THEN
+ IDWSPH=1
+ ELSE
+ IDWSPH=0
+ ENDIF
+ IF(I_DAMP.LE.1) THEN
+ I_MFP=0
+ ELSE
+ I_MFP=1
+ ENDIF
+ ENDIF
+C
+C Computing the renormalization coefficients
+C
+ IF(I_REN.LE.4) THEN
+ CALL COEF_RENORM(NDIF)
+ ELSEIF(I_REN.EQ.5) THEN
+ CALL COEF_LOEWDIN(NDIF)
+ ENDIF
+C
+C Storage of the logarithm of the Gamma function GLD(N+1,N_INT)
+C for integer (N_INT=1) and semi-integer (N_INT=2) values :
+C
+C GLD(N+1,1) = Log(N!) for N integer
+C GLD(N+1/2,2) = Log(N!) for N semi-integer
+C
+ IF((ISPHER.GE.0).OR.(I_MULT.EQ.1)) THEN
+ GLG(1)=0.0
+ GLD(1,1)=0.D0
+ GLD(1,2)=DLOG(SQPI/2.D0)
+ DO I=2,NFAC
+ J=I-1
+ GLG(I)=GLG(J)+ALOG(FLOAT(J))
+ GLD(I,1)=GLD(J,1)+DLOG(DFLOAT(J))
+ GLD(I,2)=GLD(J,2)+DLOG(DFLOAT(J) +0.5D0)
+ ENDDO
+ ELSEIF((IFTHET.EQ.1).AND.(ITEST.EQ.1)) THEN
+ GLG(1)=0.0
+ DO I=2,NFAC
+ J=I-1
+ GLG(I)=GLG(J)+ALOG(FLOAT(J))
+ ENDDO
+ ENDIF
+ EXPF(0,0)=1.
+ EXPR(0,0)=1.
+ FACT1L=0.D0
+ DO L=1,2*NL_M-2
+ XDEN=1./SQRT(FLOAT(L+L+1))
+ DXDEN=1.D0/DSQRT(DFLOAT(L+L+1))
+ FACT1L=FACT1L+DLOG(DFLOAT(L))
+ FACT2L=DLOG(DFLOAT(L+1))
+ DO M1=0,L
+ EXPF(M1,L)=EXP(0.5*(GLG(L+M1+1)-GLG(L-M1+1)))
+ DEXPF=DEXP(0.5D0*(GLD(L+M1+1,1)-GLD(L-M1+1,1)))
+ EXPR(M1,L)=EXP(0.5*(GLG(L+L+1)-GLG(L+M1+1)-GLG(L-M1+1)))
+ EXPF2(L,M1)=EXPF(M1,L)*XDEN
+ DEXPF2(L,M1)=DEXPF*DXDEN
+ IF(M1.GT.0) THEN
+ FACT2L=FACT2L+DLOG(DFLOAT(1+L+M1))
+ ENDIF
+ IF(L.LT.NL_M) THEN
+ DO M2=0,L
+ CF(L,M1,M2)=SQRT(FLOAT((L*L-M1*M1)*(L*L-M2*M2)))/FLOAT(L)
+ ENDDO
+ ENDIF
+ ENDDO
+ FSQ(L)=EXP(0.5*REAL(FACT2L-FACT1L))
+ DFSQ(L)=DEXP(0.5D0*(FACT2L-FACT1L))
+ ENDDO
+C
+ IF((INITL.LT.-1).OR.(INITL.GT.2)) THEN
+ INITL=1
+ WRITE(IUO1,511)
+ ENDIF
+ NEPS=2-ABS(IPOL)
+ IF(IDICHR.GE.1) NEPS=1
+ ISTEP_LF=ABS(INITL)
+ IF(INITL.EQ.-1) THEN
+ LF1=LI-1
+ LF2=LF1
+ ELSEIF(INITL.EQ.1) THEN
+ LF1=LI+1
+ LF2=LF1
+ ELSEIF(INITL.EQ.2) THEN
+ LF1=LI-1
+ LF2=LI+1
+ ELSEIF(INITL.EQ.0) THEN
+ LF1=LI
+ LF2=LI
+ ISTEP_LF=1
+ ENDIF
+C
+C Initialization of the values of ji if spin-orbit is taken
+C into account.
+C
+C Here : JI is the loop index going from JF1 to JF2 with :
+C
+C JI=1 : ji = li + 1/2
+C JI=2 : ji = li - 1/2
+C
+ IF(I_SO.EQ.0) THEN
+ JF1=1
+ JF2=2
+ ELSEIF(I_SO.EQ.1) THEN
+ IF(S_O.EQ.'1/2') THEN
+ IF(LI.EQ.0) THEN
+ JF1=1
+ JF2=1
+ ELSEIF(LI.EQ.1) THEN
+ JF1=2
+ JF2=2
+ ENDIF
+ ELSEIF(S_O.EQ.'3/2') THEN
+ IF(LI.EQ.1) THEN
+ JF1=1
+ JF2=1
+ ELSEIF(LI.EQ.2) THEN
+ JF1=2
+ JF2=2
+ ENDIF
+ ELSEIF(S_O.EQ.'5/2') THEN
+ IF(LI.EQ.2) THEN
+ JF1=1
+ JF2=1
+ ELSEIF(LI.EQ.3) THEN
+ JF1=2
+ JF2=2
+ ENDIF
+ ELSEIF(S_O.EQ.'7/2') THEN
+ IF(LI.EQ.3) THEN
+ JF1=1
+ JF2=1
+ ELSEIF(LI.EQ.4) THEN
+ JF1=2
+ JF2=2
+ ENDIF
+ ELSEIF(S_O.EQ.'9/2') THEN
+ IF(LI.EQ.4) THEN
+ JF1=1
+ JF2=1
+ ELSE
+ RETURN 7
+ ENDIF
+ ELSE
+ RETURN 7
+ ENDIF
+ ELSEIF(I_SO.EQ.2) THEN
+ JF1=1
+ JF2=2
+ ELSE
+ RETURN 7
+ ENDIF
+C
+ IF(NI.LE.5) THEN
+ NNL=NI*(NI-1)/2 +LI+1
+ ELSEIF(NI.EQ.6) THEN
+ NNL=NI*(NI-1)/2 +LI
+ ELSEIF(NI.EQ.7) THEN
+ NNL=NI*(NI-1)/2 +LI-3
+ ENDIF
+C
+C Storage of the Clebsch-Gordan coefficients for the spin-orbit
+C dependent coupling matrix elements in the array CG(MJI,JI,JSPIN).
+C
+C Here : JI=1 : ji = li + 1/2
+C JI=2 : ji = li - 1/2
+C MJI : mji + 1/2
+C JSPIN=1 : msi = +1/2
+C JSPIN=2 : msi = -1/2
+C
+C so that all indices remain integer
+C
+ IF((I_SO.GT.0).OR.(ISPIN.EQ.1).OR.(SPECTRO.EQ.'APC')) THEN
+ DO JS=1,2
+ DO JI=1,2
+ DO MJI=-LI,LI+1
+ CG(MJI,JI,JS)=0.0
+ ENDDO
+ ENDDO
+ ENDDO
+ DO MJI=-LI,LI+1
+ CG(MJI,1,1)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1))
+ CG(MJI,1,2)=SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1))
+ IF((MJI.GT.-LI).AND.(MJI.LT.LI+1)) THEN
+ CG(MJI,2,1)=-SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1))
+ CG(MJI,2,2)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1))
+ ENDIF
+ ENDDO
+ ENDIF
+C
+C
+C Storage of the Clebsch-Gordan coefficients for the Auger multiplet
+C dependent coupling matrix elements in the array CGA(LJ1,MJ1,LJ2,MJ2,LJ).
+C
+C Here : LJ1 is an integer index related to J1 (LJ1=2*J1)
+C LMJ1 is an integer index related to MJ1 (LMJ1=2*MJ1)
+C LJ2 is an integer index related to J2 (LJ2=2*J2)
+C LMJ2 is an integer index related to MJ2 (LMJ2=2*MJ2)
+C LJ is an integer index related to J :
+C J = FLOAT(LJ) for J integer
+C J = FLOAT(LJ) + 0.5 for J half integer
+C
+C so that all indices remain integer
+C
+ IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(I_MULT.EQ.1) THEN
+ N=3
+ MJ3=0.D0
+ LJ_MAX=2*(LI_I+LI_A+1)
+ DO LJ1=0,LJ_MAX
+ J1=DFLOAT(LJ1)/2.D0
+ DO LMJ1=-LJ1,LJ1,2
+ MJ1=DFLOAT(LMJ1)/2.D0
+ DO LJ2=0,LJ_MAX
+ J2=DFLOAT(LJ2)/2.D0
+ DO LMJ2=-LJ2,LJ2,2
+ MJ2=DFLOAT(LMJ2)/2.D0
+ CALL N_J(J1,MJ1,J2,MJ2,MJ3,NJ,I_INT,N)
+C
+ JJ12=J1-J2
+ JL12=MJ1-MJ2
+C
+ LJ12=INT(JJ12+SIGN(SMALL,JJ12))
+ LL12=INT(JL12+SIGN(SMALL,JL12))
+C
+ JJ_MIN=ABS(LJ12)
+ JJ_MAX=J1+J2
+ LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN))
+ LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX))
+C
+ DO LJJ=LJJ_MIN,LJJ_MAX,1
+ IF(I_INT.EQ.1) THEN
+ JJ=DFLOAT(LJJ)
+ ELSE
+ JJ=DFLOAT(LJJ)+0.5D0
+ ENDIF
+ L_EXP=INT(J1-J2+MJ1+MJ2)
+ IF(MOD(L_EXP,2).EQ.0) THEN
+ CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=NJ(LJJ)*SQRT(2.*REAL(JJ
+ &)+1.)
+ ELSE
+ CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=-NJ(LJJ)*SQRT(2.*REAL(J
+ &J)+1.)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+C
+C Storage of another of the spin Clebsch-Gordan used
+C when the Auger line is multiplet-resolved. It
+C originates from the coupling of SA and SC,
+C the spins of the Auger electron of the original
+C core electron (which is supposed to be the same
+C as that of the photoelectron).
+C
+C CG_S(I,J,K) with : I = 1 ---> MSA = -1/2
+C I = 2 ---> MSA = 1/2
+C J = 1 ---> MSC = -1/2
+C J = 2 ---> MSC = 1/2
+C K = 1 ---> S = 0
+C K = 2 ---> S = 1
+C
+C MS = MSA+MSC
+C
+ IF(I_MULT.EQ.1) THEN
+ CG_S(1,1,1)=0.
+ CG_S(1,1,2)=1.
+ CG_S(1,2,1)=-0.707107
+ CG_S(1,2,2)= 0.707107
+ CG_S(2,1,1)= 0.707107
+ CG_S(2,1,2)= 0.707107
+ CG_S(2,2,1)= 0.
+ CG_S(2,2,2)= 1.
+ ENDIF
+C
+C Initialization of the variables used when only one multiplet
+C is taken into account in the Auger peak
+C
+ IF(I_MULT.EQ.1) THEN
+ MULTIPLET=CHAR(48+IM1)//MULT//CHAR(48+IM2)
+ IF(MOD(IM1,2).EQ.0) THEN
+ WRITE(IUO1,522) IM1
+ STOP
+ ENDIF
+ S_MUL=(IM1-1)/2
+ J_MUL=IM2
+ IF(MULT.EQ.'S') THEN
+ L_MUL=0
+ ELSEIF(MULT.EQ.'P') THEN
+ L_MUL=1
+ ELSEIF(MULT.EQ.'D') THEN
+ L_MUL=2
+ ELSEIF(MULT.EQ.'F') THEN
+ L_MUL=3
+ ELSEIF(MULT.EQ.'G') THEN
+ L_MUL=4
+ ELSEIF(MULT.EQ.'H') THEN
+ L_MUL=5
+ ELSEIF(MULT.EQ.'I') THEN
+ L_MUL=6
+ ELSEIF(MULT.EQ.'K') THEN
+ L_MUL=7
+ ELSEIF(MULT.EQ.'L') THEN
+ L_MUL=8
+ ELSEIF(MULT.EQ.'M') THEN
+ L_MUL=9
+ ELSE
+ WRITE(IUO1,521) MULTIPLET
+ STOP
+ ENDIF
+ ENDIF
+C
+C.......... Check of the dimensioning in the Gaussian case ..........
+C
+ CALL STOP_EXT(I_EXT,I_EXT_A,SPECTRO)
+C
+C.................... Read FORMAT ....................
+C
+C
+ 1 FORMAT(A7)
+ 2 FORMAT(21X,10A4)
+ 3 FORMAT(7X,A3,9X,A1,9X,I1,6X,I4)
+ 4 FORMAT(8X,F6.3,4X,F6.3,4X,F6.3,3X,A3)
+ 5 FORMAT(49X,A7)
+ 6 FORMAT(7X,F6.2,4X,F6.2,4X,F6.2)
+ 7 FORMAT(8X,I2,8X,I2,8X,I2,8X,I2)
+ 8 FORMAT(8X,I2,8X,F6.3,3X,I3,9X,I1)
+ 9 FORMAT(8X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2)
+ 10 FORMAT(9X,I1,8X,I2,7X,F5.1,5X,F5.1)
+ 11 FORMAT(7X,F5.1,3(5X,F5.1))
+ 12 FORMAT(7X,F6.2,4X,F6.2,6X,I1)
+ 13 FORMAT(7X,A3,9X,I1,9X,I1,8X,I2)
+ 14 FORMAT(8X,I2,9X,I1,9X,I1,9X,I1,9X,I1)
+ 15 FORMAT(7X,I3,7X,I3,7X,I3,7X,I3)
+ 16 FORMAT(6X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3)
+ 17 FORMAT(6X,F7.2,3X,F7.2,2X,F8.2)
+ 18 FORMAT(9X,I1,9X,I1,8X,F5.2,6X,I1)
+ 19 FORMAT(7X,I3,6X,F7.2,3X,F7.2,2X,F8.2)
+ 20 FORMAT(8X,I1,A1,8X,A3,7X,I2,8X,I2)
+ 21 FORMAT(8X,I2,8X,I2,9X,I1,9X,I1)
+ 22 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
+ 23 FORMAT(8X,I2)
+ 24 FORMAT(8X,I2,3(8X,I2))
+ 25 FORMAT(9X,I1,8X,I2,6X,I4,8X,F6.2)
+ 26 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
+ 27 FORMAT(9X,I1,6X,F6.2,7X,I1,7X,F6.2)
+ 28 FORMAT(9X,I1,9X,I1,7X,F8.4,4X,I1)
+ 29 FORMAT(9X,I1,7X,F6.2,4X,A3)
+ 30 FORMAT(9X,I1,8X,I2,9X,I1,9X,I1)
+ 31 FORMAT(9X,I1,6X,F8.3,2X,F8.3,5X,F4.2)
+ 32 FORMAT(8X,I2,7X,F6.2)
+ 33 FORMAT(8X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5)
+ 34 FORMAT(9X,A24,5X,I2)
+ 35 FORMAT(18X,I2,8X,I2,8X,I2)
+ 36 FORMAT(18X,A2,8X,A2,8X,A2)
+ 37 FORMAT(18X,F8.5,2X,F8.5,2X,F8.5)
+ 38 FORMAT(9X,I1,7X,F5.1,5X,F5.1,5X,F5.1)
+ 39 FORMAT(8X,A1,I1,8X,I2,6X,F7.2,3X,F7.2)
+ 40 FORMAT(8X,A1,I1,8X,A1,I1,8X,A1,I1)
+ 41 FORMAT(6X,F7.2,3X,F7.2,5X,F6.3)
+ 42 FORMAT(9X,I1,8X,I1,A1,I1)
+ 43 FORMAT(7X,I3,6X,F7.2,3X,F7.2,6X,I1)
+ 44 FORMAT(9X,I1)
+ 46 FORMAT(8X,I2,6X,A4,9X,F7.5,2X,F6.3)
+ 47 FORMAT(5X,I5,6X,I4,6X,I4,8X,F6.3)
+ 48 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
+ 49 FORMAT(8X,I2,6X,F7.2,3X,F7.2)
+ 50 FORMAT(9X,I1,9X,I1,6X,F8.3,2X,F8.3)
+C
+C
+C.................... Write FORMAT ....................
+C
+C
+ 100 FORMAT(//////////,'******************************', '*************
+ &***************************************')
+ 101 FORMAT('*********************',40X,'*********************')
+ 102 FORMAT('*********************',10A4,'*********************')
+ 103 FORMAT(10X,A3,9X,A1,9X,I1,6X,I4,9X,'CRIST,CENTR,IBAS,NAT')
+ 104 FORMAT(11X,F6.3,4X,F6.3,4X,F6.3,15X,'A,BSURA,CSURA')
+ 105 FORMAT(///,'ooooooooooooooooooooooooooooooooooooooooo','oooooooooo
+ &ooooooooooooooooooooooooooooooo',/,'oooooooooooooooo',50X,'ooooooo
+ &ooooooooo',/,'oooooooooooooooo INPUT DATA FILE : ',A24,' ooo
+ &ooooooooooooo',/,'oooooooooooooooo',50X,'oooooooooooooooo',/,'oooo
+ &oooooooooooooooooooooooo','ooooooooooooooooooooooooooooooooooooooo
+ &oooooooooo','ooooo',///)
+ 106 FORMAT(10X,F6.2,4X,F6.2,4X,F6.2,16X,'ALPHAD,BETAD,GAMMAD')
+ 107 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'H,K,I,L')
+ 108 FORMAT(12X,I1,8X,F6.3,3X,I3,9X,I1,9X,'NIV,COUPUR,ITEST,IESURF')
+ 109 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2,4X,'ATBAS,CHEM(NAT)','
+ &,NZAT(NAT)')
+ 110 FORMAT(12X,I1,8X,I2,7X,F5.1,5X,F5.1,7X,'IREL,NREL,PCREL(NREL)')
+ 112 FORMAT(10X,F6.2,4X,F6.2,6X,I1,19X,'OMEGA1,OMEGA2,IADS')
+ 113 FORMAT(12X,I1,9X,I1,8X,I2,19X,'ISPIN,IDICHR,IPOL')
+ 114 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI,ITHETA,IE,',
+ &'IFTHET')
+ 115 FORMAT(10X,I3,7X,I3,7X,I3,7X,I3,9X,'NPHI,NTHETA,NE,NFTHET')
+ 116 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI0,THETA0,E0,R0')
+ 117 FORMAT(9X,F7.2,3X,F7.2,2X,F8.2,16X,'THLUM,PHILUM,ELUM')
+ 118 FORMAT(12X,I1,9X,I1,8X,F5.2,6X,I1,9X,'IMOD,IMOY,ACCEPT,ICHKDIR')
+ 119 FORMAT(10X,I3,6X,F7.2,3X,F7.2,2X,F8.2,6X,'NE,EK_INI,','EK_FIN,EPH_
+ &INI')
+ 120 FORMAT(11X,I1,A1,8X,A3,7X,I2,8X,I2,9X,'LI,S-O,INITL,I_SO')
+ 121 FORMAT(11X,I2,8X,I2,9X,I1,9X,I1,9X,'NO,NDIF,ISPHER,I_GR')
+ 122 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'ISFLIP,IR_DIA,ITRTL,I_TEST')
+ 123 FORMAT(11X,I2,3(8X,I2),9X,'NEMET,IEMET(NEMET)')
+ 124 FORMAT(12X,I1,8X,I2,6X,I4,7X,F6.2,6X,'ISOM,NONVOL,NPATH,VINT')
+ 125 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'IFWD,NTHOUT,I_NO,I_RA')
+ 126 FORMAT(12X,I1,7X,F6.2,6X,I1,7X,F6.2,6X,'N_RA(NAT),THFWD(NAT)',',IB
+ &WD(NAT),THBWD(NAT)')
+ 127 FORMAT(12X,I1,9X,I1,7X,F8.4,4X,I1,9X,'IPW,NCUT,PCTINT,IPP')
+ 128 FORMAT(12X,I1,7X,F6.2,4X,A3,19X,'ILENGTH,RLENGTH,UNLENGTH')
+ 129 FORMAT(12X,I1,8X,I2,9X,I1,9X,I1,9X,'IDWSPH,ISPEED,IATT,IPRINT')
+ 130 FORMAT(12X,I1,6X,F8.3,2X,F8.3,5X,F4.2,6X,'IDCM,TD,T,RSJ')
+ 131 FORMAT(11X,I2,7X,F6.2,26X,'ILPM,XLPM0')
+ 132 FORMAT(11X,F8.5,33X,'UJ2(NAT) : ','SUBSTRATE')
+ 133 FORMAT(11X,F8.5,33X,'UJ2(NATA) : ','ADSORBATES')
+ 134 FORMAT(11X,A1,I1,8X,I2,6X,F7.2,3X,F7.2,6X,'EDGE,INITL,THLUM,','PHI
+ &LUM')
+ 135 FORMAT(11X,A1,I1,8X,A1,I1,8X,A1,I1,19X,'EDGE_C,EDGE_I,','EDGE_A')
+ 136 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI_A,ITHETA_A,','IFTHET_A,I_
+ &INT')
+ 137 FORMAT(10X,I3,7X,I3,7X,I3,19X,'NPHI_A,NTHETA_A,NFTHET_A')
+ 138 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI0_A,THETA0_A,R0_A')
+ 139 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI1_A,THETA1_A,R1_A')
+ 140 FORMAT(12X,I1,8X,I1,A1,I1,28X,'I_MULT,MULT')
+ 141 FORMAT(12X,I1,39X,'ISPIN')
+ 142 FORMAT(9X,F7.2,3X,F7.2,26X,'TH_INI,PHI_INI')
+ 143 FORMAT(10X,I3,6X,F7.2,3X,F7.2,6X,I1,9X,'NE,EK_INI,EK_FIN,I_DAMP')
+ 144 FORMAT(10X,F6.2,36X,'VINT')
+ 145 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'I_SPECTRUM(NE)')
+ 146 FORMAT(11X,I2,6X,A4,9X,F7.5,2X,F6.3,5X,'I_PWM,METHOD,ACC,EXPO')
+ 147 FORMAT(8X,I5,6X,I4,6X,I4,8X,F6.3,5X,'N_MAX,N_ITER,N_TABLE,SHIFT')
+ 148 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'I_XN,I_VA,I_GN,I_WN')
+ 149 FORMAT(11X,I2,6X,F7.2,3X,F7.2,16X,'L,ALPHA,BETA')
+ 150 FORMAT(12X,I1,9X,I1,6X,F8.3,2X,F8.3,5X,'I_REN,N_REN,REN_R,REN_I')
+C
+ 201 FORMAT(///,21X,10A4,////)
+ 203 FORMAT('**************************************************',
+ &'********************************',//////////)
+ 204 FORMAT(11X,F6.3,5X,I1,29X,'A,IBAS')
+ 206 FORMAT(10X,F6.2,36X,'ALPHAD')
+ 207 FORMAT(11X,I2,8X,I2,8X,I2,19X,'H,K,L')
+ 209 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'VECBAS')
+ 210 FORMAT(10X,F5.1,3(5X,F5.1),7X,'PCREL(NREL)')
+ 211 FORMAT(20X,'SUBSTRATE : ',10(F5.1,','))
+ 212 FORMAT(32X,I1,19X,'IADS')
+ 216 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI1,THETA1,EFIN,R1')
+ 223 FORMAT(11X,I2,1(8X,I2),29X,'NEMET,IEMET(NEMET)')
+ 232 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NAT) : ','SUBSTRATE')
+ 233 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NATA) : ','ADSORBATES')
+C
+ 303 FORMAT(/,33X,'ATOMS OF TYPE ',I1,' :',/)
+ 304 FORMAT(11X,F6.3,35X,'A')
+ 306 FORMAT(10X,F6.2,36X,'BETAD')
+ 309 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'XADS,YADS,ZADS')
+ 311 FORMAT(20X,'ADSORBATE : ',3(F5.1,','))
+ 323 FORMAT(11X,I2,2(8X,I2),19X,'NEMET,IEMET(NEMET)')
+ 332 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NAT) : ','SUBSTRATE')
+ 333 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NATA) : ','ADSORBATES')
+C
+ 404 FORMAT(11X,F6.3,4X,F6.3,25X,'A,CSURA')
+ 432 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5,3X,'UJ2(NAT) : ','SUBSTRA
+ &TE')
+C
+ 501 FORMAT(//,30X,'POSITION OF THE ADSORBATES :')
+ 502 FORMAT(///,25X,'VALUE OF THE RELAXATIONS :',/)
+ 503 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL PHOTOELECTRON',' D
+ &IFFRACTION')
+ 504 FORMAT(///,18X,'TYPE OF CALCULATION : FINE STRUCTURE ','OSCILLATIO
+ &NS')
+ 505 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR PHOTOELECTRON',' DIFFR
+ &ACTION')
+ 506 FORMAT(///,23X,'TYPE OF CALCULATION : SCATTERING FACTOR')
+ 507 FORMAT(///,28X,'TYPE OF CALCULATION : EXAFS')
+ 508 FORMAT(///,2X,' <<<<<<<<<< THE THETA VARIATION EXCEEDS THE ', 'P
+ &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///)
+ 509 FORMAT(///,2X,' <<<<<<<<<< THE THLUM VARIATION EXCEEDS THE ', 'P
+ &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///)
+ 510 FORMAT(///,4X,' <<<<<<<<<< AS THE CALCULATION HAS MORE THAN ','25
+ &0 POINTS, SOME OUTPUTS HAVE BEEN SUPRESSED >>>>>>>>>>',///)
+ 511 FORMAT(///,4X,' <<<<<<<<<< INCORRECT VALUE OF INITL, THE ', 'C
+ &ALCULATION IS PERFORMED WITH INITL = 1 >>>>>>>>>>')
+ 512 FORMAT(///,4X,' <<<<<<<<<< IMPOSSIBLE TO HAVE A SPIN RESOLVED ','
+ &EXAFS EXPERIMENT : DECREASE IDICHR >>>>>>>>>>')
+ 513 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IPOL = 0 AND ','ID
+ &ICHR > 0 >>>>>>>>>>')
+ 514 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IDICHR = 2 AND ','
+ &ISPIN = 0 >>>>>>>>>>')
+ 515 FORMAT(///,12X,'TYPE OF CALCULATION : AZIMUTHAL AUGER ELECTRON','
+ &DIFFRACTION')
+ 516 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR AUGER ELECTRON',' DIFF
+ &RACTION')
+ 517 FORMAT(///,10X,'TYPE OF CALCULATION : AUGER PHOTOELECTRON ','COINC
+ &IDENCE SPECTROSCOPY')
+ 518 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','-----
+ &-------------------')
+ 519 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','-----
+ &-------------------')
+ 520 FORMAT(///,9X,'----------------------------------------------','--
+ &--------------------')
+ 521 FORMAT(///,4X,' <<<<<<<<<< ',A3,' IS NOT IMPLEMENTED IN THIS ','V
+ &ERSION >>>>>>>>>>')
+ 522 FORMAT(///,4X,' <<<<<<<<<< WRONG NAME FOR THE MULTIPLET',' >>>>>
+ &>>>>>',/,4X,' <<<<<<<<<< ODD NUMBER ','EXPECTED INSTEAD OF',I2,'
+ & >>>>>>>>>>')
+ 523 FORMAT(///,4X,' <<<<<<<<<< BOTH DETECTOR DIRECTIONS MUST BE ','EI
+ &THER INTERNAL OR EXTERNAL >>>>>>>>>>',/,8X,' -----> PROCEEDING WI
+ &TH EXTERNAL DIRECTIONS',/)
+ 524 FORMAT(///,4X,' <<<<<<<<<< AVERAGING OVER ',I3,' DOMAINS ','FOR P
+ &HOTOELECTRON >>>>>>>>>>',/,4X,' <<<<<<<<<< AVERAGING OVER ',I3,
+ &' DOMAINS ','FOR AUGER ELECTRON >>>>>>>>>>',/,8X,' -----> IMPOSS
+ &IBLE : CHECK INPUT FILES !')
+ 525 FORMAT(///,14X,'ATOMIC CALCULATION : Z AXIS ALONG POLARIZATION ','
+ &DIRECTION',/,' ',/,' ',/,' ')
+ 526 FORMAT(///,18X,'ATOMIC CALCULATION : Z AXIS ALONG LIGHT ','DIRECTI
+ &ON',/,' ',/,' ',/,' ')
+ 527 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' PHOTOELEC
+ &TRON DIFFRACTION')
+ 528 FORMAT(///,10X,'TYPE OF CALCULATION : FULL HEMISPHERE',' AUGER ELE
+ &CTRON DIFFRACTION')
+ 529 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL LEED',' VARIATIONS
+ &')
+ 530 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' LEED')
+ 531 FORMAT(///,18X,'TYPE OF CALCULATION : LEED ENERGY ','VARIATIONS')
+ 532 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR LEED',' VARIATIONS')
+ 533 FORMAT(///,17X,'TYPE OF CALCULATION : EIGENVALUE',' ANALYSIS')
+ 534 FORMAT(///,22X,'THE AMPLITUDES WILL BE PRINTED SEPARATELY')
+C
+ 701 FORMAT(6X,I1,1X,I3,2X,I4)
+ 702 FORMAT(6X,I1,1X,I3,3X,I3)
+ 703 FORMAT(15X,F8.3,3X,F8.3)
+ 713 FORMAT(6X,I1,1X,I3)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/refrac.f b/src/msspec/spec/fortran/common_sub/refrac.f
new file mode 100644
index 0000000..3479f6c
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/refrac.f
@@ -0,0 +1,29 @@
+C
+C=======================================================================
+C
+ SUBROUTINE REFRAC(VINT,EKIN,RTHETA,RTHINT)
+C
+C This routine calculates the refraction of a plane wave beam induced
+C by the surface potential barrier VINT. EKIN is the kinetic energy
+C outside the crystal.
+C
+C Last modified : 3 Dec 2008
+C
+ DATA PIS180,SMALL /0.017453,0.001/
+C
+ IF(VINT.LT.0.) VINT=ABS(VINT)
+ IF(ABS(VINT).LT.SMALL) THEN
+ RTHINT=RTHETA
+ ELSE
+ U=VINT/(EKIN+VINT)
+ DTHETA=RTHETA/PIS180
+ REFRA=SIN(RTHETA)*SIN(RTHETA)*(1.-U)
+ RTHINT=ASIN(SQRT(REFRA))
+ IF(DTHETA.LT.0.) THEN
+ RTHINT=-RTHINT
+ ENDIF
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/sig2.f b/src/msspec/spec/fortran/common_sub/sig2.f
new file mode 100644
index 0000000..da359c6
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/sig2.f
@@ -0,0 +1,48 @@
+C
+C=======================================================================
+C
+ FUNCTION SIG2(RJ,JTYP)
+C
+C This routine evaluates the mean square displacements.
+C
+ USE DIM_MOD
+C
+ USE DEBWAL_MOD , T => TEMP
+ USE MASSAT_MOD , XM => XMT
+ USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT
+ &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT
+C
+ REAL MJ
+C
+C
+C
+ DATA COEF/145.52539/
+ DATA RZ2,RZ4,RZ6/1.644934,1.082323,1.017343/
+C
+ A=TD/T
+ BJ=QD*RJ
+ U=BJ/A
+ MJ=XM(JTYP)
+ C=COEF/(2.*MJ*TD)
+ COMP=RZ2-U*U*RZ4+U*U*U*U*RZ6
+ X1=0.
+ X2=0.
+ X3=0.
+ X4=0.
+ DO 10 N=1,8
+ Z=FLOAT(N)
+ X1=X1+EXP(-Z*A)*((A/Z)+(1./(Z*Z)))
+ X2=X2+1./(Z**8+U*U*(Z**6))
+ X3=X3+EXP(-Z*A)*Z/(Z*Z+U*U)
+ X4=X4+EXP(-Z*A)/(Z*Z+U*U)
+ 10 CONTINUE
+ P1=1.+4.*(RZ2-X1)/(A*A)
+ P2=-2.*(1.-COS(BJ))/(BJ*BJ)
+ P3=-4.*(COMP-(U**6)*X2)/(A*A)
+ P4=4.*SIN(BJ)*X3/(A*BJ)
+ P5=4.*COS(BJ)*X4/(A*A)
+ SIG2=C*(P1+P2+P3+P4+P5)/(A0*A0)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/sixj_in.f b/src/msspec/spec/fortran/common_sub/sixj_in.f
new file mode 100644
index 0000000..59186e8
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/sixj_in.f
@@ -0,0 +1,82 @@
+C
+C=======================================================================
+C
+ DOUBLE PRECISION FUNCTION SIXJ_IN(J1,J2,L1,L2,L3)
+C
+C This function calculates the initial value {J1 J2 L1+L2}
+C {L1 L2 L3 }
+C
+C A 6j symbol {J1 J2 J3} is non zero only if
+C {J4 J5 J6}
+C
+C (J1,J2,J3),(J4,J5,J3),(J2,J4,J6) and (J1,J5,J6) satisfy the triangular inequality :
+C
+C (a,b,c) non zero if |a-b| <= c <= (a+b) . This means also that (a+b) and c must
+C have the same nature (integer or half-integer).
+C
+C (J1,J2,J3) and (J4,J5,J3) are taken care of by the bounds of J3, JJ_MIN and JJ_MAX,
+C as chosen in the N_J routine. Here we check the two last ones.
+C
+C Last modified : 8 Dec 2008
+C
+C
+ USE DIM_MOD
+ USE LOGAMAD_MOD
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ REAL*8 J1,J2,L1,L2,L3
+C
+C
+ DATA SMALL /0.0001/
+C
+ IZERO=0
+C
+C Check for unphysical values of L3
+C
+ IF(DABS(J2-L1).GT.L3) IZERO=1
+ IF(J2+L1.LT.L3) IZERO=1
+ IF(IG(J2+L1).NE.IG(L3)) IZERO=1
+ IF(DABS(J1-L2).GT.L3) IZERO=1
+ IF(J1+L2.LT.L3) IZERO=1
+ IF(IG(J1+L2).NE.IG(L3)) IZERO=1
+C
+ IF(IZERO.EQ.1) THEN
+ SIXJ_IN=0.D0
+ ELSE
+C
+C Storage indices of the angular momenta.
+C
+ LJ1=INT(J1+SIGN(SMALL,J1))
+ LJ2=INT(J2+SIGN(SMALL,J2))
+ LL1=INT(L1+SIGN(SMALL,L1))
+ LL2=INT(L2+SIGN(SMALL,L2))
+ LL3=INT(L3+SIGN(SMALL,L3))
+ LL1_2=INT(L1+L1+SIGN(SMALL,L1))
+ LL2_2=INT(L2+L2+SIGN(SMALL,L2))
+C
+ MSIGN=INT(J1+J2+L1+L2+SIGN(SMALL,J1+J2+L1+L2))
+ IF(MOD(MSIGN,2).EQ.0) THEN
+ SIGNE=1.D0
+ ELSE
+ SIGNE=-1.D0
+ ENDIF
+C
+ D1=GLD(LL1_2+1,1) + GLD(LL2_2+1,1) - GLD(LL1_2+LL2_2+2,1)
+ D2=GLD(INT(J1+J2+L1+L2)+2,IG(J1+J2+L1+L2)) - GLD(INT(J1+J2-L1-L2
+ &)+1,IG(J1+J2-L1-L2))
+ D3=GLD(INT(J1-J2+L1+L2)+1,IG(J1-J2+L1+L2)) - GLD(INT(J1+L2-L3)+1
+ &,IG(J1+L2-L3))
+ D4=GLD(INT(J2-J1+L1+L2)+1,IG(J2-J1+L1+L2)) -GLD(INT(-J1+L2+L3)+1
+ &,IG(-J1+L2+L3))
+ D5=GLD(INT(J1-L2+L3)+1,IG(J1-L2+L3)) - GLD(INT(J1+L2+L3)+2,IG(J1
+ &+L2+L3))
+ D6=GLD(INT(J2+L3-L1)+1,IG(J2+L3-L1)) - GLD(INT(J2-L3+L1)+1,IG(J2
+ &-L3+L1))
+ D7=GLD(INT(L1+L3-J2)+1,IG(L1+L3-J2)) +GLD(INT(L1+J2+L3)+2,IG(L1+
+ &J2+L3))
+C
+ SIXJ_IN=SIGNE*DSQRT(DEXP(D1+D2+D3+D4+D5+D6-D7))
+C
+ ENDIF
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/sph_har.f b/src/msspec/spec/fortran/common_sub/sph_har.f
new file mode 100644
index 0000000..c8103ad
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/sph_har.f
@@ -0,0 +1,61 @@
+C
+C=======================================================================
+C
+ SUBROUTINE SPH_HAR(NL,X,CF,YLM,NC)
+C
+C This routine computes the complex spherical harmonics using Condon and
+C Shortley phase convention.
+C
+C If the angular direction R=(THETAR,PHIR) is given in cartesian
+C coordinates by (XR,YR,ZR), the arguments of the subroutine are :
+C
+C X = ZR = cos(THETAR)
+C CF = XR + i YR = sin(THETAR)*exp(i PHIR)
+C
+C NL is the dimensioning of the YLM array and NC is
+C the maximum l value to be computed.
+C
+ USE DIM_MOD
+C
+ USE EXPFAC2_MOD
+ USE FACTSQ_MOD
+C
+ COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF
+C
+ DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
+C
+C
+ YLM(0,0)=CMPLX(SQ4PI_INV)
+ YLM(1,0)=X*SQR3_INV
+ DO L=2,NC
+ Y=1./FLOAT(L)
+ YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
+ &-1.5))*YLM(L-2,0)
+ ENDDO
+C
+ C2=-1.
+ C=-0.5*CF
+C
+ C1=1.
+ COEF=(1.,0.)
+ DO M=1,NC
+ C1=C1*C2
+ COEF=COEF*C
+ YMM=SQ4PI_INV*COEF*FSQ(M)
+ YLM(M,M)=YMM
+ YLM(M,-M)=C1*CONJG(YMM)
+ YMMP=X*SQRT(FLOAT(M+M+3))*YMM
+ YLM(M+1,M)=YMMP
+ YLM(M+1,-M)=C1*CONJG(YMMP)
+ IF(M.LT.NC-1) THEN
+ DO L=M+2,NC
+ YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
+ &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
+ YLM(L,-M)=C1*CONJG(YLM(L,M))
+ ENDDO
+ ENDIF
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/sph_har2.f b/src/msspec/spec/fortran/common_sub/sph_har2.f
new file mode 100644
index 0000000..bdc8d6f
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/sph_har2.f
@@ -0,0 +1,67 @@
+C
+C=======================================================================
+C
+ SUBROUTINE SPH_HAR2(NL,X,CF,YLM,NC)
+C
+C This routine computes the complex spherical harmonics using Condon and
+C Shortley phase convention.
+C
+C If the angular direction R=(THETAR,PHIR) is given in cartesian
+C coordinates by (XR,YR,ZR), the arguments of the subroutine are :
+C
+C X = ZR = cos(THETAR)
+C CF = XR + i YR = sin(THETAR)*exp(i PHIR)
+C
+C NL is the dimensioning of the YLM array and NC is
+C the maximum l value to be computed.
+C
+C This is the double precision version of sph_har.f
+C
+C
+ USE DIM_MOD
+C
+ USE DEXPFAC2_MOD
+ USE DFACTSQ_MOD
+C
+C
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ COMPLEX*16 YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF
+C
+ DATA SQ4PI_INV,SQR3_INV /0.282094791774D0,0.488602511903D0/
+C
+C
+ YLM(0,0)=DCMPLX(SQ4PI_INV)
+ YLM(1,0)=X*SQR3_INV
+ DO L=2,NC
+ Y=1.D0/DFLOAT(L)
+ YLM(L,0)=X*DSQRT(4.D0-Y*Y)*YLM(L-1,0) - (1.D0-Y)*DSQRT(1.D0+2.D0
+ &/(DFLOAT(L)-1.5D0))*YLM(L-2,0)
+ ENDDO
+C
+ C2=-1.D0
+ C=-0.5D0*CF
+C
+ C1=1.D0
+ COEF=(1.D0,0.D0)
+ DO M=1,NC
+ C1=C1*C2
+ COEF=COEF*C
+ YMM=SQ4PI_INV*COEF*DFSQ(M)
+ YLM(M,M)=YMM
+ YLM(M,-M)=C1*DCONJG(YMM)
+ YMMP=X*DSQRT(DFLOAT(M+M+3))*YMM
+ YLM(M+1,M)=YMMP
+ YLM(M+1,-M)=C1*DCONJG(YMMP)
+ IF(M.LT.NC-1) THEN
+ DO L=M+2,NC
+ YLM(L,M)=(X*DFLOAT(L+L-1)*DEXPF2(L-1,M)*YLM(L-1,M) - DFLOAT(
+ &L+M-1)*DEXPF2(L-2,M)*YLM(L-2,M))/(DEXPF2(L,M)*DFLOAT(L-M))
+ YLM(L,-M)=C1*DCONJG(YLM(L,M))
+ ENDDO
+ ENDIF
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/stop_ext.f b/src/msspec/spec/fortran/common_sub/stop_ext.f
new file mode 100644
index 0000000..4108375
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/stop_ext.f
@@ -0,0 +1,59 @@
+C
+C=======================================================================
+C
+ SUBROUTINE STOP_EXT(I_EXT,I_EXT_A,SPECTRO)
+C
+C This routine stops the code when the dimension N_TILT_M in the
+C spec.inc file is insufficient for the number of values to
+C Gaussian average over (as generated by the ext_dir.f code)
+C
+ USE DIM_MOD
+C
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE OUTUNITS_MOD
+C
+C
+C
+ CHARACTER*3 SPECTRO
+C
+ NSET=1
+ NSET_A=1
+C
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+ IF(I_EXT.EQ.-1) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,15) IDIR,NSET
+ CLOSE(IUI6)
+ ENDIF
+ IF(I_EXT_A.EQ.-1) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,15) IDIR,NSET_A
+ CLOSE(IUI6)
+ ENDIF
+ ENDIF
+ IF(SPECTRO.EQ.'APC') THEN
+ IF(I_EXT.EQ.-1) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,15) IDIR,NSET
+ CLOSE(IUI6)
+ ENDIF
+ IF(I_EXT_A.EQ.-1) THEN
+ OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
+ READ(IUI9,15) IDIR,NSET_A
+ CLOSE(IUI9)
+ ENDIF
+ ENDIF
+C
+ IF(MAX(NSET,NSET_A).GT.N_TILT_M) THEN
+ WRITE(IUO1,10) MAX(NSET,NSET_A)
+ STOP
+ ENDIF
+C
+ 10 FORMAT(///,16X,'<<<<<<<<<< N_TILT_M SHOULD BE AT LEAST ',I3,' >>
+ &>>>>>>>>')
+ 15 FORMAT(6X,I1,1X,I3)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/stop_treat.f b/src/msspec/spec/fortran/common_sub/stop_treat.f
new file mode 100644
index 0000000..1f64b94
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/stop_treat.f
@@ -0,0 +1,197 @@
+C
+C=======================================================================
+C
+ SUBROUTINE STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI
+ &,NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
+C
+C This subroutine stops the code before the long MS calculations
+C when the dimensioning NDIM_M of the treatment routines
+C (treat_aed,treat_apc,treat_phd,treat_xas) is insufficient.
+C
+C
+C Last modified : 06 Oct 2006
+C
+ USE DIM_MOD
+ USE OUTUNITS_MOD
+C
+ CHARACTER*3 SPECTRO
+C
+C
+ IF(ISOM.EQ.0) THEN
+C
+C Photoelectron diffraction case
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
+ NDP=NEMET*NTHETA*NPHI*NE
+ ELSEIF(I_EXT.EQ.-1) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*2
+ ELSEIF(I_EXT.EQ.2) THEN
+ NDP=NEMET*NTHETA*NE
+ ENDIF
+ NTT=NPLAN*NDP
+ IF(NTT.GT.NDIM_M) GOTO 10
+ IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
+C
+C Auger electron diffraction case
+C
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NEMET*NTHETA_A*NPHI_A*NE
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NEMET*NTHETA_A*NPHI_A*NE*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NEMET*NTHETA_A*NE
+ ENDIF
+ NTT=NPLAN*NDP
+ IF(NTT.GT.NDIM_M) GOTO 20
+ IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
+C
+C X-ray absorption case
+C
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ NDP=NEMET*NE
+ NTT=NPLAN*NDP
+ IF(NTT.GT.NDIM_M) GOTO 30
+C
+C Auger Photoelectron coincidence spectroscopy case
+C
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A
+ ENDIF
+ ELSEIF(I_EXT.EQ.-1) THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A
+ ENDIF
+ ELSEIF(I_EXT.EQ.2) THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NEMET*NTHETA*NE*NTHETA_A
+ ENDIF
+ ENDIF
+ NTT=NPLAN*NDP
+ IF(NTT.GT.NDIM_M) GOTO 40
+ IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
+ IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
+ ENDIF
+C
+ ELSE
+C
+C Photoelectron diffraction case
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
+ NDP=NTHETA*NPHI*NE
+ ELSEIF(I_EXT.EQ.-1) THEN
+ NDP=NTHETA*NPHI*NE*2
+ ELSEIF(I_EXT.EQ.2) THEN
+ NDP=NTHETA*NE
+ ENDIF
+ NTT=NFICHLEC*NDP
+ IF(NTT.GT.NDIM_M) GOTO 10
+ IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
+C
+C Auger electron diffraction case
+C
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NTHETA_A*NPHI_A*NE
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NTHETA_A*NPHI_A*NE*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NTHETA_A*NE
+ ENDIF
+ NTT=NFICHLEC*NDP
+ IF(NTT.GT.NDIM_M) GOTO 20
+ IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
+C
+C X-ray absorption case
+C
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ NDP=NE
+ NTT=NFICHLEC*NDP
+ IF(NTT.GT.NDIM_M) GOTO 30
+C
+C Auger Photoelectron coincidence spectroscopy case
+C
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NTHETA*NPHI*NE*NTHETA_A
+ ENDIF
+ ELSEIF(I_EXT.EQ.-1) THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NTHETA*NPHI*NE*2*NTHETA_A
+ ENDIF
+ ELSEIF(I_EXT.EQ.2) THEN
+ IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
+ NDP=NTHETA*NE*NTHETA_A*NPHI_A
+ ELSEIF(I_EXT_A.EQ.-1) THEN
+ NDP=NTHETA*NE*NTHETA_A*NPHI_A*2
+ ELSEIF(I_EXT_A.EQ.2) THEN
+ NDP=NTHETA*NE*NTHETA_A
+ ENDIF
+ ENDIF
+ NTT=NFICHLEC*NDP
+ IF(NTT.GT.NDIM_M) GOTO 40
+ IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
+ IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
+ ENDIF
+ ENDIF
+C
+ GOTO 5
+C
+ 10 WRITE(IUO1,11) NTT
+ STOP
+ 20 WRITE(IUO1,21) NTT
+ STOP
+ 30 WRITE(IUO1,31) NTT
+ STOP
+ 40 WRITE(IUO1,41) NTT
+ STOP
+ 50 WRITE(IUO1,51) MAX(NTHETA,NPHI,NTHETA_A,NPHI_A)
+ STOP
+C
+ 11 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
+ &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
+ &_PHD SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
+ &AT LEAST ',I8,' >>>>>>>>>>')
+ 21 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
+ &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
+ &_AED SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
+ &AT LEAST ',I8,' >>>>>>>>>>')
+ 31 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
+ &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
+ &_XAS SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
+ &AT LEAST ',I8,' >>>>>>>>>>')
+ 41 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
+ &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
+ &_APC SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
+ &AT LEAST ',I8,' >>>>>>>>>>')
+ 51 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL','
+ &IN THE INCLUDE FILE - SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
+C
+ 5 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/sup_zeros.f b/src/msspec/spec/fortran/common_sub/sup_zeros.f
new file mode 100644
index 0000000..4c3c7a9
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/sup_zeros.f
@@ -0,0 +1,72 @@
+C
+C=======================================================================
+C
+ SUBROUTINE SUP_ZEROS(TL,LMAX,NE,NAT,IUO1,ITRTL)
+C
+C This routine suppresses possible zeros in the TL arrays so that
+C the code runs faster because of lower values of LMAX. Actually,
+C the TL array is not modified, it is just the LMAX array that is
+C altered. This is particularly useful for energy variations or
+C for matrix inversion
+C
+ USE DIM_MOD
+C
+ COMPLEX TL_,TL(0:NT_M,4,NATM,NE_M)
+C
+ INTEGER LMAX(NATM,NE_M)
+C
+ IF(ITRTL.EQ.1) THEN
+ SMALL=0.1
+ ELSEIF(ITRTL.EQ.2) THEN
+ SMALL=0.01
+ ELSEIF(ITRTL.EQ.3) THEN
+ SMALL=0.001
+ ELSEIF(ITRTL.EQ.4) THEN
+ SMALL=0.0001
+ ELSEIF(ITRTL.EQ.5) THEN
+ SMALL=0.00001
+ ELSEIF(ITRTL.EQ.6) THEN
+ SMALL=0.000001
+ ELSEIF(ITRTL.EQ.7) THEN
+ SMALL=0.0000001
+ ELSEIF(ITRTL.EQ.8) THEN
+ SMALL=0.00000001
+ ELSE
+ ITRTL=9
+ SMALL=0.000000001
+ ENDIF
+C
+ WRITE(IUO1,10)
+ WRITE(IUO1,15) ITRTL
+C
+ DO JE=1,NE
+ WRITE(IUO1,20) JE
+ DO JAT=1,NAT
+ NONZERO=0
+ LM=LMAX(JAT,JE)
+ DO L=0,LM
+ TL_=TL(L,1,JAT,JE)
+ IF((ABS(REAL(TL_)).GE.SMALL).OR.(ABS(AIMAG(TL_)).GE.SMALL))
+ &THEN
+ NONZERO=NONZERO+1
+ ENDIF
+ ENDDO
+ LMAX(JAT,JE)=NONZERO-1
+ WRITE(IUO1,30) JAT,LM,NONZERO-1
+ ENDDO
+ ENDDO
+C
+ WRITE(IUO1,40)
+C
+ 10 FORMAT(//,' ---> CHECK FOR ZEROS IN THE TL FILE TO REDUCE',' THE
+ & AMOUNT OF COMPUTING :',/)
+ 15 FORMAT(/,' (ONLY THE MATRIX ELEMENTS NON ZERO ','TO THE FIRST ',I
+ &1,' DECIMAL DIGITS ARE KEPT)',/)
+ 20 FORMAT(/,15X,'ENERGY POINT No ',I3,/)
+ 30 FORMAT(8X,'PROTOTYPICAL ATOM No ',I5,' INITIAL LMAX = ',I2,' FI
+ &NAL LMAX = ',I2)
+ 40 FORMAT(//)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/sym_clus.f b/src/msspec/spec/fortran/common_sub/sym_clus.f
new file mode 100644
index 0000000..5481fdd
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/sym_clus.f
@@ -0,0 +1,1850 @@
+C
+C=======================================================================
+C
+ SUBROUTINE SYM_CLUS(CUNIT,COORD,CHEM_OLD,NZAT,NTYP,IPHA)
+C
+C This subroutine reorganizes the cluster into equivalence classes
+C taking advantage of its symmetry properties. The corresponding
+C symmetry operations are stored for further use.
+C
+C Written by Mihai Gavaza : 15 Feb 2000
+C Modified by Didier Sebilleau : 05 Nov 2003
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+C
+ USE ATOMS_MOD, NZ_AT => NZAT
+ USE CLUSLIM_MOD, Z_PLAN => VAL
+ USE COOR_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE ROT_CUB_MOD
+ USE SYMMOP_MOD
+ USE TAU_PROT_MOD
+ USE TAUSYMMOP_MOD
+ USE TESTS_MOD
+C
+C
+C
+ COMPLEX ONEC,IC,JC1,JC2,JC4,JC5
+ COMPLEX ONEC_,IC_,JC1_,JC2_,JC4_,JC5_
+C
+ PARAMETER(ONEC=(1.,0.),IC=(0.,1.),JC1=(0.5,0.866025))
+ PARAMETER(ONEC_=(-1.,0.),IC_=(0.,-1.),JC1_=(-0.5,-0.866025))
+ PARAMETER(JC2=JC1*JC1,JC4=JC2*JC2,JC5=JC4*JC1)
+ PARAMETER(JC2_=ONEC_*JC2,JC4_=ONEC_*JC4,JC5_=ONEC_*JC5)
+C
+ REAL*4 COORD(3,NATCLU_M),COORD1(3,NATCLU_M),SYM_AT1(3,NATCLU_M)
+ REAL*4 DNBR(NATCLU_M,NATCLU_M),DIST0(NATCLU_M),DIST1(NATCLU_M)
+ REAL*4 S_M(3,3,64),S_MUL(3,3)
+C
+ INTEGER NSYM_M(64),CONT_G(48,32),SIZE_G(32)
+ INTEGER INV_P(NATP_M,64),INV_PT(NATP_M,64),NAT_SYM(4)
+ INTEGER I_SET(NATP_M),GR(NATP_M)
+ INTEGER NEQAT(NATCLU_M),NBRZ(NATCLU_M,NATCLU_M),NZAT(NATCLU_M)
+ INTEGER IUSED(NATCLU_M),NTYP(NATCLU_M),NGAIN_B(NATP_M)
+ INTEGER NQAT(NATCLU_M),I_33(32),IS_WRONG(64),OLD_G(32),NEW_G(32)
+ INTEGER N_NEW_OLD(NATCLU_M)
+C
+ CHARACTER*2 CHEM_OLD(NATCLU_M)
+ CHARACTER*3 NAME_G(0:32)
+ CHARACTER*4 ANG_ROT(4)
+ CHARACTER*5 NAME_S(64)
+ CHARACTER*8 AT_ADD(2)
+C
+C
+ LOGICAL EQUIV,MATCH
+C
+C Matrices of the 64 symmetry operations in the form S_M(I,J)
+C I is chosen as the line index and J as the column one
+C
+C Matrices for the rotations of the group Oh
+C
+C The greek indices for the cubic rotations have been written as :
+C
+C alpha ----> l
+C beta ----> m
+C gamma ----> n
+C delta ----> o
+C
+ DATA ((S_M(I,J,1), J=1,3), I=1,3) /1.,0.,0.,0.,1.,0.,0.,0.,1./
+ & ! E
+ DATA ((S_M(I,J,2), J=1,3), I=1,3) /1.,0.,0.,0.,-1.,0.,0.,0.,-1./
+ & ! C2X
+ DATA ((S_M(I,J,3), J=1,3), I=1,3) /-1.,0.,0.,0.,1.,0.,0.,0.,-1./
+ & ! C2Y
+ DATA ((S_M(I,J,4), J=1,3), I=1,3) /-1.,0.,0.,0.,-1.,0.,0.,0.,1./
+ & ! C2Z
+ DATA ((S_M(I,J,5), J=1,3), I=1,3) /0.,0.,1.,1.,0.,0.,0.,1.,0./
+ & ! C3l
+ DATA ((S_M(I,J,6), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,1.,-1.,0.,0./
+ & ! C3m
+ DATA ((S_M(I,J,7), J=1,3), I=1,3) /0.,0.,-1.,1.,0.,0.,0.,-1.,0./
+ & ! C3n
+ DATA ((S_M(I,J,8), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,-1.,1.,0.,0./
+ & ! C3o
+ DATA ((S_M(I,J,9), J=1,3), I=1,3) /0.,1.,0.,0.,0.,1.,1.,0.,0./
+ & ! C3l2
+ DATA ((S_M(I,J,10), J=1,3), I=1,3) /0.,0.,-1.,-1.,0.,0.,0.,1.,0./
+ & ! C3m2
+ DATA ((S_M(I,J,11), J=1,3), I=1,3) /0.,1.,0.,0.,0.,-1.,-1.,0.,0./
+ & ! C3n2
+ DATA ((S_M(I,J,12), J=1,3), I=1,3) /0.,0.,1.,-1.,0.,0.,0.,-1.,0./
+ & ! C3o2
+ DATA ((S_M(I,J,13), J=1,3), I=1,3) /1.,0.,0.,0.,0.,-1.,0.,1.,0./
+ & ! C4X
+ DATA ((S_M(I,J,14), J=1,3), I=1,3) /0.,0.,1.,0.,1.,0.,-1.,0.,0./
+ & ! C4Y
+ DATA ((S_M(I,J,15), J=1,3), I=1,3) /0.,-1.,0.,1.,0.,0.,0.,0.,1./
+ & ! C4Z
+ DATA ((S_M(I,J,16), J=1,3), I=1,3) /1.,0.,0.,0.,0.,1.,0.,-1.,0./
+ & ! C4X3
+ DATA ((S_M(I,J,17), J=1,3), I=1,3) /0.,0.,-1.,0.,1.,0.,1.,0.,0./
+ & ! C4Y3
+ DATA ((S_M(I,J,18), J=1,3), I=1,3) /0.,1.,0.,-1.,0.,0.,0.,0.,1./
+ & ! C4Z3
+ DATA ((S_M(I,J,19), J=1,3), I=1,3) /0.,1.,0.,1.,0.,0.,0.,0.,-1./
+ & ! C2a
+ DATA ((S_M(I,J,20), J=1,3), I=1,3) /0.,-1.,0.,-1.,0.,0.,0.,0.,-1.
+ &/ ! C2b
+ DATA ((S_M(I,J,21), J=1,3), I=1,3) /0.,0.,1.,0.,-1.,0.,1.,0.,0./
+ & ! C2c
+ DATA ((S_M(I,J,22), J=1,3), I=1,3) /0.,0.,-1.,0.,-1.,0.,-1.,0.,0.
+ &/ ! C2d
+ DATA ((S_M(I,J,23), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,-1.,0.,-1.,0.
+ &/ ! C2e
+ DATA ((S_M(I,J,24), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,1.,0.,1.,0./
+ & ! C2f
+C
+C Matrices for the rotations of the group D6h
+C
+ DATA ((S_M(I,J,25), J=1,3), I=1,3) /-0.5,-0.866025,0.,0.866025,-
+ &0.5,0.,0.,0.,1./ ! C3Z
+ DATA ((S_M(I,J,26), J=1,3), I=1,3) /-0.5,0.866025,0.,-0.866025,-
+ &0.5,0.,0.,0.,1./ ! C3Z2
+ DATA ((S_M(I,J,27), J=1,3), I=1,3) /0.5,-0.866025,0.,0.866025,0.
+ &5,0.,0.,0.,1./ ! C6Z
+ DATA ((S_M(I,J,28), J=1,3), I=1,3) /0.5,0.866025,0.,-0.866025,0.
+ &5,0.,0.,0.,1./ ! C6Z5
+ DATA ((S_M(I,J,29), J=1,3), I=1,3) /-0.5,-0.866025,0.,-0.866025,
+ &0.5,0.,0.,0.,-1./ ! C2A
+ DATA ((S_M(I,J,30), J=1,3), I=1,3) /-0.5,0.866025,0.,0.866025,0.
+ &5,0.,0.,0.,-1./ ! C2B
+ DATA ((S_M(I,J,31), J=1,3), I=1,3) /0.5,-0.866025,0.,-0.866025,-
+ &0.5,0.,0.,0.,-1./ ! C2C
+ DATA ((S_M(I,J,32), J=1,3), I=1,3) /0.5,0.866025,0.,0.866025,-0.
+ &5,0.,0.,0.,-1./ ! C2D
+C
+C Matrices for the roto-inversions of the group Oh
+C
+ DATA ((S_M(I,J,33), J=1,3), I=1,3) /-1.,0.,0.,0.,-1.,0.,0.,0.,-1.
+ &/ ! I
+ DATA ((S_M(I,J,34), J=1,3), I=1,3) /-1.,0.,0.,0.,1.,0.,0.,0.,1./
+ & ! IC2X
+ DATA ((S_M(I,J,35), J=1,3), I=1,3) /1.,0.,0.,0.,-1.,0.,0.,0.,1./
+ & ! IC2Y
+ DATA ((S_M(I,J,36), J=1,3), I=1,3) /1.,0.,0.,0.,1.,0.,0.,0.,-1./
+ & ! IC2Z
+ DATA ((S_M(I,J,37), J=1,3), I=1,3) /0.,0.,-1.,-1.,0.,0.,0.,-1.,
+ &0./ ! IC3l
+ DATA ((S_M(I,J,38), J=1,3), I=1,3)/0.,1.,0.,0.,0.,-1.,1.,0.,0./
+ & ! IC3m
+ DATA ((S_M(I,J,39), J=1,3), I=1,3) /0.,0.,1.,-1.,0.,0.,0.,1.,0./
+ & ! IC3n
+ DATA ((S_M(I,J,40), J=1,3), I=1,3) /0.,1.,0.,0.,0.,1.,-1.,0.,0./
+ & ! IC3o
+ DATA ((S_M(I,J,41), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,-1.,-1.,0.,0.
+ &/ ! IC3l2
+ DATA ((S_M(I,J,42), J=1,3), I=1,3) /0.,0.,1.,1.,0.,0.,0.,-1.,0./
+ & ! IC3m2
+ DATA ((S_M(I,J,43), J=1,3), I=1,3) /0.,-1.,0.,0.,0.,1.,1.,0.,0./
+ & ! IC3n2
+ DATA ((S_M(I,J,44), J=1,3), I=1,3) /0.,0.,-1.,1.,0.,0.,0.,1.,0./
+ & ! IC3o2
+ DATA ((S_M(I,J,45), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,1.,0.,-1.,0./
+ & ! IC4X
+ DATA ((S_M(I,J,46), J=1,3), I=1,3) /0.,0.,-1.,0.,-1.,0.,1.,0.,0./
+ & ! IC4Y
+ DATA ((S_M(I,J,47), J=1,3), I=1,3) /0.,1.,0.,-1.,0.,0.,0.,0.,-1./
+ & ! IC4Z
+ DATA ((S_M(I,J,48), J=1,3), I=1,3) /-1.,0.,0.,0.,0.,-1.,0.,1.,0./
+ & ! IC4X3
+ DATA ((S_M(I,J,49), J=1,3), I=1,3) /0.,0.,1.,0.,-1.,0.,-1.,0.,0./
+ & ! IC4Y3
+ DATA ((S_M(I,J,50), J=1,3), I=1,3) /0.,-1.,0.,1.,0.,0.,0.,0.,-1./
+ & ! IC4Z3
+ DATA ((S_M(I,J,51), J=1,3), I=1,3) /0.,-1.,0.,-1.,0.,0.,0.,0.,1./
+ & ! IC2a
+ DATA ((S_M(I,J,52), J=1,3), I=1,3) /0.,1.,0.,1.,0.,0.,0.,0.,1./
+ & ! IC2b
+ DATA ((S_M(I,J,53), J=1,3), I=1,3) /0.,0.,-1.,0.,1.,0.,-1.,0.,0./
+ & ! IC2c
+ DATA ((S_M(I,J,54), J=1,3), I=1,3) /0.,0.,1.,0.,1.,0.,1.,0.,0./
+ & ! IC2d
+ DATA ((S_M(I,J,55), J=1,3), I=1,3) /1.,0.,0.,0.,0.,1.,0.,1.,0./
+ & ! IC2e
+ DATA ((S_M(I,J,56), J=1,3), I=1,3) /1.,0.,0.,0.,0.,-1.,0.,-1.,0./
+ & ! IC2f
+C
+C Matrices for the roto-inversions of the group D6h
+C
+ DATA ((S_M(I,J,57), J=1,3), I=1,3) /0.5,0.866025,0.,-0.866025,0.
+ &5,0.,0.,0.,-1./ ! IC3Z
+ DATA ((S_M(I,J,58), J=1,3), I=1,3) /0.5,-0.866025,0.,0.866025,0.
+ &5,0.,0.,0.,-1./ ! IC3Z2
+ DATA ((S_M(I,J,59), J=1,3), I=1,3) /-0.5,0.866025,0.,-0.866025,-
+ &0.5,0.,0.,0.,-1./ ! IC6Z
+ DATA ((S_M(I,J,60), J=1,3), I=1,3) /-0.5,-0.866025,0.,0.866025,-
+ &0.5,0.,0.,0.,-1./ ! IC6Z5
+ DATA ((S_M(I,J,61), J=1,3), I=1,3) /0.5,0.866025,0.,0.866025,-0.
+ &5,0.,0.,0.,1./ ! IC2A
+ DATA ((S_M(I,J,62), J=1,3), I=1,3)/0.5,-0.866025,0.,-0.866025,-0.
+ &5,0.,0.,0.,1./ ! IC2B
+ DATA ((S_M(I,J,63), J=1,3), I=1,3) /-0.5,0.866025,0.,0.866025,0.
+ &5,0.,0.,0.,1./ ! IC2C
+ DATA ((S_M(I,J,64), J=1,3), I=1,3) /-0.5,-0.866025,0.,-0.866025,
+ &0.5,0.,0.,0.,1./ ! IC2D
+C
+C For a given symmetry operation S, IZ can have three values :
+C
+C IZ = 1 ----> delta_{L, L'} in S_{L L'}
+C IZ = 0 ----> delta_{l, l'} only in S_{L L'}
+C IZ = -1 ----> delta_{L,-L'} in S_{L L'}
+C
+ IZ = (/1,-1,-1,1,0,0,0,0,0,0,0,0,0,0,1,0,0,1,-1,-1,0,0,0,0,1,1,
+ &1,1,-1,-1,-1,-1,1,-1,-1,1,0,0,0,0,0,0,0,0,0,0,1,0,0,1,-1,-1,0,0,
+ &0,0,1,1,1,1,-1,-1,-1,-1/)
+C
+C For a given symmetry operation S, S_{L L'} is proportional to
+C ZL**L and ZM1**M (and ZM2**M' if IZ=0)
+C
+ ZL = (/1.,-1.,-1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,
+ &-1.,-1.,1.,1.,1.,1.,1.,1.,1.,1.,-1.,-1.,-1.,-1.,-1.,1.,1.,-1.,-1.
+ &,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,-1.,1.,1.,-1.,-
+ &1.,-1.,-1.,-1.,-1.,-1.,-1.,1.,1.,1.,1./)
+C
+ ZM1 = (/ONEC,ONEC,ONEC_,ONEC_,ONEC,IC_,ONEC_,IC,IC_,ONEC_,IC,
+ &ONEC,IC,ONEC,IC_,IC_,ONEC_,IC,IC_,IC,ONEC,ONEC_,IC,IC_,JC4,JC2,
+ &JC5,JC1,JC5_,JC1_,JC4_,JC2_,ONEC,ONEC,ONEC_,ONEC_,ONEC,IC_,ONEC_,
+ &IC,IC_,ONEC_,IC,ONEC,IC,ONEC,IC_,IC_,ONEC_,IC,IC_,IC,ONEC,ONEC_,
+ &IC,IC_,JC4,JC2,JC5,JC1,JC5_,JC1_,JC4_,JC2_/)
+ ZM2 = (/ONEC,ONEC,ONEC,ONEC,IC_,ONEC,IC,ONEC_,ONEC_,IC_,ONEC,
+ &IC,IC_,ONEC,ONEC,IC,ONEC_,ONEC,ONEC,ONEC,ONEC_,ONEC,IC,IC_,ONEC,
+ &ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,IC_,ONEC,
+ &IC,ONEC_,ONEC_,IC_,ONEC,IC,IC_,ONEC,ONEC,ONEC,ONEC,ONEC,ONEC,
+ &ONEC,ONEC_,ONEC,IC,IC_,ONEC,ONEC,IC,ONEC_,ONEC,ONEC,ONEC,ONEC/)
+C
+C Name of the crystallographic point-groups
+C
+ DATA NAME_G /'---',
+ & ' C1',' Ci',' C2','C1h','C2h',' D2','C2v','D2h',
+ & ' C4',' S4','C4h',' D4','C4v','D2d','D4h',' C3',
+ & 'C3i',' D3','C3v','D3d',' C6','C3h','C6h',' D6',
+ & 'C6v','D3h','D6h',' T',' Th',' Td',' O',' Oh'/
+C
+C Content of the crystallographic point-groups : CONT_G(JROT,JGROUP)
+C
+C In some cases, two contents are given. They correspond to a rotation of
+C the x and y axes about 0z by pi/4 in the cube (D2,C2v,D2h,D2d)
+C or pi/6 in the hexagon (D3,C3v,D3d,D3h). In this case, x and y
+C are respectively transformed into a and b in the first case,
+C and D and A in the second. The cube is invariant by any pi/2
+C rotation and the hexagon by any pi/3 rotation about 0z.
+C
+C
+ DATA (CONT_G(I,1), I=1,48) /1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0/ ! C1
+ DATA (CONT_G(I,2), I=1,48) /1,33,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0/ ! Ci
+ DATA (CONT_G(I,3), I=1,48) /1,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! C2
+ DATA (CONT_G(I,4), I=1,48) /1,36,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! C1h
+ DATA (CONT_G(I,5), I=1,48) /1,4,33,36,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! C2h
+ DATA (CONT_G(I,6), I=1,48) /1,2,3,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,19,20/
+ & ! D2
+ DATA (CONT_G(I,7), I=1,48) /1,4,34,35,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,51,52/
+ & ! C2v
+ DATA (CONT_G(I,8), I=1,48) /1,2,3,4,33,34,35,36,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,19,20,33,36,
+ &51,52/ ! D2h
+ DATA (CONT_G(I,9), I=1,48) /1,4,15,18,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! C4
+ DATA (CONT_G(I,10), I=1,48)/1,4,47,50,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! S4
+ DATA (CONT_G(I,11), I=1,48)/1,4,15,18,33,36,47,50,0,0,0,0,0,0,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0/ ! C4h
+ DATA (CONT_G(I,12), I=1,48)/1,2,3,4,15,18,19,20,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! D4
+ DATA (CONT_G(I,13), I=1,48)/1,4,15,18,34,35,51,52,0,0,0,0,0,0,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0/ ! C4v
+ DATA (CONT_G(I,14), I=1,48)/1,2,3,4,47,50,51,52,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,4,19,20,34,35,
+ &47,50/ ! D2d
+ DATA (CONT_G(I,15), I=1,48)/1,2,3,4,15,18,19,20,33,34,35,36,47,
+ * 50,51,52,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0/ ! D4h
+ DATA (CONT_G(I,16), I=1,48)/1,25,26,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! C3
+ DATA (CONT_G(I,17), I=1,48)/1,25,26,33,57,58,0,0,0,0,0,0,0,0,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0/ ! C3i
+ DATA (CONT_G(I,18), I=1,48)/1,3,25,26,31,32,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,25,26,29,
+ &30/ ! D3
+ DATA (CONT_G(I,19), I=1,48)/1,25,26,34,61,62,0,0,0,0,0,0,0,0,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,25,26,
+ & 35,63,64/ ! C3v
+ DATA (CONT_G(I,20), I=1,48)/1,3,25,26,31,32,33,35,57,58,63,64,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,25,26,29,30,
+ & 33,34,57,58,61,62/ ! D3d
+ DATA (CONT_G(I,21), I=1,48)/1,4,25,26,27,28,0,0,0,0,0,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! C6
+ DATA (CONT_G(I,22), I=1,48)/1,25,26,36,59,60,0,0,0,0,0,0,0,0,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0/ ! C3h
+ DATA (CONT_G(I,23), I=1,48)/1,4,25,26,27,28,33,36,57,58,59,60,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0/ ! C6h
+ DATA (CONT_G(I,24), I=1,48)/1,2,3,4,25,26,27,28,29,30,31,32,0,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0/ ! D6
+ DATA (CONT_G(I,25), I=1,48)/1,4,25,26,27,28,34,35,61,62,63,64,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0/ ! C6v
+ DATA (CONT_G(I,26), I=1,48)/1,3,25,26,31,32,34,36,59,60,61,62,
+ * 0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,25,26,29,30,
+ & 35,36,59,60,63,64/ ! D3h
+ DATA (CONT_G(I,27), I=1,48)/1,2,3,4,25,26,27,28,29,30,31,32,33,
+ * 34,35,36,57,58,59,60,
+ & 61,62,63,64,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0,0/ ! D6h
+ DATA (CONT_G(I,28), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,0,0,0,0,0,
+ &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
+ & ! T
+ DATA (CONT_G(I,29), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,33,34,
+ * 35,36,37,38,39,40,41,
+ & 42,43,44,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0/ ! Th
+ DATA (CONT_G(I,30), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,45,46,
+ * 47,48,49,50,51,52,53,
+ & 54,55,56,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0/ ! Td
+ DATA (CONT_G(I,31), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,
+ * 15,16,17,18,19,20,21,
+ & 22,23,24,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ & 0,0,0,0,0,0,0/ ! O
+ DATA (CONT_G(I,32), I=1,48)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,
+ * 15,16,17,18,19,20,21,22,23,24,33,
+ & 34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,
+ & 50,51,52,53,54,55,56/ ! Oh
+C
+C Size of the point-groups
+C
+ DATA SIZE_G /1,2,2,2,4,4,4,8,4,4,8,8,8,8,16,3,6,6,6,12,6,6,12,12,
+ &12,12,24,12,24,24,24,48/
+C
+C Groups containing the space inversion I
+C
+ DATA I_33 /0,1,0,0,1,0,0,1,0,0,1,0,0,0,1,0,1,0,0,1,0,0,1,0,0,0,
+ &1,0,1,0,0,1/
+C
+C Name of the symmetry operations
+C
+C Note : the three-fold rotation axes alpha, beta, gamma and delta
+C of the cubic groups have been coded respectively
+C l, m, n and o
+C
+ DATA NAME_S /' E',' C2X',' C2Y',' C2Z',' C3l',' C3m',
+ & ' C3n',' C3o',' C3l2',' C3m2',' C3n2',' C3o2',
+ & ' C4X',' C4Y',' C4Z',' C4X3',' C4Y3',' C4Z3',
+ & ' C2a',' C2b',' C2c',' C2d',' C2e',' C2f',
+ & ' C3Z',' C3Z2',' C6Z',' C6Z5',' C2A',' C2B',
+ & ' C2C',' C2D',' I',' IC2X',' IC2Y',' IC2Z',
+ & ' IC3l',' IC3m',' IC3n',' IC3o','IC3l2','IC3m2',
+ & 'IC3n2','IC3o2',' IC4X',' IC4Y',' IC4Z','IC4X3',
+ & 'IC4Y3','IC4Z3',' IC2a',' IC2b',' IC2c',' IC2d',
+ & ' IC2e',' IC2f',' IC3Z','IC3Z2',' IC6Z','IC6Z5',
+ & ' IC2A',' IC2B',' IC2C',' IC2D'/
+C
+ DATA ANG_ROT /'PI/4','PI/2','PI/6','PI/3'/
+C
+ DATA AT_ADD /' ','<--- NEW'/
+C
+ DATA SMALL /0.001/
+C
+ PRINT 444
+C
+ DO JS=1,64
+ IS_WRONG(JS)=0
+ ENDDO
+ IROT=0
+ NAT_NEW=NATCLU
+C
+ IF(I_GR.EQ.2) THEN
+ I_SB=1
+ ELSE
+ I_SB=0
+ ENDIF
+C
+ 111 DO JAT=1,NAT_NEW
+ NEQAT(JAT)=0
+ ENDDO
+C
+C Calculates the distance between the atoms and all
+C their neighbors
+C
+ DIST0(1)=0.
+ DO JAT1=1,NAT_NEW
+ INEW_AT(JAT1)=0
+ NABOR=0
+ DO JAT2=1,NAT_NEW
+ IF(JAT1.EQ.JAT2) GO TO 10
+ NABOR=NABOR+1
+ NBRZ(NABOR,JAT1)=NZAT(JAT2)
+ RAB=SQRT((COORD(1,JAT1)-COORD(1,JAT2))*(COORD(1,JAT1)-
+ & COORD(1,JAT2))+(COORD(2,JAT1)-COORD(2,JAT2))*(COORD(2,JAT1)-
+ & COORD(2,JAT2))+(COORD(3,JAT1)-COORD(3,JAT2))*(COORD(3,JAT1)-
+ & COORD(3,JAT2)))
+ IF((JAT2.GT.JAT1).AND.(RAB.LT.SMALL)) GOTO 895
+ IF(JAT1.EQ.1) DIST0(JAT2)=RAB
+ DNBR(NABOR,JAT1)=RAB
+ 10 CONTINUE
+ ENDDO
+ ENDDO
+C
+C Generates the set of class distances to the absorber
+C
+ CALL ORDRE(NAT_NEW,DIST0,NDIST,DIST1)
+C
+C Determines the prototypical and equivalent atoms:
+C two atoms are equivalent if they have the same type,
+C they are at the same distance from the emitter
+C and they have the same geometrical environment.
+C This part of the routine has been adapted from
+C R. Gunnella and C. R. Natoli.
+C
+ JTYP_C_M=0
+ NEQAT_M=0
+ JTYP=2
+ NASHUFF=2
+ NABORS=NAT_NEW-1
+C
+ NATYP(1)=1
+ NQAT(1)=1
+ NCORR(1,1)=1
+ NEQAT(1)=1
+ NCHTYP(1)=1
+ I_Z(1,1)=1
+ Z_L(1,1)=1.
+ Z_M1(1,1)=ONEC
+ Z_M2(1,1)=ONEC
+ SYM_AT(1,1)=COORD(1,1)
+ SYM_AT(2,1)=COORD(2,1)
+ SYM_AT(3,1)=COORD(3,1)
+ NZ_AT(1)=NZAT(1)
+ CHEM(1)=CHEM_OLD(1)
+ INEW_AT(1)=0
+ N_NEW_OLD(1)=1
+C
+ NATYP(2)=1
+ NQAT(2)=2
+ NCORR(1,2)=2
+ NEQAT(2)=2
+ NCHTYP(2)=2
+ I_Z(1,2)=1
+ Z_L(1,2)=1.
+ Z_M1(1,2)=ONEC
+ Z_M2(1,2)=ONEC
+ SYM_AT(1,2)=COORD(1,2)
+ SYM_AT(2,2)=COORD(2,2)
+ SYM_AT(3,2)=COORD(3,2)
+ NZ_AT(2)=NZAT(2)
+ CHEM(2)=CHEM_OLD(2)
+ INEW_AT(2)=0
+ N_NEW_OLD(2)=2
+C
+ JNUM=0
+ DO JAT1=2,NAT_NEW
+ IF(JNUM.GT.NEQAT_M) THEN
+ NEQAT_M=JNUM
+ JTYP_C_M=JTYP
+ ENDIF
+ JNUM=1
+ NA1P1=JAT1+1
+ IF(NA1P1.GT.NAT_NEW) GO TO 32
+ DO JAT2=NA1P1,NAT_NEW
+ IF(NZAT(JAT1).NE.NZAT(JAT2)) GO TO 30
+ N1=JAT1-1
+ N2=JAT2-1
+ IF(ABS(DNBR(N1,1)-DNBR(N2,1)).GT.SMALL) GOTO 30
+ DO NAB=1,NABORS
+ IUSED(NAB)=0
+ ENDDO
+ DO NABOR1=1,NABORS
+ NZT=NBRZ(NABOR1,JAT1)
+ RABT=DNBR(NABOR1,JAT1)
+ EQUIV=.FALSE.
+ DO NABOR2=1,NABORS
+ IF(IUSED(NABOR2).EQ.1) GOTO 22
+ IF(NBRZ(NABOR2,JAT2).NE.NZT) GOTO 22
+ IF(ABS(DNBR(NABOR2,JAT2)-RABT).GT.SMALL) GOTO 22
+ EQUIV=.TRUE.
+ IUSED(NABOR2)=1
+ GOTO 23
+ 22 CONTINUE
+ ENDDO
+ 23 IF(.NOT.EQUIV) GO TO 30
+ ENDDO
+ IF(NEQAT(JAT1).EQ.0) THEN
+ JTYP=JTYP+1
+ NASHUFF=NASHUFF+1
+ NCORR(JNUM,JTYP)=NASHUFF
+ I_Z(JNUM,JTYP)=1
+ Z_L(JNUM,JTYP)=1.
+ Z_M1(JNUM,JTYP)=ONEC
+ Z_M2(JNUM,JTYP)=ONEC
+ SYM_AT(1,NASHUFF)=COORD(1,JAT1)
+ SYM_AT(2,NASHUFF)=COORD(2,JAT1)
+ SYM_AT(3,NASHUFF)=COORD(3,JAT1)
+ N_NEW_OLD(NASHUFF)=JAT1
+ NEQAT(JAT1)=JTYP
+ NCHTYP(JTYP)=NTYP(JAT1)
+ NZ_AT(NASHUFF)=NZAT(JAT1)
+ CHEM(NASHUFF)=CHEM_OLD(JAT1)
+ NQAT(NASHUFF)=JTYP
+ IF(JAT1.GT.NATCLU) INEW_AT(NASHUFF)=1
+ ENDIF
+ IF(NEQAT(JAT2).EQ.0) THEN
+ JNUM=JNUM+1
+ NATYP(JTYP)=JNUM
+ NASHUFF=NASHUFF+1
+ NCORR(JNUM,JTYP)=NASHUFF
+ SYM_AT(1,NASHUFF)=COORD(1,JAT2)
+ SYM_AT(2,NASHUFF)=COORD(2,JAT2)
+ SYM_AT(3,NASHUFF)=COORD(3,JAT2)
+ N_NEW_OLD(NASHUFF)=JAT2
+ NEQAT(JAT2)=JTYP
+ NCHTYP(JTYP)=NTYP(JAT2)
+ NZ_AT(NASHUFF)=NZAT(JAT2)
+ CHEM(NASHUFF)=CHEM_OLD(JAT2)
+ NQAT(NASHUFF)=JTYP
+ IF(JAT2.GT.NATCLU) INEW_AT(NASHUFF)=1
+ ENDIF
+30 CONTINUE
+ ENDDO
+32 IF(NEQAT(JAT1).EQ.0) THEN
+ JTYP=JTYP+1
+ NATYP(JTYP)=JNUM
+ NASHUFF=NASHUFF+1
+ NCORR(JNUM,JTYP)=NASHUFF
+ I_Z(JNUM,JTYP)=1
+ Z_L(JNUM,JTYP)=1.
+ Z_M1(JNUM,JTYP)=ONEC
+ Z_M2(JNUM,JTYP)=ONEC
+ SYM_AT(1,NASHUFF)=COORD(1,JAT1)
+ SYM_AT(2,NASHUFF)=COORD(2,JAT1)
+ SYM_AT(3,NASHUFF)=COORD(3,JAT1)
+ N_NEW_OLD(NASHUFF)=JAT1
+ NEQAT(JAT1)=JTYP
+ NCHTYP(JTYP)=NTYP(JAT1)
+ NZ_AT(NASHUFF)=NZAT(JAT1)
+ CHEM(NASHUFF)=CHEM_OLD(JAT1)
+ NQAT(NASHUFF)=JTYP
+ IF(JAT1.GT.NATCLU) INEW_AT(NASHUFF)=1
+ ENDIF
+ CONTINUE
+ ENDDO
+ N_PROT=JTYP
+C
+C Stop if the maximal number of prototypical and equivalent
+C atoms are not correctly dimensionned
+C
+ IF(N_PROT.GT.NATP_M) THEN
+ WRITE(IUO1,897) N_PROT
+ STOP
+ ENDIF
+ IF(NEQAT_M.GT.NAT_EQ_M) THEN
+ WRITE(IUO1,898) NEQAT_M
+ STOP
+ ENDIF
+C
+ DO JAT=1,NAT_NEW
+ COORD1(1,JAT)=SYM_AT(1,JAT)-SYM_AT(1,1)
+ COORD1(2,JAT)=SYM_AT(2,JAT)-SYM_AT(2,1)
+ COORD1(3,JAT)=SYM_AT(3,JAT)-SYM_AT(3,1)
+ ENDDO
+C
+C Test of all symmetry operations for the largest
+C symmetry class
+C
+ NROTCLUS=0
+ 556 NSYM_M(1)=1
+ NSIZE_C=1
+ DO JROT=2,64
+ DO JNUM1=1,NEQAT_M
+ JAT1=NCORR(JNUM1,JTYP_C_M)
+ MATCH=.FALSE.
+ SYM_AT1(1,JAT1)=S_M(1,1,JROT)*COORD1(1,JAT1)+S_M(1,2,
+ & JROT)*COORD1(2,JAT1)+S_M(1,3,JROT)*COORD1(3,JAT1)
+ SYM_AT1(2,JAT1)=S_M(2,1,JROT)*COORD1(1,JAT1)+S_M(2,2,
+ & JROT)*COORD1(2,JAT1)+S_M(2,3,JROT)*COORD1(3,JAT1)
+ SYM_AT1(3,JAT1)=S_M(3,1,JROT)*COORD1(1,JAT1)+S_M(3,2,
+ & JROT)*COORD1(2,JAT1)+S_M(3,3,JROT)*COORD1(3,JAT1)
+ DO JNUM2=1,NEQAT_M
+ JAT2=NCORR(JNUM2,JTYP_C_M)
+ AD=ABS(COORD1(1,JAT2)-SYM_AT1(1,JAT1))+ABS(COORD1(2,
+ & JAT2)-SYM_AT1(2,JAT1))+ABS(COORD1(3,JAT2)-SYM_AT1(3,JAT1))
+ IF(AD.LT.SMALL) THEN
+ MATCH=.TRUE.
+ ENDIF
+ ENDDO
+ IF(.NOT.MATCH) GOTO 333
+ ENDDO
+ NSIZE_C=NSIZE_C+1
+ NSYM_M(NSIZE_C)=JROT
+ 333 CONTINUE
+ ENDDO
+C
+C Test on all classes of the symmetry operations that work
+C for the largest class
+C
+ NSYM_G(1)=1
+ NSIZE_GR=1
+ I_THREE=0
+ I_INCRG=0
+ I_INVG=0
+ DO JSYM=2,NSIZE_C
+ JROT=NSYM_M(JSYM)
+ DO JTYP=1,N_PROT
+ NEQATS=NATYP(JTYP)
+ DO JNUM1=1,NEQATS
+ JAT1=NCORR(JNUM1,JTYP)
+ MATCH=.FALSE.
+ SYM_AT1(1,JAT1)=S_M(1,1,JROT)*COORD1(1,JAT1)+S_M(1,2,
+ & JROT)*COORD1(2,JAT1)+S_M(1,3,JROT)*COORD1(3,JAT1)
+ SYM_AT1(2,JAT1)=S_M(2,1,JROT)*COORD1(1,JAT1)+S_M(2,2,
+ & JROT)*COORD1(2,JAT1)+S_M(2,3,JROT)*COORD1(3,JAT1)
+ SYM_AT1(3,JAT1)=S_M(3,1,JROT)*COORD1(1,JAT1)+S_M(3,2,
+ & JROT)*COORD1(2,JAT1)+S_M(3,3,JROT)*COORD1(3,JAT1)
+ DO JNUM2=1,NEQATS
+ JAT2=NCORR(JNUM2,JTYP)
+ AD=ABS(COORD1(1,JAT2)-SYM_AT1(1,JAT1))+ABS(
+ & COORD1(2,JAT2)-SYM_AT1(2,JAT1))+ABS(COORD1(3,JAT2)-
+ & SYM_AT1(3,JAT1))
+ IF(AD.LT.SMALL) THEN
+ MATCH=.TRUE.
+ ENDIF
+ ENDDO
+ IF(.NOT.MATCH) GOTO 335
+ ENDDO
+ ENDDO
+ IF(MATCH) THEN
+ NSIZE_GR=NSIZE_GR+1
+ NSYM_G(NSIZE_GR)=JROT
+ IF(JROT.EQ.25) I_THREE=1
+ IF(JROT.EQ.33) I_INVG=1
+ ENDIF
+ 335 CONTINUE
+ ENDDO
+ IF(NSIZE_GR.GT.48) GOTO 998
+C
+C Set up of the parameter used to check if a larger
+C group containing the inversion I can be constructed
+C if the inversion is physically acceptable as an approximation
+C
+ IF((I_GR.EQ.2).AND.(I_INVG.EQ.0)) THEN
+ IF(I_INV.EQ.1) THEN
+ I_INCRG=1
+ ENDIF
+ ENDIF
+C
+ IF(NROTCLUS.LE.2) THEN
+ IF(NSIZE_GR.GT.1) THEN
+ WRITE(IUO1,699) NSIZE_GR
+ ELSE
+ WRITE(IUO1,698) NSIZE_GR
+ ENDIF
+ IF(NSIZE_GR.EQ.1) THEN
+ WRITE(IUO1,705) NAME_S(NSYM_G(1))
+ ELSEIF(NSIZE_GR.EQ.2) THEN
+ WRITE(IUO1,704) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2))
+ ELSEIF(NSIZE_GR.EQ.3) THEN
+ WRITE(IUO1,703) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)),
+ & NAME_S(NSYM_G(3))
+ ELSEIF(NSIZE_GR.EQ.4) THEN
+ WRITE(IUO1,702) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)),
+ & NAME_S(NSYM_G(3)),NAME_S(NSYM_G(4))
+ ELSEIF(NSIZE_GR.EQ.6) THEN
+ WRITE(IUO1,701) (NAME_S(NSYM_G(JROT)), JROT=1,6)
+ ELSEIF(NSIZE_GR.GE.8) THEN
+ WRITE(IUO1,700) (NAME_S(NSYM_G(JROT)), JROT=1,NSIZE_GR)
+ ENDIF
+ IF(NROTCLUS.GT.0) THEN
+ IF(I_THREE.EQ.0) THEN
+ WRITE(IUO1,706) ANG_ROT(NROTCLUS)
+ ELSE
+ WRITE(IUO1,706) ANG_ROT(NROTCLUS+2)
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C Finding the cluster's symmetry group
+C
+ 555 JGROUP=0
+ IF(NSIZE_GR.EQ.1) THEN
+ JGROUP=1
+ ELSEIF(NSIZE_GR.EQ.2) THEN
+ IF(NSYM_G(2).EQ.33) THEN
+ JGROUP=2
+ ELSEIF(NSYM_G(2).EQ.4) THEN
+ JGROUP=3
+ ELSEIF(NSYM_G(2).EQ.36) THEN
+ JGROUP=4
+ ENDIF
+ ELSEIF(NSIZE_GR.EQ.3) THEN
+ JGROUP=16
+ ELSEIF(NSIZE_GR.EQ.4) THEN
+ IF(NSYM_G(3).EQ.33) THEN
+ JGROUP=5
+ ELSEIF((NSYM_G(3).EQ.3).OR.(NSYM_G(3).EQ.19)) THEN
+ JGROUP=6
+ ELSEIF((NSYM_G(3).EQ.34).OR.(NSYM_G(3).EQ.51)) THEN
+ JGROUP=7
+ ELSEIF(NSYM_G(3).EQ.15) THEN
+ JGROUP=9
+ ELSEIF(NSYM_G(3).EQ.47) THEN
+ JGROUP=10
+ ENDIF
+ ELSEIF(NSIZE_GR.EQ.6) THEN
+ IF(NSYM_G(4).EQ.26) THEN
+ JGROUP=18
+ ELSEIF((NSYM_G(4).EQ.34).OR.(NSYM_G(4).EQ.35)) THEN
+ JGROUP=19
+ ELSEIF(NSYM_G(4).EQ.33) THEN
+ JGROUP=17
+ ELSEIF(NSYM_G(4).EQ.26) THEN
+ JGROUP=21
+ ELSEIF(NSYM_G(4).EQ.36) THEN
+ JGROUP=22
+ ENDIF
+ ELSEIF(NSIZE_GR.EQ.8) THEN
+ IF(NSYM_G(4).EQ.33) THEN
+ IF(NSYM_G(8).EQ.50) THEN
+ JGROUP=11
+ ELSE
+ JGROUP=8
+ ENDIF
+ ELSE
+ IF(NSYM_G(5).EQ.15) THEN
+ JGROUP=12
+ ELSE
+ IF(NSYM_G(3).EQ.15) THEN
+ JGROUP=13
+ ELSEIF((NSYM_G(3).EQ.3).OR.(NSYM_G(3).EQ.19)) THEN
+ JGROUP=14
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSEIF(NSIZE_GR.EQ.12) THEN
+ IF(NSYM_G(5).EQ.5) THEN
+ JGROUP=28
+ ELSEIF(NSYM_G(7).EQ.33) THEN
+ IF(NSYM_G(12).EQ.60) THEN
+ JGROUP=23
+ ELSE
+ JGROUP=20
+ ENDIF
+ ELSE
+ IF(NSYM_G(3).EQ.3) THEN
+ JGROUP=24
+ ELSEIF(NSYM_G(9).EQ.59) THEN
+ JGROUP=26
+ ELSEIF(NSYM_G(5).EQ.27) THEN
+ JGROUP=25
+ ENDIF
+ ENDIF
+ ELSEIF(NSIZE_GR.EQ.16) THEN
+ JGROUP=15
+ ELSEIF(NSIZE_GR.EQ.24) THEN
+ IF(NSYM_G(17).EQ.57) THEN
+ JGROUP=27
+ ELSEIF(NSYM_G(17).EQ.17) THEN
+ JGROUP=31
+ ELSEIF(NSYM_G(17).EQ.49) THEN
+ JGROUP=30
+ ELSEIF(NSYM_G(17).EQ.37) THEN
+ JGROUP=29
+ ENDIF
+ ELSEIF(NSIZE_GR.EQ.48) THEN
+ JGROUP=32
+ ENDIF
+c IF((JGROUP.GT.0).AND.(NEQAT_M.LE.NSIZE_GR)) THEN
+ IF(JGROUP.GT.0) THEN
+ WRITE(IUO1,886)
+ WRITE(IUO1,880) NAME_G(JGROUP)
+ ELSE
+C
+C If no group is found, the cluster is rotated by pi/4 ,or pi/6 for
+C hexagonal structures (i. e. when C3z=25 is present), around Oz
+C at most twice to account for possible misnaming of the Ox axis.
+C Then, the search for the point-group is restarted.
+C
+ IF(NROTCLUS.LT.2) THEN
+ NROTCLUS=NROTCLUS+1
+ DO JPROT=1,N_PROT
+ NEQATS=NATYP(JPROT)
+ DO JNUM=1,NEQATS
+ JAT=NCORR(JNUM,JPROT)
+ X=COORD1(1,JAT)
+ Y=COORD1(2,JAT)
+ IF(I_THREE.EQ.0) THEN
+ COORD1(1,JAT)=0.707107*(X-Y)
+ COORD1(2,JAT)=0.707107*(X+Y)
+ ELSE
+ COORD1(1,JAT)=0.866025*X-0.500000*Y
+ COORD1(2,JAT)=0.500000*X+0.866025*Y
+ ENDIF
+ COORD1(3,JAT)=COORD1(3,JAT)
+ SYM_AT(1,JAT)=COORD1(1,JAT)+SYM_AT(1,1)
+ SYM_AT(2,JAT)=COORD1(2,JAT)+SYM_AT(2,1)
+ SYM_AT(3,JAT)=COORD1(3,JAT)+SYM_AT(3,1)
+ ENDDO
+ ENDDO
+ GOTO 556
+ ELSE
+ IF((JGROUP.EQ.0).AND.(NROTCLUS.EQ.2)) WRITE(IUO1,881)
+ ENDIF
+ ENDIF
+ IF(JGROUP.GE.28) WRITE(IUO1,697)
+ IF((JGROUP.GT.0) .AND.(I_INCRG.EQ.1)) WRITE(IUO1,722)
+C
+C Recovery of the original cluster when no group has been found
+C
+ IF((NROTCLUS.EQ.2).AND.(JGROUP.EQ.0)) THEN
+ DO JPROT=1,N_PROT
+ NEQATS=NATYP(JPROT)
+ DO JNUM=1,NEQATS
+ JAT=NCORR(JNUM,JPROT)
+ X=COORD1(1,JAT)
+ Y=COORD1(2,JAT)
+ IF(I_THREE.EQ.0) THEN
+ COORD1(1,JAT)=Y
+ COORD1(2,JAT)=-X
+ ELSE
+ COORD1(1,JAT)=0.500000*X+0.866025*Y
+ COORD1(2,JAT)=-0.866025*X+0.500000*Y
+ ENDIF
+ COORD1(3,JAT)=COORD1(3,JAT)
+ SYM_AT(1,JAT)=COORD1(1,JAT)+SYM_AT(1,1)
+ SYM_AT(2,JAT)=COORD1(2,JAT)+SYM_AT(2,1)
+ SYM_AT(3,JAT)=COORD1(3,JAT)+SYM_AT(3,1)
+ ENDDO
+ ENDDO
+ NROTCLUS=NROTCLUS+1
+ GOTO 556
+ ENDIF
+C
+C If still no group is found, or if the group can be augmented by
+C the inversion (as an approximation), check of the other symmetries that
+C should be present to account for group properties (i. e. those
+C obtained by multiplication of those that are effectively present)
+C
+ IF((JGROUP.EQ.0).OR.(I_INCRG.EQ.1)) THEN
+ IF(I_INCRG.EQ.1) THEN
+ NSIZE_GR=NSIZE_GR+1
+ NSYM_G(NSIZE_GR)=33
+ ENDIF
+ NSIZE_RE=NSIZE_GR
+ 553 I_NEW=0
+ DO JSYM1=2,NSIZE_RE
+ JS1=NSYM_G(JSYM1)
+ DO JSYM2=JSYM1,NSIZE_RE
+ JS2=NSYM_G(JSYM2)
+ DO I=1,3
+ DO J=1,3
+ S_MUL(I,J)=0.
+ DO K=1,3
+ S_MUL(I,J)=S_MUL(I,J)+S_M(I,K,JS1)*S_M(K,
+ & J,JS2)
+ ENDDO
+ ENDDO
+ ENDDO
+ I_EQ=0
+ DO JSYM3=1,NSIZE_RE
+ JS3=NSYM_G(JSYM3)
+ I_OLD=0
+ DO I=1,3
+ DO J=1,3
+ S1=S_MUL(I,J)
+ S2=S_M(I,J,JS3)
+ IF(ABS(S1-S2).LT.SMALL) I_OLD=I_OLD+1
+ ENDDO
+ ENDDO
+ IF(I_OLD.EQ.9) I_EQ=1
+ ENDDO
+ IF(I_EQ.EQ.0) THEN
+ I_NEW=I_NEW+1
+ J_RE=NSIZE_GR+I_NEW
+ DO JS4=2,64
+ I_OLD=0
+ DO I=1,3
+ DO J=1,3
+ S1=S_MUL(I,J)
+ S2=S_M(I,J,JS4)
+ IF(ABS(S1-S2).LT.SMALL) I_OLD=I_OLD+1
+ ENDDO
+ ENDDO
+ IF(I_OLD.EQ.9) THEN
+ NSYM_G(J_RE)=JS4
+ NSIZE_RE=NSIZE_RE+1
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+ IF(I_NEW.GT.0) GOTO 553
+C
+ IF(NSIZE_RE.GT.NSIZE_GR) THEN
+ WRITE(IUO1,696) NSIZE_RE
+ IF(NSIZE_RE.EQ.2) THEN
+ WRITE(IUO1,704) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2))
+ ELSEIF(NSIZE_RE.EQ.3) THEN
+ WRITE(IUO1,703) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)),
+ & NAME_S(NSYM_G(3))
+ ELSEIF(NSIZE_RE.EQ.4) THEN
+ WRITE(IUO1,702) NAME_S(NSYM_G(1)),NAME_S(NSYM_G(2)),
+ & NAME_S(NSYM_G(3)),NAME_S(NSYM_G(4))
+ ELSEIF(NSIZE_RE.EQ.6) THEN
+ WRITE(IUO1,701) (NAME_S(NSYM_G(JROT)), JROT=1,6)
+ ELSEIF(NSIZE_RE.GE.8) THEN
+ WRITE(IUO1,700) (NAME_S(NSYM_G(JROT)), JROT=1,
+ & NSIZE_RE)
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C If no group has been found, it means that the cluster does not
+C retain the whole symmetry of the crystal. When I_GR = 1 or 2,
+C the largest group consistent with the symmetry operations
+C found is sought. Then a new cluster is built to support
+C all the symmetries of this group.
+C
+ I_BACK=0
+ IF(((JGROUP.EQ.0).OR.(I_INCRG.EQ.1)).AND.(I_GR.GE.1)) THEN
+C
+C Search for the different point-groups containing the NSIZE_RE
+C symmetries found. If the cluster can not support the
+C inversion I (I_INV=0), a test is made on the content
+C of the point-groups to suppress those that contain I.
+C
+ WRITE(IUO1,707)
+ WRITE(IUO1,708)
+C
+C Input cluster
+C
+ NB_GR=0
+ DO JG=1,32
+ IF((I_INV.EQ.0).AND.(I_33(JG).EQ.1)) GOTO 223
+ JS_MAX=SIZE_G(JG)
+ IF(JS_MAX.LT.NSIZE_RE) GOTO 223
+C
+ ICHECK_S=0
+ DO JSYM=1,NSIZE_RE
+ JS_RE=NSYM_G(JSYM)
+C
+ DO JS_GR1=1,JS_MAX
+ JS_NE1=CONT_G(JS_GR1,JG)
+ IWRONG=0
+ IF(IROT.GT.0) THEN
+ DO JS=1,IROT
+ IF(JS_NE1.EQ.IS_WRONG(JS)) THEN
+ IWRONG=1
+ ENDIF
+ ENDDO
+ ENDIF
+ IF(JS_NE1.EQ.JS_RE) THEN
+ ICHECK_S=ICHECK_S+1
+ ENDIF
+ ENDDO
+C
+ ENDDO
+C
+ IF(IWRONG.EQ.1) GOTO 223
+ IF(ICHECK_S.EQ.NSIZE_RE) THEN
+ NB_GR=NB_GR+1
+ OLD_G(NB_GR)=JG
+ ENDIF
+ 223 CONTINUE
+C
+ ENDDO
+ NB_GR1=NB_GR
+ WRITE(IUO1,709) (NAME_G(OLD_G(J)), J=1,NB_GR1)
+ WRITE(IUO1,710)
+C
+C Input cluster rotated
+C
+ DO JG=1,32
+ IF((I_INV.EQ.0).AND.(I_33(JG).EQ.1)) GOTO 225
+ IOLD=0
+ DO J_OLD=1,NB_GR1
+ IF(OLD_G(J_OLD).EQ.JG) THEN
+ IOLD=IOLD+1
+ ENDIF
+ ENDDO
+ IF(IOLD.NE.0) GOTO 225
+ JS_MAX=SIZE_G(JG)
+ IF(JS_MAX.LT.NSIZE_RE) GOTO 225
+C
+ ICHECK_S=0
+ DO JSYM=1,NSIZE_RE
+ JS_RE=NSYM_G(JSYM)
+C
+ DO JS_GR1=1,JS_MAX
+ JS_GR2=49-JS_GR1
+ JS_NE2=CONT_G(JS_GR2,JG)
+ IWRONG=0
+ IF(IROT.GT.0) THEN
+ DO JS=1,IROT
+ IF(JS_NE2.EQ.IS_WRONG(JS)) THEN
+ IWRONG=1
+ ENDIF
+ ENDDO
+ ENDIF
+ IF(JS_NE2.EQ.JS_RE) THEN
+ ICHECK_S=ICHECK_S+1
+ ENDIF
+ ENDDO
+C
+ ENDDO
+C
+ IF(IWRONG.EQ.1) GOTO 225
+ IF(ICHECK_S.EQ.NSIZE_RE) THEN
+ NB_GR=NB_GR+1
+ OLD_G(NB_GR)=JG
+ ENDIF
+ 225 CONTINUE
+C
+ ENDDO
+ IF(NB_GR1.LT.NB_GR) THEN
+ WRITE(IUO1,713)
+ WRITE(IUO1,711) (NAME_G(OLD_G(J)), J=NB_GR1+1,NB_GR)
+ WRITE(IUO1,712)
+ ENDIF
+ IF(I_INV.EQ.0) THEN
+ IF(I_GR.EQ.2) THEN
+ WRITE(IUO1,721)
+ ELSE
+ WRITE(IUO1,726)
+ ENDIF
+ ENDIF
+ CALL ORDRE2(NB_GR,OLD_G,NB_G,NEW_G)
+C
+C Construction of the augmented cluster consistent with the group JGROUP_M.
+C Note that this group must be consistent with the original cluster.
+C This is checked through 3 criteria :
+C
+C 1. No atom must be generated above the surface plane
+C
+C 2. If an atom generated by a symmetry of JGROUP_M coincides
+C with one of the original cluster, it must have the same
+C atomic number
+C
+C 3. Every new atom generated by a symmetry of JGROUP_M must
+C be outside the original cluster except those meeting
+C the previous criterion
+C
+C When one of this criteria is not satisfied, it means that the group
+C JGROUP_M can not accomodate the original cluster. Hence, a smaller
+C group must be looked for
+C
+C An extra criterion is used when I_GR = 1 :
+C
+C 4. No surface atom can be transformed into a bulk atom
+C and likewise no bulk atom into a surface atom
+C
+C
+ JG_MIN=NEW_G(1)
+ I_MINUS=0
+ 222 JGROUP_M=NEW_G(NB_G-I_MINUS)
+ IF(JGROUP_M.LT.JG_MIN) THEN
+ IF(I_GR.GE.1) THEN
+ I_GR=0
+ WRITE(IUO1,723)
+ GOTO 111
+ ELSE
+ WRITE(IUO1,719)
+ STOP
+ ENDIF
+ ENDIF
+ JS_M=SIZE_G(JGROUP_M)
+ WRITE(IUO1,714) NAME_G(JGROUP_M)
+ I_END=0
+ IROT=0
+ NAT=NAT_NEW
+C
+ DO JS=2,JS_M
+ JROT=CONT_G(JS,JGROUP_M)
+C
+ DO J_AT=2,NAT
+ IF(I_END.EQ.1) GOTO 224
+ X_NEW=S_M(1,1,JROT)*(COORD(1,J_AT)-COORD(1,1)) + S_M(
+ & 1,2,JROT)*(COORD(2,J_AT)-COORD(2,1)) +S_M(1,3,JROT)*(COORD(
+ & 3,J_AT)-COORD(3,1)) + COORD(1,1)
+ Y_NEW=S_M(2,1,JROT)*(COORD(1,J_AT)-COORD(1,1)) + S_M(
+ & 2,2,JROT)*(COORD(2,J_AT)-COORD(2,1)) +S_M(2,3,JROT)*(COORD(
+ & 3,J_AT)-COORD(3,1)) + COORD(2,1)
+ Z_NEW=S_M(3,1,JROT)*(COORD(1,J_AT)-COORD(1,1)) + S_M(
+ & 3,2,JROT)*(COORD(2,J_AT)-COORD(2,1)) +S_M(3,3,JROT)*(COORD(
+ & 3,J_AT)-COORD(3,1)) + COORD(3,1)
+C
+C Check for criterion 1
+C
+ IF(Z_NEW.GT.VALZ_MAX) THEN
+ WRITE(IUO1,715) (COORD(J,J_AT), J=1,3),X_NEW,
+ & Y_NEW,Z_NEW
+ WRITE(IUO1,716) NAME_S(JROT),VALZ_MAX
+ IROT=IROT+1
+ IS_WRONG(IROT)=JROT
+ ENDIF
+ IF(IROT.GT.0) THEN
+ I_END=1
+ GOTO 224
+ ENDIF
+ NZ_NEW=NZAT(J_AT)
+ I_OLD=0
+ I_IN_OK=0
+C
+C Check for criterion 2
+C
+ DO J_AT_P=2,NAT
+ D2=(X_NEW-COORD(1,J_AT_P))*(X_NEW-COORD(1,J_AT_P)
+ & ) + (Y_NEW-COORD(2,J_AT_P))*(Y_NEW-COORD(2,J_AT_P)) +(
+ & Z_NEW-COORD(3,J_AT_P))*(Z_NEW-COORD(3,J_AT_P))
+ NZ_OLD=NZAT(J_AT_P)
+ IF(D2.LT.SMALL) THEN
+ I_OLD=I_OLD+1
+ IF(NZ_NEW.NE.NZ_OLD) THEN
+ IROT=IROT+1
+ IS_WRONG(IROT)=JROT
+ WRITE(IUO1,715) (COORD(J,J_AT), J=1,3),
+ & X_NEW,Y_NEW,Z_NEW
+ WRITE(IUO1,717) CHEM_OLD(J_AT),J_AT,
+ & NAME_S(JROT),CHEM_OLD(J_AT_P),J_AT_P
+ ELSE
+ I_IN_OK=1
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(I_IN_OK.EQ.1) GOTO 226
+C
+C Check for criterion 3
+C
+ DO JPLAN=1,NPLAN
+ IF(ABS(Z_NEW-Z_PLAN(JPLAN)).LT.SMALL) THEN
+ IF(X_NEW.GT.X_MIN(JPLAN)) THEN
+ IF(X_NEW.LT.X_MAX(JPLAN)) THEN
+ IF(Y_NEW.GT.Y_MIN(JPLAN)) THEN
+ IF(Y_NEW.LT.Y_MAX(JPLAN)) THEN
+ IROT=IROT+1
+ IS_WRONG(IROT)=JROT
+ WRITE(IUO1,715) (COORD(J,
+ & J_AT), J=1,3),X_NEW,Y_NEW,Z_NEW
+ WRITE(IUO1,720) NAME_S(JROT)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+C
+C Check for criterion 4
+C
+ IF(I_SB.EQ.0) THEN
+ Z_DIF=ABS(Z_NEW-COORD(3,J_AT))
+ Z_TYP=ABS(Z_NEW-VALZ_MAX)
+ IF(Z_DIF.GT.SMALL) THEN
+ WRITE(IUO1,715) (COORD(J,J_AT), J=1,3),X_NEW,
+ & Y_NEW,Z_NEW
+ IF(Z_TYP.LT.SMALL) THEN
+ WRITE(IUO1,725) NAME_S(JROT),I_GR
+ ELSE
+ WRITE(IUO1,724) NAME_S(JROT),I_GR
+ ENDIF
+ IROT=IROT+1
+ IS_WRONG(IROT)=JROT
+ ENDIF
+ IF(IROT.GT.0) THEN
+ I_END=1
+ GOTO 224
+ ENDIF
+ ENDIF
+C
+ 226 IF(I_OLD.EQ.0) THEN
+ NAT=NAT+1
+ IF(NAT.GT.NATCLU_M) THEN
+ WRITE(IUO1,718) NAT
+ STOP
+ ENDIF
+ COORD(1,NAT)=X_NEW
+ COORD(2,NAT)=Y_NEW
+ COORD(3,NAT)=Z_NEW
+ VALZ(NAT)=Z_NEW
+ CHEM_OLD(NAT)=CHEM_OLD(J_AT)
+ NZAT(NAT)=NZAT(J_AT)
+ NTYP(NAT)=NTYP(J_AT)
+ ENDIF
+ 224 CONTINUE
+ ENDDO
+C
+ ENDDO
+C
+ I_BACK=1
+ IF(IROT.GT.0) THEN
+ I_MINUS=I_MINUS+1
+ GOTO 222
+ ENDIF
+ ENDIF
+ IF(I_BACK.EQ.1) THEN
+ NAT_NEW=NAT
+ GOTO 111
+ ENDIF
+C
+C Writes the classes of atoms by increasing distance
+C
+ WRITE(IUO1,888)
+ DO JDIST=NDIST,1,-1
+ DO JTYP=1,N_PROT
+ NMAX=NATYP(JTYP)
+ DO JCLASS=1,NMAX
+ N=NCORR(JCLASS,JTYP)
+ D1=SQRT(COORD1(1,N)*COORD1(1,N)+COORD1(2,N)*COORD1(2,
+ & N)+COORD1(3,N)*COORD1(3,N))
+ IF(ABS(D1-DIST1(JDIST)).LT.SMALL) THEN
+ WRITE(IUO1,557) N,SYM_AT(1,N),SYM_AT(2,N),SYM_AT(
+ & 3,N),NQAT(N),JCLASS,CHEM(N),DIST1(JDIST),AT_ADD(INEW_AT(
+ & N)+1)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Writes the augmented symmetrized cluster into the output
+C file OUTFILE4 for further use if necessary
+C
+ OPEN(UNIT=IUO4, FILE=OUTFILE4, STATUS='UNKNOWN')
+ WRITE(IUO4,778) IPHA
+ DO JTYP=1,N_PROT
+ NMAX=NATYP(JTYP)
+ DO JCLASS=1,NMAX
+ N=NCORR(JCLASS,JTYP)
+ X=SYM_AT(1,N)/CUNIT
+ Y=SYM_AT(2,N)/CUNIT
+ Z=SYM_AT(3,N)/CUNIT
+ IF(IPHA.EQ.0) THEN
+ WRITE(IUO4,125) N,CHEM(N),NZ_AT(N),X,Y,Z,JTYP
+ ELSEIF(IPHA.EQ.1) THEN
+ WRITE(IUO4,779) N,CHEM(N),NZ_AT(N),X,Y,Z,JTYP
+ ELSEIF(IPHA.EQ.2) THEN
+ WRITE(IUO4,*) NZ_AT(N),X,Y,Z,JTYP
+ ENDIF
+ ENDDO
+ ENDDO
+ CLOSE(IUO4)
+C
+C Construction of the symmetry operations list.
+C Associates the appropriate symmetry operation
+C for all equivalent atoms
+C
+ IF(IPRINT.GE.2) WRITE(IUO1,887)
+ 438 CONTINUE
+ I_CALC_ROT=0
+ DO JTYP=1,N_PROT
+ ISYM(1,JTYP)=1
+ NEQATS=NATYP(JTYP)
+ IF(NEQATS.EQ.1) THEN
+ IF(JTYP.GT.N_PROT) GOTO 555
+ GOTO 338
+ ENDIF
+ NAP=NCORR(1,JTYP)
+ DO JNUM=1,NEQATS
+ IF(JNUM.GE.2) THEN
+ JSYM_0=2
+ ELSE
+ JSYM_0=1
+ ENDIF
+ NA=NCORR(JNUM,JTYP)
+ X=COORD1(1,NAP)
+ Y=COORD1(2,NAP)
+ Z=COORD1(3,NAP)
+ DO JSYM=JSYM_0,NSIZE_GR
+ JROT=NSYM_G(JSYM)
+ SYM_AT1(1,NAP)=S_M(1,1,JROT)*X+S_M(1,2,JROT)*Y+S_M(1,
+ & 3,JROT)*Z
+ SYM_AT1(2,NAP)=S_M(2,1,JROT)*X+S_M(2,2,JROT)*Y+S_M(2,
+ & 3,JROT)*Z
+ SYM_AT1(3,NAP)=S_M(3,1,JROT)*X+S_M(3,2,JROT)*Y+S_M(3,
+ & 3,JROT)*Z
+ AD=ABS(COORD1(1,NA)-SYM_AT1(1,NAP))+ABS(COORD1(2,NA)-
+ & SYM_AT1(2,NAP))+ABS(COORD1(3,NA)-SYM_AT1(3,NAP))
+ IF(AD.LT.SMALL)THEN
+ ISYM(JNUM,JTYP)=JROT
+ I_Z(JNUM,JTYP)=IZ(JROT)
+ Z_L(JNUM,JTYP)=ZL(JROT)
+ Z_M1(JNUM,JTYP)=ZM1(JROT)
+ Z_M2(JNUM,JTYP)=ZM2(JROT)
+ IF(IZ(JROT).EQ.0) THEN
+ I_CALC_ROT=I_CALC_ROT+1
+ ENDIF
+ GOTO 404
+ ENDIF
+ ENDDO
+ IF(ISYM(JNUM,JTYP).EQ.0) THEN
+ N_PROT=N_PROT+1
+ NCHTYP(N_PROT)=NCHTYP(JTYP)
+ NCORR(1,N_PROT)=NA
+ NATYP(N_PROT)=1
+ I_Z(1,N_PROT)=1
+ Z_L(1,N_PROT)=1.
+ Z_M1(1,N_PROT)=ONEC
+ Z_M2(1,N_PROT)=ONEC
+ DO JCHANGE=JNUM,NEQATS-1
+ NCORR(JCHANGE,JTYP)=NCORR(JCHANGE+1,JTYP)
+ ENDDO
+ NATYP(JTYP)=NATYP(JTYP)-1
+ GOTO 438
+ ENDIF
+ 404 CONTINUE
+ IF((IPRINT.GE.2).AND.(NSIZE_GR.GT.1)) THEN
+ JR=ISYM(JNUM,JTYP)
+ WRITE(IUO1,849) JTYP,JNUM,NCORR(JNUM,JTYP),NAME_S(JR)
+ & ,JR,Z_L(JNUM,JTYP),Z_M1(JNUM,JTYP),Z_M2(JNUM,JTYP),I_Z(
+ & JNUM,JTYP)
+ ENDIF
+ ENDDO
+ WRITE(IUO1,*) ' '
+ 338 CONTINUE
+ ENDDO
+C
+ GAIN_G=REAL(NAT_NEW)/REAL(N_PROT)
+ WRITE(IUO1,854) GAIN_G
+C
+C Test of the symmetry operations leaving the prototypical
+C atoms invariant. Associates the apropriate symmetry
+C relation and/or selection rule for each atom.
+C
+C NAT_SYM(J) is the number of prototypical atoms in the
+C various symmetry sets :
+C
+C J = 1 : atom 0
+C J = 2 : z axis
+C J = 3 : x0y plane
+C J = 4 : other atoms
+C
+ IF(IPRINT.GE.2) WRITE(IUO1,889)
+ NAT_SYM(1)=1
+ NAT_SYM(2)=0
+ NAT_SYM(3)=0
+ NAT_SYM(4)=0
+ I_SET(1)=1
+C
+C Loop on the prototypical atoms
+C
+ DO JTYP=1,N_PROT
+C
+ ISTEP_L(JTYP)=1
+ ISTEP_M(JTYP)=1
+ I_REL_MP(JTYP)=0
+ I_LM(JTYP)=0
+ I_Z_P(JTYP)=0
+ Z_L_P(JTYP)=1.
+ Z_M_P(JTYP)=ONEC
+C
+ NSYM_P=1
+ NSYM_PT=1
+ INV_P(JTYP,NSYM_P)=1
+ INV_PT(JTYP,NSYM_PT)=1
+C
+ JAT_P=NCORR(1,JTYP)
+ X=COORD1(1,JAT_P)
+ Y=COORD1(2,JAT_P)
+ Z=COORD1(3,JAT_P)
+ X_A=ABS(X)
+ Y_A=ABS(Y)
+ Z_A=ABS(Z)
+ IF(JTYP.GT.1) THEN
+ IF((X_A+Y_A.LT.SMALL).AND.(Z_A.GE.SMALL)) THEN
+ NAT_SYM(2)=NAT_SYM(2)+1
+ I_SET(JTYP)=2
+ ELSEIF((Z_A.LT.SMALL).AND.(X_A+Y_A.GE.SMALL)) THEN
+ NAT_SYM(3)=NAT_SYM(3)+1
+ I_SET(JTYP)=3
+ ELSEIF(((X_A+Y_A).GE.SMALL).AND.(Z_A.GE.SMALL)) THEN
+ NAT_SYM(4)=NAT_SYM(4)+1
+ I_SET(JTYP)=4
+ ENDIF
+ ENDIF
+C
+C Loop on the symmetries keeping the cluster unchanged
+C
+ DO JSYM=2,NSIZE_GR
+C
+ JROT=NSYM_G(JSYM)
+ X1=S_M(1,1,JROT)*X+S_M(1,2,JROT)*Y+S_M(1,3,JROT)*Z
+ Y1=S_M(2,1,JROT)*X+S_M(2,2,JROT)*Y+S_M(2,3,JROT)*Z
+ Z1=S_M(3,1,JROT)*X+S_M(3,2,JROT)*Y+S_M(3,3,JROT)*Z
+ AD=ABS(X-X1)+ABS(Y-Y1)+ABS(Z-Z1)
+C
+C Case of an atom invariant by the symmetry JROT
+C
+ IF(AD.LT.SMALL) THEN
+ NSYM_PT=NSYM_PT+1
+ INV_PT(JTYP,NSYM_PT)=JROT
+ IF(IZ(JROT).NE.0) THEN
+ I_Z_P(JTYP)=IZ(JROT)
+ NSYM_P=NSYM_P+1
+ INV_P(JTYP,NSYM_P)=JROT
+ ISL=ISTEP_L(JTYP)
+ ISM=ISTEP_M(JTYP)
+C
+C Case of an atom off the z axis
+C
+ IF((ABS(X).GE.SMALL).OR.(ABS(Y).GE.SMALL)) THEN
+C
+C Symmetry = IC2z
+C
+ IF(JROT.EQ.36) THEN
+ ISTEP_M(JTYP)=MAX(ISM,2)
+ I_LM(JTYP)=1
+C
+C Symmetry = C2u or IC2u_perp
+C
+ ELSE
+ I_REL_MP(JTYP)=1
+ Z_L_P(JTYP)=ZL(JROT)
+ Z_M_P(JTYP)=ZM1(JROT)
+ ENDIF
+C
+C Case of an atom on the z axis but different from the absorber
+C
+ ELSE
+ IF(ABS(Z).GE.SMALL) THEN
+C
+C Symmetry = C2z
+C
+ IF(JROT.EQ.4) THEN
+ ISTEP_M(JTYP)=MAX(ISM,2)
+C
+C Symmetry = C4z
+C
+ ELSEIF(JROT.EQ.15) THEN
+ ISTEP_M(JTYP)=MAX(ISM,4)
+C
+C Symmetry = C4z3
+C
+ ELSEIF(JROT.EQ.18) THEN
+ ISTEP_M(JTYP)=MAX(ISM,4)
+C
+C Symmetry = C3z
+C
+ ELSEIF(JROT.EQ.25) THEN
+ ISTEP_M(JTYP)=MAX(ISM,3)
+C
+C Symmetry = C3z2
+C
+ ELSEIF(JROT.EQ.26) THEN
+ ISTEP_M(JTYP)=MAX(ISM,3)
+C
+C Symmetry = C6z
+C
+ ELSEIF(JROT.EQ.27) THEN
+ ISTEP_M(JTYP)=MAX(ISM,6)
+C
+C Symmetry = C6z5
+C
+ ELSEIF(JROT.EQ.28) THEN
+ ISTEP_M(JTYP)=MAX(ISM,6)
+C
+C Symmetry = IC2u
+C
+ ELSEIF(JROT.GT.33) THEN
+ I_REL_MP(JTYP)=1
+ I_Z_P(JTYP)=IZ(JROT)
+ Z_L_P(JTYP)=ZL(JROT)
+ Z_M_P(JTYP)=ZM1(JROT)
+ ENDIF
+C
+C Case of atom 0 (the absorber)
+C
+ ELSE
+C
+C Symmetry = C2z or IC2z
+C
+ IF((JROT.EQ.4).OR.(JROT.EQ.36)) THEN
+ ISTEP_M(JTYP)=MAX(ISM,2)
+ IF(JROT.EQ.36) THEN
+ I_LM(JTYP)=1
+ ENDIF
+C
+C Symmetry = C4z or IC4z
+C
+ ELSEIF((JROT.EQ.15).OR.(JROT.EQ.47)) THEN
+ ISTEP_M(JTYP)=MAX(ISM,4)
+ IF(JROT.EQ.47) THEN
+ I_LM(JTYP)=1
+ ENDIF
+C
+C Symmetry = C4z3 or IC4z3
+C
+ ELSEIF((JROT.EQ.18).OR.(JROT.EQ.50)) THEN
+ ISTEP_M(JTYP)=MAX(ISM,4)
+ IF(JROT.EQ.50) THEN
+ I_LM(JTYP)=1
+ ENDIF
+C
+C Symmetry = C3z or IC3z
+C
+ ELSEIF((JROT.EQ.25).OR.(JROT.EQ.57)) THEN
+ ISTEP_M(JTYP)=MAX(ISM,3)
+ IF(JROT.EQ.57) THEN
+ ISTEP_L(JTYP)=MAX(ISL,2)
+ ENDIF
+C
+C Symmetry = C3z2 or IC3z2
+C
+ ELSEIF((JROT.EQ.26).OR.(JROT.EQ.58)) THEN
+ ISTEP_M(JTYP)=MAX(ISM,3)
+ IF(JROT.EQ.58) THEN
+ ISTEP_L(JTYP)=MAX(ISL,2)
+ ENDIF
+C
+C Symmetry = C6z or IC6z
+C
+ ELSEIF((JROT.EQ.27).OR.(JROT.EQ.59)) THEN
+ ISTEP_M(JTYP)=MAX(ISM,6)
+ IF(JROT.EQ.59) THEN
+ I_LM(JTYP)=1
+ ENDIF
+C
+C Symmetry = C6z5 or IC6z5
+C
+ ELSEIF((JROT.EQ.28).OR.(JROT.EQ.60)) THEN
+ ISTEP_M(JTYP)=MAX(ISM,6)
+ IF(JROT.EQ.60) THEN
+ I_LM(JTYP)=1
+ ENDIF
+C
+C Symmetry = I
+C
+ ELSEIF(JROT.EQ.33) THEN
+ ISTEP_L(JTYP)=MAX(ISL,2)
+C
+C Symmetry = C2u or IC2u_perp with u within (x0y)
+C
+ ELSE
+ IF(IZ(JROT).EQ.-1) THEN
+ I_REL_MP(JTYP)=1
+ Z_L_P(JTYP)=ZL(JROT)
+ Z_M_P(JTYP)=ZM1(JROT)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+C
+C Finding the symmetry group (if any) associated to each prototypical atom
+C
+ JGROUP=0
+ IF(NSYM_PT.EQ.1) THEN
+ JGROUP=1
+ ELSEIF(NSYM_PT.EQ.2) THEN
+ IF(INV_PT(JTYP,2).EQ.33) THEN
+ JGROUP=2
+ ELSEIF(INV_PT(JTYP,2).EQ.4) THEN
+ JGROUP=3
+ ELSEIF(INV_PT(JTYP,2).EQ.36) THEN
+ JGROUP=4
+ ENDIF
+ ELSEIF(NSYM_PT.EQ.3) THEN
+ JGROUP=16
+ ELSEIF(NSYM_PT.EQ.4) THEN
+ IF(INV_PT(JTYP,3).EQ.33) THEN
+ JGROUP=5
+ ELSEIF((INV_PT(JTYP,3).EQ.3).OR.(INV_PT(JTYP,3).EQ.19))
+ & THEN
+ JGROUP=6
+ ELSEIF((INV_PT(JTYP,3).EQ.34).OR.(INV_PT(JTYP,3).EQ.51))
+ & THEN
+ JGROUP=7
+ ELSEIF(INV_PT(JTYP,3).EQ.15) THEN
+ JGROUP=9
+ ELSEIF(INV_PT(JTYP,3).EQ.47) THEN
+ JGROUP=10
+ ENDIF
+ ELSEIF(NSYM_PT.EQ.6) THEN
+ IF(INV_PT(JTYP,4).EQ.26) THEN
+ JGROUP=18
+ ELSEIF((INV_PT(JTYP,4).EQ.34).OR.(INV_PT(JTYP,4).EQ.35))
+ & THEN
+ JGROUP=19
+ ELSEIF(INV_PT(JTYP,4).EQ.33) THEN
+ JGROUP=17
+ ELSEIF(INV_PT(JTYP,4).EQ.26) THEN
+ JGROUP=21
+ ELSEIF(INV_PT(JTYP,4).EQ.36) THEN
+ JGROUP=22
+ ENDIF
+ ELSEIF(NSYM_PT.EQ.8) THEN
+ IF(INV_PT(JTYP,4).EQ.33) THEN
+ IF(INV_PT(JTYP,8).EQ.50) THEN
+ JGROUP=11
+ ELSE
+ JGROUP=8
+ ENDIF
+ ELSE
+ IF(INV_PT(JTYP,5).EQ.15) THEN
+ JGROUP=12
+ ELSE
+ IF(INV_PT(JTYP,3).EQ.15) THEN
+ JGROUP=13
+ ELSEIF((INV_PT(JTYP,3).EQ.3).OR.(INV_PT(JTYP,3).
+ & EQ.19)) THEN
+ JGROUP=14
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSEIF(NSYM_PT.EQ.12) THEN
+ IF(INV_PT(JTYP,5).EQ.5) THEN
+ JGROUP=28
+ ELSEIF(INV_PT(JTYP,7).EQ.33) THEN
+ IF(INV_PT(JTYP,12).EQ.60) THEN
+ JGROUP=23
+ ELSE
+ JGROUP=20
+ ENDIF
+ ELSE
+ IF(INV_PT(JTYP,3).EQ.3) THEN
+ JGROUP=24
+ ELSEIF(INV_PT(JTYP,9).EQ.59) THEN
+ JGROUP=26
+ ELSEIF(INV_PT(JTYP,5).EQ.27) THEN
+ JGROUP=25
+ ENDIF
+ ENDIF
+ ELSEIF(NSYM_PT.EQ.16) THEN
+ JGROUP=15
+ ELSEIF(NSYM_PT.EQ.24) THEN
+ IF(INV_PT(JTYP,17).EQ.57) THEN
+ JGROUP=27
+ ELSEIF(INV_PT(JTYP,17).EQ.17) THEN
+ JGROUP=31
+ ELSEIF(INV_PT(JTYP,17).EQ.49) THEN
+ JGROUP=30
+ ELSEIF(INV_PT(JTYP,17).EQ.37) THEN
+ JGROUP=29
+ ENDIF
+ ELSEIF(NSYM_PT.EQ.48) THEN
+ JGROUP=32
+ ENDIF
+ GR(JTYP)=JGROUP
+C
+ IF((IPRINT.GE.2).AND.(NSIZE_GR.GT.1)) THEN
+ WRITE(IUO1,851) JTYP,JAT_P,SYM_AT(1,JAT_P),SYM_AT(2,
+ & JAT_P),SYM_AT(3,JAT_P),I_SET(JTYP),NSYM_PT,NSYM_P,NAME_G(GR(
+ & JTYP)),(NAME_S(INV_P(JTYP,JS)),JS=1,NSYM_P)
+ ENDIF
+ ENDDO
+ WRITE(IUO1,852)
+ GAIN_B=0.
+ DO JTYP=1,N_PROT
+ NGAIN_B(JTYP)=ISTEP_L(JTYP)*ISTEP_M(JTYP)*(I_REL_MP(JTYP)+1)
+ GAIN_B=GAIN_B+NGAIN_B(JTYP)
+ WRITE(IUO1,853) JTYP,I_Z_P(JTYP),INT(Z_L_P(JTYP)),Z_M_P(JTYP)
+ & ,ISTEP_L(JTYP),ISTEP_M(JTYP),I_LM(JTYP),I_REL_MP(JTYP),NGAIN_B(
+ & JTYP)
+ ENDDO
+ GAIN_B=GAIN_B/FLOAT(N_PROT)
+ WRITE(IUO1,855) GAIN_B
+C
+C Calculation and storage of r^{l}_{m m'}(pi/2) for the specific
+C cubic group symmetry operations
+C
+ IF(I_CALC_ROT.GT.0) THEN
+ PIS2=1.570796
+ CALL DJMN(PIS2,R_PIS2,LI_M+1)
+ ENDIF
+C
+C Construction of the inverse matrices used for point-groups
+C
+ DO I=1,3
+ DO J=1,3
+ DO JOP=1,NSIZE_GR
+ JSYM=NSYM_G(JOP)
+ S_INV(JSYM,J,I)=S_M(I,J,JSYM)
+ ENDDO
+ ENDDO
+ ENDDO
+ GOTO 999
+C
+ 895 WRITE(IUO1,896) JAT1,JAT2
+ STOP
+ 998 WRITE(IUO1,997) NSIZE_GR
+ STOP
+ 999 PRINT 445
+C
+C Input/output formats
+C
+ 125 FORMAT(2X,I4,5X,A2,5X,I2,3F10.4,12X,I4)
+ 444 FORMAT(////,5X,'++++++++++++++++++++ SYMMETRIZATION OF THE ',
+ &'CLUSTER +++++++++++++++++++',/)
+ 445 FORMAT(//,5X,'+++++++++++++++++++++++++++++++++++++++++++++++','+
+ &++++++++++++++++++++++++',//)
+ 557 FORMAT(10X,I3,3X,'(',F7.3,',',F7.3,',',F7.3,')',3X,I3,3X,I3,3X,
+ &A2,3X,F7.3,2X,A8)
+ 696 FORMAT(///,6X,I2,' SYMMETRY OPERATIONS AT LEAST SHOULD BE ',
+ &'PRESENT IN THE CLUSTER :',/)
+ 697 FORMAT(///,16X,' THE THREE-FOLD AXES HAVE BEEN CODED AS : ',//,
+ &30X,'alpha -----> l',/,30X,'beta -----> m',/,30X,'gamma ---
+ &--> n',/,30X,'delta -----> o')
+ 698 FORMAT(///,17X,I1,' SYMMETRY OPERATION FOUND IN THE CLUSTER :',/)
+ 699 FORMAT(///,16X,I2,' SYMMETRY OPERATIONS FOUND IN THE CLUSTER :',/
+ &)
+ 700 FORMAT(12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/,12X,A5,
+ &2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X,
+ &A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5,
+ &2X,A5,2X,A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,
+ &A5,2X,A5,2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,
+ &2X,A5,/, 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,/,
+ & 12X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5)
+ 701 FORMAT(19X,A5,2X,A5,2X,A5,2X,A5,2X,A5,2X,A5)
+ 702 FORMAT(26X,A5,2X,A5,2X,A5,2X,A5)
+ 703 FORMAT(30X,A5,2X,A5,2X,A5)
+ 704 FORMAT(33X,A5,2X,A5)
+ 705 FORMAT(37X,A5)
+ 706 FORMAT(/,19X,'AFTER ROTATION OF THIS CLUSTER BY ',A4,/)
+ 707 FORMAT(//,' ----------',9X,'CONSTRUCTION OF A NEW CLUSTER :',
+ &8X,'----------')
+ 708 FORMAT(//,10X,'THE DIFFERENT GROUPS THAT COULD SUPPORT ','THE
+ &CLUSTER ARE :',/)
+ 709 FORMAT(28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),
+ &/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,
+ &28X,4(A3,3X))
+ 710 FORMAT(/,28X,'FOR THE INPUT CLUSTER ')
+ 711 FORMAT(/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,
+ &3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/,28X,4(A3,3X),/
+ &,28X,4(A3,3X))
+ 712 FORMAT(/,24X,'FOR THE ROTATED INPUT CLUSTER')
+ 713 FORMAT(//,36X,'AND :')
+ 714 FORMAT(//,25X,'---> TRYING THE GROUP : ',A3)
+ 715 FORMAT(/,13X,'GROUP IMPOSSIBLE : ATOM (',F7.3,',',F7.3,',',F7.3,
+ &')',/,19X,' TRANSFORMED INTO (',F7.3,',',F7.3,',',F7.3,')')
+ 716 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS ABOVE',/,20X,
+ &'THE SURFACE PLANE LOCATED AT Z = ',F7.3)
+ 717 FORMAT(27X,'NEW ATOM OF TYPE ',A2,' (No ',I4,') GENERATED BY ',
+ &A5,/,27X,'AT THE POSITION OF AN ATOM OF TYPE ',A2,' (No ',I4,')',
+ &/,27X,'IN THE ORIGINAL CLUSTER')
+ 718 FORMAT(///,5X,'<<<<<<<<<< NATCLU_M TOO SMALL IN THE .inc FILE ',
+ &'TO INCREASE >>>>>>>>>>',/,5X,'<<<<<<<<<< THE ','CLUSTER.
+ & SHOULD BE AT LEAST ',I4,' >>>>>>>>>>')
+ 719 FORMAT(///,3X,'<<<<<<<<<< ERROR : NO GROUP WAS FOUND TO ',
+ &'ACCOMODATE THE CLUSTER >>>>>>>>>>')
+ 720 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS INSIDE',/,25X,
+ &'THE ORIGINAL CLUSTER, BUT NOT',/,29X,'AT AN ATOMIC POSITION')
+ 721 FORMAT(//,11X,' THE INVERSION I IS NOT CONSISTENT WITH THIS ',
+ &'CLUSTER',/,17X,'AS THE ABSORBER IS CLOSER TO THE SURFACE',/,21X,
+ &'THAN TO THE BOTTOM OF THE CLUSTER')
+ 722 FORMAT(//,16X,'THE CLUSTER CAN ACCOMODATE THE INVERSION I',//,
+ &13X,'---> BUILDING A LARGER CLUSTER INVARIANT BY I')
+ 723 FORMAT(//,4X,'-------- IMPOSSIBLE TO AUGMENT THE CLUSTER TO ',
+ &'SUPPORT I --------',//,15X,'---> RESTARTING WITH THE
+ &ORIGINAL CLUSTER ...')
+ 724 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS OF BULK TYPE',/,
+ &25X,'WHILE THE ORIGINAL ONE IS OF SURFACE TYPE',/,29X,'--->
+ &IMPOSSIBLE WITH I_GR = ',I1)
+ 725 FORMAT(20X,'THE NEW ATOM GENERATED BY ',A5,' IS OF SURFACE TYPE',
+ &/,25X,'WHILE THE ORIGINAL ONE IS OF BULK TYPE',/,29X,'--->
+ &IMPOSSIBLE WITH I_GR = ',I1)
+ 726 FORMAT(//,11X,' THE INVERSION I IS NOT CONSISTENT WITH THIS ',
+ &'CALCULATION',/,10X,'AS SURFACE AND BULK ATOMS HAVE TO ','BE
+ &DISCRIMINATED (I_GR=1)')
+ 778 FORMAT(30X,I1)
+ 779 FORMAT(2X,I4,5X,A2,5X,I2,3F10.4,I5)
+ 849 FORMAT(1X,I4,4X,I2,3X,I4,2X,A5,' = ',I2,2X,F6.3,2X,'(',F6.3,',',
+ &F6.3,')',2X,'(',F6.3,',',F6.3,')',4X,I2)
+ 851 FORMAT(1X,I4,3X,I4,2X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I1,3X,I2,
+ &1X,I2,2X,A3,2X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,
+ &A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/
+ &,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X,4(1X,A5),/,57X)
+ 852 FORMAT(///,10X,'SELECTION RULE AND/OR RELATION ON THE MATRIX','
+ &ELEMENTS OF TAU :',//,4X,'CLASS',2X,'I_Z',2X,'Z_L',8X,'Z_M',9X,
+ &'ISTEP_L',2X,'ISTEP_M',2X,'I_LM',2X,'I_REL_MP',2X,'GAIN',/)
+ 853 FORMAT(4X,I3,4X,I2,3X,I2,3X,'(',F6.3,',',F6.3,')',6X,I1,8X,I1,7X,
+ &I1,7X,I1,6X,I2)
+ 854 FORMAT(//,16X,'-----> EXPECTED GAIN FOR THE GLOBAL LEVEL : ',F5.
+ &2,//)
+ 855 FORMAT(///,18X,'-----> EXPECTED GAIN FOR THE BASIS LEVEL : ',F5.
+ &2,//)
+ 880 FORMAT(33X,A3)
+ 881 FORMAT(/,' ---------- THESE OPERATIONS DON''T FORM A','
+ &SYMMETRY GROUP ----------', /' ---------- i. e. THE CLUSTER
+ &IS NOT CORRECTLY',' TRUNCATED ----------',/,' ----------
+ & FROM THE POINT OF VIEW OF ','SYMMETRY ----------')
+ 886 FORMAT(///,25X,'CLUSTER SYMMETRY GROUP :',/,33X,A4)
+ 887 FORMAT(///,10X,'SYMMETRY OPERATIONS ASSOCIATED WITH THE ',
+ &'EQUIVALENT ATOMS : ',//,2X,'CLASS',2X,'ATOM',2X,' No ',3X,
+ &'SYMMETRY',3X,'Z**L',8X,'Z**M',13X,'Z**M''',7X,'DELTA',/)
+ 888 FORMAT(///,20X,'CONTENTS OF THE SYMMETRIZED CLUSTER',/,18X,'BY
+ &INCREASING DISTANCE TO THE ABSORBER :',//,11X,'No',13X,'(X,Y,Z)',
+ &11X,'CLASS',1X,'ATOM',1X,'ChSp',4X,'DIST',//)
+ 889 FORMAT(///,10X,'SYMMETRY OPERATIONS LEAVING THE PROTOTYPICAL ',
+ &'ATOMS INVARIANT : ',//,27X,'G = 1 -----> atom 0 only',/,27X,
+ &'G = 2 -----> atom along 0z',/,27X,'G = 3 -----> atom within
+ &x0y',/,27X,'G = 4 -----> other atom',//,19X,'ST : total number
+ &of symmetries leaving',/,29X,'the prototypical atom invariant',//
+ &,19X,'SE : number of symmetries taken into account',/,29X,'(
+ &Euler angle BETA = 0 or pi)',//,2X,'CLASS',2X,' No ',11X,'(X,Y,Z)
+ &',10X,'G',3X,'ST',1X,'SE',1X,'GROUP',7X,'SE SYMMETRIES',/)
+ 896 FORMAT(///,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE ATOMS',
+ &' >>>>>>>>>>',/,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' ARE
+ &IDENTICAL >>>>>>>>>>')
+ 897 FORMAT(///,11X,'<<<<<<<<<< NATP_M TOO SMALL IN THE INCLUDE ',
+ &'FILE >>>>>>>>>>',/,11X,'<<<<<<<<<< SHOULD BE',' AT
+ &LEAST ',I4,' >>>>>>>>>>')
+ 898 FORMAT(///,12X,'<<<<<<<<<< NAT_EQ_M TOO SMALL IN THE INCLUDE','
+ &FILE >>>>>>>>>>',/,12X,'<<<<<<<<<< SHOULD BE AT LEAST ',I4,'
+ &>>>>>>>>>>')
+ 997 FORMAT(///,'<<<<<<<<<< ',I2,' SYMMETRIES HAVE BEEN FOUND. THIS
+ &','>>>>>>>>>>',/,'<<<<<<<<<< EXCEEDS THE SIZE OF THE ','LARGEST
+ &POINT-GROUP >>>>>>>>>>')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/common_sub/uj_sq.f b/src/msspec/spec/fortran/common_sub/uj_sq.f
new file mode 100644
index 0000000..fbdafb1
--- /dev/null
+++ b/src/msspec/spec/fortran/common_sub/uj_sq.f
@@ -0,0 +1,79 @@
+C
+C=======================================================================
+C
+ FUNCTION UJ_SQ(JTYP)
+C
+C This routine evaluates the mean square displacements UJ_SQ,
+C first along une direction (x, y or z): UJ2 within the Debye model,
+C using the Debye function formulation
+C
+C X1 is the Debye function phi_1
+C UJ_SQ is given in unit of the square of the lattice parameter A0
+C Temperatures are expressed in Kelvin
+C
+C The coefficient COEF equals:
+C
+C 3 hbar^{2} N_A 10^{3} / (4 k_B)
+C
+C where N_A is the Avogadro number, k_B is Boltzmann's constant
+C and 10^3 arises from the fact that the atomic mass is
+C expressed in grams
+C
+C Then UJ_SQ is obtained as UJ_SQ = (2 + RSJ) UJJ for surface atoms
+C UJ_SQ = 3 UJJ for bulk atoms
+C
+C
+C For empty spheres, two possibilities are provided. By construction,
+C they are very light (their mass is taken as 1/1836 of the mass
+C of a H atom) and so they will vibrate a lot (IDCM = 1). When
+C setting IDCM = 2, their mean square displacement is set to a
+C tiny value so that they hardly vibrate (frozen empty spheres)
+C
+C Last modified : 31 Jan 2017
+C
+ USE DIM_MOD
+C
+ USE DEBWAL_MOD , T => TEMP
+ USE MASSAT_MOD , XM => XMT
+ USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT
+ &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT
+ USE VIBRAT_MOD
+C
+ REAL MJ
+C
+C
+C
+ DATA COEF /36.381551/ ! 3 hbar^{2} / (4 k_B) for MJ in grams
+ DATA RZ2 /1.644934/ ! Pi^2 / 6
+ DATA LITTLE /0.01/ ! lowest temperature for calculation of phi_1
+C
+ N_MAX=20
+C
+C Computation of the 1D mean square displacement UJ2
+C
+ A=TD/T
+ MJ=XM(JTYP)
+ C=COEF/(MJ*TD)
+C
+ X1=0.
+ IF(T.GT.LITTLE) THEN
+ DO N=1,N_MAX
+ Z=FLOAT(N)
+ X1=X1+EXP(-Z*A)*(A+1./Z)/Z
+ ENDDO
+ ENDIF
+C
+ P1=1.+4.*(RZ2-X1)/(A*A)
+ UJJ=C*P1/(A0*A0)
+C
+C 3D mean square displacement UJ_SQ
+C
+ IF(IDCM.EQ.1) THEN
+ UJ_SQ=(3.+FLOAT(I_FREE(JTYP))*(RSJ-1.))*UJJ
+ ELSEIF(IDCM.EQ.2) THEN
+ UJ_SQ=1.0E-20
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/common/dwsph.f b/src/msspec/spec/fortran/eig/common/dwsph.f
new file mode 100644
index 0000000..468fec1
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/common/dwsph.f
@@ -0,0 +1,85 @@
+C
+C=======================================================================
+C
+ SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
+C
+C This routine recomputes the T-matrix elements taking into account the
+C mean square displacements.
+C
+C When the argument X is tiny, no vibrations are taken into account
+C
+C Last modified : 25 Apr 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE TRANS_MOD
+C
+ DIMENSION GNT(0:N_GAUNT)
+C
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC
+C
+ COMPLEX*16 FFL(0:2*NL_M)
+C
+ DATA PI4,EPS /12.566371,1.0E-10/
+C
+ ZEROC=(0.,0.)
+C
+ IF(X.GT.EPS) THEN
+C
+C Standard case: vibrations
+C
+ IF(ISPEED.LT.0) THEN
+ NSUM_LB=ABS(ISPEED)
+ ENDIF
+C
+ COEF=PI4*EXP(-X)
+ NL2=2*LMAX(JTYP,JE)+2
+ IBESP=5
+ MG1=0
+ MG2=0
+C
+ CALL BESPHE(NL2,IBESP,X,FFL)
+C
+ DO L=0,LMAX(JTYP,JE)
+ XL=FLOAT(L+L+1)
+ SL1=ZEROC
+C
+ DO L1=0,LMAX(JTYP,JE)
+ XL1=FLOAT(L1+L1+1)
+ CALL GAUNT(L,MG1,L1,MG2,GNT)
+ L2MIN=ABS(L1-L)
+ IF(ISPEED.GE.0) THEN
+ L2MAX=L1+L
+ ELSEIF(ISPEED.LT.0) THEN
+ L2MAX=L2MIN+2*(NSUM_LB-1)
+ ENDIF
+ SL2=0.
+C
+ DO L2=L2MIN,L2MAX,2
+ XL2=FLOAT(L2+L2+1)
+ C=SQRT(XL1*XL2/(PI4*XL))
+ SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2)))
+ ENDDO
+C
+ SL1=SL1+SL2*TL(L1,1,JTYP,JE)
+ ENDDO
+C
+ TLT(L,1,JTYP,JE)=COEF*SL1
+C
+ ENDDO
+C
+ ELSE
+C
+C Argument X tiny: no vibrations
+C
+ DO L=0,LMAX(JTYP,JE)
+C
+ TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE)
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/common/eig_mat_ms.f b/src/msspec/spec/fortran/eig/common/eig_mat_ms.f
new file mode 100644
index 0000000..7a7a091
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/common/eig_mat_ms.f
@@ -0,0 +1,261 @@
+C
+C=======================================================================
+C
+ SUBROUTINE EIG_MAT_MS(JE,E_KIN)
+C
+C This subroutine stores the G_o T kernel matrix and computes
+C its eigenvalues to check the larger ones. If one or more
+C of these eigenvalues are larger than or equal to 1, no
+C series expansion can converge
+C
+C Last modified : 20 Jul 2009
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE COOR_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE TRANS_MOD
+C
+C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD
+C
+ CHARACTER*24 OUTFILE,PATH
+C
+ COMPLEX*16 HL1(0:NLTWO),SM(LINMAX*NATCLU_M,LINMAX*NATCLU_M)
+ COMPLEX*16 SUM_L,IC,ZEROC,WORK(32*LINMAX*NATCLU_M)
+ COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO),TLK,EXPKJ
+ COMPLEX*16 W(LINMAX*NATCLU_M)
+ COMPLEX*16 VL(1,1),VR(1,1)
+C
+ DOUBLE PRECISION RWORK(2*LINMAX*NATCLU_M)
+C
+ REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
+C
+ REAL W1(LINMAX*NATCLU_M),W2(LINMAX*NATCLU_M)
+C
+ DATA PI,SMALL /3.1415926535898D0,0.0001/
+C
+ IC=(0.D0,1.D0)
+ ZEROC=(0.D0,0.D0)
+ IBESS=3
+ NPRINT=10
+C
+ WRITE(IUO1,5)
+ IF(JE.EQ.1) THEN
+C
+C Name of the second output file where all the eigenvalues
+C will be written
+C
+ IOUT2=55
+ IOUT3=60
+ N_DOT=1
+ DO J_CHAR=1,24
+ IF(OUTFILE2(J_CHAR:J_CHAR).EQ.'.') GOTO 888
+ N_DOT=N_DOT+1
+ ENDDO
+ 888 CONTINUE
+ OUTFILE=OUTFILE2(1:N_DOT)//'egv'
+ PATH=OUTFILE2(1:N_DOT)//'pth'
+ OPEN(UNIT=IOUT2, FILE=OUTFILE, STATUS='UNKNOWN')
+ OPEN(UNIT=IOUT3, FILE=PATH, STATUS='UNKNOWN')
+ ENDIF
+C
+C Construction of the multiple scattering kernel matrix G_o T.
+C Elements are stored using a linear index LINJ
+C representing (J,LJ)
+C
+ JLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ XJ=SYM_AT(1,JATL)
+ YJ=SYM_AT(2,JATL)
+ ZJ=SYM_AT(3,JATL)
+C
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ JLIN=JLIN+1
+C
+ KLIN=0
+ DO KTYP=1,N_PROT
+ NBTYPK=NATYP(KTYP)
+ LMK=LMAX(KTYP,JE)
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.NE.JATL) THEN
+ XKJ=DBLE(SYM_AT(1,KATL)-XJ)
+ YKJ=DBLE(SYM_AT(2,KATL)-YJ)
+ ZKJ=DBLE(SYM_AT(3,KATL)-ZJ)
+ RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
+ KRKJ=DBLE(VK(JE))*RKJ
+ ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*
+ & RKJ)
+ EXPKJ=(XKJ+IC*YKJ)/RKJ
+ ZDKJ=ZKJ/RKJ
+ CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,
+ & LMJ+LMK)
+ CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,
+ & HL1)
+ ENDIF
+C
+ DO LK=0,LMK
+ L_MIN=ABS(LK-LJ)
+ L_MAX=LK+LJ
+ TLK=DCMPLX(TL(LK,1,KTYP,JE))
+ DO MK=-LK,LK
+ KLIN=KLIN+1
+ SM(KLIN,JLIN)=ZEROC
+ SUM_L=ZEROC
+ IF(KATL.NE.JATL) THEN
+ CALL GAUNT2(LK,MK,LJ,MJ,GNT)
+C
+ DO L=L_MIN,L_MAX,2
+ M=MJ-MK
+ IF(ABS(M).LE.L) THEN
+ SUM_L=SUM_L+(IC**L)*
+ & HL1(L)*YLM(L,M)*GNT(L)
+ ENDIF
+ ENDDO
+ SUM_L=SUM_L*ATTKJ*4.D0*PI*IC
+ ELSE
+ SUM_L=ZEROC
+ ENDIF
+C
+ SM(KLIN,JLIN)=TLK*SUM_L
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ N_DIM=LINMAX*NATCLU_M
+C
+C Eigenvalues of the kernel multiple scattering matrix SM
+C
+ CALL ZGEEV('N','N',JLIN,SM,N_DIM,W,VL,1,VR,1,WORK,34*N_DIM,RWORK,
+ &INFO)
+ IF(INFO.NE.0) THEN
+ WRITE(IUO1,*) ' '
+ WRITE(IUO1,*) ' ---> WORK(1),INFO =',WORK(1),INFO
+ WRITE(IUO1,*) ' '
+ ENDIF
+C
+ N_EIG=0
+C
+ WRITE(IOUT2,75)
+ WRITE(IOUT2,110)
+ WRITE(IOUT2,80) E_KIN
+ WRITE(IOUT2,110)
+ WRITE(IOUT2,75)
+ WRITE(IOUT2,105)
+ WRITE(IOUT2,75)
+ XMAX_L=0.
+ N_XMAX=0
+C
+ DO LIN=1,JLIN
+ EIG=REAL(CDABS(W(LIN)))
+ WRITE(IOUT2,100) REAL(DBLE(W(LIN))),REAL(DIMAG(W(LIN))),EIG
+ IF((EIG-XMAX_L).GT.0.0001) N_XMAX=LIN
+ XMAX_L=MAX(XMAX_L,EIG)
+ W1(LIN)=EIG
+ IF(EIG.GT.1.000) THEN
+ N_EIG=N_EIG+1
+ ENDIF
+ ENDDO
+C
+ WRITE(IOUT2,75)
+ WRITE(IOUT2,85) XMAX_L
+ WRITE(IOUT2,90) N_XMAX
+ WRITE(IOUT2,95) W(N_XMAX)
+ WRITE(IOUT2,75)
+C
+ CALL ORDRE(JLIN,W1,NFIN,W2)
+C
+C
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,15) W2(1)
+ WRITE(IUO1,20) W2(NFIN)
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ IF(N_EIG.GE.1) THEN
+ IF(N_EIG.EQ.1) THEN
+ WRITE(IUO1,25) JLIN
+ ELSE
+ WRITE(IUO1,30) N_EIG,JLIN
+ ENDIF
+ ENDIF
+C
+ WRITE(IUO1,65) N_XMAX
+ WRITE(IUO1,70) W(N_XMAX)
+ WRITE(IUO1,10)
+ WRITE(IOUT3,100) REAL(DBLE(W(N_XMAX))),REAL(DIMAG(W(N_XMAX)))
+C
+ NPR=NPRINT/5
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,35) 5*NPR
+ WRITE(IUO1,10)
+C
+ DO JP=0,NPR-1
+ J=5*JP
+ WRITE(IUO1,40) W2(J+1),W2(J+2),W2(J+3),W2(J+4),W2(J+5)
+ ENDDO
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,45) W2(1)
+ WRITE(IUO2,*) E_KIN,W2(1)
+ IF(N_EIG.EQ.0) THEN
+ WRITE(IUO1,50)
+ ELSE
+ WRITE(IUO1,55)
+ ENDIF
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,60)
+C
+ RETURN
+C
+ 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','---------
+ &--------')
+ 10 FORMAT(11X,'-',54X,'-')
+ 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-')
+ 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-')
+ 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-')
+ 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X,
+ &'-')
+ 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-')
+ 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-')
+ 45 FORMAT(11X,'-',5X,'SPECTRAL RADIUS OF THE KERNEL MATRIX :',F6.3,
+ &5X,'-')
+ 50 FORMAT(11X,'-',5X,'---> THE MULTIPLE SCATTERING SERIES ',
+ &'CONVERGES',4X,'-')
+ 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/
+ &,11X,'-',18X,'SCATTERING SERIES',19X,'-')
+ 60 FORMAT(11X,'----------------------------------------','----------
+ &------',/)
+ 65 FORMAT(11X,'-',5X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,'-
+ &')
+ 70 FORMAT(11X,'-',5X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.3,
+ &')',8X,'-')
+ 75 FORMAT(' ')
+ 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV')
+ 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3)
+ 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5)
+ 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,')
+ &')
+ 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3)
+ 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :')
+ 110 FORMAT(2X,'-------------------------------')
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/common/facdif1.f b/src/msspec/spec/fortran/eig/common/facdif1.f
new file mode 100644
index 0000000..3254b80
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/common/facdif1.f
@@ -0,0 +1,116 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,
+ &JE,*)
+C
+C This routine computes a spherical wave scattering factor
+C
+C Last modified : 03/04/2006
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE APPROX_MOD
+ USE EXPFAC_MOD
+ USE TRANS_MOD
+ USE TYPCAL_MOD, I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD,
+ &I6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
+
+ DIMENSION PLMM(0:100,0:100)
+ DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
+C
+ COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
+ COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
+ COMPLEX RHOJK
+C
+C
+ DATA PI/3.141593/
+C
+ A=1.
+ INTER=0
+ IF(ITL.EQ.1) VKE=VK(JE)
+ RHOJ=VKE*RJ
+ RHOJK=VKE*RJK
+ HLM1=(1.,0.)
+ HLM2=(1.,0.)
+ HLM3=(1.,0.)
+ HLM4=(1.,0.)
+ IEM=1
+ CSTH=COS(BETA)
+ IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN
+ INTER=1
+ BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI))
+ ENDIF
+ CALL PLM(CSTH,PLMM,LMAX(JAT,JE))
+ IF(ISPHER.EQ.0) NO1=0
+ IF(ISPHER.EQ.1) THEN
+ IF(NO.EQ.8) THEN
+ NO1=LMAX(JAT,JE)+1
+ ELSE
+ NO1=NO
+ ENDIF
+ CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM)
+ IF(IEM.EQ.0) THEN
+ HLM4=HLM(0,L)
+ ENDIF
+ IF(RJK.GT.0.0001) THEN
+ NDUM=0
+ CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN)
+ ENDIF
+ CALL DJMN(THRJ,D,L)
+ A1=ABS(D(0,M,L))
+ IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0))
+ & RETURN 1
+ ENDIF
+ MUMAX=MIN0(L,NO1)
+ SMU=(0.,0.)
+ DO 10 MU=0,MUMAX
+ IF(MOD(MU,2).EQ.0) THEN
+ B=1.
+ ELSE
+ B=-1.
+ IF(SIN(BETA).LT.0.) THEN
+ A=-1.
+ ENDIF
+ ENDIF
+ IF(ISPHER.LE.1) THEN
+ ALMU=(1.,0.)
+ C=1.
+ ENDIF
+ IF(ISPHER.EQ.0) GOTO 40
+ IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L))
+ IF(MU.GT.0) THEN
+ C=B*FLOAT(L+L+1)/EXPF(MU,L)
+ ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B*
+ * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU
+ ELSE
+ C=1.
+ ALMU=CMPLX(D(M,0,L))/BLMU
+ ENDIF
+ 40 SNU=(0.,0.)
+ NU1=INT(0.5*(NO1-MU)+0.0001)
+ NUMAX=MIN0(NU1,L-MU)
+ DO 20 NU=0,NUMAX
+ SLP=(0.,0.)
+ LPMIN=MAX0(MU,NU)
+ DO 30 LP=LPMIN,LMAX(JAT,JE)
+ IF(ISPHER.EQ.1) THEN
+ HLM1=HLM(NU,LP)
+ IF(RJK.GT.0.0001) HLM3=HLN(0,LP)
+ ENDIF
+ SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,
+ & MU)*HLM3
+ 30 CONTINUE
+ IF(ISPHER.EQ.1) THEN
+ HLM2=HLM(MU+NU,L)
+ ENDIF
+ SNU=SNU+SLP*HLM2
+ 20 CONTINUE
+ SMU=SMU+SNU*C*ALMU*A*B
+ 10 CONTINUE
+ FSPH=SMU/(VKE*HLM4)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/common/lapack_eig.f b/src/msspec/spec/fortran/eig/common/lapack_eig.f
new file mode 100644
index 0000000..c90c8fa
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/common/lapack_eig.f
@@ -0,0 +1,21492 @@
+C
+C=======================================================================
+C
+C LAPACK eigenvalue subroutines
+C
+C=======================================================================
+C
+C (version 3.8.0) Jul 2018
+C
+C=======================================================================
+C
+*> \brief ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGEEV + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
+* WORK, LWORK, RWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBVL, JOBVR
+* INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+* $ W( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
+*> eigenvalues and, optionally, the left and/or right eigenvectors.
+*>
+*> The right eigenvector v(j) of A satisfies
+*> A * v(j) = lambda(j) * v(j)
+*> where lambda(j) is its eigenvalue.
+*> The left eigenvector u(j) of A satisfies
+*> u(j)**H * A = lambda(j) * u(j)**H
+*> where u(j)**H denotes the conjugate transpose of u(j).
+*>
+*> The computed eigenvectors are normalized to have Euclidean norm
+*> equal to 1 and largest component real.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBVL
+*> \verbatim
+*> JOBVL is CHARACTER*1
+*> = 'N': left eigenvectors of A are not computed;
+*> = 'V': left eigenvectors of are computed.
+*> \endverbatim
+*>
+*> \param[in] JOBVR
+*> \verbatim
+*> JOBVR is CHARACTER*1
+*> = 'N': right eigenvectors of A are not computed;
+*> = 'V': right eigenvectors of A are computed.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the N-by-N matrix A.
+*> On exit, A has been overwritten.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (N)
+*> W contains the computed eigenvalues.
+*> \endverbatim
+*>
+*> \param[out] VL
+*> \verbatim
+*> VL is COMPLEX*16 array, dimension (LDVL,N)
+*> If JOBVL = 'V', the left eigenvectors u(j) are stored one
+*> after another in the columns of VL, in the same order
+*> as their eigenvalues.
+*> If JOBVL = 'N', VL is not referenced.
+*> u(j) = VL(:,j), the j-th column of VL.
+*> \endverbatim
+*>
+*> \param[in] LDVL
+*> \verbatim
+*> LDVL is INTEGER
+*> The leading dimension of the array VL. LDVL >= 1; if
+*> JOBVL = 'V', LDVL >= N.
+*> \endverbatim
+*>
+*> \param[out] VR
+*> \verbatim
+*> VR is COMPLEX*16 array, dimension (LDVR,N)
+*> If JOBVR = 'V', the right eigenvectors v(j) are stored one
+*> after another in the columns of VR, in the same order
+*> as their eigenvalues.
+*> If JOBVR = 'N', VR is not referenced.
+*> v(j) = VR(:,j), the j-th column of VR.
+*> \endverbatim
+*>
+*> \param[in] LDVR
+*> \verbatim
+*> LDVR is INTEGER
+*> The leading dimension of the array VR. LDVR >= 1; if
+*> JOBVR = 'V', LDVR >= N.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= max(1,2*N).
+*> For good performance, LWORK must generally be larger.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: if INFO = i, the QR algorithm failed to compute all the
+*> eigenvalues, and no eigenvectors have been computed;
+*> elements and i+1:N of W contain eigenvalues which have
+*> converged.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2016
+*
+* @precisions fortran z -> c
+*
+*> \ingroup complex16GEeigen
+*
+* =====================================================================
+ SUBROUTINE zgeev( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
+ $ WORK, LWORK, RWORK, INFO )
+ implicit none
+*
+* -- LAPACK driver routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVL, JOBVR
+ INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( lda, * ), VL( ldvl, * ), VR( ldvr, * ),
+ $ w( * ), work( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ parameter( zero = 0.0d0, one = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
+ CHARACTER SIDE
+ INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
+ $ iwrk, k, lwork_trevc, maxwrk, minwrk, nout
+ DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
+ COMPLEX*16 TMP
+* ..
+* .. Local Arrays ..
+ LOGICAL SELECT( 1 )
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL dlabad, xerbla, zdscal, zgebak, zgebal, zgehrd,
+ $ zhseqr, zlacpy, zlascl, zscal, ztrevc3, zunghr
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX, ILAENV
+ DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE
+ EXTERNAL lsame, idamax, ilaenv, dlamch, dznrm2, zlange
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dble, dcmplx, conjg, aimag, max, sqrt
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+ lquery = ( lwork.EQ.-1 )
+ wantvl = lsame( jobvl, 'V' )
+ wantvr = lsame( jobvr, 'V' )
+ IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl, 'N' ) ) ) THEN
+ info = -1
+ ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr, 'N' ) ) ) THEN
+ info = -2
+ ELSE IF( n.LT.0 ) THEN
+ info = -3
+ ELSE IF( lda.LT.max( 1, n ) ) THEN
+ info = -5
+ ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) ) THEN
+ info = -8
+ ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) ) THEN
+ info = -10
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* CWorkspace refers to complex workspace, and RWorkspace to real
+* workspace. NB refers to the optimal block size for the
+* immediately following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by ZHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.)
+*
+ IF( info.EQ.0 ) THEN
+ IF( n.EQ.0 ) THEN
+ minwrk = 1
+ maxwrk = 1
+ ELSE
+ maxwrk = n + n*ilaenv( 1, 'ZGEHRD', ' ', n, 1, n, 0 )
+ minwrk = 2*n
+ IF( wantvl ) THEN
+ maxwrk = max( maxwrk, n + ( n - 1 )*ilaenv( 1, 'ZUNGHR',
+ $ ' ', n, 1, n, -1 ) )
+ CALL ztrevc3( 'L', 'B', SELECT, n, a, lda,
+ $ vl, ldvl, vr, ldvr,
+ $ n, nout, work, -1, rwork, -1, ierr )
+ lwork_trevc = int( work(1) )
+ maxwrk = max( maxwrk, n + lwork_trevc )
+ CALL zhseqr( 'S', 'V', n, 1, n, a, lda, w, vl, ldvl,
+ $ work, -1, info )
+ ELSE IF( wantvr ) THEN
+ maxwrk = max( maxwrk, n + ( n - 1 )*ilaenv( 1, 'ZUNGHR',
+ $ ' ', n, 1, n, -1 ) )
+ CALL ztrevc3( 'R', 'B', SELECT, n, a, lda,
+ $ vl, ldvl, vr, ldvr,
+ $ n, nout, work, -1, rwork, -1, ierr )
+ lwork_trevc = int( work(1) )
+ maxwrk = max( maxwrk, n + lwork_trevc )
+ CALL zhseqr( 'S', 'V', n, 1, n, a, lda, w, vr, ldvr,
+ $ work, -1, info )
+ ELSE
+ CALL zhseqr( 'E', 'N', n, 1, n, a, lda, w, vr, ldvr,
+ $ work, -1, info )
+ END IF
+ hswork = int( work(1) )
+ maxwrk = max( maxwrk, hswork, minwrk )
+ END IF
+ work( 1 ) = maxwrk
+*
+ IF( lwork.LT.minwrk .AND. .NOT.lquery ) THEN
+ info = -12
+ END IF
+ END IF
+*
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZGEEV ', -info )
+ RETURN
+ ELSE IF( lquery ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ eps = dlamch( 'P' )
+ smlnum = dlamch( 'S' )
+ bignum = one / smlnum
+ CALL dlabad( smlnum, bignum )
+ smlnum = sqrt( smlnum ) / eps
+ bignum = one / smlnum
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ anrm = zlange( 'M', n, n, a, lda, dum )
+ scalea = .false.
+ IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
+ scalea = .true.
+ cscale = smlnum
+ ELSE IF( anrm.GT.bignum ) THEN
+ scalea = .true.
+ cscale = bignum
+ END IF
+ IF( scalea )
+ $ CALL zlascl( 'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
+*
+* Balance the matrix
+* (CWorkspace: none)
+* (RWorkspace: need N)
+*
+ ibal = 1
+ CALL zgebal( 'B', n, a, lda, ilo, ihi, rwork( ibal ), ierr )
+*
+* Reduce to upper Hessenberg form
+* (CWorkspace: need 2*N, prefer N+N*NB)
+* (RWorkspace: none)
+*
+ itau = 1
+ iwrk = itau + n
+ CALL zgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
+ $ lwork-iwrk+1, ierr )
+*
+ IF( wantvl ) THEN
+*
+* Want left eigenvectors
+* Copy Householder vectors to VL
+*
+ side = 'L'
+ CALL zlacpy( 'L', n, n, a, lda, vl, ldvl )
+*
+* Generate unitary matrix in VL
+* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
+* (RWorkspace: none)
+*
+ CALL zunghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
+ $ lwork-iwrk+1, ierr )
+*
+* Perform QR iteration, accumulating Schur vectors in VL
+* (CWorkspace: need 1, prefer HSWORK (see comments) )
+* (RWorkspace: none)
+*
+ iwrk = itau
+ CALL zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vl, ldvl,
+ $ work( iwrk ), lwork-iwrk+1, info )
+*
+ IF( wantvr ) THEN
+*
+* Want left and right eigenvectors
+* Copy Schur vectors to VR
+*
+ side = 'B'
+ CALL zlacpy( 'F', n, n, vl, ldvl, vr, ldvr )
+ END IF
+*
+ ELSE IF( wantvr ) THEN
+*
+* Want right eigenvectors
+* Copy Householder vectors to VR
+*
+ side = 'R'
+ CALL zlacpy( 'L', n, n, a, lda, vr, ldvr )
+*
+* Generate unitary matrix in VR
+* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
+* (RWorkspace: none)
+*
+ CALL zunghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
+ $ lwork-iwrk+1, ierr )
+*
+* Perform QR iteration, accumulating Schur vectors in VR
+* (CWorkspace: need 1, prefer HSWORK (see comments) )
+* (RWorkspace: none)
+*
+ iwrk = itau
+ CALL zhseqr( 'S', 'V', n, ilo, ihi, a, lda, w, vr, ldvr,
+ $ work( iwrk ), lwork-iwrk+1, info )
+*
+ ELSE
+*
+* Compute eigenvalues only
+* (CWorkspace: need 1, prefer HSWORK (see comments) )
+* (RWorkspace: none)
+*
+ iwrk = itau
+ CALL zhseqr( 'E', 'N', n, ilo, ihi, a, lda, w, vr, ldvr,
+ $ work( iwrk ), lwork-iwrk+1, info )
+ END IF
+*
+* If INFO .NE. 0 from ZHSEQR, then quit
+*
+ IF( info.NE.0 )
+ $ GO TO 50
+*
+ IF( wantvl .OR. wantvr ) THEN
+*
+* Compute left and/or right eigenvectors
+* (CWorkspace: need 2*N, prefer N + 2*N*NB)
+* (RWorkspace: need 2*N)
+*
+ irwork = ibal + n
+ CALL ztrevc3( side, 'B', SELECT, n, a, lda, vl, ldvl, vr, ldvr,
+ $ n, nout, work( iwrk ), lwork-iwrk+1,
+ $ rwork( irwork ), n, ierr )
+ END IF
+*
+ IF( wantvl ) THEN
+*
+* Undo balancing of left eigenvectors
+* (CWorkspace: none)
+* (RWorkspace: need N)
+*
+ CALL zgebak( 'B', 'L', n, ilo, ihi, rwork( ibal ), n, vl, ldvl,
+ $ ierr )
+*
+* Normalize left eigenvectors and make largest component real
+*
+ DO 20 i = 1, n
+ scl = one / dznrm2( n, vl( 1, i ), 1 )
+ CALL zdscal( n, scl, vl( 1, i ), 1 )
+ DO 10 k = 1, n
+ rwork( irwork+k-1 ) = dble( vl( k, i ) )**2 +
+ $ aimag( vl( k, i ) )**2
+ 10 CONTINUE
+ k = idamax( n, rwork( irwork ), 1 )
+ tmp = conjg( vl( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
+ CALL zscal( n, tmp, vl( 1, i ), 1 )
+ vl( k, i ) = dcmplx( dble( vl( k, i ) ), zero )
+ 20 CONTINUE
+ END IF
+*
+ IF( wantvr ) THEN
+*
+* Undo balancing of right eigenvectors
+* (CWorkspace: none)
+* (RWorkspace: need N)
+*
+ CALL zgebak( 'B', 'R', n, ilo, ihi, rwork( ibal ), n, vr, ldvr,
+ $ ierr )
+*
+* Normalize right eigenvectors and make largest component real
+*
+ DO 40 i = 1, n
+ scl = one / dznrm2( n, vr( 1, i ), 1 )
+ CALL zdscal( n, scl, vr( 1, i ), 1 )
+ DO 30 k = 1, n
+ rwork( irwork+k-1 ) = dble( vr( k, i ) )**2 +
+ $ aimag( vr( k, i ) )**2
+ 30 CONTINUE
+ k = idamax( n, rwork( irwork ), 1 )
+ tmp = conjg( vr( k, i ) ) / sqrt( rwork( irwork+k-1 ) )
+ CALL zscal( n, tmp, vr( 1, i ), 1 )
+ vr( k, i ) = dcmplx( dble( vr( k, i ) ), zero )
+ 40 CONTINUE
+ END IF
+*
+* Undo scaling if necessary
+*
+ 50 CONTINUE
+ IF( scalea ) THEN
+ CALL zlascl( 'G', 0, 0, cscale, anrm, n-info, 1, w( info+1 ),
+ $ max( n-info, 1 ), ierr )
+ IF( info.GT.0 ) THEN
+ CALL zlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr )
+ END IF
+ END IF
+*
+ work( 1 ) = maxwrk
+ RETURN
+*
+* End of ZGEEV
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b IEEECK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download IEEECK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
+*
+* .. Scalar Arguments ..
+* INTEGER ISPEC
+* REAL ONE, ZERO
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> IEEECK is called from the ILAENV to verify that Infinity and
+*> possibly NaN arithmetic is safe (i.e. will not trap).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] ISPEC
+*> \verbatim
+*> ISPEC is INTEGER
+*> Specifies whether to test just for inifinity arithmetic
+*> or whether to test for infinity and NaN arithmetic.
+*> = 0: Verify infinity arithmetic only.
+*> = 1: Verify infinity and NaN arithmetic.
+*> \endverbatim
+*>
+*> \param[in] ZERO
+*> \verbatim
+*> ZERO is REAL
+*> Must contain the value 0.0
+*> This is passed to prevent the compiler from optimizing
+*> away this code.
+*> \endverbatim
+*>
+*> \param[in] ONE
+*> \verbatim
+*> ONE is REAL
+*> Must contain the value 1.0
+*> This is passed to prevent the compiler from optimizing
+*> away this code.
+*>
+*> RETURN VALUE: INTEGER
+*> = 0: Arithmetic failed to produce the correct answers
+*> = 1: Arithmetic produced the correct answers
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup OTHERauxiliary
+*
+* =====================================================================
+ INTEGER FUNCTION ieeeck( ISPEC, ZERO, ONE )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER ISPEC
+ REAL ONE, ZERO
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
+ $ negzro, newzro, posinf
+* ..
+* .. Executable Statements ..
+ ieeeck = 1
+*
+ posinf = one / zero
+ IF( posinf.LE.one ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ neginf = -one / zero
+ IF( neginf.GE.zero ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ negzro = one / ( neginf+one )
+ IF( negzro.NE.zero ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ neginf = one / negzro
+ IF( neginf.GE.zero ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ newzro = negzro + zero
+ IF( newzro.NE.zero ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ posinf = one / newzro
+ IF( posinf.LE.one ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ neginf = neginf*posinf
+ IF( neginf.GE.zero ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ posinf = posinf*posinf
+ IF( posinf.LE.one ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+*
+*
+*
+* Return if we were only asked to check infinity arithmetic
+*
+ IF( ispec.EQ.0 )
+ $ RETURN
+*
+ nan1 = posinf + neginf
+*
+ nan2 = posinf / neginf
+*
+ nan3 = posinf / posinf
+*
+ nan4 = posinf*zero
+*
+ nan5 = neginf*negzro
+*
+ nan6 = nan5*zero
+*
+ IF( nan1.EQ.nan1 ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ IF( nan2.EQ.nan2 ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ IF( nan3.EQ.nan3 ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ IF( nan4.EQ.nan4 ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ IF( nan5.EQ.nan5 ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ IF( nan6.EQ.nan6 ) THEN
+ ieeeck = 0
+ RETURN
+ END IF
+*
+ RETURN
+ END
+C
+C======================================================================
+C
+*>v\brief \b ILAENV
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ILAENV + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+*
+* .. Scalar Arguments ..
+* CHARACTER*( * ) NAME, OPTS
+* INTEGER ISPEC, N1, N2, N3, N4
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ILAENV is called from the LAPACK routines to choose problem-dependent
+*> parameters for the local environment. See ISPEC for a description of
+*> the parameters.
+*>
+*> ILAENV returns an INTEGER
+*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
+*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.
+*>
+*> This version provides a set of parameters which should give good,
+*> but not optimal, performance on many of the currently available
+*> computers. Users are encouraged to modify this subroutine to set
+*> the tuning parameters for their particular machine using the option
+*> and problem size information in the arguments.
+*>
+*> This routine will not function correctly if it is converted to all
+*> lower case. Converting it to all upper case is allowed.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] ISPEC
+*> \verbatim
+*> ISPEC is INTEGER
+*> Specifies the parameter to be returned as the value of
+*> ILAENV.
+*> = 1: the optimal blocksize; if this value is 1, an unblocked
+*> algorithm will give the best performance.
+*> = 2: the minimum block size for which the block routine
+*> should be used; if the usable block size is less than
+*> this value, an unblocked routine should be used.
+*> = 3: the crossover point (in a block routine, for N less
+*> than this value, an unblocked routine should be used)
+*> = 4: the number of shifts, used in the nonsymmetric
+*> eigenvalue routines (DEPRECATED)
+*> = 5: the minimum column dimension for blocking to be used;
+*> rectangular blocks must have dimension at least k by m,
+*> where k is given by ILAENV(2,...) and m by ILAENV(5,...)
+*> = 6: the crossover point for the SVD (when reducing an m by n
+*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
+*> this value, a QR factorization is used first to reduce
+*> the matrix to a triangular form.)
+*> = 7: the number of processors
+*> = 8: the crossover point for the multishift QR method
+*> for nonsymmetric eigenvalue problems (DEPRECATED)
+*> = 9: maximum size of the subproblems at the bottom of the
+*> computation tree in the divide-and-conquer algorithm
+*> (used by xGELSD and xGESDD)
+*> =10: ieee NaN arithmetic can be trusted not to trap
+*> =11: infinity arithmetic can be trusted not to trap
+*> 12 <= ISPEC <= 16:
+*> xHSEQR or related subroutines,
+*> see IPARMQ for detailed explanation
+*> \endverbatim
+*>
+*> \param[in] NAME
+*> \verbatim
+*> NAME is CHARACTER*(*)
+*> The name of the calling subroutine, in either upper case or
+*> lower case.
+*> \endverbatim
+*>
+*> \param[in] OPTS
+*> \verbatim
+*> OPTS is CHARACTER*(*)
+*> The character options to the subroutine NAME, concatenated
+*> into a single character string. For example, UPLO = 'U',
+*> TRANS = 'T', and DIAG = 'N' for a triangular routine would
+*> be specified as OPTS = 'UTN'.
+*> \endverbatim
+*>
+*> \param[in] N1
+*> \verbatim
+*> N1 is INTEGER
+*> \endverbatim
+*>
+*> \param[in] N2
+*> \verbatim
+*> N2 is INTEGER
+*> \endverbatim
+*>
+*> \param[in] N3
+*> \verbatim
+*> N3 is INTEGER
+*> \endverbatim
+*>
+*> \param[in] N4
+*> \verbatim
+*> N4 is INTEGER
+*> Problem dimensions for the subroutine NAME; these may not all
+*> be required.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup OTHERauxiliary
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The following conventions have been used when calling ILAENV from the
+*> LAPACK routines:
+*> 1) OPTS is a concatenation of all of the character options to
+*> subroutine NAME, in the same order that they appear in the
+*> argument list for NAME, even if they are not used in determining
+*> the value of the parameter specified by ISPEC.
+*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order
+*> that they appear in the argument list for NAME. N1 is used
+*> first, N2 second, and so on, and unused problem dimensions are
+*> passed a value of -1.
+*> 3) The parameter value returned by ILAENV is checked for validity in
+*> the calling subroutine. For example, ILAENV is used to retrieve
+*> the optimal blocksize for STRTRI as follows:
+*>
+*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+*> IF( NB.LE.1 ) NB = MAX( 1, N )
+*> \endverbatim
+*>
+* =====================================================================
+ INTEGER FUNCTION ilaenv( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+*
+* -- LAPACK auxiliary routine (version 3.8.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ CHARACTER*( * ) NAME, OPTS
+ INTEGER ISPEC, N1, N2, N3, N4
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IC, IZ, NB, NBMIN, NX
+ LOGICAL CNAME, SNAME, TWOSTAGE
+ CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC char, ichar, int, min, real
+* ..
+* .. External Functions ..
+ INTEGER IEEECK, IPARMQ, IPARAM2STAGE
+ EXTERNAL ieeeck, iparmq, iparam2stage
+* ..
+* .. Executable Statements ..
+*
+ GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
+ $ 130, 140, 150, 160, 160, 160, 160, 160)ispec
+*
+* Invalid value for ISPEC
+*
+ ilaenv = -1
+ RETURN
+*
+ 10 CONTINUE
+*
+* Convert NAME to upper case if the first character is lower case.
+*
+ ilaenv = 1
+ subnam = name
+ ic = ichar( subnam( 1: 1 ) )
+ iz = ichar( 'Z' )
+ IF( iz.EQ.90 .OR. iz.EQ.122 ) THEN
+*
+* ASCII character set
+*
+ IF( ic.GE.97 .AND. ic.LE.122 ) THEN
+ subnam( 1: 1 ) = char( ic-32 )
+ DO 20 i = 2, 6
+ ic = ichar( subnam( i: i ) )
+ IF( ic.GE.97 .AND. ic.LE.122 )
+ $ subnam( i: i ) = char( ic-32 )
+ 20 CONTINUE
+ END IF
+*
+ ELSE IF( iz.EQ.233 .OR. iz.EQ.169 ) THEN
+*
+* EBCDIC character set
+*
+ IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
+ $ ( ic.GE.145 .AND. ic.LE.153 ) .OR.
+ $ ( ic.GE.162 .AND. ic.LE.169 ) ) THEN
+ subnam( 1: 1 ) = char( ic+64 )
+ DO 30 i = 2, 6
+ ic = ichar( subnam( i: i ) )
+ IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
+ $ ( ic.GE.145 .AND. ic.LE.153 ) .OR.
+ $ ( ic.GE.162 .AND. ic.LE.169 ) )subnam( i:
+ $ i ) = char( ic+64 )
+ 30 CONTINUE
+ END IF
+*
+ ELSE IF( iz.EQ.218 .OR. iz.EQ.250 ) THEN
+*
+* Prime machines: ASCII+128
+*
+ IF( ic.GE.225 .AND. ic.LE.250 ) THEN
+ subnam( 1: 1 ) = char( ic-32 )
+ DO 40 i = 2, 6
+ ic = ichar( subnam( i: i ) )
+ IF( ic.GE.225 .AND. ic.LE.250 )
+ $ subnam( i: i ) = char( ic-32 )
+ 40 CONTINUE
+ END IF
+ END IF
+*
+ c1 = subnam( 1: 1 )
+ sname = c1.EQ.'S' .OR. c1.EQ.'D'
+ cname = c1.EQ.'C' .OR. c1.EQ.'Z'
+ IF( .NOT.( cname .OR. sname ) )
+ $ RETURN
+ c2 = subnam( 2: 3 )
+ c3 = subnam( 4: 6 )
+ c4 = c3( 2: 3 )
+ twostage = len( subnam ).GE.11
+ $ .AND. subnam( 11: 11 ).EQ.'2'
+*
+ GO TO ( 50, 60, 70 )ispec
+*
+ 50 CONTINUE
+*
+* ISPEC = 1: block size
+*
+* In these examples, separate code is provided for setting NB for
+* real and complex. We assume that NB will take the same value in
+* single or double precision.
+*
+ nb = 1
+*
+ IF( c2.EQ.'GE' ) THEN
+ IF( c3.EQ.'TRF' ) THEN
+ IF( sname ) THEN
+ nb = 64
+ ELSE
+ nb = 64
+ END IF
+ ELSE IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR.
+ $ c3.EQ.'QLF' ) THEN
+ IF( sname ) THEN
+ nb = 32
+ ELSE
+ nb = 32
+ END IF
+ ELSE IF( c3.EQ.'QR ') THEN
+ IF( n3 .EQ. 1) THEN
+ IF( sname ) THEN
+* M*N
+ IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
+ nb = n1
+ ELSE
+ nb = 32768/n2
+ END IF
+ ELSE
+ IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
+ nb = n1
+ ELSE
+ nb = 32768/n2
+ END IF
+ END IF
+ ELSE
+ IF( sname ) THEN
+ nb = 1
+ ELSE
+ nb = 1
+ END IF
+ END IF
+ ELSE IF( c3.EQ.'LQ ') THEN
+ IF( n3 .EQ. 2) THEN
+ IF( sname ) THEN
+* M*N
+ IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
+ nb = n1
+ ELSE
+ nb = 32768/n2
+ END IF
+ ELSE
+ IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
+ nb = n1
+ ELSE
+ nb = 32768/n2
+ END IF
+ END IF
+ ELSE
+ IF( sname ) THEN
+ nb = 1
+ ELSE
+ nb = 1
+ END IF
+ END IF
+ ELSE IF( c3.EQ.'HRD' ) THEN
+ IF( sname ) THEN
+ nb = 32
+ ELSE
+ nb = 32
+ END IF
+ ELSE IF( c3.EQ.'BRD' ) THEN
+ IF( sname ) THEN
+ nb = 32
+ ELSE
+ nb = 32
+ END IF
+ ELSE IF( c3.EQ.'TRI' ) THEN
+ IF( sname ) THEN
+ nb = 64
+ ELSE
+ nb = 64
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'PO' ) THEN
+ IF( c3.EQ.'TRF' ) THEN
+ IF( sname ) THEN
+ nb = 64
+ ELSE
+ nb = 64
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'SY' ) THEN
+ IF( c3.EQ.'TRF' ) THEN
+ IF( sname ) THEN
+ IF( twostage ) THEN
+ nb = 192
+ ELSE
+ nb = 64
+ END IF
+ ELSE
+ IF( twostage ) THEN
+ nb = 192
+ ELSE
+ nb = 64
+ END IF
+ END IF
+ ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN
+ nb = 32
+ ELSE IF( sname .AND. c3.EQ.'GST' ) THEN
+ nb = 64
+ END IF
+ ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
+ IF( c3.EQ.'TRF' ) THEN
+ IF( twostage ) THEN
+ nb = 192
+ ELSE
+ nb = 64
+ END IF
+ ELSE IF( c3.EQ.'TRD' ) THEN
+ nb = 32
+ ELSE IF( c3.EQ.'GST' ) THEN
+ nb = 64
+ END IF
+ ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
+ IF( c3( 1: 1 ).EQ.'G' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nb = 32
+ END IF
+ ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nb = 32
+ END IF
+ END IF
+ ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
+ IF( c3( 1: 1 ).EQ.'G' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nb = 32
+ END IF
+ ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nb = 32
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'GB' ) THEN
+ IF( c3.EQ.'TRF' ) THEN
+ IF( sname ) THEN
+ IF( n4.LE.64 ) THEN
+ nb = 1
+ ELSE
+ nb = 32
+ END IF
+ ELSE
+ IF( n4.LE.64 ) THEN
+ nb = 1
+ ELSE
+ nb = 32
+ END IF
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'PB' ) THEN
+ IF( c3.EQ.'TRF' ) THEN
+ IF( sname ) THEN
+ IF( n2.LE.64 ) THEN
+ nb = 1
+ ELSE
+ nb = 32
+ END IF
+ ELSE
+ IF( n2.LE.64 ) THEN
+ nb = 1
+ ELSE
+ nb = 32
+ END IF
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'TR' ) THEN
+ IF( c3.EQ.'TRI' ) THEN
+ IF( sname ) THEN
+ nb = 64
+ ELSE
+ nb = 64
+ END IF
+ ELSE IF ( c3.EQ.'EVC' ) THEN
+ IF( sname ) THEN
+ nb = 64
+ ELSE
+ nb = 64
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'LA' ) THEN
+ IF( c3.EQ.'UUM' ) THEN
+ IF( sname ) THEN
+ nb = 64
+ ELSE
+ nb = 64
+ END IF
+ END IF
+ ELSE IF( sname .AND. c2.EQ.'ST' ) THEN
+ IF( c3.EQ.'EBZ' ) THEN
+ nb = 1
+ END IF
+ ELSE IF( c2.EQ.'GG' ) THEN
+ nb = 32
+ IF( c3.EQ.'HD3' ) THEN
+ IF( sname ) THEN
+ nb = 32
+ ELSE
+ nb = 32
+ END IF
+ END IF
+ END IF
+ ilaenv = nb
+ RETURN
+*
+ 60 CONTINUE
+*
+* ISPEC = 2: minimum block size
+*
+ nbmin = 2
+ IF( c2.EQ.'GE' ) THEN
+ IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR. c3.EQ.
+ $ 'QLF' ) THEN
+ IF( sname ) THEN
+ nbmin = 2
+ ELSE
+ nbmin = 2
+ END IF
+ ELSE IF( c3.EQ.'HRD' ) THEN
+ IF( sname ) THEN
+ nbmin = 2
+ ELSE
+ nbmin = 2
+ END IF
+ ELSE IF( c3.EQ.'BRD' ) THEN
+ IF( sname ) THEN
+ nbmin = 2
+ ELSE
+ nbmin = 2
+ END IF
+ ELSE IF( c3.EQ.'TRI' ) THEN
+ IF( sname ) THEN
+ nbmin = 2
+ ELSE
+ nbmin = 2
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'SY' ) THEN
+ IF( c3.EQ.'TRF' ) THEN
+ IF( sname ) THEN
+ nbmin = 8
+ ELSE
+ nbmin = 8
+ END IF
+ ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN
+ nbmin = 2
+ END IF
+ ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
+ IF( c3.EQ.'TRD' ) THEN
+ nbmin = 2
+ END IF
+ ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
+ IF( c3( 1: 1 ).EQ.'G' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nbmin = 2
+ END IF
+ ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nbmin = 2
+ END IF
+ END IF
+ ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
+ IF( c3( 1: 1 ).EQ.'G' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nbmin = 2
+ END IF
+ ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nbmin = 2
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'GG' ) THEN
+ nbmin = 2
+ IF( c3.EQ.'HD3' ) THEN
+ nbmin = 2
+ END IF
+ END IF
+ ilaenv = nbmin
+ RETURN
+*
+ 70 CONTINUE
+*
+* ISPEC = 3: crossover point
+*
+ nx = 0
+ IF( c2.EQ.'GE' ) THEN
+ IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR. c3.EQ.
+ $ 'QLF' ) THEN
+ IF( sname ) THEN
+ nx = 128
+ ELSE
+ nx = 128
+ END IF
+ ELSE IF( c3.EQ.'HRD' ) THEN
+ IF( sname ) THEN
+ nx = 128
+ ELSE
+ nx = 128
+ END IF
+ ELSE IF( c3.EQ.'BRD' ) THEN
+ IF( sname ) THEN
+ nx = 128
+ ELSE
+ nx = 128
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'SY' ) THEN
+ IF( sname .AND. c3.EQ.'TRD' ) THEN
+ nx = 32
+ END IF
+ ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
+ IF( c3.EQ.'TRD' ) THEN
+ nx = 32
+ END IF
+ ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
+ IF( c3( 1: 1 ).EQ.'G' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nx = 128
+ END IF
+ END IF
+ ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
+ IF( c3( 1: 1 ).EQ.'G' ) THEN
+ IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
+ $ 'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
+ $ THEN
+ nx = 128
+ END IF
+ END IF
+ ELSE IF( c2.EQ.'GG' ) THEN
+ nx = 128
+ IF( c3.EQ.'HD3' ) THEN
+ nx = 128
+ END IF
+ END IF
+ ilaenv = nx
+ RETURN
+*
+ 80 CONTINUE
+*
+* ISPEC = 4: number of shifts (used by xHSEQR)
+*
+ ilaenv = 6
+ RETURN
+*
+ 90 CONTINUE
+*
+* ISPEC = 5: minimum column dimension (not used)
+*
+ ilaenv = 2
+ RETURN
+*
+ 100 CONTINUE
+*
+* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
+*
+ ilaenv = int( REAL( MIN( N1, N2 ) )*1.6e0 )
+ RETURN
+*
+ 110 CONTINUE
+*
+* ISPEC = 7: number of processors (not used)
+*
+ ilaenv = 1
+ RETURN
+*
+ 120 CONTINUE
+*
+* ISPEC = 8: crossover point for multishift (used by xHSEQR)
+*
+ ilaenv = 50
+ RETURN
+*
+ 130 CONTINUE
+*
+* ISPEC = 9: maximum size of the subproblems at the bottom of the
+* computation tree in the divide-and-conquer algorithm
+* (used by xGELSD and xGESDD)
+*
+ ilaenv = 25
+ RETURN
+*
+ 140 CONTINUE
+*
+* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
+*
+* ILAENV = 0
+ ilaenv = 1
+ IF( ilaenv.EQ.1 ) THEN
+ ilaenv = ieeeck( 1, 0.0, 1.0 )
+ END IF
+ RETURN
+*
+ 150 CONTINUE
+*
+* ISPEC = 11: infinity arithmetic can be trusted not to trap
+*
+* ILAENV = 0
+ ilaenv = 1
+ IF( ilaenv.EQ.1 ) THEN
+ ilaenv = ieeeck( 0, 0.0, 1.0 )
+ END IF
+ RETURN
+*
+ 160 CONTINUE
+*
+* 12 <= ISPEC <= 16: xHSEQR or related subroutines.
+*
+ ilaenv = iparmq( ispec, name, opts, n1, n2, n3, n4 )
+ RETURN
+*
+* End of ILAENV
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b LSAME
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* LOGICAL FUNCTION LSAME(CA,CB)
+*
+* .. Scalar Arguments ..
+* CHARACTER CA,CB
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> LSAME returns .TRUE. if CA is the same letter as CB regardless of
+*> case.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] CA
+*> \verbatim
+*> CA is CHARACTER*1
+*> \endverbatim
+*>
+*> \param[in] CB
+*> \verbatim
+*> CB is CHARACTER*1
+*> CA and CB specify the single characters to be compared.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup aux_blas
+*
+* =====================================================================
+ LOGICAL FUNCTION lsame(CA,CB)
+*
+* -- Reference BLAS level1 routine (version 3.1) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER CA,CB
+* ..
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC ichar
+* ..
+* .. Local Scalars ..
+ INTEGER INTA,INTB,ZCODE
+* ..
+*
+* Test if the characters are equal
+*
+ lsame = ca .EQ. cb
+ IF (lsame) RETURN
+*
+* Now test for equivalence if both characters are alphabetic.
+*
+ zcode = ichar('Z')
+*
+* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
+* machines, on which ICHAR returns a value with bit 8 set.
+* ICHAR('A') on Prime machines returns 193 which is the same as
+* ICHAR('A') on an EBCDIC machine.
+*
+ inta = ichar(ca)
+ intb = ichar(cb)
+*
+ IF (zcode.EQ.90 .OR. zcode.EQ.122) THEN
+*
+* ASCII is assumed - ZCODE is the ASCII code of either lower or
+* upper case 'Z'.
+*
+ IF (inta.GE.97 .AND. inta.LE.122) inta = inta - 32
+ IF (intb.GE.97 .AND. intb.LE.122) intb = intb - 32
+*
+ ELSE IF (zcode.EQ.233 .OR. zcode.EQ.169) THEN
+*
+* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
+* upper case 'Z'.
+*
+ IF (inta.GE.129 .AND. inta.LE.137 .OR.
+ + inta.GE.145 .AND. inta.LE.153 .OR.
+ + inta.GE.162 .AND. inta.LE.169) inta = inta + 64
+ IF (intb.GE.129 .AND. intb.LE.137 .OR.
+ + intb.GE.145 .AND. intb.LE.153 .OR.
+ + intb.GE.162 .AND. intb.LE.169) intb = intb + 64
+*
+ ELSE IF (zcode.EQ.218 .OR. zcode.EQ.250) THEN
+*
+* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
+* plus 128 of either lower or upper case 'Z'.
+*
+ IF (inta.GE.225 .AND. inta.LE.250) inta = inta - 32
+ IF (intb.GE.225 .AND. intb.LE.250) intb = intb - 32
+ END IF
+ lsame = inta .EQ. intb
+*
+* RETURN
+*
+* End of LSAME
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b XERBLA
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE XERBLA( SRNAME, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER*(*) SRNAME
+* INTEGER INFO
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> XERBLA is an error handler for the LAPACK routines.
+*> It is called by an LAPACK routine if an input parameter has an
+*> invalid value. A message is printed and execution stops.
+*>
+*> Installers may consider modifying the STOP statement in order to
+*> call system-specific exception-handling facilities.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SRNAME
+*> \verbatim
+*> SRNAME is CHARACTER*(*)
+*> The name of the routine which called XERBLA.
+*> \endverbatim
+*>
+*> \param[in] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> The position of the invalid parameter in the parameter list
+*> of the calling routine.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup aux_blas
+*
+* =====================================================================
+ SUBROUTINE xerbla( SRNAME, INFO )
+*
+* -- Reference BLAS level1 routine (version 3.7.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER*(*) SRNAME
+ INTEGER INFO
+* ..
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC len_trim
+* ..
+* .. Executable Statements ..
+*
+ WRITE( *, fmt = 9999 )srname( 1:len_trim( srname ) ), info
+*
+ stop
+*
+ 9999 FORMAT( ' ** On entry to ', a, ' parameter number ', i2, ' had ',
+ $ 'an illegal value' )
+*
+* End of XERBLA
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b DCABS1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* DOUBLE PRECISION FUNCTION DCABS1(Z)
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 Z
+* ..
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] Z
+*> \verbatim
+*> Z is COMPLEX*16
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup double_blas_level1
+*
+* =====================================================================
+ DOUBLE PRECISION FUNCTION dcabs1(Z)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 Z
+* ..
+* ..
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC abs,dble,dimag
+*
+ dcabs1 = abs(dble(z)) + abs(dimag(z))
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b IZAMAX
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* INTEGER FUNCTION IZAMAX(N,ZX,INCX)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)|
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] ZX
+*> \verbatim
+*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of SX
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup aux_blas
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 1/15/85.
+*> modified 3/93 to return if incx .le. 0.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ INTEGER FUNCTION izamax(N,ZX,INCX)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DMAX
+ INTEGER I,IX
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DCABS1
+ EXTERNAL dcabs1
+* ..
+ izamax = 0
+ IF (n.LT.1 .OR. incx.LE.0) RETURN
+ izamax = 1
+ IF (n.EQ.1) RETURN
+ IF (incx.EQ.1) THEN
+*
+* code for increment equal to 1
+*
+ dmax = dcabs1(zx(1))
+ DO i = 2,n
+ IF (dcabs1(zx(i)).GT.dmax) THEN
+ izamax = i
+ dmax = dcabs1(zx(i))
+ END IF
+ END DO
+ ELSE
+*
+* code for increment not equal to 1
+*
+ ix = 1
+ dmax = dcabs1(zx(1))
+ ix = ix + incx
+ DO i = 2,n
+ IF (dcabs1(zx(ix)).GT.dmax) THEN
+ izamax = i
+ dmax = dcabs1(zx(ix))
+ END IF
+ ix = ix + incx
+ END DO
+ END IF
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b ZGEMM
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 ALPHA,BETA
+* INTEGER K,LDA,LDB,LDC,M,N
+* CHARACTER TRANSA,TRANSB
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEMM performs one of the matrix-matrix operations
+*>
+*> C := alpha*op( A )*op( B ) + beta*C,
+*>
+*> where op( X ) is one of
+*>
+*> op( X ) = X or op( X ) = X**T or op( X ) = X**H,
+*>
+*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
+*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TRANSA
+*> \verbatim
+*> TRANSA is CHARACTER*1
+*> On entry, TRANSA specifies the form of op( A ) to be used in
+*> the matrix multiplication as follows:
+*>
+*> TRANSA = 'N' or 'n', op( A ) = A.
+*>
+*> TRANSA = 'T' or 't', op( A ) = A**T.
+*>
+*> TRANSA = 'C' or 'c', op( A ) = A**H.
+*> \endverbatim
+*>
+*> \param[in] TRANSB
+*> \verbatim
+*> TRANSB is CHARACTER*1
+*> On entry, TRANSB specifies the form of op( B ) to be used in
+*> the matrix multiplication as follows:
+*>
+*> TRANSB = 'N' or 'n', op( B ) = B.
+*>
+*> TRANSB = 'T' or 't', op( B ) = B**T.
+*>
+*> TRANSB = 'C' or 'c', op( B ) = B**H.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> On entry, M specifies the number of rows of the matrix
+*> op( A ) and of the matrix C. M must be at least zero.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> On entry, N specifies the number of columns of the matrix
+*> op( B ) and the number of columns of the matrix C. N must be
+*> at least zero.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> On entry, K specifies the number of columns of the matrix
+*> op( A ) and the number of rows of the matrix op( B ). K must
+*> be at least zero.
+*> \endverbatim
+*>
+*> \param[in] ALPHA
+*> \verbatim
+*> ALPHA is COMPLEX*16
+*> On entry, ALPHA specifies the scalar alpha.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is
+*> k when TRANSA = 'N' or 'n', and is m otherwise.
+*> Before entry with TRANSA = 'N' or 'n', the leading m by k
+*> part of the array A must contain the matrix A, otherwise
+*> the leading k by m part of the array A must contain the
+*> matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> On entry, LDA specifies the first dimension of A as declared
+*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
+*> LDA must be at least max( 1, m ), otherwise LDA must be at
+*> least max( 1, k ).
+*> \endverbatim
+*>
+*> \param[in] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is
+*> n when TRANSB = 'N' or 'n', and is k otherwise.
+*> Before entry with TRANSB = 'N' or 'n', the leading k by n
+*> part of the array B must contain the matrix B, otherwise
+*> the leading n by k part of the array B must contain the
+*> matrix B.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> On entry, LDB specifies the first dimension of B as declared
+*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
+*> LDB must be at least max( 1, k ), otherwise LDB must be at
+*> least max( 1, n ).
+*> \endverbatim
+*>
+*> \param[in] BETA
+*> \verbatim
+*> BETA is COMPLEX*16
+*> On entry, BETA specifies the scalar beta. When BETA is
+*> supplied as zero then C need not be set on input.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension ( LDC, N )
+*> Before entry, the leading m by n part of the array C must
+*> contain the matrix C, except when beta is zero, in which
+*> case C need not be set on entry.
+*> On exit, the array C is overwritten by the m by n matrix
+*> ( alpha*op( A )*op( B ) + beta*C ).
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> On entry, LDC specifies the first dimension of C as declared
+*> in the calling (sub) program. LDC must be at least
+*> max( 1, m ).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16_blas_level3
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Level 3 Blas routine.
+*>
+*> -- Written on 8-February-1989.
+*> Jack Dongarra, Argonne National Laboratory.
+*> Iain Duff, AERE Harwell.
+*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*> Sven Hammarling, Numerical Algorithms Group Ltd.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zgemm(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+*
+* -- Reference BLAS level3 routine (version 3.7.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 ALPHA,BETA
+ INTEGER K,LDA,LDB,LDC,M,N
+ CHARACTER TRANSA,TRANSB
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A(lda,*),B(ldb,*),C(ldc,*)
+* ..
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg,max
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 TEMP
+ INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
+ LOGICAL CONJA,CONJB,NOTA,NOTB
+* ..
+* .. Parameters ..
+ COMPLEX*16 ONE
+ parameter(one= (1.0d+0,0.0d+0))
+ COMPLEX*16 ZERO
+ parameter(zero= (0.0d+0,0.0d+0))
+* ..
+*
+* Set NOTA and NOTB as true if A and B respectively are not
+* conjugated or transposed, set CONJA and CONJB as true if A and
+* B respectively are to be transposed but not conjugated and set
+* NROWA, NCOLA and NROWB as the number of rows and columns of A
+* and the number of rows of B respectively.
+*
+ nota = lsame(transa,'N')
+ notb = lsame(transb,'N')
+ conja = lsame(transa,'C')
+ conjb = lsame(transb,'C')
+ IF (nota) THEN
+ nrowa = m
+ ncola = k
+ ELSE
+ nrowa = k
+ ncola = m
+ END IF
+ IF (notb) THEN
+ nrowb = k
+ ELSE
+ nrowb = n
+ END IF
+*
+* Test the input parameters.
+*
+ info = 0
+ IF ((.NOT.nota) .AND. (.NOT.conja) .AND.
+ + (.NOT.lsame(transa,'T'))) THEN
+ info = 1
+ ELSE IF ((.NOT.notb) .AND. (.NOT.conjb) .AND.
+ + (.NOT.lsame(transb,'T'))) THEN
+ info = 2
+ ELSE IF (m.LT.0) THEN
+ info = 3
+ ELSE IF (n.LT.0) THEN
+ info = 4
+ ELSE IF (k.LT.0) THEN
+ info = 5
+ ELSE IF (lda.LT.max(1,nrowa)) THEN
+ info = 8
+ ELSE IF (ldb.LT.max(1,nrowb)) THEN
+ info = 10
+ ELSE IF (ldc.LT.max(1,m)) THEN
+ info = 13
+ END IF
+ IF (info.NE.0) THEN
+ CALL xerbla('ZGEMM ',info)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((m.EQ.0) .OR. (n.EQ.0) .OR.
+ + (((alpha.EQ.zero).OR. (k.EQ.0)).AND. (beta.EQ.one))) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (alpha.EQ.zero) THEN
+ IF (beta.EQ.zero) THEN
+ DO 20 j = 1,n
+ DO 10 i = 1,m
+ c(i,j) = zero
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 j = 1,n
+ DO 30 i = 1,m
+ c(i,j) = beta*c(i,j)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (notb) THEN
+ IF (nota) THEN
+*
+* Form C := alpha*A*B + beta*C.
+*
+ DO 90 j = 1,n
+ IF (beta.EQ.zero) THEN
+ DO 50 i = 1,m
+ c(i,j) = zero
+ 50 CONTINUE
+ ELSE IF (beta.NE.one) THEN
+ DO 60 i = 1,m
+ c(i,j) = beta*c(i,j)
+ 60 CONTINUE
+ END IF
+ DO 80 l = 1,k
+ temp = alpha*b(l,j)
+ DO 70 i = 1,m
+ c(i,j) = c(i,j) + temp*a(i,l)
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ ELSE IF (conja) THEN
+*
+* Form C := alpha*A**H*B + beta*C.
+*
+ DO 120 j = 1,n
+ DO 110 i = 1,m
+ temp = zero
+ DO 100 l = 1,k
+ temp = temp + dconjg(a(l,i))*b(l,j)
+ 100 CONTINUE
+ IF (beta.EQ.zero) THEN
+ c(i,j) = alpha*temp
+ ELSE
+ c(i,j) = alpha*temp + beta*c(i,j)
+ END IF
+ 110 CONTINUE
+ 120 CONTINUE
+ ELSE
+*
+* Form C := alpha*A**T*B + beta*C
+*
+ DO 150 j = 1,n
+ DO 140 i = 1,m
+ temp = zero
+ DO 130 l = 1,k
+ temp = temp + a(l,i)*b(l,j)
+ 130 CONTINUE
+ IF (beta.EQ.zero) THEN
+ c(i,j) = alpha*temp
+ ELSE
+ c(i,j) = alpha*temp + beta*c(i,j)
+ END IF
+ 140 CONTINUE
+ 150 CONTINUE
+ END IF
+ ELSE IF (nota) THEN
+ IF (conjb) THEN
+*
+* Form C := alpha*A*B**H + beta*C.
+*
+ DO 200 j = 1,n
+ IF (beta.EQ.zero) THEN
+ DO 160 i = 1,m
+ c(i,j) = zero
+ 160 CONTINUE
+ ELSE IF (beta.NE.one) THEN
+ DO 170 i = 1,m
+ c(i,j) = beta*c(i,j)
+ 170 CONTINUE
+ END IF
+ DO 190 l = 1,k
+ temp = alpha*dconjg(b(j,l))
+ DO 180 i = 1,m
+ c(i,j) = c(i,j) + temp*a(i,l)
+ 180 CONTINUE
+ 190 CONTINUE
+ 200 CONTINUE
+ ELSE
+*
+* Form C := alpha*A*B**T + beta*C
+*
+ DO 250 j = 1,n
+ IF (beta.EQ.zero) THEN
+ DO 210 i = 1,m
+ c(i,j) = zero
+ 210 CONTINUE
+ ELSE IF (beta.NE.one) THEN
+ DO 220 i = 1,m
+ c(i,j) = beta*c(i,j)
+ 220 CONTINUE
+ END IF
+ DO 240 l = 1,k
+ temp = alpha*b(j,l)
+ DO 230 i = 1,m
+ c(i,j) = c(i,j) + temp*a(i,l)
+ 230 CONTINUE
+ 240 CONTINUE
+ 250 CONTINUE
+ END IF
+ ELSE IF (conja) THEN
+ IF (conjb) THEN
+*
+* Form C := alpha*A**H*B**H + beta*C.
+*
+ DO 280 j = 1,n
+ DO 270 i = 1,m
+ temp = zero
+ DO 260 l = 1,k
+ temp = temp + dconjg(a(l,i))*dconjg(b(j,l))
+ 260 CONTINUE
+ IF (beta.EQ.zero) THEN
+ c(i,j) = alpha*temp
+ ELSE
+ c(i,j) = alpha*temp + beta*c(i,j)
+ END IF
+ 270 CONTINUE
+ 280 CONTINUE
+ ELSE
+*
+* Form C := alpha*A**H*B**T + beta*C
+*
+ DO 310 j = 1,n
+ DO 300 i = 1,m
+ temp = zero
+ DO 290 l = 1,k
+ temp = temp + dconjg(a(l,i))*b(j,l)
+ 290 CONTINUE
+ IF (beta.EQ.zero) THEN
+ c(i,j) = alpha*temp
+ ELSE
+ c(i,j) = alpha*temp + beta*c(i,j)
+ END IF
+ 300 CONTINUE
+ 310 CONTINUE
+ END IF
+ ELSE
+ IF (conjb) THEN
+*
+* Form C := alpha*A**T*B**H + beta*C
+*
+ DO 340 j = 1,n
+ DO 330 i = 1,m
+ temp = zero
+ DO 320 l = 1,k
+ temp = temp + a(l,i)*dconjg(b(j,l))
+ 320 CONTINUE
+ IF (beta.EQ.zero) THEN
+ c(i,j) = alpha*temp
+ ELSE
+ c(i,j) = alpha*temp + beta*c(i,j)
+ END IF
+ 330 CONTINUE
+ 340 CONTINUE
+ ELSE
+*
+* Form C := alpha*A**T*B**T + beta*C
+*
+ DO 370 j = 1,n
+ DO 360 i = 1,m
+ temp = zero
+ DO 350 l = 1,k
+ temp = temp + a(l,i)*b(j,l)
+ 350 CONTINUE
+ IF (beta.EQ.zero) THEN
+ c(i,j) = alpha*temp
+ ELSE
+ c(i,j) = alpha*temp + beta*c(i,j)
+ END IF
+ 360 CONTINUE
+ 370 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZGEMM .
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZGEMV
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 ALPHA,BETA
+* INTEGER INCX,INCY,LDA,M,N
+* CHARACTER TRANS
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A(LDA,*),X(*),Y(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEMV performs one of the matrix-vector operations
+*>
+*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
+*>
+*> y := alpha*A**H*x + beta*y,
+*>
+*> where alpha and beta are scalars, x and y are vectors and A is an
+*> m by n matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> On entry, TRANS specifies the operation to be performed as
+*> follows:
+*>
+*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
+*>
+*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
+*>
+*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> On entry, M specifies the number of rows of the matrix A.
+*> M must be at least zero.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> On entry, N specifies the number of columns of the matrix A.
+*> N must be at least zero.
+*> \endverbatim
+*>
+*> \param[in] ALPHA
+*> \verbatim
+*> ALPHA is COMPLEX*16
+*> On entry, ALPHA specifies the scalar alpha.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension ( LDA, N )
+*> Before entry, the leading m by n part of the array A must
+*> contain the matrix of coefficients.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> On entry, LDA specifies the first dimension of A as declared
+*> in the calling (sub) program. LDA must be at least
+*> max( 1, m ).
+*> \endverbatim
+*>
+*> \param[in] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension at least
+*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+*> and at least
+*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+*> Before entry, the incremented array X must contain the
+*> vector x.
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> On entry, INCX specifies the increment for the elements of
+*> X. INCX must not be zero.
+*> \endverbatim
+*>
+*> \param[in] BETA
+*> \verbatim
+*> BETA is COMPLEX*16
+*> On entry, BETA specifies the scalar beta. When BETA is
+*> supplied as zero then Y need not be set on input.
+*> \endverbatim
+*>
+*> \param[in,out] Y
+*> \verbatim
+*> Y is COMPLEX*16 array, dimension at least
+*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+*> and at least
+*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+*> Before entry with BETA non-zero, the incremented array Y
+*> must contain the vector y. On exit, Y is overwritten by the
+*> updated vector y.
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> On entry, INCY specifies the increment for the elements of
+*> Y. INCY must not be zero.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16_blas_level2
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Level 2 Blas routine.
+*> The vector and matrix arguments are not referenced when N = 0, or M = 0
+*>
+*> -- Written on 22-October-1986.
+*> Jack Dongarra, Argonne National Lab.
+*> Jeremy Du Croz, Nag Central Office.
+*> Sven Hammarling, Nag Central Office.
+*> Richard Hanson, Sandia National Labs.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zgemv(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+*
+* -- Reference BLAS level2 routine (version 3.7.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 ALPHA,BETA
+ INTEGER INCX,INCY,LDA,M,N
+ CHARACTER TRANS
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A(lda,*),X(*),Y(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ parameter(one= (1.0d+0,0.0d+0))
+ COMPLEX*16 ZERO
+ parameter(zero= (0.0d+0,0.0d+0))
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 TEMP
+ INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
+ LOGICAL NOCONJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg,max
+* ..
+*
+* Test the input parameters.
+*
+ info = 0
+ IF (.NOT.lsame(trans,'N') .AND. .NOT.lsame(trans,'T') .AND.
+ + .NOT.lsame(trans,'C')) THEN
+ info = 1
+ ELSE IF (m.LT.0) THEN
+ info = 2
+ ELSE IF (n.LT.0) THEN
+ info = 3
+ ELSE IF (lda.LT.max(1,m)) THEN
+ info = 6
+ ELSE IF (incx.EQ.0) THEN
+ info = 8
+ ELSE IF (incy.EQ.0) THEN
+ info = 11
+ END IF
+ IF (info.NE.0) THEN
+ CALL xerbla('ZGEMV ',info)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((m.EQ.0) .OR. (n.EQ.0) .OR.
+ + ((alpha.EQ.zero).AND. (beta.EQ.one))) RETURN
+*
+ noconj = lsame(trans,'T')
+*
+* Set LENX and LENY, the lengths of the vectors x and y, and set
+* up the start points in X and Y.
+*
+ IF (lsame(trans,'N')) THEN
+ lenx = n
+ leny = m
+ ELSE
+ lenx = m
+ leny = n
+ END IF
+ IF (incx.GT.0) THEN
+ kx = 1
+ ELSE
+ kx = 1 - (lenx-1)*incx
+ END IF
+ IF (incy.GT.0) THEN
+ ky = 1
+ ELSE
+ ky = 1 - (leny-1)*incy
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+* First form y := beta*y.
+*
+ IF (beta.NE.one) THEN
+ IF (incy.EQ.1) THEN
+ IF (beta.EQ.zero) THEN
+ DO 10 i = 1,leny
+ y(i) = zero
+ 10 CONTINUE
+ ELSE
+ DO 20 i = 1,leny
+ y(i) = beta*y(i)
+ 20 CONTINUE
+ END IF
+ ELSE
+ iy = ky
+ IF (beta.EQ.zero) THEN
+ DO 30 i = 1,leny
+ y(iy) = zero
+ iy = iy + incy
+ 30 CONTINUE
+ ELSE
+ DO 40 i = 1,leny
+ y(iy) = beta*y(iy)
+ iy = iy + incy
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (alpha.EQ.zero) RETURN
+ IF (lsame(trans,'N')) THEN
+*
+* Form y := alpha*A*x + y.
+*
+ jx = kx
+ IF (incy.EQ.1) THEN
+ DO 60 j = 1,n
+ temp = alpha*x(jx)
+ DO 50 i = 1,m
+ y(i) = y(i) + temp*a(i,j)
+ 50 CONTINUE
+ jx = jx + incx
+ 60 CONTINUE
+ ELSE
+ DO 80 j = 1,n
+ temp = alpha*x(jx)
+ iy = ky
+ DO 70 i = 1,m
+ y(iy) = y(iy) + temp*a(i,j)
+ iy = iy + incy
+ 70 CONTINUE
+ jx = jx + incx
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
+*
+ jy = ky
+ IF (incx.EQ.1) THEN
+ DO 110 j = 1,n
+ temp = zero
+ IF (noconj) THEN
+ DO 90 i = 1,m
+ temp = temp + a(i,j)*x(i)
+ 90 CONTINUE
+ ELSE
+ DO 100 i = 1,m
+ temp = temp + dconjg(a(i,j))*x(i)
+ 100 CONTINUE
+ END IF
+ y(jy) = y(jy) + alpha*temp
+ jy = jy + incy
+ 110 CONTINUE
+ ELSE
+ DO 140 j = 1,n
+ temp = zero
+ ix = kx
+ IF (noconj) THEN
+ DO 120 i = 1,m
+ temp = temp + a(i,j)*x(ix)
+ ix = ix + incx
+ 120 CONTINUE
+ ELSE
+ DO 130 i = 1,m
+ temp = temp + dconjg(a(i,j))*x(ix)
+ ix = ix + incx
+ 130 CONTINUE
+ END IF
+ y(jy) = y(jy) + alpha*temp
+ jy = jy + incy
+ 140 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZGEMV .
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZSCAL
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSCAL(N,ZA,ZX,INCX)
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 ZA
+* INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSCAL scales a vector by a constant.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] ZA
+*> \verbatim
+*> ZA is COMPLEX*16
+*> On entry, ZA specifies the scalar alpha.
+*> \endverbatim
+*>
+*> \param[in,out] ZX
+*> \verbatim
+*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 3/11/78.
+*> modified 3/93 to return if incx .le. 0.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zscal(N,ZA,ZX,INCX)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 ZA
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I,NINCX
+* ..
+ IF (n.LE.0 .OR. incx.LE.0) RETURN
+ IF (incx.EQ.1) THEN
+*
+* code for increment equal to 1
+*
+ DO i = 1,n
+ zx(i) = za*zx(i)
+ END DO
+ ELSE
+*
+* code for increment not equal to 1
+*
+ nincx = n*incx
+ DO i = 1,nincx,incx
+ zx(i) = za*zx(i)
+ END DO
+ END IF
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b ZSWAP
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSWAP interchanges two vectors.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in,out] ZX
+*> \verbatim
+*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*>
+*> \param[in,out] ZY
+*> \verbatim
+*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> storage spacing between elements of ZY
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 3/11/78.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zswap(N,ZX,INCX,ZY,INCY)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ COMPLEX*16 ZTEMP
+ INTEGER I,IX,IY
+* ..
+ IF (n.LE.0) RETURN
+ IF (incx.EQ.1 .AND. incy.EQ.1) THEN
+*
+* code for both increments equal to 1
+ DO i = 1,n
+ ztemp = zx(i)
+ zx(i) = zy(i)
+ zy(i) = ztemp
+ END DO
+ ELSE
+*
+* code for unequal increments or equal increments not equal
+* to 1
+*
+ ix = 1
+ iy = 1
+ IF (incx.LT.0) ix = (-n+1)*incx + 1
+ IF (incy.LT.0) iy = (-n+1)*incy + 1
+ DO i = 1,n
+ ztemp = zx(ix)
+ zx(ix) = zy(iy)
+ zy(iy) = ztemp
+ ix = ix + incx
+ iy = iy + incy
+ END DO
+ END IF
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b ZTRMM
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 ALPHA
+* INTEGER LDA,LDB,M,N
+* CHARACTER DIAG,SIDE,TRANSA,UPLO
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A(LDA,*),B(LDB,*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZTRMM performs one of the matrix-matrix operations
+*>
+*> B := alpha*op( A )*B, or B := alpha*B*op( A )
+*>
+*> where alpha is a scalar, B is an m by n matrix, A is a unit, or
+*> non-unit, upper or lower triangular matrix and op( A ) is one of
+*>
+*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> On entry, SIDE specifies whether op( A ) multiplies B from
+*> the left or right as follows:
+*>
+*> SIDE = 'L' or 'l' B := alpha*op( A )*B.
+*>
+*> SIDE = 'R' or 'r' B := alpha*B*op( A ).
+*> \endverbatim
+*>
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> On entry, UPLO specifies whether the matrix A is an upper or
+*> lower triangular matrix as follows:
+*>
+*> UPLO = 'U' or 'u' A is an upper triangular matrix.
+*>
+*> UPLO = 'L' or 'l' A is a lower triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] TRANSA
+*> \verbatim
+*> TRANSA is CHARACTER*1
+*> On entry, TRANSA specifies the form of op( A ) to be used in
+*> the matrix multiplication as follows:
+*>
+*> TRANSA = 'N' or 'n' op( A ) = A.
+*>
+*> TRANSA = 'T' or 't' op( A ) = A**T.
+*>
+*> TRANSA = 'C' or 'c' op( A ) = A**H.
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> On entry, DIAG specifies whether or not A is unit triangular
+*> as follows:
+*>
+*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*>
+*> DIAG = 'N' or 'n' A is not assumed to be unit
+*> triangular.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> On entry, M specifies the number of rows of B. M must be at
+*> least zero.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> On entry, N specifies the number of columns of B. N must be
+*> at least zero.
+*> \endverbatim
+*>
+*> \param[in] ALPHA
+*> \verbatim
+*> ALPHA is COMPLEX*16
+*> On entry, ALPHA specifies the scalar alpha. When alpha is
+*> zero then A is not referenced and B need not be set before
+*> entry.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension ( LDA, k ), where k is m
+*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
+*> Before entry with UPLO = 'U' or 'u', the leading k by k
+*> upper triangular part of the array A must contain the upper
+*> triangular matrix and the strictly lower triangular part of
+*> A is not referenced.
+*> Before entry with UPLO = 'L' or 'l', the leading k by k
+*> lower triangular part of the array A must contain the lower
+*> triangular matrix and the strictly upper triangular part of
+*> A is not referenced.
+*> Note that when DIAG = 'U' or 'u', the diagonal elements of
+*> A are not referenced either, but are assumed to be unity.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> On entry, LDA specifies the first dimension of A as declared
+*> in the calling (sub) program. When SIDE = 'L' or 'l' then
+*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
+*> then LDA must be at least max( 1, n ).
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension ( LDB, N ).
+*> Before entry, the leading m by n part of the array B must
+*> contain the matrix B, and on exit is overwritten by the
+*> transformed matrix.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> On entry, LDB specifies the first dimension of B as declared
+*> in the calling (sub) program. LDB must be at least
+*> max( 1, m ).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16_blas_level3
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Level 3 Blas routine.
+*>
+*> -- Written on 8-February-1989.
+*> Jack Dongarra, Argonne National Laboratory.
+*> Iain Duff, AERE Harwell.
+*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*> Sven Hammarling, Numerical Algorithms Group Ltd.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ztrmm(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
+*
+* -- Reference BLAS level3 routine (version 3.7.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 ALPHA
+ INTEGER LDA,LDB,M,N
+ CHARACTER DIAG,SIDE,TRANSA,UPLO
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A(lda,*),B(ldb,*)
+* ..
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg,max
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 TEMP
+ INTEGER I,INFO,J,K,NROWA
+ LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
+* ..
+* .. Parameters ..
+ COMPLEX*16 ONE
+ parameter(one= (1.0d+0,0.0d+0))
+ COMPLEX*16 ZERO
+ parameter(zero= (0.0d+0,0.0d+0))
+* ..
+*
+* Test the input parameters.
+*
+ lside = lsame(side,'L')
+ IF (lside) THEN
+ nrowa = m
+ ELSE
+ nrowa = n
+ END IF
+ noconj = lsame(transa,'T')
+ nounit = lsame(diag,'N')
+ upper = lsame(uplo,'U')
+*
+ info = 0
+ IF ((.NOT.lside) .AND. (.NOT.lsame(side,'R'))) THEN
+ info = 1
+ ELSE IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN
+ info = 2
+ ELSE IF ((.NOT.lsame(transa,'N')) .AND.
+ + (.NOT.lsame(transa,'T')) .AND.
+ + (.NOT.lsame(transa,'C'))) THEN
+ info = 3
+ ELSE IF ((.NOT.lsame(diag,'U')) .AND. (.NOT.lsame(diag,'N'))) THEN
+ info = 4
+ ELSE IF (m.LT.0) THEN
+ info = 5
+ ELSE IF (n.LT.0) THEN
+ info = 6
+ ELSE IF (lda.LT.max(1,nrowa)) THEN
+ info = 9
+ ELSE IF (ldb.LT.max(1,m)) THEN
+ info = 11
+ END IF
+ IF (info.NE.0) THEN
+ CALL xerbla('ZTRMM ',info)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (m.EQ.0 .OR. n.EQ.0) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (alpha.EQ.zero) THEN
+ DO 20 j = 1,n
+ DO 10 i = 1,m
+ b(i,j) = zero
+ 10 CONTINUE
+ 20 CONTINUE
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (lside) THEN
+ IF (lsame(transa,'N')) THEN
+*
+* Form B := alpha*A*B.
+*
+ IF (upper) THEN
+ DO 50 j = 1,n
+ DO 40 k = 1,m
+ IF (b(k,j).NE.zero) THEN
+ temp = alpha*b(k,j)
+ DO 30 i = 1,k - 1
+ b(i,j) = b(i,j) + temp*a(i,k)
+ 30 CONTINUE
+ IF (nounit) temp = temp*a(k,k)
+ b(k,j) = temp
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 80 j = 1,n
+ DO 70 k = m,1,-1
+ IF (b(k,j).NE.zero) THEN
+ temp = alpha*b(k,j)
+ b(k,j) = temp
+ IF (nounit) b(k,j) = b(k,j)*a(k,k)
+ DO 60 i = k + 1,m
+ b(i,j) = b(i,j) + temp*a(i,k)
+ 60 CONTINUE
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*A**T*B or B := alpha*A**H*B.
+*
+ IF (upper) THEN
+ DO 120 j = 1,n
+ DO 110 i = m,1,-1
+ temp = b(i,j)
+ IF (noconj) THEN
+ IF (nounit) temp = temp*a(i,i)
+ DO 90 k = 1,i - 1
+ temp = temp + a(k,i)*b(k,j)
+ 90 CONTINUE
+ ELSE
+ IF (nounit) temp = temp*dconjg(a(i,i))
+ DO 100 k = 1,i - 1
+ temp = temp + dconjg(a(k,i))*b(k,j)
+ 100 CONTINUE
+ END IF
+ b(i,j) = alpha*temp
+ 110 CONTINUE
+ 120 CONTINUE
+ ELSE
+ DO 160 j = 1,n
+ DO 150 i = 1,m
+ temp = b(i,j)
+ IF (noconj) THEN
+ IF (nounit) temp = temp*a(i,i)
+ DO 130 k = i + 1,m
+ temp = temp + a(k,i)*b(k,j)
+ 130 CONTINUE
+ ELSE
+ IF (nounit) temp = temp*dconjg(a(i,i))
+ DO 140 k = i + 1,m
+ temp = temp + dconjg(a(k,i))*b(k,j)
+ 140 CONTINUE
+ END IF
+ b(i,j) = alpha*temp
+ 150 CONTINUE
+ 160 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IF (lsame(transa,'N')) THEN
+*
+* Form B := alpha*B*A.
+*
+ IF (upper) THEN
+ DO 200 j = n,1,-1
+ temp = alpha
+ IF (nounit) temp = temp*a(j,j)
+ DO 170 i = 1,m
+ b(i,j) = temp*b(i,j)
+ 170 CONTINUE
+ DO 190 k = 1,j - 1
+ IF (a(k,j).NE.zero) THEN
+ temp = alpha*a(k,j)
+ DO 180 i = 1,m
+ b(i,j) = b(i,j) + temp*b(i,k)
+ 180 CONTINUE
+ END IF
+ 190 CONTINUE
+ 200 CONTINUE
+ ELSE
+ DO 240 j = 1,n
+ temp = alpha
+ IF (nounit) temp = temp*a(j,j)
+ DO 210 i = 1,m
+ b(i,j) = temp*b(i,j)
+ 210 CONTINUE
+ DO 230 k = j + 1,n
+ IF (a(k,j).NE.zero) THEN
+ temp = alpha*a(k,j)
+ DO 220 i = 1,m
+ b(i,j) = b(i,j) + temp*b(i,k)
+ 220 CONTINUE
+ END IF
+ 230 CONTINUE
+ 240 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*B*A**T or B := alpha*B*A**H.
+*
+ IF (upper) THEN
+ DO 280 k = 1,n
+ DO 260 j = 1,k - 1
+ IF (a(j,k).NE.zero) THEN
+ IF (noconj) THEN
+ temp = alpha*a(j,k)
+ ELSE
+ temp = alpha*dconjg(a(j,k))
+ END IF
+ DO 250 i = 1,m
+ b(i,j) = b(i,j) + temp*b(i,k)
+ 250 CONTINUE
+ END IF
+ 260 CONTINUE
+ temp = alpha
+ IF (nounit) THEN
+ IF (noconj) THEN
+ temp = temp*a(k,k)
+ ELSE
+ temp = temp*dconjg(a(k,k))
+ END IF
+ END IF
+ IF (temp.NE.one) THEN
+ DO 270 i = 1,m
+ b(i,k) = temp*b(i,k)
+ 270 CONTINUE
+ END IF
+ 280 CONTINUE
+ ELSE
+ DO 320 k = n,1,-1
+ DO 300 j = k + 1,n
+ IF (a(j,k).NE.zero) THEN
+ IF (noconj) THEN
+ temp = alpha*a(j,k)
+ ELSE
+ temp = alpha*dconjg(a(j,k))
+ END IF
+ DO 290 i = 1,m
+ b(i,j) = b(i,j) + temp*b(i,k)
+ 290 CONTINUE
+ END IF
+ 300 CONTINUE
+ temp = alpha
+ IF (nounit) THEN
+ IF (noconj) THEN
+ temp = temp*a(k,k)
+ ELSE
+ temp = temp*dconjg(a(k,k))
+ END IF
+ END IF
+ IF (temp.NE.one) THEN
+ DO 310 i = 1,m
+ b(i,k) = temp*b(i,k)
+ 310 CONTINUE
+ END IF
+ 320 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZTRMM .
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZTRMV
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,LDA,N
+* CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A(LDA,*),X(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZTRMV performs one of the matrix-vector operations
+*>
+*> x := A*x, or x := A**T*x, or x := A**H*x,
+*>
+*> where x is an n element vector and A is an n by n unit, or non-unit,
+*> upper or lower triangular matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> On entry, UPLO specifies whether the matrix is an upper or
+*> lower triangular matrix as follows:
+*>
+*> UPLO = 'U' or 'u' A is an upper triangular matrix.
+*>
+*> UPLO = 'L' or 'l' A is a lower triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> On entry, TRANS specifies the operation to be performed as
+*> follows:
+*>
+*> TRANS = 'N' or 'n' x := A*x.
+*>
+*> TRANS = 'T' or 't' x := A**T*x.
+*>
+*> TRANS = 'C' or 'c' x := A**H*x.
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> On entry, DIAG specifies whether or not A is unit
+*> triangular as follows:
+*>
+*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*>
+*> DIAG = 'N' or 'n' A is not assumed to be unit
+*> triangular.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> On entry, N specifies the order of the matrix A.
+*> N must be at least zero.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension ( LDA, N ).
+*> Before entry with UPLO = 'U' or 'u', the leading n by n
+*> upper triangular part of the array A must contain the upper
+*> triangular matrix and the strictly lower triangular part of
+*> A is not referenced.
+*> Before entry with UPLO = 'L' or 'l', the leading n by n
+*> lower triangular part of the array A must contain the lower
+*> triangular matrix and the strictly upper triangular part of
+*> A is not referenced.
+*> Note that when DIAG = 'U' or 'u', the diagonal elements of
+*> A are not referenced either, but are assumed to be unity.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> On entry, LDA specifies the first dimension of A as declared
+*> in the calling (sub) program. LDA must be at least
+*> max( 1, n ).
+*> \endverbatim
+*>
+*> \param[in,out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension at least
+*> ( 1 + ( n - 1 )*abs( INCX ) ).
+*> Before entry, the incremented array X must contain the n
+*> element vector x. On exit, X is overwritten with the
+*> transformed vector x.
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> On entry, INCX specifies the increment for the elements of
+*> X. INCX must not be zero.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16_blas_level2
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Level 2 Blas routine.
+*> The vector and matrix arguments are not referenced when N = 0, or M = 0
+*>
+*> -- Written on 22-October-1986.
+*> Jack Dongarra, Argonne National Lab.
+*> Jeremy Du Croz, Nag Central Office.
+*> Sven Hammarling, Nag Central Office.
+*> Richard Hanson, Sandia National Labs.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ztrmv(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+*
+* -- Reference BLAS level2 routine (version 3.7.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A(lda,*),X(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ parameter(zero= (0.0d+0,0.0d+0))
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+ LOGICAL NOCONJ,NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg,max
+* ..
+*
+* Test the input parameters.
+*
+ info = 0
+ IF (.NOT.lsame(uplo,'U') .AND. .NOT.lsame(uplo,'L')) THEN
+ info = 1
+ ELSE IF (.NOT.lsame(trans,'N') .AND. .NOT.lsame(trans,'T') .AND.
+ + .NOT.lsame(trans,'C')) THEN
+ info = 2
+ ELSE IF (.NOT.lsame(diag,'U') .AND. .NOT.lsame(diag,'N')) THEN
+ info = 3
+ ELSE IF (n.LT.0) THEN
+ info = 4
+ ELSE IF (lda.LT.max(1,n)) THEN
+ info = 6
+ ELSE IF (incx.EQ.0) THEN
+ info = 8
+ END IF
+ IF (info.NE.0) THEN
+ CALL xerbla('ZTRMV ',info)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (n.EQ.0) RETURN
+*
+ noconj = lsame(trans,'T')
+ nounit = lsame(diag,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (incx.LE.0) THEN
+ kx = 1 - (n-1)*incx
+ ELSE IF (incx.NE.1) THEN
+ kx = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (lsame(trans,'N')) THEN
+*
+* Form x := A*x.
+*
+ IF (lsame(uplo,'U')) THEN
+ IF (incx.EQ.1) THEN
+ DO 20 j = 1,n
+ IF (x(j).NE.zero) THEN
+ temp = x(j)
+ DO 10 i = 1,j - 1
+ x(i) = x(i) + temp*a(i,j)
+ 10 CONTINUE
+ IF (nounit) x(j) = x(j)*a(j,j)
+ END IF
+ 20 CONTINUE
+ ELSE
+ jx = kx
+ DO 40 j = 1,n
+ IF (x(jx).NE.zero) THEN
+ temp = x(jx)
+ ix = kx
+ DO 30 i = 1,j - 1
+ x(ix) = x(ix) + temp*a(i,j)
+ ix = ix + incx
+ 30 CONTINUE
+ IF (nounit) x(jx) = x(jx)*a(j,j)
+ END IF
+ jx = jx + incx
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (incx.EQ.1) THEN
+ DO 60 j = n,1,-1
+ IF (x(j).NE.zero) THEN
+ temp = x(j)
+ DO 50 i = n,j + 1,-1
+ x(i) = x(i) + temp*a(i,j)
+ 50 CONTINUE
+ IF (nounit) x(j) = x(j)*a(j,j)
+ END IF
+ 60 CONTINUE
+ ELSE
+ kx = kx + (n-1)*incx
+ jx = kx
+ DO 80 j = n,1,-1
+ IF (x(jx).NE.zero) THEN
+ temp = x(jx)
+ ix = kx
+ DO 70 i = n,j + 1,-1
+ x(ix) = x(ix) + temp*a(i,j)
+ ix = ix - incx
+ 70 CONTINUE
+ IF (nounit) x(jx) = x(jx)*a(j,j)
+ END IF
+ jx = jx - incx
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := A**T*x or x := A**H*x.
+*
+ IF (lsame(uplo,'U')) THEN
+ IF (incx.EQ.1) THEN
+ DO 110 j = n,1,-1
+ temp = x(j)
+ IF (noconj) THEN
+ IF (nounit) temp = temp*a(j,j)
+ DO 90 i = j - 1,1,-1
+ temp = temp + a(i,j)*x(i)
+ 90 CONTINUE
+ ELSE
+ IF (nounit) temp = temp*dconjg(a(j,j))
+ DO 100 i = j - 1,1,-1
+ temp = temp + dconjg(a(i,j))*x(i)
+ 100 CONTINUE
+ END IF
+ x(j) = temp
+ 110 CONTINUE
+ ELSE
+ jx = kx + (n-1)*incx
+ DO 140 j = n,1,-1
+ temp = x(jx)
+ ix = jx
+ IF (noconj) THEN
+ IF (nounit) temp = temp*a(j,j)
+ DO 120 i = j - 1,1,-1
+ ix = ix - incx
+ temp = temp + a(i,j)*x(ix)
+ 120 CONTINUE
+ ELSE
+ IF (nounit) temp = temp*dconjg(a(j,j))
+ DO 130 i = j - 1,1,-1
+ ix = ix - incx
+ temp = temp + dconjg(a(i,j))*x(ix)
+ 130 CONTINUE
+ END IF
+ x(jx) = temp
+ jx = jx - incx
+ 140 CONTINUE
+ END IF
+ ELSE
+ IF (incx.EQ.1) THEN
+ DO 170 j = 1,n
+ temp = x(j)
+ IF (noconj) THEN
+ IF (nounit) temp = temp*a(j,j)
+ DO 150 i = j + 1,n
+ temp = temp + a(i,j)*x(i)
+ 150 CONTINUE
+ ELSE
+ IF (nounit) temp = temp*dconjg(a(j,j))
+ DO 160 i = j + 1,n
+ temp = temp + dconjg(a(i,j))*x(i)
+ 160 CONTINUE
+ END IF
+ x(j) = temp
+ 170 CONTINUE
+ ELSE
+ jx = kx
+ DO 200 j = 1,n
+ temp = x(jx)
+ ix = jx
+ IF (noconj) THEN
+ IF (nounit) temp = temp*a(j,j)
+ DO 180 i = j + 1,n
+ ix = ix + incx
+ temp = temp + a(i,j)*x(ix)
+ 180 CONTINUE
+ ELSE
+ IF (nounit) temp = temp*dconjg(a(j,j))
+ DO 190 i = j + 1,n
+ ix = ix + incx
+ temp = temp + dconjg(a(i,j))*x(ix)
+ 190 CONTINUE
+ END IF
+ x(jx) = temp
+ jx = jx + incx
+ 200 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZTRMV .
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZGEBAK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGEBAK + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOB, SIDE
+* INTEGER IHI, ILO, INFO, LDV, M, N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION SCALE( * )
+* COMPLEX*16 V( LDV, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEBAK forms the right or left eigenvectors of a complex general
+*> matrix by backward transformation on the computed eigenvectors of the
+*> balanced matrix output by ZGEBAL.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOB
+*> \verbatim
+*> JOB is CHARACTER*1
+*> Specifies the type of backward transformation required:
+*> = 'N', do nothing, return immediately;
+*> = 'P', do backward transformation for permutation only;
+*> = 'S', do backward transformation for scaling only;
+*> = 'B', do backward transformations for both permutation and
+*> scaling.
+*> JOB must be the same as the argument JOB supplied to ZGEBAL.
+*> \endverbatim
+*>
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'R': V contains right eigenvectors;
+*> = 'L': V contains left eigenvectors.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows of the matrix V. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*> The integers ILO and IHI determined by ZGEBAL.
+*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*> \endverbatim
+*>
+*> \param[in] SCALE
+*> \verbatim
+*> SCALE is DOUBLE PRECISION array, dimension (N)
+*> Details of the permutation and scaling factors, as returned
+*> by ZGEBAL.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of columns of the matrix V. M >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension (LDV,M)
+*> On entry, the matrix of right or left eigenvectors to be
+*> transformed, as returned by ZHSEIN or ZTREVC.
+*> On exit, V is overwritten by the transformed eigenvectors.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V. LDV >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16GEcomputational
+*
+* =====================================================================
+ SUBROUTINE zgebak( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB, SIDE
+ INTEGER IHI, ILO, INFO, LDV, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION SCALE( * )
+ COMPLEX*16 V( ldv, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ parameter( one = 1.0d+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFTV, RIGHTV
+ INTEGER I, II, K
+ DOUBLE PRECISION S
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zdscal, zswap
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC max, min
+* ..
+* .. Executable Statements ..
+*
+* Decode and Test the input parameters
+*
+ rightv = lsame( side, 'R' )
+ leftv = lsame( side, 'L' )
+*
+ info = 0
+ IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
+ $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
+ info = -1
+ ELSE IF( .NOT.rightv .AND. .NOT.leftv ) THEN
+ info = -2
+ ELSE IF( n.LT.0 ) THEN
+ info = -3
+ ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
+ info = -4
+ ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
+ info = -5
+ ELSE IF( m.LT.0 ) THEN
+ info = -7
+ ELSE IF( ldv.LT.max( 1, n ) ) THEN
+ info = -9
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZGEBAK', -info )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.EQ.0 )
+ $ RETURN
+ IF( m.EQ.0 )
+ $ RETURN
+ IF( lsame( job, 'N' ) )
+ $ RETURN
+*
+ IF( ilo.EQ.ihi )
+ $ GO TO 30
+*
+* Backward balance
+*
+ IF( lsame( job, 'S' ) .OR. lsame( job, 'B' ) ) THEN
+*
+ IF( rightv ) THEN
+ DO 10 i = ilo, ihi
+ s = scale( i )
+ CALL zdscal( m, s, v( i, 1 ), ldv )
+ 10 CONTINUE
+ END IF
+*
+ IF( leftv ) THEN
+ DO 20 i = ilo, ihi
+ s = one / scale( i )
+ CALL zdscal( m, s, v( i, 1 ), ldv )
+ 20 CONTINUE
+ END IF
+*
+ END IF
+*
+* Backward permutation
+*
+* For I = ILO-1 step -1 until 1,
+* IHI+1 step 1 until N do --
+*
+ 30 CONTINUE
+ IF( lsame( job, 'P' ) .OR. lsame( job, 'B' ) ) THEN
+ IF( rightv ) THEN
+ DO 40 ii = 1, n
+ i = ii
+ IF( i.GE.ilo .AND. i.LE.ihi )
+ $ GO TO 40
+ IF( i.LT.ilo )
+ $ i = ilo - ii
+ k = scale( i )
+ IF( k.EQ.i )
+ $ GO TO 40
+ CALL zswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv )
+ 40 CONTINUE
+ END IF
+*
+ IF( leftv ) THEN
+ DO 50 ii = 1, n
+ i = ii
+ IF( i.GE.ilo .AND. i.LE.ihi )
+ $ GO TO 50
+ IF( i.LT.ilo )
+ $ i = ilo - ii
+ k = scale( i )
+ IF( k.EQ.i )
+ $ GO TO 50
+ CALL zswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv )
+ 50 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZGEBAK
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZGEBAL
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGEBAL + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOB
+* INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION SCALE( * )
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEBAL balances a general complex matrix A. This involves, first,
+*> permuting A by a similarity transformation to isolate eigenvalues
+*> in the first 1 to ILO-1 and last IHI+1 to N elements on the
+*> diagonal; and second, applying a diagonal similarity transformation
+*> to rows and columns ILO to IHI to make the rows and columns as
+*> close in norm as possible. Both steps are optional.
+*>
+*> Balancing may reduce the 1-norm of the matrix, and improve the
+*> accuracy of the computed eigenvalues and/or eigenvectors.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOB
+*> \verbatim
+*> JOB is CHARACTER*1
+*> Specifies the operations to be performed on A:
+*> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
+*> for i = 1,...,N;
+*> = 'P': permute only;
+*> = 'S': scale only;
+*> = 'B': both permute and scale.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the input matrix A.
+*> On exit, A is overwritten by the balanced matrix.
+*> If JOB = 'N', A is not referenced.
+*> See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[out] IHI
+*> \verbatim
+*> IHI is INTEGER
+*> ILO and IHI are set to INTEGER such that on exit
+*> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
+*> If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*> \endverbatim
+*>
+*> \param[out] SCALE
+*> \verbatim
+*> SCALE is DOUBLE PRECISION array, dimension (N)
+*> Details of the permutations and scaling factors applied to
+*> A. If P(j) is the index of the row and column interchanged
+*> with row and column j and D(j) is the scaling factor
+*> applied to row and column j, then
+*> SCALE(j) = P(j) for j = 1,...,ILO-1
+*> = D(j) for j = ILO,...,IHI
+*> = P(j) for j = IHI+1,...,N.
+*> The order in which the interchanges are made is N to IHI+1,
+*> then 1 to ILO-1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2017
+*
+*> \ingroup complex16GEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The permutations consist of row and column interchanges which put
+*> the matrix in the form
+*>
+*> ( T1 X Y )
+*> P A P = ( 0 B Z )
+*> ( 0 0 T2 )
+*>
+*> where T1 and T2 are upper triangular matrices whose eigenvalues lie
+*> along the diagonal. The column indices ILO and IHI mark the starting
+*> and ending columns of the submatrix B. Balancing consists of applying
+*> a diagonal similarity transformation inv(D) * B * D to make the
+*> 1-norms of each row of B and its corresponding column nearly equal.
+*> The output matrix is
+*>
+*> ( T1 X*D Y )
+*> ( 0 inv(D)*B*D inv(D)*Z ).
+*> ( 0 0 T2 )
+*>
+*> Information about the permutations P and the diagonal matrix D is
+*> returned in the vector SCALE.
+*>
+*> This subroutine is based on the EISPACK routine CBAL.
+*>
+*> Modified by Tzu-Yi Chen, Computer Science Division, University of
+*> California at Berkeley, USA
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zgebal( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+* -- LAPACK computational routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2017
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION SCALE( * )
+ COMPLEX*16 A( lda, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ parameter( zero = 0.0d+0, one = 1.0d+0 )
+ DOUBLE PRECISION SCLFAC
+ parameter( sclfac = 2.0d+0 )
+ DOUBLE PRECISION FACTOR
+ parameter( factor = 0.95d+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOCONV
+ INTEGER I, ICA, IEXC, IRA, J, K, L, M
+ DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+ $ sfmin2
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN, LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH, DZNRM2
+ EXTERNAL disnan, lsame, izamax, dlamch, dznrm2
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zdscal, zswap
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dimag, max, min
+*
+* Test the input parameters
+*
+ info = 0
+ IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
+ $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
+ info = -1
+ ELSE IF( n.LT.0 ) THEN
+ info = -2
+ ELSE IF( lda.LT.max( 1, n ) ) THEN
+ info = -4
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZGEBAL', -info )
+ RETURN
+ END IF
+*
+ k = 1
+ l = n
+*
+ IF( n.EQ.0 )
+ $ GO TO 210
+*
+ IF( lsame( job, 'N' ) ) THEN
+ DO 10 i = 1, n
+ scale( i ) = one
+ 10 CONTINUE
+ GO TO 210
+ END IF
+*
+ IF( lsame( job, 'S' ) )
+ $ GO TO 120
+*
+* Permutation to isolate eigenvalues if possible
+*
+ GO TO 50
+*
+* Row and column exchange.
+*
+ 20 CONTINUE
+ scale( m ) = j
+ IF( j.EQ.m )
+ $ GO TO 30
+*
+ CALL zswap( l, a( 1, j ), 1, a( 1, m ), 1 )
+ CALL zswap( n-k+1, a( j, k ), lda, a( m, k ), lda )
+*
+ 30 CONTINUE
+ GO TO ( 40, 80 )iexc
+*
+* Search for rows isolating an eigenvalue and push them down.
+*
+ 40 CONTINUE
+ IF( l.EQ.1 )
+ $ GO TO 210
+ l = l - 1
+*
+ 50 CONTINUE
+ DO 70 j = l, 1, -1
+*
+ DO 60 i = 1, l
+ IF( i.EQ.j )
+ $ GO TO 60
+ IF( dble( a( j, i ) ).NE.zero .OR. dimag( a( j, i ) ).NE.
+ $ zero )GO TO 70
+ 60 CONTINUE
+*
+ m = l
+ iexc = 1
+ GO TO 20
+ 70 CONTINUE
+*
+ GO TO 90
+*
+* Search for columns isolating an eigenvalue and push them left.
+*
+ 80 CONTINUE
+ k = k + 1
+*
+ 90 CONTINUE
+ DO 110 j = k, l
+*
+ DO 100 i = k, l
+ IF( i.EQ.j )
+ $ GO TO 100
+ IF( dble( a( i, j ) ).NE.zero .OR. dimag( a( i, j ) ).NE.
+ $ zero )GO TO 110
+ 100 CONTINUE
+*
+ m = k
+ iexc = 2
+ GO TO 20
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ DO 130 i = k, l
+ scale( i ) = one
+ 130 CONTINUE
+*
+ IF( lsame( job, 'P' ) )
+ $ GO TO 210
+*
+* Balance the submatrix in rows K to L.
+*
+* Iterative loop for norm reduction
+*
+ sfmin1 = dlamch( 'S' ) / dlamch( 'P' )
+ sfmax1 = one / sfmin1
+ sfmin2 = sfmin1*sclfac
+ sfmax2 = one / sfmin2
+ 140 CONTINUE
+ noconv = .false.
+*
+ DO 200 i = k, l
+*
+ c = dznrm2( l-k+1, a( k, i ), 1 )
+ r = dznrm2( l-k+1, a( i, k ), lda )
+ ica = izamax( l, a( 1, i ), 1 )
+ ca = abs( a( ica, i ) )
+ ira = izamax( n-k+1, a( i, k ), lda )
+ ra = abs( a( i, ira+k-1 ) )
+*
+* Guard against zero C or R due to underflow.
+*
+ IF( c.EQ.zero .OR. r.EQ.zero )
+ $ GO TO 200
+ g = r / sclfac
+ f = one
+ s = c + r
+ 160 CONTINUE
+ IF( c.GE.g .OR. max( f, c, ca ).GE.sfmax2 .OR.
+ $ min( r, g, ra ).LE.sfmin2 )GO TO 170
+ IF( disnan( c+f+ca+r+g+ra ) ) THEN
+*
+* Exit if NaN to avoid infinite loop
+*
+ info = -3
+ CALL xerbla( 'ZGEBAL', -info )
+ RETURN
+ END IF
+ f = f*sclfac
+ c = c*sclfac
+ ca = ca*sclfac
+ r = r / sclfac
+ g = g / sclfac
+ ra = ra / sclfac
+ GO TO 160
+*
+ 170 CONTINUE
+ g = c / sclfac
+ 180 CONTINUE
+ IF( g.LT.r .OR. max( r, ra ).GE.sfmax2 .OR.
+ $ min( f, c, g, ca ).LE.sfmin2 )GO TO 190
+ f = f / sclfac
+ c = c / sclfac
+ g = g / sclfac
+ ca = ca / sclfac
+ r = r*sclfac
+ ra = ra*sclfac
+ GO TO 180
+*
+* Now balance.
+*
+ 190 CONTINUE
+ IF( ( c+r ).GE.factor*s )
+ $ GO TO 200
+ IF( f.LT.one .AND. scale( i ).LT.one ) THEN
+ IF( f*scale( i ).LE.sfmin1 )
+ $ GO TO 200
+ END IF
+ IF( f.GT.one .AND. scale( i ).GT.one ) THEN
+ IF( scale( i ).GE.sfmax1 / f )
+ $ GO TO 200
+ END IF
+ g = one / f
+ scale( i ) = scale( i )*f
+ noconv = .true.
+*
+ CALL zdscal( n-k+1, g, a( i, k ), lda )
+ CALL zdscal( l, f, a( 1, i ), 1 )
+*
+ 200 CONTINUE
+*
+ IF( noconv )
+ $ GO TO 140
+*
+ 210 CONTINUE
+ ilo = k
+ ihi = l
+*
+ RETURN
+*
+* End of ZGEBAL
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGEHD2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
+*> by a unitary similarity transformation: Q**H * A * Q = H .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*>
+*> It is assumed that A is already upper triangular in rows
+*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*> set by a previous call to ZGEBAL; otherwise they should be
+*> set to 1 and N respectively. See Further Details.
+*> 1 <= ILO <= IHI <= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the n by n general matrix to be reduced.
+*> On exit, the upper triangle and the first subdiagonal of A
+*> are overwritten with the upper Hessenberg matrix H, and the
+*> elements below the first subdiagonal, with the array TAU,
+*> represent the unitary matrix Q as a product of elementary
+*> reflectors. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (N-1)
+*> The scalar factors of the elementary reflectors (see Further
+*> Details).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16GEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix Q is represented as a product of (ihi-ilo) elementary
+*> reflectors
+*>
+*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*>
+*> Each H(i) has the form
+*>
+*> H(i) = I - tau * v * v**H
+*>
+*> where tau is a complex scalar, and v is a complex vector with
+*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+*> exit in A(i+2:ihi,i), and tau in TAU(i).
+*>
+*> The contents of A are illustrated by the following example, with
+*> n = 7, ilo = 2 and ihi = 6:
+*>
+*> on entry, on exit,
+*>
+*> ( a a a a a a a ) ( a a h h h h a )
+*> ( a a a a a a ) ( a h h h h a )
+*> ( a a a a a a ) ( h h h h h h )
+*> ( a a a a a a ) ( v2 h h h h h )
+*> ( a a a a a a ) ( v2 v3 h h h h )
+*> ( a a a a a a ) ( v2 v3 v4 h h h )
+*> ( a ) ( a )
+*>
+*> where a denotes an element of the original matrix A, h denotes a
+*> modified element of the upper Hessenberg matrix H, and vi denotes an
+*> element of the vector defining H(i).
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zgehd2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ parameter( one = ( 1.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ COMPLEX*16 ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zlarf, zlarfg
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg, max, min
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ info = 0
+ IF( n.LT.0 ) THEN
+ info = -1
+ ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
+ info = -2
+ ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
+ info = -3
+ ELSE IF( lda.LT.max( 1, n ) ) THEN
+ info = -5
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZGEHD2', -info )
+ RETURN
+ END IF
+*
+ DO 10 i = ilo, ihi - 1
+*
+* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
+*
+ alpha = a( i+1, i )
+ CALL zlarfg( ihi-i, alpha, a( min( i+2, n ), i ), 1, tau( i ) )
+ a( i+1, i ) = one
+*
+* Apply H(i) to A(1:ihi,i+1:ihi) from the right
+*
+ CALL zlarf( 'Right', ihi, ihi-i, a( i+1, i ), 1, tau( i ),
+ $ a( 1, i+1 ), lda, work )
+*
+* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left
+*
+ CALL zlarf( 'Left', ihi-i, n-i, a( i+1, i ), 1,
+ $ dconjg( tau( i ) ), a( i+1, i+1 ), lda, work )
+*
+ a( i+1, i ) = alpha
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of ZGEHD2
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZGEHRD
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGEHRD + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by
+*> an unitary similarity transformation: Q**H * A * Q = H .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*>
+*> It is assumed that A is already upper triangular in rows
+*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*> set by a previous call to ZGEBAL; otherwise they should be
+*> set to 1 and N respectively. See Further Details.
+*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the N-by-N general matrix to be reduced.
+*> On exit, the upper triangle and the first subdiagonal of A
+*> are overwritten with the upper Hessenberg matrix H, and the
+*> elements below the first subdiagonal, with the array TAU,
+*> represent the unitary matrix Q as a product of elementary
+*> reflectors. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (N-1)
+*> The scalar factors of the elementary reflectors (see Further
+*> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
+*> zero.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of the array WORK. LWORK >= max(1,N).
+*> For good performance, LWORK should generally be larger.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16GEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix Q is represented as a product of (ihi-ilo) elementary
+*> reflectors
+*>
+*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*>
+*> Each H(i) has the form
+*>
+*> H(i) = I - tau * v * v**H
+*>
+*> where tau is a complex scalar, and v is a complex vector with
+*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+*> exit in A(i+2:ihi,i), and tau in TAU(i).
+*>
+*> The contents of A are illustrated by the following example, with
+*> n = 7, ilo = 2 and ihi = 6:
+*>
+*> on entry, on exit,
+*>
+*> ( a a a a a a a ) ( a a h h h h a )
+*> ( a a a a a a ) ( a h h h h a )
+*> ( a a a a a a ) ( h h h h h h )
+*> ( a a a a a a ) ( v2 h h h h h )
+*> ( a a a a a a ) ( v2 v3 h h h h )
+*> ( a a a a a a ) ( v2 v3 v4 h h h )
+*> ( a ) ( a )
+*>
+*> where a denotes an element of the original matrix A, h denotes a
+*> modified element of the upper Hessenberg matrix H, and vi denotes an
+*> element of the vector defining H(i).
+*>
+*> This file is a slight modification of LAPACK-3.0's DGEHRD
+*> subroutine incorporating improvements proposed by Quintana-Orti and
+*> Van de Geijn (2006). (See DLAHR2.)
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zgehrd( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT, TSIZE
+ parameter( nbmax = 64, ldt = nbmax+1,
+ $ tsize = ldt*nbmax )
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d+0, 0.0d+0 ),
+ $ one = ( 1.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB,
+ $ nbmin, nh, nx
+ COMPLEX*16 EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL zaxpy, zgehd2, zgemm, zlahr2, zlarfb, ztrmm,
+ $ xerbla
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC max, min
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ilaenv
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ info = 0
+ lquery = ( lwork.EQ.-1 )
+ IF( n.LT.0 ) THEN
+ info = -1
+ ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
+ info = -2
+ ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
+ info = -3
+ ELSE IF( lda.LT.max( 1, n ) ) THEN
+ info = -5
+ ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
+ info = -8
+ END IF
+*
+ IF( info.EQ.0 ) THEN
+*
+* Compute the workspace requirements
+*
+ nb = min( nbmax, ilaenv( 1, 'ZGEHRD', ' ', n, ilo, ihi, -1 ) )
+ lwkopt = n*nb + tsize
+ work( 1 ) = lwkopt
+ ENDIF
+*
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZGEHRD', -info )
+ RETURN
+ ELSE IF( lquery ) THEN
+ RETURN
+ END IF
+*
+* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
+*
+ DO 10 i = 1, ilo - 1
+ tau( i ) = zero
+ 10 CONTINUE
+ DO 20 i = max( 1, ihi ), n - 1
+ tau( i ) = zero
+ 20 CONTINUE
+*
+* Quick return if possible
+*
+ nh = ihi - ilo + 1
+ IF( nh.LE.1 ) THEN
+ work( 1 ) = 1
+ RETURN
+ END IF
+*
+* Determine the block size
+*
+ nb = min( nbmax, ilaenv( 1, 'ZGEHRD', ' ', n, ilo, ihi, -1 ) )
+ nbmin = 2
+ IF( nb.GT.1 .AND. nb.LT.nh ) THEN
+*
+* Determine when to cross over from blocked to unblocked code
+* (last block is always handled by unblocked code)
+*
+ nx = max( nb, ilaenv( 3, 'ZGEHRD', ' ', n, ilo, ihi, -1 ) )
+ IF( nx.LT.nh ) THEN
+*
+* Determine if workspace is large enough for blocked code
+*
+ IF( lwork.LT.n*nb+tsize ) THEN
+*
+* Not enough workspace to use optimal NB: determine the
+* minimum value of NB, and reduce NB or force use of
+* unblocked code
+*
+ nbmin = max( 2, ilaenv( 2, 'ZGEHRD', ' ', n, ilo, ihi,
+ $ -1 ) )
+ IF( lwork.GE.(n*nbmin + tsize) ) THEN
+ nb = (lwork-tsize) / n
+ ELSE
+ nb = 1
+ END IF
+ END IF
+ END IF
+ END IF
+ ldwork = n
+*
+ IF( nb.LT.nbmin .OR. nb.GE.nh ) THEN
+*
+* Use unblocked code below
+*
+ i = ilo
+*
+ ELSE
+*
+* Use blocked code
+*
+ iwt = 1 + n*nb
+ DO 40 i = ilo, ihi - 1 - nx, nb
+ ib = min( nb, ihi-i )
+*
+* Reduce columns i:i+ib-1 to Hessenberg form, returning the
+* matrices V and T of the block reflector H = I - V*T*V**H
+* which performs the reduction, and also the matrix Y = A*V*T
+*
+ CALL zlahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),
+ $ work( iwt ), ldt, work, ldwork )
+*
+* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
+* right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set
+* to 1
+*
+ ei = a( i+ib, i+ib-1 )
+ a( i+ib, i+ib-1 ) = one
+ CALL zgemm( 'No transpose', 'Conjugate transpose',
+ $ ihi, ihi-i-ib+1,
+ $ ib, -one, work, ldwork, a( i+ib, i ), lda, one,
+ $ a( 1, i+ib ), lda )
+ a( i+ib, i+ib-1 ) = ei
+*
+* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
+* right
+*
+ CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose',
+ $ 'Unit', i, ib-1,
+ $ one, a( i+1, i ), lda, work, ldwork )
+ DO 30 j = 0, ib-2
+ CALL zaxpy( i, -one, work( ldwork*j+1 ), 1,
+ $ a( 1, i+j+1 ), 1 )
+ 30 CONTINUE
+*
+* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
+* left
+*
+ CALL zlarfb( 'Left', 'Conjugate transpose', 'Forward',
+ $ 'Columnwise',
+ $ ihi-i, n-i-ib+1, ib, a( i+1, i ), lda,
+ $ work( iwt ), ldt, a( i+1, i+ib ), lda,
+ $ work, ldwork )
+ 40 CONTINUE
+ END IF
+*
+* Use unblocked code to reduce the rest of the matrix
+*
+ CALL zgehd2( n, i, ihi, a, lda, tau, work, iinfo )
+ work( 1 ) = lwkopt
+*
+ RETURN
+*
+* End of ZGEHRD
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZHSEQR
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHSEQR + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
+* CHARACTER COMPZ, JOB
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHSEQR computes the eigenvalues of a Hessenberg matrix H
+*> and, optionally, the matrices T and Z from the Schur decomposition
+*> H = Z T Z**H, where T is an upper triangular matrix (the
+*> Schur form), and Z is the unitary matrix of Schur vectors.
+*>
+*> Optionally Z may be postmultiplied into an input unitary
+*> matrix Q so that this routine can give the Schur factorization
+*> of a matrix A which has been reduced to the Hessenberg form H
+*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOB
+*> \verbatim
+*> JOB is CHARACTER*1
+*> = 'E': compute eigenvalues only;
+*> = 'S': compute eigenvalues and the Schur form T.
+*> \endverbatim
+*>
+*> \param[in] COMPZ
+*> \verbatim
+*> COMPZ is CHARACTER*1
+*> = 'N': no Schur vectors are computed;
+*> = 'I': Z is initialized to the unit matrix and the matrix Z
+*> of Schur vectors of H is returned;
+*> = 'V': Z must contain an unitary matrix Q on entry, and
+*> the product Q*Z is returned.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix H. N .GE. 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*>
+*> It is assumed that H is already upper triangular in rows
+*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*> set by a previous call to ZGEBAL, and then passed to ZGEHRD
+*> when the matrix output by ZGEBAL is reduced to Hessenberg
+*> form. Otherwise ILO and IHI should be set to 1 and N
+*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*> If N = 0, then ILO = 1 and IHI = 0.
+*> \endverbatim
+*>
+*> \param[in,out] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> On entry, the upper Hessenberg matrix H.
+*> On exit, if INFO = 0 and JOB = 'S', H contains the upper
+*> triangular matrix T from the Schur decomposition (the
+*> Schur form). If INFO = 0 and JOB = 'E', the contents of
+*> H are unspecified on exit. (The output value of H when
+*> INFO.GT.0 is given under the description of INFO below.)
+*>
+*> Unlike earlier versions of ZHSEQR, this subroutine may
+*> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
+*> or j = IHI+1, IHI+2, ... N.
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> The leading dimension of the array H. LDH .GE. max(1,N).
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (N)
+*> The computed eigenvalues. If JOB = 'S', the eigenvalues are
+*> stored in the same order as on the diagonal of the Schur
+*> form returned in H, with W(i) = H(i,i).
+*> \endverbatim
+*>
+*> \param[in,out] Z
+*> \verbatim
+*> Z is COMPLEX*16 array, dimension (LDZ,N)
+*> If COMPZ = 'N', Z is not referenced.
+*> If COMPZ = 'I', on entry Z need not be set and on exit,
+*> if INFO = 0, Z contains the unitary matrix Z of the Schur
+*> vectors of H. If COMPZ = 'V', on entry Z must contain an
+*> N-by-N matrix Q, which is assumed to be equal to the unit
+*> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
+*> if INFO = 0, Z contains Q*Z.
+*> Normally Q is the unitary matrix generated by ZUNGHR
+*> after the call to ZGEHRD which formed the Hessenberg matrix
+*> H. (The output value of Z when INFO.GT.0 is given under
+*> the description of INFO below.)
+*> \endverbatim
+*>
+*> \param[in] LDZ
+*> \verbatim
+*> LDZ is INTEGER
+*> The leading dimension of the array Z. if COMPZ = 'I' or
+*> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> On exit, if INFO = 0, WORK(1) returns an estimate of
+*> the optimal value for LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK .GE. max(1,N)
+*> is sufficient and delivers very good and sometimes
+*> optimal performance. However, LWORK as large as 11*N
+*> may be required for optimal performance. A workspace
+*> query is recommended to determine the optimal workspace
+*> size.
+*>
+*> If LWORK = -1, then ZHSEQR does a workspace query.
+*> In this case, ZHSEQR checks the input parameters and
+*> estimates the optimal workspace size for the given
+*> values of N, ILO and IHI. The estimate is returned
+*> in WORK(1). No error message related to LWORK is
+*> issued by XERBLA. Neither H nor Z are accessed.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> .LT. 0: if INFO = -i, the i-th argument had an illegal
+*> value
+*> .GT. 0: if INFO = i, ZHSEQR failed to compute all of
+*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+*> and WI contain those eigenvalues which have been
+*> successfully computed. (Failures are rare.)
+*>
+*> If INFO .GT. 0 and JOB = 'E', then on exit, the
+*> remaining unconverged eigenvalues are the eigen-
+*> values of the upper Hessenberg matrix rows and
+*> columns ILO through INFO of the final, output
+*> value of H.
+*>
+*> If INFO .GT. 0 and JOB = 'S', then on exit
+*>
+*> (*) (initial value of H)*U = U*(final value of H)
+*>
+*> where U is a unitary matrix. The final
+*> value of H is upper Hessenberg and triangular in
+*> rows and columns INFO+1 through IHI.
+*>
+*> If INFO .GT. 0 and COMPZ = 'V', then on exit
+*>
+*> (final value of Z) = (initial value of Z)*U
+*>
+*> where U is the unitary matrix in (*) (regard-
+*> less of the value of JOB.)
+*>
+*> If INFO .GT. 0 and COMPZ = 'I', then on exit
+*> (final value of Z) = U
+*> where U is the unitary matrix in (*) (regard-
+*> less of the value of JOB.)
+*>
+*> If INFO .GT. 0 and COMPZ = 'N', then Z is not
+*> accessed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> Karen Braman and Ralph Byers, Department of Mathematics,
+*> University of Kansas, USA
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Default values supplied by
+*> ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
+*> It is suggested that these defaults be adjusted in order
+*> to attain best performance in each particular
+*> computational environment.
+*>
+*> ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.
+*> Default: 75. (Must be at least 11.)
+*>
+*> ISPEC=13: Recommended deflation window size.
+*> This depends on ILO, IHI and NS. NS is the
+*> number of simultaneous shifts returned
+*> by ILAENV(ISPEC=15). (See ISPEC=15 below.)
+*> The default for (IHI-ILO+1).LE.500 is NS.
+*> The default for (IHI-ILO+1).GT.500 is 3*NS/2.
+*>
+*> ISPEC=14: Nibble crossover point. (See IPARMQ for
+*> details.) Default: 14% of deflation window
+*> size.
+*>
+*> ISPEC=15: Number of simultaneous shifts in a multishift
+*> QR iteration.
+*>
+*> If IHI-ILO+1 is ...
+*>
+*> greater than ...but less ... the
+*> or equal to ... than default is
+*>
+*> 1 30 NS = 2(+)
+*> 30 60 NS = 4(+)
+*> 60 150 NS = 10(+)
+*> 150 590 NS = **
+*> 590 3000 NS = 64
+*> 3000 6000 NS = 128
+*> 6000 infinity NS = 256
+*>
+*> (+) By default some or all matrices of this order
+*> are passed to the implicit double shift routine
+*> ZLAHQR and this parameter is ignored. See
+*> ISPEC=12 above and comments in IPARMQ for
+*> details.
+*>
+*> (**) The asterisks (**) indicate an ad-hoc
+*> function of N increasing from 10 to 64.
+*>
+*> ISPEC=16: Select structured matrix multiply.
+*> If the number of simultaneous shifts (specified
+*> by ISPEC=15) is less than 14, then the default
+*> for ISPEC=16 is 0. Otherwise the default for
+*> ISPEC=16 is 2.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*> 929--947, 2002.
+*> \n
+*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*> of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+* =====================================================================
+ SUBROUTINE zhseqr( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
+ CHARACTER COMPZ, JOB
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), W( * ), WORK( * ), Z( ldz, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . ZLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+ INTEGER NTINY
+ parameter( ntiny = 11 )
+*
+* ==== NL allocates some local workspace to help small matrices
+* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is
+* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom-
+* . mended. (The default value of NMIN is 75.) Using NL = 49
+* . allows up to six simultaneous shifts and a 16-by-16
+* . deflation window. ====
+ INTEGER NL
+ parameter( nl = 49 )
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d0, 0.0d0 ),
+ $ one = ( 1.0d0, 0.0d0 ) )
+ DOUBLE PRECISION RZERO
+ parameter( rzero = 0.0d0 )
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 HL( nl, nl ), WORKL( nl )
+* ..
+* .. Local Scalars ..
+ INTEGER KBOT, NMIN
+ LOGICAL INITZ, LQUERY, WANTT, WANTZ
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ LOGICAL LSAME
+ EXTERNAL ilaenv, lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zcopy, zlacpy, zlahqr, zlaqr0, zlaset
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dble, dcmplx, max, min
+* ..
+* .. Executable Statements ..
+*
+* ==== Decode and check the input parameters. ====
+*
+ wantt = lsame( job, 'S' )
+ initz = lsame( compz, 'I' )
+ wantz = initz .OR. lsame( compz, 'V' )
+ work( 1 ) = dcmplx( dble( max( 1, n ) ), rzero )
+ lquery = lwork.EQ.-1
+*
+ info = 0
+ IF( .NOT.lsame( job, 'E' ) .AND. .NOT.wantt ) THEN
+ info = -1
+ ELSE IF( .NOT.lsame( compz, 'N' ) .AND. .NOT.wantz ) THEN
+ info = -2
+ ELSE IF( n.LT.0 ) THEN
+ info = -3
+ ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
+ info = -4
+ ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
+ info = -5
+ ELSE IF( ldh.LT.max( 1, n ) ) THEN
+ info = -7
+ ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.max( 1, n ) ) ) THEN
+ info = -10
+ ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
+ info = -12
+ END IF
+*
+ IF( info.NE.0 ) THEN
+*
+* ==== Quick return in case of invalid argument. ====
+*
+ CALL xerbla( 'ZHSEQR', -info )
+ RETURN
+*
+ ELSE IF( n.EQ.0 ) THEN
+*
+* ==== Quick return in case N = 0; nothing to do. ====
+*
+ RETURN
+*
+ ELSE IF( lquery ) THEN
+*
+* ==== Quick return in case of a workspace query ====
+*
+ CALL zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z,
+ $ ldz, work, lwork, info )
+* ==== Ensure reported workspace size is backward-compatible with
+* . previous LAPACK versions. ====
+ work( 1 ) = dcmplx( max( dble( work( 1 ) ), dble( max( 1,
+ $ n ) ) ), rzero )
+ RETURN
+*
+ ELSE
+*
+* ==== copy eigenvalues isolated by ZGEBAL ====
+*
+ IF( ilo.GT.1 )
+ $ CALL zcopy( ilo-1, h, ldh+1, w, 1 )
+ IF( ihi.LT.n )
+ $ CALL zcopy( n-ihi, h( ihi+1, ihi+1 ), ldh+1, w( ihi+1 ), 1 )
+*
+* ==== Initialize Z, if requested ====
+*
+ IF( initz )
+ $ CALL zlaset( 'A', n, n, zero, one, z, ldz )
+*
+* ==== Quick return if possible ====
+*
+ IF( ilo.EQ.ihi ) THEN
+ w( ilo ) = h( ilo, ilo )
+ RETURN
+ END IF
+*
+* ==== ZLAHQR/ZLAQR0 crossover point ====
+*
+ nmin = ilaenv( 12, 'ZHSEQR', job( : 1 ) // compz( : 1 ), n,
+ $ ilo, ihi, lwork )
+ nmin = max( ntiny, nmin )
+*
+* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ====
+*
+ IF( n.GT.nmin ) THEN
+ CALL zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,
+ $ z, ldz, work, lwork, info )
+ ELSE
+*
+* ==== Small matrix ====
+*
+ CALL zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,
+ $ z, ldz, info )
+*
+ IF( info.GT.0 ) THEN
+*
+* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds
+* . when ZLAHQR fails. ====
+*
+ kbot = info
+*
+ IF( n.GE.nl ) THEN
+*
+* ==== Larger matrices have enough subdiagonal scratch
+* . space to call ZLAQR0 directly. ====
+*
+ CALL zlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,
+ $ ilo, ihi, z, ldz, work, lwork, info )
+*
+ ELSE
+*
+* ==== Tiny matrices don't have enough subdiagonal
+* . scratch space to benefit from ZLAQR0. Hence,
+* . tiny matrices must be copied into a larger
+* . array before calling ZLAQR0. ====
+*
+ CALL zlacpy( 'A', n, n, h, ldh, hl, nl )
+ hl( n+1, n ) = zero
+ CALL zlaset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),
+ $ nl )
+ CALL zlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,
+ $ ilo, ihi, z, ldz, workl, nl, info )
+ IF( wantt .OR. info.NE.0 )
+ $ CALL zlacpy( 'A', n, n, hl, nl, h, ldh )
+ END IF
+ END IF
+ END IF
+*
+* ==== Clear out the trash, if necessary. ====
+*
+ IF( ( wantt .OR. info.NE.0 ) .AND. n.GT.2 )
+ $ CALL zlaset( 'L', n-2, n-2, zero, zero, h( 3, 1 ), ldh )
+*
+* ==== Ensure reported workspace size is backward-compatible with
+* . previous LAPACK versions. ====
+*
+ work( 1 ) = dcmplx( max( dble( max( 1, n ) ),
+ $ dble( work( 1 ) ) ), rzero )
+ END IF
+*
+* ==== End of ZHSEQR ====
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZLACGV conjugates a complex vector.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLACGV + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLACGV( N, X, INCX )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 X( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLACGV conjugates a complex vector of length N.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The length of the vector X. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension
+*> (1+(N-1)*abs(INCX))
+*> On entry, the vector of length N to be conjugated.
+*> On exit, X is overwritten with conjg(X).
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> The spacing between successive elements of X.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zlacgv( N, X, INCX )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 X( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IOFF
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg
+* ..
+* .. Executable Statements ..
+*
+ IF( incx.EQ.1 ) THEN
+ DO 10 i = 1, n
+ x( i ) = dconjg( x( i ) )
+ 10 CONTINUE
+ ELSE
+ ioff = 1
+ IF( incx.LT.0 )
+ $ ioff = 1 - ( n-1 )*incx
+ DO 20 i = 1, n
+ x( ioff ) = dconjg( x( ioff ) )
+ ioff = ioff + incx
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of ZLACGV
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLACPY copies all or part of one two-dimensional array to another.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLACPY + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDB, M, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), B( LDB, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLACPY copies all or part of a two-dimensional matrix A to another
+*> matrix B.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies the part of the matrix A to be copied to B.
+*> = 'U': Upper triangular part
+*> = 'L': Lower triangular part
+*> Otherwise: All of the matrix A
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The m by n matrix A. If UPLO = 'U', only the upper trapezium
+*> is accessed; if UPLO = 'L', only the lower trapezium is
+*> accessed.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,N)
+*> On exit, B = A in the locations specified by UPLO.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,M).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zlacpy( UPLO, M, N, A, LDA, B, LDB )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDB, M, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), B( ldb, * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC min
+* ..
+* .. Executable Statements ..
+*
+ IF( lsame( uplo, 'U' ) ) THEN
+ DO 20 j = 1, n
+ DO 10 i = 1, min( j, m )
+ b( i, j ) = a( i, j )
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ ELSE IF( lsame( uplo, 'L' ) ) THEN
+ DO 40 j = 1, n
+ DO 30 i = j, m
+ b( i, j ) = a( i, j )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+ ELSE
+ DO 60 j = 1, n
+ DO 50 i = 1, m
+ b( i, j ) = a( i, j )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZLACPY
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLADIV + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* COMPLEX*16 FUNCTION ZLADIV( X, Y )
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 X, Y
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
+*> will not overflow on an intermediary step unless the results
+*> overflows.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] X
+*> \verbatim
+*> X is COMPLEX*16
+*> \endverbatim
+*>
+*> \param[in] Y
+*> \verbatim
+*> Y is COMPLEX*16
+*> The complex scalars X and Y.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ COMPLEX*16 FUNCTION zladiv( X, Y )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 X, Y
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION ZI, ZR
+* ..
+* .. External Subroutines ..
+ EXTERNAL dladiv
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dble, dcmplx, dimag
+* ..
+* .. Executable Statements ..
+*
+ CALL dladiv( dble( x ), dimag( x ), dble( y ), dimag( y ), zr,
+ $ zi )
+ zladiv = dcmplx( zr, zi )
+*
+ RETURN
+*
+* End of ZLADIV
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAHQR + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+* IHIZ, Z, LDZ, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+* LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAHQR is an auxiliary routine called by CHSEQR to update the
+*> eigenvalues and Schur decomposition already computed by CHSEQR, by
+*> dealing with the Hessenberg submatrix in rows and columns ILO to
+*> IHI.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] WANTT
+*> \verbatim
+*> WANTT is LOGICAL
+*> = .TRUE. : the full Schur form T is required;
+*> = .FALSE.: only eigenvalues are required.
+*> \endverbatim
+*>
+*> \param[in] WANTZ
+*> \verbatim
+*> WANTZ is LOGICAL
+*> = .TRUE. : the matrix of Schur vectors Z is required;
+*> = .FALSE.: Schur vectors are not required.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix H. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*> It is assumed that H is already upper triangular in rows and
+*> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
+*> ZLAHQR works primarily with the Hessenberg submatrix in rows
+*> and columns ILO to IHI, but applies transformations to all of
+*> H if WANTT is .TRUE..
+*> 1 <= ILO <= max(1,IHI); IHI <= N.
+*> \endverbatim
+*>
+*> \param[in,out] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> On entry, the upper Hessenberg matrix H.
+*> On exit, if INFO is zero and if WANTT is .TRUE., then H
+*> is upper triangular in rows and columns ILO:IHI. If INFO
+*> is zero and if WANTT is .FALSE., then the contents of H
+*> are unspecified on exit. The output state of H in case
+*> INF is positive is below under the description of INFO.
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> The leading dimension of the array H. LDH >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (N)
+*> The computed eigenvalues ILO to IHI are stored in the
+*> corresponding elements of W. If WANTT is .TRUE., the
+*> eigenvalues are stored in the same order as on the diagonal
+*> of the Schur form returned in H, with W(i) = H(i,i).
+*> \endverbatim
+*>
+*> \param[in] ILOZ
+*> \verbatim
+*> ILOZ is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHIZ
+*> \verbatim
+*> IHIZ is INTEGER
+*> Specify the rows of Z to which transformations must be
+*> applied if WANTZ is .TRUE..
+*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
+*> \endverbatim
+*>
+*> \param[in,out] Z
+*> \verbatim
+*> Z is COMPLEX*16 array, dimension (LDZ,N)
+*> If WANTZ is .TRUE., on entry Z must contain the current
+*> matrix Z of transformations accumulated by CHSEQR, and on
+*> exit Z has been updated; transformations are applied only to
+*> the submatrix Z(ILOZ:IHIZ,ILO:IHI).
+*> If WANTZ is .FALSE., Z is not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDZ
+*> \verbatim
+*> LDZ is INTEGER
+*> The leading dimension of the array Z. LDZ >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> .GT. 0: if INFO = i, ZLAHQR failed to compute all the
+*> eigenvalues ILO to IHI in a total of 30 iterations
+*> per eigenvalue; elements i+1:ihi of W contain
+*> those eigenvalues which have been successfully
+*> computed.
+*>
+*> If INFO .GT. 0 and WANTT is .FALSE., then on exit,
+*> the remaining unconverged eigenvalues are the
+*> eigenvalues of the upper Hessenberg matrix
+*> rows and columns ILO thorugh INFO of the final,
+*> output value of H.
+*>
+*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*> (*) (initial value of H)*U = U*(final value of H)
+*> where U is an orthognal matrix. The final
+*> value of H is upper Hessenberg and triangular in
+*> rows and columns INFO+1 through IHI.
+*>
+*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*> (final value of Z) = (initial value of Z)*U
+*> where U is the orthogonal matrix in (*)
+*> (regardless of the value of WANTT.)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> 02-96 Based on modifications by
+*> David Day, Sandia National Laboratory, USA
+*>
+*> 12-04 Further modifications by
+*> Ralph Byers, University of Kansas, USA
+*> This is a modified version of ZLAHQR from LAPACK version 3.0.
+*> It is (1) more robust against overflow and underflow and
+*> (2) adopts the more conservative Ahues & Tisseur stopping
+*> criterion (LAWN 122, 1997).
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zlahqr( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+ $ IHIZ, Z, LDZ, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), W( * ), Z( ldz, * )
+* ..
+*
+* =========================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d0, 0.0d0 ),
+ $ one = ( 1.0d0, 0.0d0 ) )
+ DOUBLE PRECISION RZERO, RONE, HALF
+ parameter( rzero = 0.0d0, rone = 1.0d0, half = 0.5d0 )
+ DOUBLE PRECISION DAT1
+ parameter( dat1 = 3.0d0 / 4.0d0 )
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
+ $ v2, x, y
+ DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
+ $ safmin, smlnum, sx, t2, tst, ulp
+ INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M,
+ $ nh, nz
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 V( 2 )
+* ..
+* .. External Functions ..
+ COMPLEX*16 ZLADIV
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL zladiv, dlamch
+* ..
+* .. External Subroutines ..
+ EXTERNAL dlabad, zcopy, zlarfg, zscal
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dconjg, dimag, max, min, sqrt
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+*
+ info = 0
+*
+* Quick return if possible
+*
+ IF( n.EQ.0 )
+ $ RETURN
+ IF( ilo.EQ.ihi ) THEN
+ w( ilo ) = h( ilo, ilo )
+ RETURN
+ END IF
+*
+* ==== clear out the trash ====
+ DO 10 j = ilo, ihi - 3
+ h( j+2, j ) = zero
+ h( j+3, j ) = zero
+ 10 CONTINUE
+ IF( ilo.LE.ihi-2 )
+ $ h( ihi, ihi-2 ) = zero
+* ==== ensure that subdiagonal entries are real ====
+ IF( wantt ) THEN
+ jlo = 1
+ jhi = n
+ ELSE
+ jlo = ilo
+ jhi = ihi
+ END IF
+ DO 20 i = ilo + 1, ihi
+ IF( dimag( h( i, i-1 ) ).NE.rzero ) THEN
+* ==== The following redundant normalization
+* . avoids problems with both gradual and
+* . sudden underflow in ABS(H(I,I-1)) ====
+ sc = h( i, i-1 ) / cabs1( h( i, i-1 ) )
+ sc = dconjg( sc ) / abs( sc )
+ h( i, i-1 ) = abs( h( i, i-1 ) )
+ CALL zscal( jhi-i+1, sc, h( i, i ), ldh )
+ CALL zscal( min( jhi, i+1 )-jlo+1, dconjg( sc ),
+ $ h( jlo, i ), 1 )
+ IF( wantz )
+ $ CALL zscal( ihiz-iloz+1, dconjg( sc ), z( iloz, i ), 1 )
+ END IF
+ 20 CONTINUE
+*
+ nh = ihi - ilo + 1
+ nz = ihiz - iloz + 1
+*
+* Set machine-dependent constants for the stopping criterion.
+*
+ safmin = dlamch( 'SAFE MINIMUM' )
+ safmax = rone / safmin
+ CALL dlabad( safmin, safmax )
+ ulp = dlamch( 'PRECISION' )
+ smlnum = safmin*( dble( nh ) / ulp )
+*
+* I1 and I2 are the indices of the first row and last column of H
+* to which transformations must be applied. If eigenvalues only are
+* being computed, I1 and I2 are set inside the main loop.
+*
+ IF( wantt ) THEN
+ i1 = 1
+ i2 = n
+ END IF
+*
+* ITMAX is the total number of QR iterations allowed.
+*
+ itmax = 30 * max( 10, nh )
+*
+* The main loop begins here. I is the loop index and decreases from
+* IHI to ILO in steps of 1. Each iteration of the loop works
+* with the active submatrix in rows and columns L to I.
+* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
+* H(L,L-1) is negligible so that the matrix splits.
+*
+ i = ihi
+ 30 CONTINUE
+ IF( i.LT.ilo )
+ $ GO TO 150
+*
+* Perform QR iterations on rows and columns ILO to I until a
+* submatrix of order 1 splits off at the bottom because a
+* subdiagonal element has become negligible.
+*
+ l = ilo
+ DO 130 its = 0, itmax
+*
+* Look for a single small subdiagonal element.
+*
+ DO 40 k = i, l + 1, -1
+ IF( cabs1( h( k, k-1 ) ).LE.smlnum )
+ $ GO TO 50
+ tst = cabs1( h( k-1, k-1 ) ) + cabs1( h( k, k ) )
+ IF( tst.EQ.zero ) THEN
+ IF( k-2.GE.ilo )
+ $ tst = tst + abs( dble( h( k-1, k-2 ) ) )
+ IF( k+1.LE.ihi )
+ $ tst = tst + abs( dble( h( k+1, k ) ) )
+ END IF
+* ==== The following is a conservative small subdiagonal
+* . deflation criterion due to Ahues & Tisseur (LAWN 122,
+* . 1997). It has better mathematical foundation and
+* . improves accuracy in some examples. ====
+ IF( abs( dble( h( k, k-1 ) ) ).LE.ulp*tst ) THEN
+ ab = max( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) )
+ ba = min( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) )
+ aa = max( cabs1( h( k, k ) ),
+ $ cabs1( h( k-1, k-1 )-h( k, k ) ) )
+ bb = min( cabs1( h( k, k ) ),
+ $ cabs1( h( k-1, k-1 )-h( k, k ) ) )
+ s = aa + ab
+ IF( ba*( ab / s ).LE.max( smlnum,
+ $ ulp*( bb*( aa / s ) ) ) )GO TO 50
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ l = k
+ IF( l.GT.ilo ) THEN
+*
+* H(L,L-1) is negligible
+*
+ h( l, l-1 ) = zero
+ END IF
+*
+* Exit from loop if a submatrix of order 1 has split off.
+*
+ IF( l.GE.i )
+ $ GO TO 140
+*
+* Now the active submatrix is in rows and columns L to I. If
+* eigenvalues only are being computed, only the active submatrix
+* need be transformed.
+*
+ IF( .NOT.wantt ) THEN
+ i1 = l
+ i2 = i
+ END IF
+*
+ IF( its.EQ.10 ) THEN
+*
+* Exceptional shift.
+*
+ s = dat1*abs( dble( h( l+1, l ) ) )
+ t = s + h( l, l )
+ ELSE IF( its.EQ.20 ) THEN
+*
+* Exceptional shift.
+*
+ s = dat1*abs( dble( h( i, i-1 ) ) )
+ t = s + h( i, i )
+ ELSE
+*
+* Wilkinson's shift.
+*
+ t = h( i, i )
+ u = sqrt( h( i-1, i ) )*sqrt( h( i, i-1 ) )
+ s = cabs1( u )
+ IF( s.NE.rzero ) THEN
+ x = half*( h( i-1, i-1 )-t )
+ sx = cabs1( x )
+ s = max( s, cabs1( x ) )
+ y = s*sqrt( ( x / s )**2+( u / s )**2 )
+ IF( sx.GT.rzero ) THEN
+ IF( dble( x / sx )*dble( y )+dimag( x / sx )*
+ $ dimag( y ).LT.rzero )y = -y
+ END IF
+ t = t - u*zladiv( u, ( x+y ) )
+ END IF
+ END IF
+*
+* Look for two consecutive small subdiagonal elements.
+*
+ DO 60 m = i - 1, l + 1, -1
+*
+* Determine the effect of starting the single-shift QR
+* iteration at row M, and see if this would make H(M,M-1)
+* negligible.
+*
+ h11 = h( m, m )
+ h22 = h( m+1, m+1 )
+ h11s = h11 - t
+ h21 = dble( h( m+1, m ) )
+ s = cabs1( h11s ) + abs( h21 )
+ h11s = h11s / s
+ h21 = h21 / s
+ v( 1 ) = h11s
+ v( 2 ) = h21
+ h10 = dble( h( m, m-1 ) )
+ IF( abs( h10 )*abs( h21 ).LE.ulp*
+ $ ( cabs1( h11s )*( cabs1( h11 )+cabs1( h22 ) ) ) )
+ $ GO TO 70
+ 60 CONTINUE
+ h11 = h( l, l )
+ h22 = h( l+1, l+1 )
+ h11s = h11 - t
+ h21 = dble( h( l+1, l ) )
+ s = cabs1( h11s ) + abs( h21 )
+ h11s = h11s / s
+ h21 = h21 / s
+ v( 1 ) = h11s
+ v( 2 ) = h21
+ 70 CONTINUE
+*
+* Single-shift QR step
+*
+ DO 120 k = m, i - 1
+*
+* The first iteration of this loop determines a reflection G
+* from the vector V and applies it from left and right to H,
+* thus creating a nonzero bulge below the subdiagonal.
+*
+* Each subsequent iteration determines a reflection G to
+* restore the Hessenberg form in the (K-1)th column, and thus
+* chases the bulge one step toward the bottom of the active
+* submatrix.
+*
+* V(2) is always real before the call to ZLARFG, and hence
+* after the call T2 ( = T1*V(2) ) is also real.
+*
+ IF( k.GT.m )
+ $ CALL zcopy( 2, h( k, k-1 ), 1, v, 1 )
+ CALL zlarfg( 2, v( 1 ), v( 2 ), 1, t1 )
+ IF( k.GT.m ) THEN
+ h( k, k-1 ) = v( 1 )
+ h( k+1, k-1 ) = zero
+ END IF
+ v2 = v( 2 )
+ t2 = dble( t1*v2 )
+*
+* Apply G from the left to transform the rows of the matrix
+* in columns K to I2.
+*
+ DO 80 j = k, i2
+ sum = dconjg( t1 )*h( k, j ) + t2*h( k+1, j )
+ h( k, j ) = h( k, j ) - sum
+ h( k+1, j ) = h( k+1, j ) - sum*v2
+ 80 CONTINUE
+*
+* Apply G from the right to transform the columns of the
+* matrix in rows I1 to min(K+2,I).
+*
+ DO 90 j = i1, min( k+2, i )
+ sum = t1*h( j, k ) + t2*h( j, k+1 )
+ h( j, k ) = h( j, k ) - sum
+ h( j, k+1 ) = h( j, k+1 ) - sum*dconjg( v2 )
+ 90 CONTINUE
+*
+ IF( wantz ) THEN
+*
+* Accumulate transformations in the matrix Z
+*
+ DO 100 j = iloz, ihiz
+ sum = t1*z( j, k ) + t2*z( j, k+1 )
+ z( j, k ) = z( j, k ) - sum
+ z( j, k+1 ) = z( j, k+1 ) - sum*dconjg( v2 )
+ 100 CONTINUE
+ END IF
+*
+ IF( k.EQ.m .AND. m.GT.l ) THEN
+*
+* If the QR step was started at row M > L because two
+* consecutive small subdiagonals were found, then extra
+* scaling must be performed to ensure that H(M,M-1) remains
+* real.
+*
+ temp = one - t1
+ temp = temp / abs( temp )
+ h( m+1, m ) = h( m+1, m )*dconjg( temp )
+ IF( m+2.LE.i )
+ $ h( m+2, m+1 ) = h( m+2, m+1 )*temp
+ DO 110 j = m, i
+ IF( j.NE.m+1 ) THEN
+ IF( i2.GT.j )
+ $ CALL zscal( i2-j, temp, h( j, j+1 ), ldh )
+ CALL zscal( j-i1, dconjg( temp ), h( i1, j ), 1 )
+ IF( wantz ) THEN
+ CALL zscal( nz, dconjg( temp ), z( iloz, j ),
+ $ 1 )
+ END IF
+ END IF
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+*
+* Ensure that H(I,I-1) is real.
+*
+ temp = h( i, i-1 )
+ IF( dimag( temp ).NE.rzero ) THEN
+ rtemp = abs( temp )
+ h( i, i-1 ) = rtemp
+ temp = temp / rtemp
+ IF( i2.GT.i )
+ $ CALL zscal( i2-i, dconjg( temp ), h( i, i+1 ), ldh )
+ CALL zscal( i-i1, temp, h( i1, i ), 1 )
+ IF( wantz ) THEN
+ CALL zscal( nz, temp, z( iloz, i ), 1 )
+ END IF
+ END IF
+*
+ 130 CONTINUE
+*
+* Failure to converge in remaining number of iterations
+*
+ info = i
+ RETURN
+*
+ 140 CONTINUE
+*
+* H(I,I-1) is negligible: one eigenvalue has converged.
+*
+ w( i ) = h( i, i )
+*
+* return to start of the main loop with new value of I.
+*
+ i = l - 1
+ GO TO 30
+*
+ 150 CONTINUE
+ RETURN
+*
+* End of ZLAHQR
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAHR2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+* .. Scalar Arguments ..
+* INTEGER K, LDA, LDT, LDY, N, NB
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
+* $ Y( LDY, NB )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
+*> matrix A so that elements below the k-th subdiagonal are zero. The
+*> reduction is performed by an unitary similarity transformation
+*> Q**H * A * Q. The routine returns the matrices V and T which determine
+*> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
+*>
+*> This is an auxiliary routine called by ZGEHRD.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The offset for the reduction. Elements below the k-th
+*> subdiagonal in the first NB columns are reduced to zero.
+*> K < N.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The number of columns to be reduced.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N-K+1)
+*> On entry, the n-by-(n-k+1) general matrix A.
+*> On exit, the elements on and above the k-th subdiagonal in
+*> the first NB columns are overwritten with the corresponding
+*> elements of the reduced matrix; the elements below the k-th
+*> subdiagonal, with the array TAU, represent the matrix Q as a
+*> product of elementary reflectors. The other columns of A are
+*> unchanged. See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (NB)
+*> The scalar factors of the elementary reflectors. See Further
+*> Details.
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,NB)
+*> The upper triangular matrix T.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= NB.
+*> \endverbatim
+*>
+*> \param[out] Y
+*> \verbatim
+*> Y is COMPLEX*16 array, dimension (LDY,NB)
+*> The n-by-nb matrix Y.
+*> \endverbatim
+*>
+*> \param[in] LDY
+*> \verbatim
+*> LDY is INTEGER
+*> The leading dimension of the array Y. LDY >= N.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The matrix Q is represented as a product of nb elementary reflectors
+*>
+*> Q = H(1) H(2) . . . H(nb).
+*>
+*> Each H(i) has the form
+*>
+*> H(i) = I - tau * v * v**H
+*>
+*> where tau is a complex scalar, and v is a complex vector with
+*> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+*> A(i+k+1:n,i), and tau in TAU(i).
+*>
+*> The elements of the vectors v together form the (n-k+1)-by-nb matrix
+*> V which is needed, with T and Y, to apply the transformation to the
+*> unreduced part of the matrix, using an update of the form:
+*> A := (I - V*T*V**H) * (A - Y*V**H).
+*>
+*> The contents of A on exit are illustrated by the following example
+*> with n = 7, k = 3 and nb = 2:
+*>
+*> ( a a a a a )
+*> ( a a a a a )
+*> ( a a a a a )
+*> ( h h a a a )
+*> ( v1 h a a a )
+*> ( v1 v2 a a a )
+*> ( v1 v2 a a a )
+*>
+*> where a denotes an element of the original matrix A, h denotes a
+*> modified element of the upper Hessenberg matrix H, and vi denotes an
+*> element of the vector defining H(i).
+*>
+*> This subroutine is a slight modification of LAPACK-3.0's DLAHRD
+*> incorporating improvements proposed by Quintana-Orti and Van de
+*> Gejin. Note that the entries of A(1:K,2:NB) differ from those
+*> returned by the original LAPACK-3.0's DLAHRD routine. (This
+*> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the
+*> performance of reduction to Hessenberg form," ACM Transactions on
+*> Mathematical Software, 32(2):180-194, June 2006.
+*>
+* =====================================================================
+ SUBROUTINE zlahr2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER K, LDA, LDT, LDY, N, NB
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), T( ldt, nb ), TAU( nb ),
+ $ y( ldy, nb )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d+0, 0.0d+0 ),
+ $ one = ( 1.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ COMPLEX*16 EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL zaxpy, zcopy, zgemm, zgemv, zlacpy,
+ $ zlarfg, zscal, ztrmm, ztrmv, zlacgv
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC min
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( n.LE.1 )
+ $ RETURN
+*
+ DO 10 i = 1, nb
+ IF( i.GT.1 ) THEN
+*
+* Update A(K+1:N,I)
+*
+* Update I-th column of A - Y * V**H
+*
+ CALL zlacgv( i-1, a( k+i-1, 1 ), lda )
+ CALL zgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,
+ $ a( k+i-1, 1 ), lda, one, a( k+1, i ), 1 )
+ CALL zlacgv( i-1, a( k+i-1, 1 ), lda )
+*
+* Apply I - V * T**H * V**H to this column (call it b) from the
+* left, using the last column of T as workspace
+*
+* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
+* ( V2 ) ( b2 )
+*
+* where V1 is unit lower triangular
+*
+* w := V1**H * b1
+*
+ CALL zcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 )
+ CALL ztrmv( 'Lower', 'Conjugate transpose', 'UNIT',
+ $ i-1, a( k+1, 1 ),
+ $ lda, t( 1, nb ), 1 )
+*
+* w := w + V2**H * b2
+*
+ CALL zgemv( 'Conjugate transpose', n-k-i+1, i-1,
+ $ one, a( k+i, 1 ),
+ $ lda, a( k+i, i ), 1, one, t( 1, nb ), 1 )
+*
+* w := T**H * w
+*
+ CALL ztrmv( 'Upper', 'Conjugate transpose', 'NON-UNIT',
+ $ i-1, t, ldt,
+ $ t( 1, nb ), 1 )
+*
+* b2 := b2 - V2*w
+*
+ CALL zgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,
+ $ a( k+i, 1 ),
+ $ lda, t( 1, nb ), 1, one, a( k+i, i ), 1 )
+*
+* b1 := b1 - V1*w
+*
+ CALL ztrmv( 'Lower', 'NO TRANSPOSE',
+ $ 'UNIT', i-1,
+ $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
+ CALL zaxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 )
+*
+ a( k+i-1, i-1 ) = ei
+ END IF
+*
+* Generate the elementary reflector H(I) to annihilate
+* A(K+I+1:N,I)
+*
+ CALL zlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,
+ $ tau( i ) )
+ ei = a( k+i, i )
+ a( k+i, i ) = one
+*
+* Compute Y(K+1:N,I)
+*
+ CALL zgemv( 'NO TRANSPOSE', n-k, n-k-i+1,
+ $ one, a( k+1, i+1 ),
+ $ lda, a( k+i, i ), 1, zero, y( k+1, i ), 1 )
+ CALL zgemv( 'Conjugate transpose', n-k-i+1, i-1,
+ $ one, a( k+i, 1 ), lda,
+ $ a( k+i, i ), 1, zero, t( 1, i ), 1 )
+ CALL zgemv( 'NO TRANSPOSE', n-k, i-1, -one,
+ $ y( k+1, 1 ), ldy,
+ $ t( 1, i ), 1, one, y( k+1, i ), 1 )
+ CALL zscal( n-k, tau( i ), y( k+1, i ), 1 )
+*
+* Compute T(1:I,I)
+*
+ CALL zscal( i-1, -tau( i ), t( 1, i ), 1 )
+ CALL ztrmv( 'Upper', 'No Transpose', 'NON-UNIT',
+ $ i-1, t, ldt,
+ $ t( 1, i ), 1 )
+ t( i, i ) = tau( i )
+*
+ 10 CONTINUE
+ a( k+nb, nb ) = ei
+*
+* Compute Y(1:K,1:NB)
+*
+ CALL zlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy )
+ CALL ztrmm( 'RIGHT', 'Lower', 'NO TRANSPOSE',
+ $ 'UNIT', k, nb,
+ $ one, a( k+1, 1 ), lda, y, ldy )
+ IF( n.GT.k+nb )
+ $ CALL zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,
+ $ nb, n-k-nb, one,
+ $ a( 1, 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y,
+ $ ldy )
+ CALL ztrmm( 'RIGHT', 'Upper', 'NO TRANSPOSE',
+ $ 'NON-UNIT', k, nb,
+ $ one, t, ldt, y, ldy )
+*
+ RETURN
+*
+* End of ZLAHR2
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLANGE + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER NORM
+* INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION WORK( * )
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLANGE returns the value of the one norm, or the Frobenius norm, or
+*> the infinity norm, or the element of largest absolute value of a
+*> complex matrix A.
+*> \endverbatim
+*>
+*> \return ZLANGE
+*> \verbatim
+*>
+*> ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*> (
+*> ( norm1(A), NORM = '1', 'O' or 'o'
+*> (
+*> ( normI(A), NORM = 'I' or 'i'
+*> (
+*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*>
+*> where norm1 denotes the one norm of a matrix (maximum column sum),
+*> normI denotes the infinity norm of a matrix (maximum row sum) and
+*> normF denotes the Frobenius norm of a matrix (square root of sum of
+*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] NORM
+*> \verbatim
+*> NORM is CHARACTER*1
+*> Specifies the value to be returned in ZLANGE as described
+*> above.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0. When M = 0,
+*> ZLANGE is set to zero.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0. When N = 0,
+*> ZLANGE is set to zero.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The m by n matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(M,1).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*> referenced.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16GEauxiliary
+*
+* =====================================================================
+ DOUBLE PRECISION FUNCTION zlange( NORM, M, N, A, LDA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION WORK( * )
+ COMPLEX*16 A( lda, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ parameter( one = 1.0d+0, zero = 0.0d+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION SCALE, SUM, VALUE, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, DISNAN
+ EXTERNAL lsame, disnan
+* ..
+* .. External Subroutines ..
+ EXTERNAL zlassq
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, min, sqrt
+* ..
+* .. Executable Statements ..
+*
+ IF( min( m, n ).EQ.0 ) THEN
+ VALUE = zero
+ ELSE IF( lsame( norm, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = zero
+ DO 20 j = 1, n
+ DO 10 i = 1, m
+ temp = abs( a( i, j ) )
+ IF( VALUE.LT.temp .OR. disnan( temp ) ) VALUE = temp
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = zero
+ DO 40 j = 1, n
+ sum = zero
+ DO 30 i = 1, m
+ sum = sum + abs( a( i, j ) )
+ 30 CONTINUE
+ IF( VALUE.LT.sum .OR. disnan( sum ) ) VALUE = sum
+ 40 CONTINUE
+ ELSE IF( lsame( norm, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ DO 50 i = 1, m
+ work( i ) = zero
+ 50 CONTINUE
+ DO 70 j = 1, n
+ DO 60 i = 1, m
+ work( i ) = work( i ) + abs( a( i, j ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VALUE = zero
+ DO 80 i = 1, m
+ temp = work( i )
+ IF( VALUE.LT.temp .OR. disnan( temp ) ) VALUE = temp
+ 80 CONTINUE
+ ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ scale = zero
+ sum = one
+ DO 90 j = 1, n
+ CALL zlassq( m, a( 1, j ), 1, scale, sum )
+ 90 CONTINUE
+ VALUE = scale*sqrt( sum )
+ END IF
+*
+ zlange = VALUE
+ RETURN
+*
+* End of ZLANGE
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQR0 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+* IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+* LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAQR0 computes the eigenvalues of a Hessenberg matrix H
+*> and, optionally, the matrices T and Z from the Schur decomposition
+*> H = Z T Z**H, where T is an upper triangular matrix (the
+*> Schur form), and Z is the unitary matrix of Schur vectors.
+*>
+*> Optionally Z may be postmultiplied into an input unitary
+*> matrix Q so that this routine can give the Schur factorization
+*> of a matrix A which has been reduced to the Hessenberg form H
+*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] WANTT
+*> \verbatim
+*> WANTT is LOGICAL
+*> = .TRUE. : the full Schur form T is required;
+*> = .FALSE.: only eigenvalues are required.
+*> \endverbatim
+*>
+*> \param[in] WANTZ
+*> \verbatim
+*> WANTZ is LOGICAL
+*> = .TRUE. : the matrix of Schur vectors Z is required;
+*> = .FALSE.: Schur vectors are not required.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix H. N .GE. 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*>
+*> It is assumed that H is already upper triangular in rows
+*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+*> previous call to ZGEBAL, and then passed to ZGEHRD when the
+*> matrix output by ZGEBAL is reduced to Hessenberg form.
+*> Otherwise, ILO and IHI should be set to 1 and N,
+*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*> If N = 0, then ILO = 1 and IHI = 0.
+*> \endverbatim
+*>
+*> \param[in,out] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> On entry, the upper Hessenberg matrix H.
+*> On exit, if INFO = 0 and WANTT is .TRUE., then H
+*> contains the upper triangular matrix T from the Schur
+*> decomposition (the Schur form). If INFO = 0 and WANT is
+*> .FALSE., then the contents of H are unspecified on exit.
+*> (The output value of H when INFO.GT.0 is given under the
+*> description of INFO below.)
+*>
+*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> The leading dimension of the array H. LDH .GE. max(1,N).
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (N)
+*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
+*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
+*> stored in the same order as on the diagonal of the Schur
+*> form returned in H, with W(i) = H(i,i).
+*> \endverbatim
+*>
+*> \param[in] ILOZ
+*> \verbatim
+*> ILOZ is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHIZ
+*> \verbatim
+*> IHIZ is INTEGER
+*> Specify the rows of Z to which transformations must be
+*> applied if WANTZ is .TRUE..
+*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*> \endverbatim
+*>
+*> \param[in,out] Z
+*> \verbatim
+*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
+*> If WANTZ is .FALSE., then Z is not referenced.
+*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+*> (The output value of Z when INFO.GT.0 is given under
+*> the description of INFO below.)
+*> \endverbatim
+*>
+*> \param[in] LDZ
+*> \verbatim
+*> LDZ is INTEGER
+*> The leading dimension of the array Z. if WANTZ is .TRUE.
+*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension LWORK
+*> On exit, if LWORK = -1, WORK(1) returns an estimate of
+*> the optimal value for LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK .GE. max(1,N)
+*> is sufficient, but LWORK typically as large as 6*N may
+*> be required for optimal performance. A workspace query
+*> to determine the optimal workspace size is recommended.
+*>
+*> If LWORK = -1, then ZLAQR0 does a workspace query.
+*> In this case, ZLAQR0 checks the input parameters and
+*> estimates the optimal workspace size for the given
+*> values of N, ILO and IHI. The estimate is returned
+*> in WORK(1). No error message related to LWORK is
+*> issued by XERBLA. Neither H nor Z are accessed.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> .GT. 0: if INFO = i, ZLAQR0 failed to compute all of
+*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+*> and WI contain those eigenvalues which have been
+*> successfully computed. (Failures are rare.)
+*>
+*> If INFO .GT. 0 and WANT is .FALSE., then on exit,
+*> the remaining unconverged eigenvalues are the eigen-
+*> values of the upper Hessenberg matrix rows and
+*> columns ILO through INFO of the final, output
+*> value of H.
+*>
+*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*>
+*> (*) (initial value of H)*U = U*(final value of H)
+*>
+*> where U is a unitary matrix. The final
+*> value of H is upper Hessenberg and triangular in
+*> rows and columns INFO+1 through IHI.
+*>
+*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*>
+*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
+*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*>
+*> where U is the unitary matrix in (*) (regard-
+*> less of the value of WANTT.)
+*>
+*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+*> accessed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Contributors:
+* ==================
+*>
+*> Karen Braman and Ralph Byers, Department of Mathematics,
+*> University of Kansas, USA
+*
+*> \par References:
+* ================
+*>
+*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*> 929--947, 2002.
+*> \n
+*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*> of Matrix Analysis, volume 23, pages 948--973, 2002.
+*>
+* =====================================================================
+ SUBROUTINE zlaqr0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+ $ IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), W( * ), WORK( * ), Z( ldz, * )
+* ..
+*
+* ================================================================
+*
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . ZLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+ INTEGER NTINY
+ parameter( ntiny = 11 )
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by varying the size of the
+* . deflation window after KEXNW iterations. ====
+ INTEGER KEXNW
+ parameter( kexnw = 5 )
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . ====
+ INTEGER KEXSH
+ parameter( kexsh = 6 )
+*
+* ==== The constant WILK1 is used to form the exceptional
+* . shifts. ====
+ DOUBLE PRECISION WILK1
+ parameter( wilk1 = 0.75d0 )
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d0, 0.0d0 ),
+ $ one = ( 1.0d0, 0.0d0 ) )
+ DOUBLE PRECISION TWO
+ parameter( two = 2.0d0 )
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
+ DOUBLE PRECISION S
+ INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ kt, ktop, ku, kv, kwh, kwtop, kwv, ld, ls,
+ $ lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns,
+ $ nsmax, nsr, nve, nw, nwmax, nwr, nwupbd
+ LOGICAL SORTED
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ilaenv
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL zlacpy, zlahqr, zlaqr3, zlaqr4, zlaqr5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dimag, int, max, min, mod,
+ $ sqrt
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+ info = 0
+*
+* ==== Quick return for N = 0: nothing to do. ====
+*
+ IF( n.EQ.0 ) THEN
+ work( 1 ) = one
+ RETURN
+ END IF
+*
+ IF( n.LE.ntiny ) THEN
+*
+* ==== Tiny matrices must use ZLAHQR. ====
+*
+ lwkopt = 1
+ IF( lwork.NE.-1 )
+ $ CALL zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,
+ $ ihiz, z, ldz, info )
+ ELSE
+*
+* ==== Use small bulge multi-shift QR with aggressive early
+* . deflation on larger-than-tiny matrices. ====
+*
+* ==== Hope for the best. ====
+*
+ info = 0
+*
+* ==== Set up job flags for ILAENV. ====
+*
+ IF( wantt ) THEN
+ jbcmpz( 1: 1 ) = 'S'
+ ELSE
+ jbcmpz( 1: 1 ) = 'E'
+ END IF
+ IF( wantz ) THEN
+ jbcmpz( 2: 2 ) = 'V'
+ ELSE
+ jbcmpz( 2: 2 ) = 'N'
+ END IF
+*
+* ==== NWR = recommended deflation window size. At this
+* . point, N .GT. NTINY = 11, so there is enough
+* . subdiagonal workspace for NWR.GE.2 as required.
+* . (In fact, there is enough subdiagonal space for
+* . NWR.GE.3.) ====
+*
+ nwr = ilaenv( 13, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork )
+ nwr = max( 2, nwr )
+ nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
+*
+* ==== NSR = recommended number of simultaneous shifts.
+* . At this point N .GT. NTINY = 11, so there is at
+* . enough subdiagonal workspace for NSR to be even
+* . and greater than or equal to two as required. ====
+*
+ nsr = ilaenv( 15, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork )
+ nsr = min( nsr, ( n+6 ) / 9, ihi-ilo )
+ nsr = max( 2, nsr-mod( nsr, 2 ) )
+*
+* ==== Estimate optimal workspace ====
+*
+* ==== Workspace query call to ZLAQR3 ====
+*
+ CALL zlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,
+ $ ihiz, z, ldz, ls, ld, w, h, ldh, n, h, ldh, n, h,
+ $ ldh, work, -1 )
+*
+* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ====
+*
+ lwkopt = max( 3*nsr / 2, int( work( 1 ) ) )
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( lwork.EQ.-1 ) THEN
+ work( 1 ) = dcmplx( lwkopt, 0 )
+ RETURN
+ END IF
+*
+* ==== ZLAHQR/ZLAQR0 crossover point ====
+*
+ nmin = ilaenv( 12, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork )
+ nmin = max( ntiny, nmin )
+*
+* ==== Nibble crossover point ====
+*
+ nibble = ilaenv( 14, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork )
+ nibble = max( 0, nibble )
+*
+* ==== Accumulate reflections during ttswp? Use block
+* . 2-by-2 structure during matrix-matrix multiply? ====
+*
+ kacc22 = ilaenv( 16, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork )
+ kacc22 = max( 0, kacc22 )
+ kacc22 = min( 2, kacc22 )
+*
+* ==== NWMAX = the largest possible deflation window for
+* . which there is sufficient workspace. ====
+*
+ nwmax = min( ( n-1 ) / 3, lwork / 2 )
+ nw = nwmax
+*
+* ==== NSMAX = the Largest number of simultaneous shifts
+* . for which there is sufficient workspace. ====
+*
+ nsmax = min( ( n+6 ) / 9, 2*lwork / 3 )
+ nsmax = nsmax - mod( nsmax, 2 )
+*
+* ==== NDFL: an iteration count restarted at deflation. ====
+*
+ ndfl = 1
+*
+* ==== ITMAX = iteration limit ====
+*
+ itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) )
+*
+* ==== Last row and column in the active block ====
+*
+ kbot = ihi
+*
+* ==== Main Loop ====
+*
+ DO 70 it = 1, itmax
+*
+* ==== Done when KBOT falls below ILO ====
+*
+ IF( kbot.LT.ilo )
+ $ GO TO 80
+*
+* ==== Locate active block ====
+*
+ DO 10 k = kbot, ilo + 1, -1
+ IF( h( k, k-1 ).EQ.zero )
+ $ GO TO 20
+ 10 CONTINUE
+ k = ilo
+ 20 CONTINUE
+ ktop = k
+*
+* ==== Select deflation window size:
+* . Typical Case:
+* . If possible and advisable, nibble the entire
+* . active block. If not, use size MIN(NWR,NWMAX)
+* . or MIN(NWR+1,NWMAX) depending upon which has
+* . the smaller corresponding subdiagonal entry
+* . (a heuristic).
+* .
+* . Exceptional Case:
+* . If there have been no deflations in KEXNW or
+* . more iterations, then vary the deflation window
+* . size. At first, because, larger windows are,
+* . in general, more powerful than smaller ones,
+* . rapidly increase the window to the maximum possible.
+* . Then, gradually reduce the window size. ====
+*
+ nh = kbot - ktop + 1
+ nwupbd = min( nh, nwmax )
+ IF( ndfl.LT.kexnw ) THEN
+ nw = min( nwupbd, nwr )
+ ELSE
+ nw = min( nwupbd, 2*nw )
+ END IF
+ IF( nw.LT.nwmax ) THEN
+ IF( nw.GE.nh-1 ) THEN
+ nw = nh
+ ELSE
+ kwtop = kbot - nw + 1
+ IF( cabs1( h( kwtop, kwtop-1 ) ).GT.
+ $ cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + 1
+ END IF
+ END IF
+ IF( ndfl.LT.kexnw ) THEN
+ ndec = -1
+ ELSE IF( ndec.GE.0 .OR. nw.GE.nwupbd ) THEN
+ ndec = ndec + 1
+ IF( nw-ndec.LT.2 )
+ $ ndec = 0
+ nw = nw - ndec
+ END IF
+*
+* ==== Aggressive early deflation:
+* . split workspace under the subdiagonal into
+* . - an nw-by-nw work array V in the lower
+* . left-hand-corner,
+* . - an NW-by-at-least-NW-but-more-is-better
+* . (NW-by-NHO) horizontal work array along
+* . the bottom edge,
+* . - an at-least-NW-but-more-is-better (NHV-by-NW)
+* . vertical work array along the left-hand-edge.
+* . ====
+*
+ kv = n - nw + 1
+ kt = nw + 1
+ nho = ( n-nw-1 ) - kt + 1
+ kwv = nw + 2
+ nve = ( n-nw ) - kwv + 1
+*
+* ==== Aggressive early deflation ====
+*
+ CALL zlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,
+ $ ihiz, z, ldz, ls, ld, w, h( kv, 1 ), ldh, nho,
+ $ h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,
+ $ lwork )
+*
+* ==== Adjust KBOT accounting for new deflations. ====
+*
+ kbot = kbot - ld
+*
+* ==== KS points to the shifts. ====
+*
+ ks = kbot - ls + 1
+*
+* ==== Skip an expensive QR sweep if there is a (partly
+* . heuristic) reason to expect that many eigenvalues
+* . will deflate without it. Here, the QR sweep is
+* . skipped if many eigenvalues have just been deflated
+* . or if the remaining active block is small.
+*
+ IF( ( ld.EQ.0 ) .OR. ( ( 100*ld.LE.nw*nibble ) .AND. ( kbot-
+ $ ktop+1.GT.min( nmin, nwmax ) ) ) ) THEN
+*
+* ==== NS = nominal number of simultaneous shifts.
+* . This may be lowered (slightly) if ZLAQR3
+* . did not provide that many shifts. ====
+*
+ ns = min( nsmax, nsr, max( 2, kbot-ktop ) )
+ ns = ns - mod( ns, 2 )
+*
+* ==== If there have been no deflations
+* . in a multiple of KEXSH iterations,
+* . then try exceptional shifts.
+* . Otherwise use shifts provided by
+* . ZLAQR3 above or from the eigenvalues
+* . of a trailing principal submatrix. ====
+*
+ IF( mod( ndfl, kexsh ).EQ.0 ) THEN
+ ks = kbot - ns + 1
+ DO 30 i = kbot, ks + 1, -2
+ w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) )
+ w( i-1 ) = w( i )
+ 30 CONTINUE
+ ELSE
+*
+* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or
+* . ZLAHQR on a trailing principal submatrix to
+* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+* . there is enough space below the subdiagonal
+* . to fit an NS-by-NS scratch array.) ====
+*
+ IF( kbot-ks+1.LE.ns / 2 ) THEN
+ ks = kbot - ns + 1
+ kt = n - ns + 1
+ CALL zlacpy( 'A', ns, ns, h( ks, ks ), ldh,
+ $ h( kt, 1 ), ldh )
+ IF( ns.GT.nmin ) THEN
+ CALL zlaqr4( .false., .false., ns, 1, ns,
+ $ h( kt, 1 ), ldh, w( ks ), 1, 1,
+ $ zdum, 1, work, lwork, inf )
+ ELSE
+ CALL zlahqr( .false., .false., ns, 1, ns,
+ $ h( kt, 1 ), ldh, w( ks ), 1, 1,
+ $ zdum, 1, inf )
+ END IF
+ ks = ks + inf
+*
+* ==== In case of a rare QR failure use
+* . eigenvalues of the trailing 2-by-2
+* . principal submatrix. Scale to avoid
+* . overflows, underflows and subnormals.
+* . (The scale factor S can not be zero,
+* . because H(KBOT,KBOT-1) is nonzero.) ====
+*
+ IF( ks.GE.kbot ) THEN
+ s = cabs1( h( kbot-1, kbot-1 ) ) +
+ $ cabs1( h( kbot, kbot-1 ) ) +
+ $ cabs1( h( kbot-1, kbot ) ) +
+ $ cabs1( h( kbot, kbot ) )
+ aa = h( kbot-1, kbot-1 ) / s
+ cc = h( kbot, kbot-1 ) / s
+ bb = h( kbot-1, kbot ) / s
+ dd = h( kbot, kbot ) / s
+ tr2 = ( aa+dd ) / two
+ det = ( aa-tr2 )*( dd-tr2 ) - bb*cc
+ rtdisc = sqrt( -det )
+ w( kbot-1 ) = ( tr2+rtdisc )*s
+ w( kbot ) = ( tr2-rtdisc )*s
+*
+ ks = kbot - 1
+ END IF
+ END IF
+*
+ IF( kbot-ks+1.GT.ns ) THEN
+*
+* ==== Sort the shifts (Helps a little) ====
+*
+ sorted = .false.
+ DO 50 k = kbot, ks + 1, -1
+ IF( sorted )
+ $ GO TO 60
+ sorted = .true.
+ DO 40 i = ks, k - 1
+ IF( cabs1( w( i ) ).LT.cabs1( w( i+1 ) ) )
+ $ THEN
+ sorted = .false.
+ swap = w( i )
+ w( i ) = w( i+1 )
+ w( i+1 ) = swap
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ END IF
+*
+* ==== If there are only two shifts, then use
+* . only one. ====
+*
+ IF( kbot-ks+1.EQ.2 ) THEN
+ IF( cabs1( w( kbot )-h( kbot, kbot ) ).LT.
+ $ cabs1( w( kbot-1 )-h( kbot, kbot ) ) ) THEN
+ w( kbot-1 ) = w( kbot )
+ ELSE
+ w( kbot ) = w( kbot-1 )
+ END IF
+ END IF
+*
+* ==== Use up to NS of the the smallest magnatiude
+* . shifts. If there aren't NS shifts available,
+* . then use them all, possibly dropping one to
+* . make the number of shifts even. ====
+*
+ ns = min( ns, kbot-ks+1 )
+ ns = ns - mod( ns, 2 )
+ ks = kbot - ns + 1
+*
+* ==== Small-bulge multi-shift QR sweep:
+* . split workspace under the subdiagonal into
+* . - a KDU-by-KDU work array U in the lower
+* . left-hand-corner,
+* . - a KDU-by-at-least-KDU-but-more-is-better
+* . (KDU-by-NHo) horizontal work array WH along
+* . the bottom edge,
+* . - and an at-least-KDU-but-more-is-better-by-KDU
+* . (NVE-by-KDU) vertical work WV arrow along
+* . the left-hand-edge. ====
+*
+ kdu = 3*ns - 3
+ ku = n - kdu + 1
+ kwh = kdu + 1
+ nho = ( n-kdu+1-4 ) - ( kdu+1 ) + 1
+ kwv = kdu + 4
+ nve = n - kdu - kwv + 1
+*
+* ==== Small-bulge multi-shift QR sweep ====
+*
+ CALL zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,
+ $ w( ks ), h, ldh, iloz, ihiz, z, ldz, work,
+ $ 3, h( ku, 1 ), ldh, nve, h( kwv, 1 ), ldh,
+ $ nho, h( ku, kwh ), ldh )
+ END IF
+*
+* ==== Note progress (or the lack of it). ====
+*
+ IF( ld.GT.0 ) THEN
+ ndfl = 1
+ ELSE
+ ndfl = ndfl + 1
+ END IF
+*
+* ==== End of main loop ====
+ 70 CONTINUE
+*
+* ==== Iteration limit exceeded. Set INFO to show where
+* . the problem occurred and exit. ====
+*
+ info = kbot
+ 80 CONTINUE
+ END IF
+*
+* ==== Return the optimal value of LWORK. ====
+*
+ work( 1 ) = dcmplx( lwkopt, 0 )
+*
+* ==== End of ZLAQR0 ====
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQR1 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 S1, S2
+* INTEGER LDH, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), V( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a
+*> scalar multiple of the first column of the product
+*>
+*> (*) K = (H - s1*I)*(H - s2*I)
+*>
+*> scaling to avoid overflows and most underflows.
+*>
+*> This is useful for starting double implicit shift bulges
+*> in the QR algorithm.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> Order of the matrix H. N must be either 2 or 3.
+*> \endverbatim
+*>
+*> \param[in] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> The 2-by-2 or 3-by-3 matrix H in (*).
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> The leading dimension of H as declared in
+*> the calling procedure. LDH.GE.N
+*> \endverbatim
+*>
+*> \param[in] S1
+*> \verbatim
+*> S1 is COMPLEX*16
+*> \endverbatim
+*>
+*> \param[in] S2
+*> \verbatim
+*> S2 is COMPLEX*16
+*>
+*> S1 and S2 are the shifts defining K in (*) above.
+*> \endverbatim
+*>
+*> \param[out] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension (N)
+*> A scalar multiple of the first column of the
+*> matrix K in (*).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2017
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Contributors:
+* ==================
+*>
+*> Karen Braman and Ralph Byers, Department of Mathematics,
+*> University of Kansas, USA
+*>
+* =====================================================================
+ SUBROUTINE zlaqr1( N, H, LDH, S1, S2, V )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2017
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 S1, S2
+ INTEGER LDH, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), V( * )
+* ..
+*
+* ================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ parameter( zero = ( 0.0d0, 0.0d0 ) )
+ DOUBLE PRECISION RZERO
+ parameter( rzero = 0.0d0 )
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 CDUM, H21S, H31S
+ DOUBLE PRECISION S
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dimag
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+ IF( n.EQ.2 ) THEN
+ s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) )
+ IF( s.EQ.rzero ) THEN
+ v( 1 ) = zero
+ v( 2 ) = zero
+ ELSE
+ h21s = h( 2, 1 ) / s
+ v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-s1 )*
+ $ ( ( h( 1, 1 )-s2 ) / s )
+ v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 )
+ END IF
+ ELSE
+ s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) +
+ $ cabs1( h( 3, 1 ) )
+ IF( s.EQ.zero ) THEN
+ v( 1 ) = zero
+ v( 2 ) = zero
+ v( 3 ) = zero
+ ELSE
+ h21s = h( 2, 1 ) / s
+ h31s = h( 3, 1 ) / s
+ v( 1 ) = ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) +
+ $ h( 1, 2 )*h21s + h( 1, 3 )*h31s
+ v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h( 2, 3 )*h31s
+ v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-s1-s2 ) + h21s*h( 3, 2 )
+ END IF
+ END IF
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQR2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
+* NV, WV, LDWV, WORK, LWORK )
+*
+* .. Scalar Arguments ..
+* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+* $ LDZ, LWORK, N, ND, NH, NS, NV, NW
+* LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
+* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAQR2 is identical to ZLAQR3 except that it avoids
+*> recursion by calling ZLAHQR instead of ZLAQR4.
+*>
+*> Aggressive early deflation:
+*>
+*> ZLAQR2 accepts as input an upper Hessenberg matrix
+*> H and performs an unitary similarity transformation
+*> designed to detect and deflate fully converged eigenvalues from
+*> a trailing principal submatrix. On output H has been over-
+*> written by a new Hessenberg matrix that is a perturbation of
+*> an unitary similarity transformation of H. It is to be
+*> hoped that the final version of H has many zero subdiagonal
+*> entries.
+*>
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] WANTT
+*> \verbatim
+*> WANTT is LOGICAL
+*> If .TRUE., then the Hessenberg matrix H is fully updated
+*> so that the triangular Schur factor may be
+*> computed (in cooperation with the calling subroutine).
+*> If .FALSE., then only enough of H is updated to preserve
+*> the eigenvalues.
+*> \endverbatim
+*>
+*> \param[in] WANTZ
+*> \verbatim
+*> WANTZ is LOGICAL
+*> If .TRUE., then the unitary matrix Z is updated so
+*> so that the unitary Schur factor may be computed
+*> (in cooperation with the calling subroutine).
+*> If .FALSE., then Z is not referenced.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix H and (if WANTZ is .TRUE.) the
+*> order of the unitary matrix Z.
+*> \endverbatim
+*>
+*> \param[in] KTOP
+*> \verbatim
+*> KTOP is INTEGER
+*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+*> KBOT and KTOP together determine an isolated block
+*> along the diagonal of the Hessenberg matrix.
+*> \endverbatim
+*>
+*> \param[in] KBOT
+*> \verbatim
+*> KBOT is INTEGER
+*> It is assumed without a check that either
+*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+*> determine an isolated block along the diagonal of the
+*> Hessenberg matrix.
+*> \endverbatim
+*>
+*> \param[in] NW
+*> \verbatim
+*> NW is INTEGER
+*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*> \endverbatim
+*>
+*> \param[in,out] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> On input the initial N-by-N section of H stores the
+*> Hessenberg matrix undergoing aggressive early deflation.
+*> On output H has been transformed by a unitary
+*> similarity transformation, perturbed, and the returned
+*> to Hessenberg form that (it is to be hoped) has some
+*> zero subdiagonal entries.
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> Leading dimension of H just as declared in the calling
+*> subroutine. N .LE. LDH
+*> \endverbatim
+*>
+*> \param[in] ILOZ
+*> \verbatim
+*> ILOZ is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHIZ
+*> \verbatim
+*> IHIZ is INTEGER
+*> Specify the rows of Z to which transformations must be
+*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*> \endverbatim
+*>
+*> \param[in,out] Z
+*> \verbatim
+*> Z is COMPLEX*16 array, dimension (LDZ,N)
+*> IF WANTZ is .TRUE., then on output, the unitary
+*> similarity transformation mentioned above has been
+*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
+*> If WANTZ is .FALSE., then Z is unreferenced.
+*> \endverbatim
+*>
+*> \param[in] LDZ
+*> \verbatim
+*> LDZ is INTEGER
+*> The leading dimension of Z just as declared in the
+*> calling subroutine. 1 .LE. LDZ.
+*> \endverbatim
+*>
+*> \param[out] NS
+*> \verbatim
+*> NS is INTEGER
+*> The number of unconverged (ie approximate) eigenvalues
+*> returned in SR and SI that may be used as shifts by the
+*> calling subroutine.
+*> \endverbatim
+*>
+*> \param[out] ND
+*> \verbatim
+*> ND is INTEGER
+*> The number of converged eigenvalues uncovered by this
+*> subroutine.
+*> \endverbatim
+*>
+*> \param[out] SH
+*> \verbatim
+*> SH is COMPLEX*16 array, dimension (KBOT)
+*> On output, approximate eigenvalues that may
+*> be used for shifts are stored in SH(KBOT-ND-NS+1)
+*> through SR(KBOT-ND). Converged eigenvalues are
+*> stored in SH(KBOT-ND+1) through SH(KBOT).
+*> \endverbatim
+*>
+*> \param[out] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension (LDV,NW)
+*> An NW-by-NW work array.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of V just as declared in the
+*> calling subroutine. NW .LE. LDV
+*> \endverbatim
+*>
+*> \param[in] NH
+*> \verbatim
+*> NH is INTEGER
+*> The number of columns of T. NH.GE.NW.
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,NW)
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of T just as declared in the
+*> calling subroutine. NW .LE. LDT
+*> \endverbatim
+*>
+*> \param[in] NV
+*> \verbatim
+*> NV is INTEGER
+*> The number of rows of work array WV available for
+*> workspace. NV.GE.NW.
+*> \endverbatim
+*>
+*> \param[out] WV
+*> \verbatim
+*> WV is COMPLEX*16 array, dimension (LDWV,NW)
+*> \endverbatim
+*>
+*> \param[in] LDWV
+*> \verbatim
+*> LDWV is INTEGER
+*> The leading dimension of W just as declared in the
+*> calling subroutine. NW .LE. LDV
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> On exit, WORK(1) is set to an estimate of the optimal value
+*> of LWORK for the given values of N, NW, KTOP and KBOT.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the work array WORK. LWORK = 2*NW
+*> suffices, but greater efficiency may result from larger
+*> values of LWORK.
+*>
+*> If LWORK = -1, then a workspace query is assumed; ZLAQR2
+*> only estimates the optimal workspace size for the given
+*> values of N, NW, KTOP and KBOT. The estimate is returned
+*> in WORK(1). No error message related to LWORK is issued
+*> by XERBLA. Neither H nor Z are accessed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2017
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Contributors:
+* ==================
+*>
+*> Karen Braman and Ralph Byers, Department of Mathematics,
+*> University of Kansas, USA
+*>
+* =====================================================================
+ SUBROUTINE zlaqr2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
+ $ NV, WV, LDWV, WORK, LWORK )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2017
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+ $ ldz, lwork, n, nd, nh, ns, nv, nw
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), SH( * ), T( ldt, * ), V( ldv, * ),
+ $ work( * ), wv( ldwv, * ), z( ldz, * )
+* ..
+*
+* ================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d0, 0.0d0 ),
+ $ one = ( 1.0d0, 0.0d0 ) )
+ DOUBLE PRECISION RZERO, RONE
+ parameter( rzero = 0.0d0, rone = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 BETA, CDUM, S, TAU
+ DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
+ $ knt, krow, kwtop, ltop, lwk1, lwk2, lwkopt
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL dlamch
+* ..
+* .. External Subroutines ..
+ EXTERNAL dlabad, zcopy, zgehrd, zgemm, zlacpy, zlahqr,
+ $ zlarf, zlarfg, zlaset, ztrexc, zunmhr
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dconjg, dimag, int, max, min
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+*
+* ==== Estimate optimal workspace. ====
+*
+ jw = min( nw, kbot-ktop+1 )
+ IF( jw.LE.2 ) THEN
+ lwkopt = 1
+ ELSE
+*
+* ==== Workspace query call to ZGEHRD ====
+*
+ CALL zgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info )
+ lwk1 = int( work( 1 ) )
+*
+* ==== Workspace query call to ZUNMHR ====
+*
+ CALL zunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,
+ $ work, -1, info )
+ lwk2 = int( work( 1 ) )
+*
+* ==== Optimal workspace ====
+*
+ lwkopt = jw + max( lwk1, lwk2 )
+ END IF
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( lwork.EQ.-1 ) THEN
+ work( 1 ) = dcmplx( lwkopt, 0 )
+ RETURN
+ END IF
+*
+* ==== Nothing to do ...
+* ... for an empty active block ... ====
+ ns = 0
+ nd = 0
+ work( 1 ) = one
+ IF( ktop.GT.kbot )
+ $ RETURN
+* ... nor for an empty deflation window. ====
+ IF( nw.LT.1 )
+ $ RETURN
+*
+* ==== Machine constants ====
+*
+ safmin = dlamch( 'SAFE MINIMUM' )
+ safmax = rone / safmin
+ CALL dlabad( safmin, safmax )
+ ulp = dlamch( 'PRECISION' )
+ smlnum = safmin*( dble( n ) / ulp )
+*
+* ==== Setup deflation window ====
+*
+ jw = min( nw, kbot-ktop+1 )
+ kwtop = kbot - jw + 1
+ IF( kwtop.EQ.ktop ) THEN
+ s = zero
+ ELSE
+ s = h( kwtop, kwtop-1 )
+ END IF
+*
+ IF( kbot.EQ.kwtop ) THEN
+*
+* ==== 1-by-1 deflation window: not much to do ====
+*
+ sh( kwtop ) = h( kwtop, kwtop )
+ ns = 1
+ nd = 0
+ IF( cabs1( s ).LE.max( smlnum, ulp*cabs1( h( kwtop,
+ $ kwtop ) ) ) ) THEN
+ ns = 0
+ nd = 1
+ IF( kwtop.GT.ktop )
+ $ h( kwtop, kwtop-1 ) = zero
+ END IF
+ work( 1 ) = one
+ RETURN
+ END IF
+*
+* ==== Convert to spike-triangular form. (In case of a
+* . rare QR failure, this routine continues to do
+* . aggressive early deflation using that part of
+* . the deflation window that converged using INFQR
+* . here and there to keep track.) ====
+*
+ CALL zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt )
+ CALL zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 )
+*
+ CALL zlaset( 'A', jw, jw, zero, one, v, ldv )
+ CALL zlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,
+ $ jw, v, ldv, infqr )
+*
+* ==== Deflation detection loop ====
+*
+ ns = jw
+ ilst = infqr + 1
+ DO 10 knt = infqr + 1, jw
+*
+* ==== Small spike tip deflation test ====
+*
+ foo = cabs1( t( ns, ns ) )
+ IF( foo.EQ.rzero )
+ $ foo = cabs1( s )
+ IF( cabs1( s )*cabs1( v( 1, ns ) ).LE.max( smlnum, ulp*foo ) )
+ $ THEN
+*
+* ==== One more converged eigenvalue ====
+*
+ ns = ns - 1
+ ELSE
+*
+* ==== One undeflatable eigenvalue. Move it up out of the
+* . way. (ZTREXC can not fail in this case.) ====
+*
+ ifst = ns
+ CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
+ ilst = ilst + 1
+ END IF
+ 10 CONTINUE
+*
+* ==== Return to Hessenberg form ====
+*
+ IF( ns.EQ.0 )
+ $ s = zero
+*
+ IF( ns.LT.jw ) THEN
+*
+* ==== sorting the diagonal of T improves accuracy for
+* . graded matrices. ====
+*
+ DO 30 i = infqr + 1, ns
+ ifst = i
+ DO 20 j = i + 1, ns
+ IF( cabs1( t( j, j ) ).GT.cabs1( t( ifst, ifst ) ) )
+ $ ifst = j
+ 20 CONTINUE
+ ilst = i
+ IF( ifst.NE.ilst )
+ $ CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
+ 30 CONTINUE
+ END IF
+*
+* ==== Restore shift/eigenvalue array from T ====
+*
+ DO 40 i = infqr + 1, jw
+ sh( kwtop+i-1 ) = t( i, i )
+ 40 CONTINUE
+*
+*
+ IF( ns.LT.jw .OR. s.EQ.zero ) THEN
+ IF( ns.GT.1 .AND. s.NE.zero ) THEN
+*
+* ==== Reflect spike back into lower triangle ====
+*
+ CALL zcopy( ns, v, ldv, work, 1 )
+ DO 50 i = 1, ns
+ work( i ) = dconjg( work( i ) )
+ 50 CONTINUE
+ beta = work( 1 )
+ CALL zlarfg( ns, beta, work( 2 ), 1, tau )
+ work( 1 ) = one
+*
+ CALL zlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt )
+*
+ CALL zlarf( 'L', ns, jw, work, 1, dconjg( tau ), t, ldt,
+ $ work( jw+1 ) )
+ CALL zlarf( 'R', ns, ns, work, 1, tau, t, ldt,
+ $ work( jw+1 ) )
+ CALL zlarf( 'R', jw, ns, work, 1, tau, v, ldv,
+ $ work( jw+1 ) )
+*
+ CALL zgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),
+ $ lwork-jw, info )
+ END IF
+*
+* ==== Copy updated reduced window into place ====
+*
+ IF( kwtop.GT.1 )
+ $ h( kwtop, kwtop-1 ) = s*dconjg( v( 1, 1 ) )
+ CALL zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh )
+ CALL zcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),
+ $ ldh+1 )
+*
+* ==== Accumulate orthogonal matrix in order update
+* . H and Z, if requested. ====
+*
+ IF( ns.GT.1 .AND. s.NE.zero )
+ $ CALL zunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv,
+ $ work( jw+1 ), lwork-jw, info )
+*
+* ==== Update vertical slab in H ====
+*
+ IF( wantt ) THEN
+ ltop = 1
+ ELSE
+ ltop = ktop
+ END IF
+ DO 60 krow = ltop, kwtop - 1, nv
+ kln = min( nv, kwtop-krow )
+ CALL zgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),
+ $ ldh, v, ldv, zero, wv, ldwv )
+ CALL zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh )
+ 60 CONTINUE
+*
+* ==== Update horizontal slab in H ====
+*
+ IF( wantt ) THEN
+ DO 70 kcol = kbot + 1, n, nh
+ kln = min( nh, n-kcol+1 )
+ CALL zgemm( 'C', 'N', jw, kln, jw, one, v, ldv,
+ $ h( kwtop, kcol ), ldh, zero, t, ldt )
+ CALL zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),
+ $ ldh )
+ 70 CONTINUE
+ END IF
+*
+* ==== Update vertical slab in Z ====
+*
+ IF( wantz ) THEN
+ DO 80 krow = iloz, ihiz, nv
+ kln = min( nv, ihiz-krow+1 )
+ CALL zgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),
+ $ ldz, v, ldv, zero, wv, ldwv )
+ CALL zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),
+ $ ldz )
+ 80 CONTINUE
+ END IF
+ END IF
+*
+* ==== Return the number of deflations ... ====
+*
+ nd = jw - ns
+*
+* ==== ... and the number of shifts. (Subtracting
+* . INFQR from the spike length takes care
+* . of the case of a rare QR failure while
+* . calculating eigenvalues of the deflation
+* . window.) ====
+*
+ ns = ns - infqr
+*
+* ==== Return optimal workspace. ====
+*
+ work( 1 ) = dcmplx( lwkopt, 0 )
+*
+* ==== End of ZLAQR2 ====
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQR3 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
+* NV, WV, LDWV, WORK, LWORK )
+*
+* .. Scalar Arguments ..
+* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+* $ LDZ, LWORK, N, ND, NH, NS, NV, NW
+* LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
+* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> Aggressive early deflation:
+*>
+*> ZLAQR3 accepts as input an upper Hessenberg matrix
+*> H and performs an unitary similarity transformation
+*> designed to detect and deflate fully converged eigenvalues from
+*> a trailing principal submatrix. On output H has been over-
+*> written by a new Hessenberg matrix that is a perturbation of
+*> an unitary similarity transformation of H. It is to be
+*> hoped that the final version of H has many zero subdiagonal
+*> entries.
+*>
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] WANTT
+*> \verbatim
+*> WANTT is LOGICAL
+*> If .TRUE., then the Hessenberg matrix H is fully updated
+*> so that the triangular Schur factor may be
+*> computed (in cooperation with the calling subroutine).
+*> If .FALSE., then only enough of H is updated to preserve
+*> the eigenvalues.
+*> \endverbatim
+*>
+*> \param[in] WANTZ
+*> \verbatim
+*> WANTZ is LOGICAL
+*> If .TRUE., then the unitary matrix Z is updated so
+*> so that the unitary Schur factor may be computed
+*> (in cooperation with the calling subroutine).
+*> If .FALSE., then Z is not referenced.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix H and (if WANTZ is .TRUE.) the
+*> order of the unitary matrix Z.
+*> \endverbatim
+*>
+*> \param[in] KTOP
+*> \verbatim
+*> KTOP is INTEGER
+*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+*> KBOT and KTOP together determine an isolated block
+*> along the diagonal of the Hessenberg matrix.
+*> \endverbatim
+*>
+*> \param[in] KBOT
+*> \verbatim
+*> KBOT is INTEGER
+*> It is assumed without a check that either
+*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+*> determine an isolated block along the diagonal of the
+*> Hessenberg matrix.
+*> \endverbatim
+*>
+*> \param[in] NW
+*> \verbatim
+*> NW is INTEGER
+*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*> \endverbatim
+*>
+*> \param[in,out] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> On input the initial N-by-N section of H stores the
+*> Hessenberg matrix undergoing aggressive early deflation.
+*> On output H has been transformed by a unitary
+*> similarity transformation, perturbed, and the returned
+*> to Hessenberg form that (it is to be hoped) has some
+*> zero subdiagonal entries.
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> Leading dimension of H just as declared in the calling
+*> subroutine. N .LE. LDH
+*> \endverbatim
+*>
+*> \param[in] ILOZ
+*> \verbatim
+*> ILOZ is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHIZ
+*> \verbatim
+*> IHIZ is INTEGER
+*> Specify the rows of Z to which transformations must be
+*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*> \endverbatim
+*>
+*> \param[in,out] Z
+*> \verbatim
+*> Z is COMPLEX*16 array, dimension (LDZ,N)
+*> IF WANTZ is .TRUE., then on output, the unitary
+*> similarity transformation mentioned above has been
+*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
+*> If WANTZ is .FALSE., then Z is unreferenced.
+*> \endverbatim
+*>
+*> \param[in] LDZ
+*> \verbatim
+*> LDZ is INTEGER
+*> The leading dimension of Z just as declared in the
+*> calling subroutine. 1 .LE. LDZ.
+*> \endverbatim
+*>
+*> \param[out] NS
+*> \verbatim
+*> NS is INTEGER
+*> The number of unconverged (ie approximate) eigenvalues
+*> returned in SR and SI that may be used as shifts by the
+*> calling subroutine.
+*> \endverbatim
+*>
+*> \param[out] ND
+*> \verbatim
+*> ND is INTEGER
+*> The number of converged eigenvalues uncovered by this
+*> subroutine.
+*> \endverbatim
+*>
+*> \param[out] SH
+*> \verbatim
+*> SH is COMPLEX*16 array, dimension (KBOT)
+*> On output, approximate eigenvalues that may
+*> be used for shifts are stored in SH(KBOT-ND-NS+1)
+*> through SR(KBOT-ND). Converged eigenvalues are
+*> stored in SH(KBOT-ND+1) through SH(KBOT).
+*> \endverbatim
+*>
+*> \param[out] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension (LDV,NW)
+*> An NW-by-NW work array.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of V just as declared in the
+*> calling subroutine. NW .LE. LDV
+*> \endverbatim
+*>
+*> \param[in] NH
+*> \verbatim
+*> NH is INTEGER
+*> The number of columns of T. NH.GE.NW.
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,NW)
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of T just as declared in the
+*> calling subroutine. NW .LE. LDT
+*> \endverbatim
+*>
+*> \param[in] NV
+*> \verbatim
+*> NV is INTEGER
+*> The number of rows of work array WV available for
+*> workspace. NV.GE.NW.
+*> \endverbatim
+*>
+*> \param[out] WV
+*> \verbatim
+*> WV is COMPLEX*16 array, dimension (LDWV,NW)
+*> \endverbatim
+*>
+*> \param[in] LDWV
+*> \verbatim
+*> LDWV is INTEGER
+*> The leading dimension of W just as declared in the
+*> calling subroutine. NW .LE. LDV
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> On exit, WORK(1) is set to an estimate of the optimal value
+*> of LWORK for the given values of N, NW, KTOP and KBOT.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the work array WORK. LWORK = 2*NW
+*> suffices, but greater efficiency may result from larger
+*> values of LWORK.
+*>
+*> If LWORK = -1, then a workspace query is assumed; ZLAQR3
+*> only estimates the optimal workspace size for the given
+*> values of N, NW, KTOP and KBOT. The estimate is returned
+*> in WORK(1). No error message related to LWORK is issued
+*> by XERBLA. Neither H nor Z are accessed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Contributors:
+* ==================
+*>
+*> Karen Braman and Ralph Byers, Department of Mathematics,
+*> University of Kansas, USA
+*>
+* =====================================================================
+ SUBROUTINE zlaqr3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
+ $ NV, WV, LDWV, WORK, LWORK )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+ $ ldz, lwork, n, nd, nh, ns, nv, nw
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), SH( * ), T( ldt, * ), V( ldv, * ),
+ $ work( * ), wv( ldwv, * ), z( ldz, * )
+* ..
+*
+* ================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d0, 0.0d0 ),
+ $ one = ( 1.0d0, 0.0d0 ) )
+ DOUBLE PRECISION RZERO, RONE
+ parameter( rzero = 0.0d0, rone = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 BETA, CDUM, S, TAU
+ DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
+ $ knt, krow, kwtop, ltop, lwk1, lwk2, lwk3,
+ $ lwkopt, nmin
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ INTEGER ILAENV
+ EXTERNAL dlamch, ilaenv
+* ..
+* .. External Subroutines ..
+ EXTERNAL dlabad, zcopy, zgehrd, zgemm, zlacpy, zlahqr,
+ $ zlaqr4, zlarf, zlarfg, zlaset, ztrexc, zunmhr
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dconjg, dimag, int, max, min
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+*
+* ==== Estimate optimal workspace. ====
+*
+ jw = min( nw, kbot-ktop+1 )
+ IF( jw.LE.2 ) THEN
+ lwkopt = 1
+ ELSE
+*
+* ==== Workspace query call to ZGEHRD ====
+*
+ CALL zgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info )
+ lwk1 = int( work( 1 ) )
+*
+* ==== Workspace query call to ZUNMHR ====
+*
+ CALL zunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,
+ $ work, -1, info )
+ lwk2 = int( work( 1 ) )
+*
+* ==== Workspace query call to ZLAQR4 ====
+*
+ CALL zlaqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v,
+ $ ldv, work, -1, infqr )
+ lwk3 = int( work( 1 ) )
+*
+* ==== Optimal workspace ====
+*
+ lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 )
+ END IF
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( lwork.EQ.-1 ) THEN
+ work( 1 ) = dcmplx( lwkopt, 0 )
+ RETURN
+ END IF
+*
+* ==== Nothing to do ...
+* ... for an empty active block ... ====
+ ns = 0
+ nd = 0
+ work( 1 ) = one
+ IF( ktop.GT.kbot )
+ $ RETURN
+* ... nor for an empty deflation window. ====
+ IF( nw.LT.1 )
+ $ RETURN
+*
+* ==== Machine constants ====
+*
+ safmin = dlamch( 'SAFE MINIMUM' )
+ safmax = rone / safmin
+ CALL dlabad( safmin, safmax )
+ ulp = dlamch( 'PRECISION' )
+ smlnum = safmin*( dble( n ) / ulp )
+*
+* ==== Setup deflation window ====
+*
+ jw = min( nw, kbot-ktop+1 )
+ kwtop = kbot - jw + 1
+ IF( kwtop.EQ.ktop ) THEN
+ s = zero
+ ELSE
+ s = h( kwtop, kwtop-1 )
+ END IF
+*
+ IF( kbot.EQ.kwtop ) THEN
+*
+* ==== 1-by-1 deflation window: not much to do ====
+*
+ sh( kwtop ) = h( kwtop, kwtop )
+ ns = 1
+ nd = 0
+ IF( cabs1( s ).LE.max( smlnum, ulp*cabs1( h( kwtop,
+ $ kwtop ) ) ) ) THEN
+ ns = 0
+ nd = 1
+ IF( kwtop.GT.ktop )
+ $ h( kwtop, kwtop-1 ) = zero
+ END IF
+ work( 1 ) = one
+ RETURN
+ END IF
+*
+* ==== Convert to spike-triangular form. (In case of a
+* . rare QR failure, this routine continues to do
+* . aggressive early deflation using that part of
+* . the deflation window that converged using INFQR
+* . here and there to keep track.) ====
+*
+ CALL zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt )
+ CALL zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 )
+*
+ CALL zlaset( 'A', jw, jw, zero, one, v, ldv )
+ nmin = ilaenv( 12, 'ZLAQR3', 'SV', jw, 1, jw, lwork )
+ IF( jw.GT.nmin ) THEN
+ CALL zlaqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,
+ $ jw, v, ldv, work, lwork, infqr )
+ ELSE
+ CALL zlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,
+ $ jw, v, ldv, infqr )
+ END IF
+*
+* ==== Deflation detection loop ====
+*
+ ns = jw
+ ilst = infqr + 1
+ DO 10 knt = infqr + 1, jw
+*
+* ==== Small spike tip deflation test ====
+*
+ foo = cabs1( t( ns, ns ) )
+ IF( foo.EQ.rzero )
+ $ foo = cabs1( s )
+ IF( cabs1( s )*cabs1( v( 1, ns ) ).LE.max( smlnum, ulp*foo ) )
+ $ THEN
+*
+* ==== One more converged eigenvalue ====
+*
+ ns = ns - 1
+ ELSE
+*
+* ==== One undeflatable eigenvalue. Move it up out of the
+* . way. (ZTREXC can not fail in this case.) ====
+*
+ ifst = ns
+ CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
+ ilst = ilst + 1
+ END IF
+ 10 CONTINUE
+*
+* ==== Return to Hessenberg form ====
+*
+ IF( ns.EQ.0 )
+ $ s = zero
+*
+ IF( ns.LT.jw ) THEN
+*
+* ==== sorting the diagonal of T improves accuracy for
+* . graded matrices. ====
+*
+ DO 30 i = infqr + 1, ns
+ ifst = i
+ DO 20 j = i + 1, ns
+ IF( cabs1( t( j, j ) ).GT.cabs1( t( ifst, ifst ) ) )
+ $ ifst = j
+ 20 CONTINUE
+ ilst = i
+ IF( ifst.NE.ilst )
+ $ CALL ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
+ 30 CONTINUE
+ END IF
+*
+* ==== Restore shift/eigenvalue array from T ====
+*
+ DO 40 i = infqr + 1, jw
+ sh( kwtop+i-1 ) = t( i, i )
+ 40 CONTINUE
+*
+*
+ IF( ns.LT.jw .OR. s.EQ.zero ) THEN
+ IF( ns.GT.1 .AND. s.NE.zero ) THEN
+*
+* ==== Reflect spike back into lower triangle ====
+*
+ CALL zcopy( ns, v, ldv, work, 1 )
+ DO 50 i = 1, ns
+ work( i ) = dconjg( work( i ) )
+ 50 CONTINUE
+ beta = work( 1 )
+ CALL zlarfg( ns, beta, work( 2 ), 1, tau )
+ work( 1 ) = one
+*
+ CALL zlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt )
+*
+ CALL zlarf( 'L', ns, jw, work, 1, dconjg( tau ), t, ldt,
+ $ work( jw+1 ) )
+ CALL zlarf( 'R', ns, ns, work, 1, tau, t, ldt,
+ $ work( jw+1 ) )
+ CALL zlarf( 'R', jw, ns, work, 1, tau, v, ldv,
+ $ work( jw+1 ) )
+*
+ CALL zgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),
+ $ lwork-jw, info )
+ END IF
+*
+* ==== Copy updated reduced window into place ====
+*
+ IF( kwtop.GT.1 )
+ $ h( kwtop, kwtop-1 ) = s*dconjg( v( 1, 1 ) )
+ CALL zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh )
+ CALL zcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),
+ $ ldh+1 )
+*
+* ==== Accumulate orthogonal matrix in order update
+* . H and Z, if requested. ====
+*
+ IF( ns.GT.1 .AND. s.NE.zero )
+ $ CALL zunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv,
+ $ work( jw+1 ), lwork-jw, info )
+*
+* ==== Update vertical slab in H ====
+*
+ IF( wantt ) THEN
+ ltop = 1
+ ELSE
+ ltop = ktop
+ END IF
+ DO 60 krow = ltop, kwtop - 1, nv
+ kln = min( nv, kwtop-krow )
+ CALL zgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),
+ $ ldh, v, ldv, zero, wv, ldwv )
+ CALL zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh )
+ 60 CONTINUE
+*
+* ==== Update horizontal slab in H ====
+*
+ IF( wantt ) THEN
+ DO 70 kcol = kbot + 1, n, nh
+ kln = min( nh, n-kcol+1 )
+ CALL zgemm( 'C', 'N', jw, kln, jw, one, v, ldv,
+ $ h( kwtop, kcol ), ldh, zero, t, ldt )
+ CALL zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),
+ $ ldh )
+ 70 CONTINUE
+ END IF
+*
+* ==== Update vertical slab in Z ====
+*
+ IF( wantz ) THEN
+ DO 80 krow = iloz, ihiz, nv
+ kln = min( nv, ihiz-krow+1 )
+ CALL zgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),
+ $ ldz, v, ldv, zero, wv, ldwv )
+ CALL zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),
+ $ ldz )
+ 80 CONTINUE
+ END IF
+ END IF
+*
+* ==== Return the number of deflations ... ====
+*
+ nd = jw - ns
+*
+* ==== ... and the number of shifts. (Subtracting
+* . INFQR from the spike length takes care
+* . of the case of a rare QR failure while
+* . calculating eigenvalues of the deflation
+* . window.) ====
+*
+ ns = ns - infqr
+*
+* ==== Return optimal workspace. ====
+*
+ work( 1 ) = dcmplx( lwkopt, 0 )
+*
+* ==== End of ZLAQR3 ====
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQR4 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+* IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+* LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAQR4 implements one level of recursion for ZLAQR0.
+*> It is a complete implementation of the small bulge multi-shift
+*> QR algorithm. It may be called by ZLAQR0 and, for large enough
+*> deflation window size, it may be called by ZLAQR3. This
+*> subroutine is identical to ZLAQR0 except that it calls ZLAQR2
+*> instead of ZLAQR3.
+*>
+*> ZLAQR4 computes the eigenvalues of a Hessenberg matrix H
+*> and, optionally, the matrices T and Z from the Schur decomposition
+*> H = Z T Z**H, where T is an upper triangular matrix (the
+*> Schur form), and Z is the unitary matrix of Schur vectors.
+*>
+*> Optionally Z may be postmultiplied into an input unitary
+*> matrix Q so that this routine can give the Schur factorization
+*> of a matrix A which has been reduced to the Hessenberg form H
+*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] WANTT
+*> \verbatim
+*> WANTT is LOGICAL
+*> = .TRUE. : the full Schur form T is required;
+*> = .FALSE.: only eigenvalues are required.
+*> \endverbatim
+*>
+*> \param[in] WANTZ
+*> \verbatim
+*> WANTZ is LOGICAL
+*> = .TRUE. : the matrix of Schur vectors Z is required;
+*> = .FALSE.: Schur vectors are not required.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix H. N .GE. 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*> It is assumed that H is already upper triangular in rows
+*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+*> previous call to ZGEBAL, and then passed to ZGEHRD when the
+*> matrix output by ZGEBAL is reduced to Hessenberg form.
+*> Otherwise, ILO and IHI should be set to 1 and N,
+*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*> If N = 0, then ILO = 1 and IHI = 0.
+*> \endverbatim
+*>
+*> \param[in,out] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> On entry, the upper Hessenberg matrix H.
+*> On exit, if INFO = 0 and WANTT is .TRUE., then H
+*> contains the upper triangular matrix T from the Schur
+*> decomposition (the Schur form). If INFO = 0 and WANT is
+*> .FALSE., then the contents of H are unspecified on exit.
+*> (The output value of H when INFO.GT.0 is given under the
+*> description of INFO below.)
+*>
+*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> The leading dimension of the array H. LDH .GE. max(1,N).
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (N)
+*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
+*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
+*> stored in the same order as on the diagonal of the Schur
+*> form returned in H, with W(i) = H(i,i).
+*> \endverbatim
+*>
+*> \param[in] ILOZ
+*> \verbatim
+*> ILOZ is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHIZ
+*> \verbatim
+*> IHIZ is INTEGER
+*> Specify the rows of Z to which transformations must be
+*> applied if WANTZ is .TRUE..
+*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*> \endverbatim
+*>
+*> \param[in,out] Z
+*> \verbatim
+*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
+*> If WANTZ is .FALSE., then Z is not referenced.
+*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+*> (The output value of Z when INFO.GT.0 is given under
+*> the description of INFO below.)
+*> \endverbatim
+*>
+*> \param[in] LDZ
+*> \verbatim
+*> LDZ is INTEGER
+*> The leading dimension of the array Z. if WANTZ is .TRUE.
+*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension LWORK
+*> On exit, if LWORK = -1, WORK(1) returns an estimate of
+*> the optimal value for LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK .GE. max(1,N)
+*> is sufficient, but LWORK typically as large as 6*N may
+*> be required for optimal performance. A workspace query
+*> to determine the optimal workspace size is recommended.
+*>
+*> If LWORK = -1, then ZLAQR4 does a workspace query.
+*> In this case, ZLAQR4 checks the input parameters and
+*> estimates the optimal workspace size for the given
+*> values of N, ILO and IHI. The estimate is returned
+*> in WORK(1). No error message related to LWORK is
+*> issued by XERBLA. Neither H nor Z are accessed.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> .GT. 0: if INFO = i, ZLAQR4 failed to compute all of
+*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+*> and WI contain those eigenvalues which have been
+*> successfully computed. (Failures are rare.)
+*>
+*> If INFO .GT. 0 and WANT is .FALSE., then on exit,
+*> the remaining unconverged eigenvalues are the eigen-
+*> values of the upper Hessenberg matrix rows and
+*> columns ILO through INFO of the final, output
+*> value of H.
+*>
+*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*>
+*> (*) (initial value of H)*U = U*(final value of H)
+*>
+*> where U is a unitary matrix. The final
+*> value of H is upper Hessenberg and triangular in
+*> rows and columns INFO+1 through IHI.
+*>
+*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*>
+*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
+*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*>
+*> where U is the unitary matrix in (*) (regard-
+*> less of the value of WANTT.)
+*>
+*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+*> accessed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Contributors:
+* ==================
+*>
+*> Karen Braman and Ralph Byers, Department of Mathematics,
+*> University of Kansas, USA
+*
+*> \par References:
+* ================
+*>
+*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*> 929--947, 2002.
+*> \n
+*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*> of Matrix Analysis, volume 23, pages 948--973, 2002.
+*>
+* =====================================================================
+ SUBROUTINE zlaqr4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+ $ IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), W( * ), WORK( * ), Z( ldz, * )
+* ..
+*
+* ================================================================
+*
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . ZLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+ INTEGER NTINY
+ parameter( ntiny = 11 )
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by varying the size of the
+* . deflation window after KEXNW iterations. ====
+ INTEGER KEXNW
+ parameter( kexnw = 5 )
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . ====
+ INTEGER KEXSH
+ parameter( kexsh = 6 )
+*
+* ==== The constant WILK1 is used to form the exceptional
+* . shifts. ====
+ DOUBLE PRECISION WILK1
+ parameter( wilk1 = 0.75d0 )
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d0, 0.0d0 ),
+ $ one = ( 1.0d0, 0.0d0 ) )
+ DOUBLE PRECISION TWO
+ parameter( two = 2.0d0 )
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
+ DOUBLE PRECISION S
+ INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ kt, ktop, ku, kv, kwh, kwtop, kwv, ld, ls,
+ $ lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns,
+ $ nsmax, nsr, nve, nw, nwmax, nwr, nwupbd
+ LOGICAL SORTED
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ilaenv
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL zlacpy, zlahqr, zlaqr2, zlaqr5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dimag, int, max, min, mod,
+ $ sqrt
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+ info = 0
+*
+* ==== Quick return for N = 0: nothing to do. ====
+*
+ IF( n.EQ.0 ) THEN
+ work( 1 ) = one
+ RETURN
+ END IF
+*
+ IF( n.LE.ntiny ) THEN
+*
+* ==== Tiny matrices must use ZLAHQR. ====
+*
+ lwkopt = 1
+ IF( lwork.NE.-1 )
+ $ CALL zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,
+ $ ihiz, z, ldz, info )
+ ELSE
+*
+* ==== Use small bulge multi-shift QR with aggressive early
+* . deflation on larger-than-tiny matrices. ====
+*
+* ==== Hope for the best. ====
+*
+ info = 0
+*
+* ==== Set up job flags for ILAENV. ====
+*
+ IF( wantt ) THEN
+ jbcmpz( 1: 1 ) = 'S'
+ ELSE
+ jbcmpz( 1: 1 ) = 'E'
+ END IF
+ IF( wantz ) THEN
+ jbcmpz( 2: 2 ) = 'V'
+ ELSE
+ jbcmpz( 2: 2 ) = 'N'
+ END IF
+*
+* ==== NWR = recommended deflation window size. At this
+* . point, N .GT. NTINY = 11, so there is enough
+* . subdiagonal workspace for NWR.GE.2 as required.
+* . (In fact, there is enough subdiagonal space for
+* . NWR.GE.3.) ====
+*
+ nwr = ilaenv( 13, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork )
+ nwr = max( 2, nwr )
+ nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
+*
+* ==== NSR = recommended number of simultaneous shifts.
+* . At this point N .GT. NTINY = 11, so there is at
+* . enough subdiagonal workspace for NSR to be even
+* . and greater than or equal to two as required. ====
+*
+ nsr = ilaenv( 15, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork )
+ nsr = min( nsr, ( n+6 ) / 9, ihi-ilo )
+ nsr = max( 2, nsr-mod( nsr, 2 ) )
+*
+* ==== Estimate optimal workspace ====
+*
+* ==== Workspace query call to ZLAQR2 ====
+*
+ CALL zlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,
+ $ ihiz, z, ldz, ls, ld, w, h, ldh, n, h, ldh, n, h,
+ $ ldh, work, -1 )
+*
+* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ====
+*
+ lwkopt = max( 3*nsr / 2, int( work( 1 ) ) )
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( lwork.EQ.-1 ) THEN
+ work( 1 ) = dcmplx( lwkopt, 0 )
+ RETURN
+ END IF
+*
+* ==== ZLAHQR/ZLAQR0 crossover point ====
+*
+ nmin = ilaenv( 12, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork )
+ nmin = max( ntiny, nmin )
+*
+* ==== Nibble crossover point ====
+*
+ nibble = ilaenv( 14, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork )
+ nibble = max( 0, nibble )
+*
+* ==== Accumulate reflections during ttswp? Use block
+* . 2-by-2 structure during matrix-matrix multiply? ====
+*
+ kacc22 = ilaenv( 16, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork )
+ kacc22 = max( 0, kacc22 )
+ kacc22 = min( 2, kacc22 )
+*
+* ==== NWMAX = the largest possible deflation window for
+* . which there is sufficient workspace. ====
+*
+ nwmax = min( ( n-1 ) / 3, lwork / 2 )
+ nw = nwmax
+*
+* ==== NSMAX = the Largest number of simultaneous shifts
+* . for which there is sufficient workspace. ====
+*
+ nsmax = min( ( n+6 ) / 9, 2*lwork / 3 )
+ nsmax = nsmax - mod( nsmax, 2 )
+*
+* ==== NDFL: an iteration count restarted at deflation. ====
+*
+ ndfl = 1
+*
+* ==== ITMAX = iteration limit ====
+*
+ itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) )
+*
+* ==== Last row and column in the active block ====
+*
+ kbot = ihi
+*
+* ==== Main Loop ====
+*
+ DO 70 it = 1, itmax
+*
+* ==== Done when KBOT falls below ILO ====
+*
+ IF( kbot.LT.ilo )
+ $ GO TO 80
+*
+* ==== Locate active block ====
+*
+ DO 10 k = kbot, ilo + 1, -1
+ IF( h( k, k-1 ).EQ.zero )
+ $ GO TO 20
+ 10 CONTINUE
+ k = ilo
+ 20 CONTINUE
+ ktop = k
+*
+* ==== Select deflation window size:
+* . Typical Case:
+* . If possible and advisable, nibble the entire
+* . active block. If not, use size MIN(NWR,NWMAX)
+* . or MIN(NWR+1,NWMAX) depending upon which has
+* . the smaller corresponding subdiagonal entry
+* . (a heuristic).
+* .
+* . Exceptional Case:
+* . If there have been no deflations in KEXNW or
+* . more iterations, then vary the deflation window
+* . size. At first, because, larger windows are,
+* . in general, more powerful than smaller ones,
+* . rapidly increase the window to the maximum possible.
+* . Then, gradually reduce the window size. ====
+*
+ nh = kbot - ktop + 1
+ nwupbd = min( nh, nwmax )
+ IF( ndfl.LT.kexnw ) THEN
+ nw = min( nwupbd, nwr )
+ ELSE
+ nw = min( nwupbd, 2*nw )
+ END IF
+ IF( nw.LT.nwmax ) THEN
+ IF( nw.GE.nh-1 ) THEN
+ nw = nh
+ ELSE
+ kwtop = kbot - nw + 1
+ IF( cabs1( h( kwtop, kwtop-1 ) ).GT.
+ $ cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + 1
+ END IF
+ END IF
+ IF( ndfl.LT.kexnw ) THEN
+ ndec = -1
+ ELSE IF( ndec.GE.0 .OR. nw.GE.nwupbd ) THEN
+ ndec = ndec + 1
+ IF( nw-ndec.LT.2 )
+ $ ndec = 0
+ nw = nw - ndec
+ END IF
+*
+* ==== Aggressive early deflation:
+* . split workspace under the subdiagonal into
+* . - an nw-by-nw work array V in the lower
+* . left-hand-corner,
+* . - an NW-by-at-least-NW-but-more-is-better
+* . (NW-by-NHO) horizontal work array along
+* . the bottom edge,
+* . - an at-least-NW-but-more-is-better (NHV-by-NW)
+* . vertical work array along the left-hand-edge.
+* . ====
+*
+ kv = n - nw + 1
+ kt = nw + 1
+ nho = ( n-nw-1 ) - kt + 1
+ kwv = nw + 2
+ nve = ( n-nw ) - kwv + 1
+*
+* ==== Aggressive early deflation ====
+*
+ CALL zlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,
+ $ ihiz, z, ldz, ls, ld, w, h( kv, 1 ), ldh, nho,
+ $ h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,
+ $ lwork )
+*
+* ==== Adjust KBOT accounting for new deflations. ====
+*
+ kbot = kbot - ld
+*
+* ==== KS points to the shifts. ====
+*
+ ks = kbot - ls + 1
+*
+* ==== Skip an expensive QR sweep if there is a (partly
+* . heuristic) reason to expect that many eigenvalues
+* . will deflate without it. Here, the QR sweep is
+* . skipped if many eigenvalues have just been deflated
+* . or if the remaining active block is small.
+*
+ IF( ( ld.EQ.0 ) .OR. ( ( 100*ld.LE.nw*nibble ) .AND. ( kbot-
+ $ ktop+1.GT.min( nmin, nwmax ) ) ) ) THEN
+*
+* ==== NS = nominal number of simultaneous shifts.
+* . This may be lowered (slightly) if ZLAQR2
+* . did not provide that many shifts. ====
+*
+ ns = min( nsmax, nsr, max( 2, kbot-ktop ) )
+ ns = ns - mod( ns, 2 )
+*
+* ==== If there have been no deflations
+* . in a multiple of KEXSH iterations,
+* . then try exceptional shifts.
+* . Otherwise use shifts provided by
+* . ZLAQR2 above or from the eigenvalues
+* . of a trailing principal submatrix. ====
+*
+ IF( mod( ndfl, kexsh ).EQ.0 ) THEN
+ ks = kbot - ns + 1
+ DO 30 i = kbot, ks + 1, -2
+ w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) )
+ w( i-1 ) = w( i )
+ 30 CONTINUE
+ ELSE
+*
+* ==== Got NS/2 or fewer shifts? Use ZLAHQR
+* . on a trailing principal submatrix to
+* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+* . there is enough space below the subdiagonal
+* . to fit an NS-by-NS scratch array.) ====
+*
+ IF( kbot-ks+1.LE.ns / 2 ) THEN
+ ks = kbot - ns + 1
+ kt = n - ns + 1
+ CALL zlacpy( 'A', ns, ns, h( ks, ks ), ldh,
+ $ h( kt, 1 ), ldh )
+ CALL zlahqr( .false., .false., ns, 1, ns,
+ $ h( kt, 1 ), ldh, w( ks ), 1, 1, zdum,
+ $ 1, inf )
+ ks = ks + inf
+*
+* ==== In case of a rare QR failure use
+* . eigenvalues of the trailing 2-by-2
+* . principal submatrix. Scale to avoid
+* . overflows, underflows and subnormals.
+* . (The scale factor S can not be zero,
+* . because H(KBOT,KBOT-1) is nonzero.) ====
+*
+ IF( ks.GE.kbot ) THEN
+ s = cabs1( h( kbot-1, kbot-1 ) ) +
+ $ cabs1( h( kbot, kbot-1 ) ) +
+ $ cabs1( h( kbot-1, kbot ) ) +
+ $ cabs1( h( kbot, kbot ) )
+ aa = h( kbot-1, kbot-1 ) / s
+ cc = h( kbot, kbot-1 ) / s
+ bb = h( kbot-1, kbot ) / s
+ dd = h( kbot, kbot ) / s
+ tr2 = ( aa+dd ) / two
+ det = ( aa-tr2 )*( dd-tr2 ) - bb*cc
+ rtdisc = sqrt( -det )
+ w( kbot-1 ) = ( tr2+rtdisc )*s
+ w( kbot ) = ( tr2-rtdisc )*s
+*
+ ks = kbot - 1
+ END IF
+ END IF
+*
+ IF( kbot-ks+1.GT.ns ) THEN
+*
+* ==== Sort the shifts (Helps a little) ====
+*
+ sorted = .false.
+ DO 50 k = kbot, ks + 1, -1
+ IF( sorted )
+ $ GO TO 60
+ sorted = .true.
+ DO 40 i = ks, k - 1
+ IF( cabs1( w( i ) ).LT.cabs1( w( i+1 ) ) )
+ $ THEN
+ sorted = .false.
+ swap = w( i )
+ w( i ) = w( i+1 )
+ w( i+1 ) = swap
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ END IF
+*
+* ==== If there are only two shifts, then use
+* . only one. ====
+*
+ IF( kbot-ks+1.EQ.2 ) THEN
+ IF( cabs1( w( kbot )-h( kbot, kbot ) ).LT.
+ $ cabs1( w( kbot-1 )-h( kbot, kbot ) ) ) THEN
+ w( kbot-1 ) = w( kbot )
+ ELSE
+ w( kbot ) = w( kbot-1 )
+ END IF
+ END IF
+*
+* ==== Use up to NS of the the smallest magnatiude
+* . shifts. If there aren't NS shifts available,
+* . then use them all, possibly dropping one to
+* . make the number of shifts even. ====
+*
+ ns = min( ns, kbot-ks+1 )
+ ns = ns - mod( ns, 2 )
+ ks = kbot - ns + 1
+*
+* ==== Small-bulge multi-shift QR sweep:
+* . split workspace under the subdiagonal into
+* . - a KDU-by-KDU work array U in the lower
+* . left-hand-corner,
+* . - a KDU-by-at-least-KDU-but-more-is-better
+* . (KDU-by-NHo) horizontal work array WH along
+* . the bottom edge,
+* . - and an at-least-KDU-but-more-is-better-by-KDU
+* . (NVE-by-KDU) vertical work WV arrow along
+* . the left-hand-edge. ====
+*
+ kdu = 3*ns - 3
+ ku = n - kdu + 1
+ kwh = kdu + 1
+ nho = ( n-kdu+1-4 ) - ( kdu+1 ) + 1
+ kwv = kdu + 4
+ nve = n - kdu - kwv + 1
+*
+* ==== Small-bulge multi-shift QR sweep ====
+*
+ CALL zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,
+ $ w( ks ), h, ldh, iloz, ihiz, z, ldz, work,
+ $ 3, h( ku, 1 ), ldh, nve, h( kwv, 1 ), ldh,
+ $ nho, h( ku, kwh ), ldh )
+ END IF
+*
+* ==== Note progress (or the lack of it). ====
+*
+ IF( ld.GT.0 ) THEN
+ ndfl = 1
+ ELSE
+ ndfl = ndfl + 1
+ END IF
+*
+* ==== End of main loop ====
+ 70 CONTINUE
+*
+* ==== Iteration limit exceeded. Set INFO to show where
+* . the problem occurred and exit. ====
+*
+ info = kbot
+ 80 CONTINUE
+ END IF
+*
+* ==== Return the optimal value of LWORK. ====
+*
+ work( 1 ) = dcmplx( lwkopt, 0 )
+*
+* ==== End of ZLAQR4 ====
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLAQR5 performs a single small-bulge multi-shift QR sweep.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAQR5 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
+* H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
+* WV, LDWV, NH, WH, LDWH )
+*
+* .. Scalar Arguments ..
+* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
+* LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
+* $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLAQR5, called by ZLAQR0, performs a
+*> single small-bulge multi-shift QR sweep.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] WANTT
+*> \verbatim
+*> WANTT is LOGICAL
+*> WANTT = .true. if the triangular Schur factor
+*> is being computed. WANTT is set to .false. otherwise.
+*> \endverbatim
+*>
+*> \param[in] WANTZ
+*> \verbatim
+*> WANTZ is LOGICAL
+*> WANTZ = .true. if the unitary Schur factor is being
+*> computed. WANTZ is set to .false. otherwise.
+*> \endverbatim
+*>
+*> \param[in] KACC22
+*> \verbatim
+*> KACC22 is INTEGER with value 0, 1, or 2.
+*> Specifies the computation mode of far-from-diagonal
+*> orthogonal updates.
+*> = 0: ZLAQR5 does not accumulate reflections and does not
+*> use matrix-matrix multiply to update far-from-diagonal
+*> matrix entries.
+*> = 1: ZLAQR5 accumulates reflections and uses matrix-matrix
+*> multiply to update the far-from-diagonal matrix entries.
+*> = 2: ZLAQR5 accumulates reflections, uses matrix-matrix
+*> multiply to update the far-from-diagonal matrix entries,
+*> and takes advantage of 2-by-2 block structure during
+*> matrix multiplies.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> N is the order of the Hessenberg matrix H upon which this
+*> subroutine operates.
+*> \endverbatim
+*>
+*> \param[in] KTOP
+*> \verbatim
+*> KTOP is INTEGER
+*> \endverbatim
+*>
+*> \param[in] KBOT
+*> \verbatim
+*> KBOT is INTEGER
+*> These are the first and last rows and columns of an
+*> isolated diagonal block upon which the QR sweep is to be
+*> applied. It is assumed without a check that
+*> either KTOP = 1 or H(KTOP,KTOP-1) = 0
+*> and
+*> either KBOT = N or H(KBOT+1,KBOT) = 0.
+*> \endverbatim
+*>
+*> \param[in] NSHFTS
+*> \verbatim
+*> NSHFTS is INTEGER
+*> NSHFTS gives the number of simultaneous shifts. NSHFTS
+*> must be positive and even.
+*> \endverbatim
+*>
+*> \param[in,out] S
+*> \verbatim
+*> S is COMPLEX*16 array, dimension (NSHFTS)
+*> S contains the shifts of origin that define the multi-
+*> shift QR sweep. On output S may be reordered.
+*> \endverbatim
+*>
+*> \param[in,out] H
+*> \verbatim
+*> H is COMPLEX*16 array, dimension (LDH,N)
+*> On input H contains a Hessenberg matrix. On output a
+*> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+*> to the isolated diagonal block in rows and columns KTOP
+*> through KBOT.
+*> \endverbatim
+*>
+*> \param[in] LDH
+*> \verbatim
+*> LDH is INTEGER
+*> LDH is the leading dimension of H just as declared in the
+*> calling procedure. LDH.GE.MAX(1,N).
+*> \endverbatim
+*>
+*> \param[in] ILOZ
+*> \verbatim
+*> ILOZ is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHIZ
+*> \verbatim
+*> IHIZ is INTEGER
+*> Specify the rows of Z to which transformations must be
+*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*> \endverbatim
+*>
+*> \param[in,out] Z
+*> \verbatim
+*> Z is COMPLEX*16 array, dimension (LDZ,IHIZ)
+*> If WANTZ = .TRUE., then the QR Sweep unitary
+*> similarity transformation is accumulated into
+*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
+*> If WANTZ = .FALSE., then Z is unreferenced.
+*> \endverbatim
+*>
+*> \param[in] LDZ
+*> \verbatim
+*> LDZ is INTEGER
+*> LDA is the leading dimension of Z just as declared in
+*> the calling procedure. LDZ.GE.N.
+*> \endverbatim
+*>
+*> \param[out] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension (LDV,NSHFTS/2)
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> LDV is the leading dimension of V as declared in the
+*> calling procedure. LDV.GE.3.
+*> \endverbatim
+*>
+*> \param[out] U
+*> \verbatim
+*> U is COMPLEX*16 array, dimension (LDU,3*NSHFTS-3)
+*> \endverbatim
+*>
+*> \param[in] LDU
+*> \verbatim
+*> LDU is INTEGER
+*> LDU is the leading dimension of U just as declared in the
+*> in the calling subroutine. LDU.GE.3*NSHFTS-3.
+*> \endverbatim
+*>
+*> \param[in] NH
+*> \verbatim
+*> NH is INTEGER
+*> NH is the number of columns in array WH available for
+*> workspace. NH.GE.1.
+*> \endverbatim
+*>
+*> \param[out] WH
+*> \verbatim
+*> WH is COMPLEX*16 array, dimension (LDWH,NH)
+*> \endverbatim
+*>
+*> \param[in] LDWH
+*> \verbatim
+*> LDWH is INTEGER
+*> Leading dimension of WH just as declared in the
+*> calling procedure. LDWH.GE.3*NSHFTS-3.
+*> \endverbatim
+*>
+*> \param[in] NV
+*> \verbatim
+*> NV is INTEGER
+*> NV is the number of rows in WV agailable for workspace.
+*> NV.GE.1.
+*> \endverbatim
+*>
+*> \param[out] WV
+*> \verbatim
+*> WV is COMPLEX*16 array, dimension (LDWV,3*NSHFTS-3)
+*> \endverbatim
+*>
+*> \param[in] LDWV
+*> \verbatim
+*> LDWV is INTEGER
+*> LDWV is the leading dimension of WV as declared in the
+*> in the calling subroutine. LDWV.GE.NV.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Contributors:
+* ==================
+*>
+*> Karen Braman and Ralph Byers, Department of Mathematics,
+*> University of Kansas, USA
+*
+*> \par References:
+* ================
+*>
+*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*> 929--947, 2002.
+*>
+* =====================================================================
+ SUBROUTINE zlaqr5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
+ $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
+ $ WV, LDWV, NH, WH, LDWH )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+ $ ldwh, ldwv, ldz, n, nh, nshfts, nv
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 H( ldh, * ), S( * ), U( ldu, * ), V( ldv, * ),
+ $ wh( ldwh, * ), wv( ldwv, * ), z( ldz, * )
+* ..
+*
+* ================================================================
+* .. Parameters ..
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d0, 0.0d0 ),
+ $ one = ( 1.0d0, 0.0d0 ) )
+ DOUBLE PRECISION RZERO, RONE
+ parameter( rzero = 0.0d0, rone = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 ALPHA, BETA, CDUM, REFSUM
+ DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
+ $ smlnum, tst1, tst2, ulp
+ INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
+ $ jrow, jtop, k, k1, kdu, kms, knz, krcol, kzs,
+ $ m, m22, mbot, mend, mstart, mtop, nbmps, ndcol,
+ $ ns, nu
+ LOGICAL ACCUM, BLK22, BMP22
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL dlamch
+* ..
+* .. Intrinsic Functions ..
+*
+ INTRINSIC abs, dble, dconjg, dimag, max, min, mod
+* ..
+* .. Local Arrays ..
+ COMPLEX*16 VT( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL dlabad, zgemm, zlacpy, zlaqr1, zlarfg, zlaset,
+ $ ztrmm
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+*
+* ==== If there are no shifts, then there is nothing to do. ====
+*
+ IF( nshfts.LT.2 )
+ $ RETURN
+*
+* ==== If the active block is empty or 1-by-1, then there
+* . is nothing to do. ====
+*
+ IF( ktop.GE.kbot )
+ $ RETURN
+*
+* ==== NSHFTS is supposed to be even, but if it is odd,
+* . then simply reduce it by one. ====
+*
+ ns = nshfts - mod( nshfts, 2 )
+*
+* ==== Machine constants for deflation ====
+*
+ safmin = dlamch( 'SAFE MINIMUM' )
+ safmax = rone / safmin
+ CALL dlabad( safmin, safmax )
+ ulp = dlamch( 'PRECISION' )
+ smlnum = safmin*( dble( n ) / ulp )
+*
+* ==== Use accumulated reflections to update far-from-diagonal
+* . entries ? ====
+*
+ accum = ( kacc22.EQ.1 ) .OR. ( kacc22.EQ.2 )
+*
+* ==== If so, exploit the 2-by-2 block structure? ====
+*
+ blk22 = ( ns.GT.2 ) .AND. ( kacc22.EQ.2 )
+*
+* ==== clear trash ====
+*
+ IF( ktop+2.LE.kbot )
+ $ h( ktop+2, ktop ) = zero
+*
+* ==== NBMPS = number of 2-shift bulges in the chain ====
+*
+ nbmps = ns / 2
+*
+* ==== KDU = width of slab ====
+*
+ kdu = 6*nbmps - 3
+*
+* ==== Create and chase chains of NBMPS bulges ====
+*
+ DO 210 incol = 3*( 1-nbmps ) + ktop - 1, kbot - 2, 3*nbmps - 2
+ ndcol = incol + kdu
+ IF( accum )
+ $ CALL zlaset( 'ALL', kdu, kdu, zero, one, u, ldu )
+*
+* ==== Near-the-diagonal bulge chase. The following loop
+* . performs the near-the-diagonal part of a small bulge
+* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal
+* . chunk extends from column INCOL to column NDCOL
+* . (including both column INCOL and column NDCOL). The
+* . following loop chases a 3*NBMPS column long chain of
+* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL
+* . may be less than KTOP and and NDCOL may be greater than
+* . KBOT indicating phantom columns from which to chase
+* . bulges before they are actually introduced or to which
+* . to chase bulges beyond column KBOT.) ====
+*
+ DO 140 krcol = incol, min( incol+3*nbmps-3, kbot-2 )
+*
+* ==== Bulges number MTOP to MBOT are active double implicit
+* . shift bulges. There may or may not also be small
+* . 2-by-2 bulge, if there is room. The inactive bulges
+* . (if any) must wait until the active bulges have moved
+* . down the diagonal to make room. The phantom matrix
+* . paradigm described above helps keep track. ====
+*
+ mtop = max( 1, ( ( ktop-1 )-krcol+2 ) / 3+1 )
+ mbot = min( nbmps, ( kbot-krcol ) / 3 )
+ m22 = mbot + 1
+ bmp22 = ( mbot.LT.nbmps ) .AND. ( krcol+3*( m22-1 ) ).EQ.
+ $ ( kbot-2 )
+*
+* ==== Generate reflections to chase the chain right
+* . one column. (The minimum value of K is KTOP-1.) ====
+*
+ DO 10 m = mtop, mbot
+ k = krcol + 3*( m-1 )
+ IF( k.EQ.ktop-1 ) THEN
+ CALL zlaqr1( 3, h( ktop, ktop ), ldh, s( 2*m-1 ),
+ $ s( 2*m ), v( 1, m ) )
+ alpha = v( 1, m )
+ CALL zlarfg( 3, alpha, v( 2, m ), 1, v( 1, m ) )
+ ELSE
+ beta = h( k+1, k )
+ v( 2, m ) = h( k+2, k )
+ v( 3, m ) = h( k+3, k )
+ CALL zlarfg( 3, beta, v( 2, m ), 1, v( 1, m ) )
+*
+* ==== A Bulge may collapse because of vigilant
+* . deflation or destructive underflow. In the
+* . underflow case, try the two-small-subdiagonals
+* . trick to try to reinflate the bulge. ====
+*
+ IF( h( k+3, k ).NE.zero .OR. h( k+3, k+1 ).NE.
+ $ zero .OR. h( k+3, k+2 ).EQ.zero ) THEN
+*
+* ==== Typical case: not collapsed (yet). ====
+*
+ h( k+1, k ) = beta
+ h( k+2, k ) = zero
+ h( k+3, k ) = zero
+ ELSE
+*
+* ==== Atypical case: collapsed. Attempt to
+* . reintroduce ignoring H(K+1,K) and H(K+2,K).
+* . If the fill resulting from the new
+* . reflector is too large, then abandon it.
+* . Otherwise, use the new one. ====
+*
+ CALL zlaqr1( 3, h( k+1, k+1 ), ldh, s( 2*m-1 ),
+ $ s( 2*m ), vt )
+ alpha = vt( 1 )
+ CALL zlarfg( 3, alpha, vt( 2 ), 1, vt( 1 ) )
+ refsum = dconjg( vt( 1 ) )*
+ $ ( h( k+1, k )+dconjg( vt( 2 ) )*
+ $ h( k+2, k ) )
+*
+ IF( cabs1( h( k+2, k )-refsum*vt( 2 ) )+
+ $ cabs1( refsum*vt( 3 ) ).GT.ulp*
+ $ ( cabs1( h( k, k ) )+cabs1( h( k+1,
+ $ k+1 ) )+cabs1( h( k+2, k+2 ) ) ) ) THEN
+*
+* ==== Starting a new bulge here would
+* . create non-negligible fill. Use
+* . the old one with trepidation. ====
+*
+ h( k+1, k ) = beta
+ h( k+2, k ) = zero
+ h( k+3, k ) = zero
+ ELSE
+*
+* ==== Stating a new bulge here would
+* . create only negligible fill.
+* . Replace the old reflector with
+* . the new one. ====
+*
+ h( k+1, k ) = h( k+1, k ) - refsum
+ h( k+2, k ) = zero
+ h( k+3, k ) = zero
+ v( 1, m ) = vt( 1 )
+ v( 2, m ) = vt( 2 )
+ v( 3, m ) = vt( 3 )
+ END IF
+ END IF
+ END IF
+ 10 CONTINUE
+*
+* ==== Generate a 2-by-2 reflection, if needed. ====
+*
+ k = krcol + 3*( m22-1 )
+ IF( bmp22 ) THEN
+ IF( k.EQ.ktop-1 ) THEN
+ CALL zlaqr1( 2, h( k+1, k+1 ), ldh, s( 2*m22-1 ),
+ $ s( 2*m22 ), v( 1, m22 ) )
+ beta = v( 1, m22 )
+ CALL zlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) )
+ ELSE
+ beta = h( k+1, k )
+ v( 2, m22 ) = h( k+2, k )
+ CALL zlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) )
+ h( k+1, k ) = beta
+ h( k+2, k ) = zero
+ END IF
+ END IF
+*
+* ==== Multiply H by reflections from the left ====
+*
+ IF( accum ) THEN
+ jbot = min( ndcol, kbot )
+ ELSE IF( wantt ) THEN
+ jbot = n
+ ELSE
+ jbot = kbot
+ END IF
+ DO 30 j = max( ktop, krcol ), jbot
+ mend = min( mbot, ( j-krcol+2 ) / 3 )
+ DO 20 m = mtop, mend
+ k = krcol + 3*( m-1 )
+ refsum = dconjg( v( 1, m ) )*
+ $ ( h( k+1, j )+dconjg( v( 2, m ) )*
+ $ h( k+2, j )+dconjg( v( 3, m ) )*h( k+3, j ) )
+ h( k+1, j ) = h( k+1, j ) - refsum
+ h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m )
+ h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m )
+ 20 CONTINUE
+ 30 CONTINUE
+ IF( bmp22 ) THEN
+ k = krcol + 3*( m22-1 )
+ DO 40 j = max( k+1, ktop ), jbot
+ refsum = dconjg( v( 1, m22 ) )*
+ $ ( h( k+1, j )+dconjg( v( 2, m22 ) )*
+ $ h( k+2, j ) )
+ h( k+1, j ) = h( k+1, j ) - refsum
+ h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m22 )
+ 40 CONTINUE
+ END IF
+*
+* ==== Multiply H by reflections from the right.
+* . Delay filling in the last row until the
+* . vigilant deflation check is complete. ====
+*
+ IF( accum ) THEN
+ jtop = max( ktop, incol )
+ ELSE IF( wantt ) THEN
+ jtop = 1
+ ELSE
+ jtop = ktop
+ END IF
+ DO 80 m = mtop, mbot
+ IF( v( 1, m ).NE.zero ) THEN
+ k = krcol + 3*( m-1 )
+ DO 50 j = jtop, min( kbot, k+3 )
+ refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*
+ $ h( j, k+2 )+v( 3, m )*h( j, k+3 ) )
+ h( j, k+1 ) = h( j, k+1 ) - refsum
+ h( j, k+2 ) = h( j, k+2 ) -
+ $ refsum*dconjg( v( 2, m ) )
+ h( j, k+3 ) = h( j, k+3 ) -
+ $ refsum*dconjg( v( 3, m ) )
+ 50 CONTINUE
+*
+ IF( accum ) THEN
+*
+* ==== Accumulate U. (If necessary, update Z later
+* . with with an efficient matrix-matrix
+* . multiply.) ====
+*
+ kms = k - incol
+ DO 60 j = max( 1, ktop-incol ), kdu
+ refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*
+ $ u( j, kms+2 )+v( 3, m )*u( j, kms+3 ) )
+ u( j, kms+1 ) = u( j, kms+1 ) - refsum
+ u( j, kms+2 ) = u( j, kms+2 ) -
+ $ refsum*dconjg( v( 2, m ) )
+ u( j, kms+3 ) = u( j, kms+3 ) -
+ $ refsum*dconjg( v( 3, m ) )
+ 60 CONTINUE
+ ELSE IF( wantz ) THEN
+*
+* ==== U is not accumulated, so update Z
+* . now by multiplying by reflections
+* . from the right. ====
+*
+ DO 70 j = iloz, ihiz
+ refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*
+ $ z( j, k+2 )+v( 3, m )*z( j, k+3 ) )
+ z( j, k+1 ) = z( j, k+1 ) - refsum
+ z( j, k+2 ) = z( j, k+2 ) -
+ $ refsum*dconjg( v( 2, m ) )
+ z( j, k+3 ) = z( j, k+3 ) -
+ $ refsum*dconjg( v( 3, m ) )
+ 70 CONTINUE
+ END IF
+ END IF
+ 80 CONTINUE
+*
+* ==== Special case: 2-by-2 reflection (if needed) ====
+*
+ k = krcol + 3*( m22-1 )
+ IF( bmp22 ) THEN
+ IF ( v( 1, m22 ).NE.zero ) THEN
+ DO 90 j = jtop, min( kbot, k+3 )
+ refsum = v( 1, m22 )*( h( j, k+1 )+v( 2, m22 )*
+ $ h( j, k+2 ) )
+ h( j, k+1 ) = h( j, k+1 ) - refsum
+ h( j, k+2 ) = h( j, k+2 ) -
+ $ refsum*dconjg( v( 2, m22 ) )
+ 90 CONTINUE
+*
+ IF( accum ) THEN
+ kms = k - incol
+ DO 100 j = max( 1, ktop-incol ), kdu
+ refsum = v( 1, m22 )*( u( j, kms+1 )+
+ $ v( 2, m22 )*u( j, kms+2 ) )
+ u( j, kms+1 ) = u( j, kms+1 ) - refsum
+ u( j, kms+2 ) = u( j, kms+2 ) -
+ $ refsum*dconjg( v( 2, m22 ) )
+ 100 CONTINUE
+ ELSE IF( wantz ) THEN
+ DO 110 j = iloz, ihiz
+ refsum = v( 1, m22 )*( z( j, k+1 )+v( 2, m22 )*
+ $ z( j, k+2 ) )
+ z( j, k+1 ) = z( j, k+1 ) - refsum
+ z( j, k+2 ) = z( j, k+2 ) -
+ $ refsum*dconjg( v( 2, m22 ) )
+ 110 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* ==== Vigilant deflation check ====
+*
+ mstart = mtop
+ IF( krcol+3*( mstart-1 ).LT.ktop )
+ $ mstart = mstart + 1
+ mend = mbot
+ IF( bmp22 )
+ $ mend = mend + 1
+ IF( krcol.EQ.kbot-2 )
+ $ mend = mend + 1
+ DO 120 m = mstart, mend
+ k = min( kbot-1, krcol+3*( m-1 ) )
+*
+* ==== The following convergence test requires that
+* . the tradition small-compared-to-nearby-diagonals
+* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
+* . criteria both be satisfied. The latter improves
+* . accuracy in some examples. Falling back on an
+* . alternate convergence criterion when TST1 or TST2
+* . is zero (as done here) is traditional but probably
+* . unnecessary. ====
+*
+ IF( h( k+1, k ).NE.zero ) THEN
+ tst1 = cabs1( h( k, k ) ) + cabs1( h( k+1, k+1 ) )
+ IF( tst1.EQ.rzero ) THEN
+ IF( k.GE.ktop+1 )
+ $ tst1 = tst1 + cabs1( h( k, k-1 ) )
+ IF( k.GE.ktop+2 )
+ $ tst1 = tst1 + cabs1( h( k, k-2 ) )
+ IF( k.GE.ktop+3 )
+ $ tst1 = tst1 + cabs1( h( k, k-3 ) )
+ IF( k.LE.kbot-2 )
+ $ tst1 = tst1 + cabs1( h( k+2, k+1 ) )
+ IF( k.LE.kbot-3 )
+ $ tst1 = tst1 + cabs1( h( k+3, k+1 ) )
+ IF( k.LE.kbot-4 )
+ $ tst1 = tst1 + cabs1( h( k+4, k+1 ) )
+ END IF
+ IF( cabs1( h( k+1, k ) ).LE.max( smlnum, ulp*tst1 ) )
+ $ THEN
+ h12 = max( cabs1( h( k+1, k ) ),
+ $ cabs1( h( k, k+1 ) ) )
+ h21 = min( cabs1( h( k+1, k ) ),
+ $ cabs1( h( k, k+1 ) ) )
+ h11 = max( cabs1( h( k+1, k+1 ) ),
+ $ cabs1( h( k, k )-h( k+1, k+1 ) ) )
+ h22 = min( cabs1( h( k+1, k+1 ) ),
+ $ cabs1( h( k, k )-h( k+1, k+1 ) ) )
+ scl = h11 + h12
+ tst2 = h22*( h11 / scl )
+*
+ IF( tst2.EQ.rzero .OR. h21*( h12 / scl ).LE.
+ $ max( smlnum, ulp*tst2 ) )h( k+1, k ) = zero
+ END IF
+ END IF
+ 120 CONTINUE
+*
+* ==== Fill in the last row of each bulge. ====
+*
+ mend = min( nbmps, ( kbot-krcol-1 ) / 3 )
+ DO 130 m = mtop, mend
+ k = krcol + 3*( m-1 )
+ refsum = v( 1, m )*v( 3, m )*h( k+4, k+3 )
+ h( k+4, k+1 ) = -refsum
+ h( k+4, k+2 ) = -refsum*dconjg( v( 2, m ) )
+ h( k+4, k+3 ) = h( k+4, k+3 ) -
+ $ refsum*dconjg( v( 3, m ) )
+ 130 CONTINUE
+*
+* ==== End of near-the-diagonal bulge chase. ====
+*
+ 140 CONTINUE
+*
+* ==== Use U (if accumulated) to update far-from-diagonal
+* . entries in H. If required, use U to update Z as
+* . well. ====
+*
+ IF( accum ) THEN
+ IF( wantt ) THEN
+ jtop = 1
+ jbot = n
+ ELSE
+ jtop = ktop
+ jbot = kbot
+ END IF
+ IF( ( .NOT.blk22 ) .OR. ( incol.LT.ktop ) .OR.
+ $ ( ndcol.GT.kbot ) .OR. ( ns.LE.2 ) ) THEN
+*
+* ==== Updates not exploiting the 2-by-2 block
+* . structure of U. K1 and NU keep track of
+* . the location and size of U in the special
+* . cases of introducing bulges and chasing
+* . bulges off the bottom. In these special
+* . cases and in case the number of shifts
+* . is NS = 2, there is no 2-by-2 block
+* . structure to exploit. ====
+*
+ k1 = max( 1, ktop-incol )
+ nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1
+*
+* ==== Horizontal Multiply ====
+*
+ DO 150 jcol = min( ndcol, kbot ) + 1, jbot, nh
+ jlen = min( nh, jbot-jcol+1 )
+ CALL zgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),
+ $ ldu, h( incol+k1, jcol ), ldh, zero, wh,
+ $ ldwh )
+ CALL zlacpy( 'ALL', nu, jlen, wh, ldwh,
+ $ h( incol+k1, jcol ), ldh )
+ 150 CONTINUE
+*
+* ==== Vertical multiply ====
+*
+ DO 160 jrow = jtop, max( ktop, incol ) - 1, nv
+ jlen = min( nv, max( ktop, incol )-jrow )
+ CALL zgemm( 'N', 'N', jlen, nu, nu, one,
+ $ h( jrow, incol+k1 ), ldh, u( k1, k1 ),
+ $ ldu, zero, wv, ldwv )
+ CALL zlacpy( 'ALL', jlen, nu, wv, ldwv,
+ $ h( jrow, incol+k1 ), ldh )
+ 160 CONTINUE
+*
+* ==== Z multiply (also vertical) ====
+*
+ IF( wantz ) THEN
+ DO 170 jrow = iloz, ihiz, nv
+ jlen = min( nv, ihiz-jrow+1 )
+ CALL zgemm( 'N', 'N', jlen, nu, nu, one,
+ $ z( jrow, incol+k1 ), ldz, u( k1, k1 ),
+ $ ldu, zero, wv, ldwv )
+ CALL zlacpy( 'ALL', jlen, nu, wv, ldwv,
+ $ z( jrow, incol+k1 ), ldz )
+ 170 CONTINUE
+ END IF
+ ELSE
+*
+* ==== Updates exploiting U's 2-by-2 block structure.
+* . (I2, I4, J2, J4 are the last rows and columns
+* . of the blocks.) ====
+*
+ i2 = ( kdu+1 ) / 2
+ i4 = kdu
+ j2 = i4 - i2
+ j4 = kdu
+*
+* ==== KZS and KNZ deal with the band of zeros
+* . along the diagonal of one of the triangular
+* . blocks. ====
+*
+ kzs = ( j4-j2 ) - ( ns+1 )
+ knz = ns + 1
+*
+* ==== Horizontal multiply ====
+*
+ DO 180 jcol = min( ndcol, kbot ) + 1, jbot, nh
+ jlen = min( nh, jbot-jcol+1 )
+*
+* ==== Copy bottom of H to top+KZS of scratch ====
+* (The first KZS rows get multiplied by zero.) ====
+*
+ CALL zlacpy( 'ALL', knz, jlen, h( incol+1+j2, jcol ),
+ $ ldh, wh( kzs+1, 1 ), ldwh )
+*
+* ==== Multiply by U21**H ====
+*
+ CALL zlaset( 'ALL', kzs, jlen, zero, zero, wh, ldwh )
+ CALL ztrmm( 'L', 'U', 'C', 'N', knz, jlen, one,
+ $ u( j2+1, 1+kzs ), ldu, wh( kzs+1, 1 ),
+ $ ldwh )
+*
+* ==== Multiply top of H by U11**H ====
+*
+ CALL zgemm( 'C', 'N', i2, jlen, j2, one, u, ldu,
+ $ h( incol+1, jcol ), ldh, one, wh, ldwh )
+*
+* ==== Copy top of H to bottom of WH ====
+*
+ CALL zlacpy( 'ALL', j2, jlen, h( incol+1, jcol ), ldh,
+ $ wh( i2+1, 1 ), ldwh )
+*
+* ==== Multiply by U21**H ====
+*
+ CALL ztrmm( 'L', 'L', 'C', 'N', j2, jlen, one,
+ $ u( 1, i2+1 ), ldu, wh( i2+1, 1 ), ldwh )
+*
+* ==== Multiply by U22 ====
+*
+ CALL zgemm( 'C', 'N', i4-i2, jlen, j4-j2, one,
+ $ u( j2+1, i2+1 ), ldu,
+ $ h( incol+1+j2, jcol ), ldh, one,
+ $ wh( i2+1, 1 ), ldwh )
+*
+* ==== Copy it back ====
+*
+ CALL zlacpy( 'ALL', kdu, jlen, wh, ldwh,
+ $ h( incol+1, jcol ), ldh )
+ 180 CONTINUE
+*
+* ==== Vertical multiply ====
+*
+ DO 190 jrow = jtop, max( incol, ktop ) - 1, nv
+ jlen = min( nv, max( incol, ktop )-jrow )
+*
+* ==== Copy right of H to scratch (the first KZS
+* . columns get multiplied by zero) ====
+*
+ CALL zlacpy( 'ALL', jlen, knz, h( jrow, incol+1+j2 ),
+ $ ldh, wv( 1, 1+kzs ), ldwv )
+*
+* ==== Multiply by U21 ====
+*
+ CALL zlaset( 'ALL', jlen, kzs, zero, zero, wv, ldwv )
+ CALL ztrmm( 'R', 'U', 'N', 'N', jlen, knz, one,
+ $ u( j2+1, 1+kzs ), ldu, wv( 1, 1+kzs ),
+ $ ldwv )
+*
+* ==== Multiply by U11 ====
+*
+ CALL zgemm( 'N', 'N', jlen, i2, j2, one,
+ $ h( jrow, incol+1 ), ldh, u, ldu, one, wv,
+ $ ldwv )
+*
+* ==== Copy left of H to right of scratch ====
+*
+ CALL zlacpy( 'ALL', jlen, j2, h( jrow, incol+1 ), ldh,
+ $ wv( 1, 1+i2 ), ldwv )
+*
+* ==== Multiply by U21 ====
+*
+ CALL ztrmm( 'R', 'L', 'N', 'N', jlen, i4-i2, one,
+ $ u( 1, i2+1 ), ldu, wv( 1, 1+i2 ), ldwv )
+*
+* ==== Multiply by U22 ====
+*
+ CALL zgemm( 'N', 'N', jlen, i4-i2, j4-j2, one,
+ $ h( jrow, incol+1+j2 ), ldh,
+ $ u( j2+1, i2+1 ), ldu, one, wv( 1, 1+i2 ),
+ $ ldwv )
+*
+* ==== Copy it back ====
+*
+ CALL zlacpy( 'ALL', jlen, kdu, wv, ldwv,
+ $ h( jrow, incol+1 ), ldh )
+ 190 CONTINUE
+*
+* ==== Multiply Z (also vertical) ====
+*
+ IF( wantz ) THEN
+ DO 200 jrow = iloz, ihiz, nv
+ jlen = min( nv, ihiz-jrow+1 )
+*
+* ==== Copy right of Z to left of scratch (first
+* . KZS columns get multiplied by zero) ====
+*
+ CALL zlacpy( 'ALL', jlen, knz,
+ $ z( jrow, incol+1+j2 ), ldz,
+ $ wv( 1, 1+kzs ), ldwv )
+*
+* ==== Multiply by U12 ====
+*
+ CALL zlaset( 'ALL', jlen, kzs, zero, zero, wv,
+ $ ldwv )
+ CALL ztrmm( 'R', 'U', 'N', 'N', jlen, knz, one,
+ $ u( j2+1, 1+kzs ), ldu, wv( 1, 1+kzs ),
+ $ ldwv )
+*
+* ==== Multiply by U11 ====
+*
+ CALL zgemm( 'N', 'N', jlen, i2, j2, one,
+ $ z( jrow, incol+1 ), ldz, u, ldu, one,
+ $ wv, ldwv )
+*
+* ==== Copy left of Z to right of scratch ====
+*
+ CALL zlacpy( 'ALL', jlen, j2, z( jrow, incol+1 ),
+ $ ldz, wv( 1, 1+i2 ), ldwv )
+*
+* ==== Multiply by U21 ====
+*
+ CALL ztrmm( 'R', 'L', 'N', 'N', jlen, i4-i2, one,
+ $ u( 1, i2+1 ), ldu, wv( 1, 1+i2 ),
+ $ ldwv )
+*
+* ==== Multiply by U22 ====
+*
+ CALL zgemm( 'N', 'N', jlen, i4-i2, j4-j2, one,
+ $ z( jrow, incol+1+j2 ), ldz,
+ $ u( j2+1, i2+1 ), ldu, one,
+ $ wv( 1, 1+i2 ), ldwv )
+*
+* ==== Copy the result back to Z ====
+*
+ CALL zlacpy( 'ALL', jlen, kdu, wv, ldwv,
+ $ z( jrow, incol+1 ), ldz )
+ 200 CONTINUE
+ END IF
+ END IF
+ END IF
+ 210 CONTINUE
+*
+* ==== End of ZLAQR5 ====
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLARFB + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+* T, LDT, C, LDC, WORK, LDWORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIRECT, SIDE, STOREV, TRANS
+* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
+* $ WORK( LDWORK, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLARFB applies a complex block reflector H or its transpose H**H to a
+*> complex M-by-N matrix C, from either the left or the right.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply H or H**H from the Left
+*> = 'R': apply H or H**H from the Right
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': apply H (No transpose)
+*> = 'C': apply H**H (Conjugate transpose)
+*> \endverbatim
+*>
+*> \param[in] DIRECT
+*> \verbatim
+*> DIRECT is CHARACTER*1
+*> Indicates how H is formed from a product of elementary
+*> reflectors
+*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*> \endverbatim
+*>
+*> \param[in] STOREV
+*> \verbatim
+*> STOREV is CHARACTER*1
+*> Indicates how the vectors which define the elementary
+*> reflectors are stored:
+*> = 'C': Columnwise
+*> = 'R': Rowwise
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The order of the matrix T (= the number of elementary
+*> reflectors whose product defines the block reflector).
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension
+*> (LDV,K) if STOREV = 'C'
+*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
+*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
+*> See Further Details.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
+*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
+*> if STOREV = 'R', LDV >= K.
+*> \endverbatim
+*>
+*> \param[in] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,K)
+*> The triangular K-by-K matrix T in the representation of the
+*> block reflector.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= K.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LDWORK,K)
+*> \endverbatim
+*>
+*> \param[in] LDWORK
+*> \verbatim
+*> LDWORK is INTEGER
+*> The leading dimension of the array WORK.
+*> If SIDE = 'L', LDWORK >= max(1,N);
+*> if SIDE = 'R', LDWORK >= max(1,M).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2013
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The shape of the matrix V and the storage of the vectors which define
+*> the H(i) is best illustrated by the following example with n = 5 and
+*> k = 3. The elements equal to 1 are not stored; the corresponding
+*> array elements are modified but restored on exit. The rest of the
+*> array is not used.
+*>
+*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
+*>
+*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
+*> ( v1 1 ) ( 1 v2 v2 v2 )
+*> ( v1 v2 1 ) ( 1 v3 v3 )
+*> ( v1 v2 v3 )
+*> ( v1 v2 v3 )
+*>
+*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
+*>
+*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
+*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
+*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
+*> ( 1 v3 )
+*> ( 1 )
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zlarfb( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+ $ T, LDT, C, LDC, WORK, LDWORK )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2013
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, SIDE, STOREV, TRANS
+ INTEGER K, LDC, LDT, LDV, LDWORK, M, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 C( ldc, * ), T( ldt, * ), V( ldv, * ),
+ $ work( ldwork, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ parameter( one = ( 1.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ CHARACTER TRANST
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL zcopy, zgemm, zlacgv, ztrmm
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( m.LE.0 .OR. n.LE.0 )
+ $ RETURN
+*
+ IF( lsame( trans, 'N' ) ) THEN
+ transt = 'C'
+ ELSE
+ transt = 'N'
+ END IF
+*
+ IF( lsame( storev, 'C' ) ) THEN
+*
+ IF( lsame( direct, 'F' ) ) THEN
+*
+* Let V = ( V1 ) (first K rows)
+* ( V2 )
+* where V1 is unit lower triangular.
+*
+ IF( lsame( side, 'L' ) ) THEN
+*
+* Form H * C or H**H * C where C = ( C1 )
+* ( C2 )
+*
+* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
+*
+* W := C1**H
+*
+ DO 10 j = 1, k
+ CALL zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
+ CALL zlacgv( n, work( 1, j ), 1 )
+ 10 CONTINUE
+*
+* W := W * V1
+*
+ CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', n,
+ $ k, one, v, ldv, work, ldwork )
+ IF( m.GT.k ) THEN
+*
+* W := W + C2**H * V2
+*
+ CALL zgemm( 'Conjugate transpose', 'No transpose', n,
+ $ k, m-k, one, c( k+1, 1 ), ldc,
+ $ v( k+1, 1 ), ldv, one, work, ldwork )
+ END IF
+*
+* W := W * T**H or W * T
+*
+ CALL ztrmm( 'Right', 'Upper', transt, 'Non-unit', n, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - V * W**H
+*
+ IF( m.GT.k ) THEN
+*
+* C2 := C2 - V2 * W**H
+*
+ CALL zgemm( 'No transpose', 'Conjugate transpose',
+ $ m-k, n, k, -one, v( k+1, 1 ), ldv, work,
+ $ ldwork, one, c( k+1, 1 ), ldc )
+ END IF
+*
+* W := W * V1**H
+*
+ CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose',
+ $ 'Unit', n, k, one, v, ldv, work, ldwork )
+*
+* C1 := C1 - W**H
+*
+ DO 30 j = 1, k
+ DO 20 i = 1, n
+ c( j, i ) = c( j, i ) - dconjg( work( i, j ) )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE IF( lsame( side, 'R' ) ) THEN
+*
+* Form C * H or C * H**H where C = ( C1 C2 )
+*
+* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
+*
+* W := C1
+*
+ DO 40 j = 1, k
+ CALL zcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
+ 40 CONTINUE
+*
+* W := W * V1
+*
+ CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', m,
+ $ k, one, v, ldv, work, ldwork )
+ IF( n.GT.k ) THEN
+*
+* W := W + C2 * V2
+*
+ CALL zgemm( 'No transpose', 'No transpose', m, k, n-k,
+ $ one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv,
+ $ one, work, ldwork )
+ END IF
+*
+* W := W * T or W * T**H
+*
+ CALL ztrmm( 'Right', 'Upper', trans, 'Non-unit', m, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - W * V**H
+*
+ IF( n.GT.k ) THEN
+*
+* C2 := C2 - W * V2**H
+*
+ CALL zgemm( 'No transpose', 'Conjugate transpose', m,
+ $ n-k, k, -one, work, ldwork, v( k+1, 1 ),
+ $ ldv, one, c( 1, k+1 ), ldc )
+ END IF
+*
+* W := W * V1**H
+*
+ CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose',
+ $ 'Unit', m, k, one, v, ldv, work, ldwork )
+*
+* C1 := C1 - W
+*
+ DO 60 j = 1, k
+ DO 50 i = 1, m
+ c( i, j ) = c( i, j ) - work( i, j )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Let V = ( V1 )
+* ( V2 ) (last K rows)
+* where V2 is unit upper triangular.
+*
+ IF( lsame( side, 'L' ) ) THEN
+*
+* Form H * C or H**H * C where C = ( C1 )
+* ( C2 )
+*
+* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
+*
+* W := C2**H
+*
+ DO 70 j = 1, k
+ CALL zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
+ CALL zlacgv( n, work( 1, j ), 1 )
+ 70 CONTINUE
+*
+* W := W * V2
+*
+ CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', n,
+ $ k, one, v( m-k+1, 1 ), ldv, work, ldwork )
+ IF( m.GT.k ) THEN
+*
+* W := W + C1**H * V1
+*
+ CALL zgemm( 'Conjugate transpose', 'No transpose', n,
+ $ k, m-k, one, c, ldc, v, ldv, one, work,
+ $ ldwork )
+ END IF
+*
+* W := W * T**H or W * T
+*
+ CALL ztrmm( 'Right', 'Lower', transt, 'Non-unit', n, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - V * W**H
+*
+ IF( m.GT.k ) THEN
+*
+* C1 := C1 - V1 * W**H
+*
+ CALL zgemm( 'No transpose', 'Conjugate transpose',
+ $ m-k, n, k, -one, v, ldv, work, ldwork,
+ $ one, c, ldc )
+ END IF
+*
+* W := W * V2**H
+*
+ CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose',
+ $ 'Unit', n, k, one, v( m-k+1, 1 ), ldv, work,
+ $ ldwork )
+*
+* C2 := C2 - W**H
+*
+ DO 90 j = 1, k
+ DO 80 i = 1, n
+ c( m-k+j, i ) = c( m-k+j, i ) -
+ $ dconjg( work( i, j ) )
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ ELSE IF( lsame( side, 'R' ) ) THEN
+*
+* Form C * H or C * H**H where C = ( C1 C2 )
+*
+* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
+*
+* W := C2
+*
+ DO 100 j = 1, k
+ CALL zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
+ 100 CONTINUE
+*
+* W := W * V2
+*
+ CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', m,
+ $ k, one, v( n-k+1, 1 ), ldv, work, ldwork )
+ IF( n.GT.k ) THEN
+*
+* W := W + C1 * V1
+*
+ CALL zgemm( 'No transpose', 'No transpose', m, k, n-k,
+ $ one, c, ldc, v, ldv, one, work, ldwork )
+ END IF
+*
+* W := W * T or W * T**H
+*
+ CALL ztrmm( 'Right', 'Lower', trans, 'Non-unit', m, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - W * V**H
+*
+ IF( n.GT.k ) THEN
+*
+* C1 := C1 - W * V1**H
+*
+ CALL zgemm( 'No transpose', 'Conjugate transpose', m,
+ $ n-k, k, -one, work, ldwork, v, ldv, one,
+ $ c, ldc )
+ END IF
+*
+* W := W * V2**H
+*
+ CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose',
+ $ 'Unit', m, k, one, v( n-k+1, 1 ), ldv, work,
+ $ ldwork )
+*
+* C2 := C2 - W
+*
+ DO 120 j = 1, k
+ DO 110 i = 1, m
+ c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
+ 110 CONTINUE
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( lsame( storev, 'R' ) ) THEN
+*
+ IF( lsame( direct, 'F' ) ) THEN
+*
+* Let V = ( V1 V2 ) (V1: first K columns)
+* where V1 is unit upper triangular.
+*
+ IF( lsame( side, 'L' ) ) THEN
+*
+* Form H * C or H**H * C where C = ( C1 )
+* ( C2 )
+*
+* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
+*
+* W := C1**H
+*
+ DO 130 j = 1, k
+ CALL zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
+ CALL zlacgv( n, work( 1, j ), 1 )
+ 130 CONTINUE
+*
+* W := W * V1**H
+*
+ CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose',
+ $ 'Unit', n, k, one, v, ldv, work, ldwork )
+ IF( m.GT.k ) THEN
+*
+* W := W + C2**H * V2**H
+*
+ CALL zgemm( 'Conjugate transpose',
+ $ 'Conjugate transpose', n, k, m-k, one,
+ $ c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, one,
+ $ work, ldwork )
+ END IF
+*
+* W := W * T**H or W * T
+*
+ CALL ztrmm( 'Right', 'Upper', transt, 'Non-unit', n, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - V**H * W**H
+*
+ IF( m.GT.k ) THEN
+*
+* C2 := C2 - V2**H * W**H
+*
+ CALL zgemm( 'Conjugate transpose',
+ $ 'Conjugate transpose', m-k, n, k, -one,
+ $ v( 1, k+1 ), ldv, work, ldwork, one,
+ $ c( k+1, 1 ), ldc )
+ END IF
+*
+* W := W * V1
+*
+ CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', n,
+ $ k, one, v, ldv, work, ldwork )
+*
+* C1 := C1 - W**H
+*
+ DO 150 j = 1, k
+ DO 140 i = 1, n
+ c( j, i ) = c( j, i ) - dconjg( work( i, j ) )
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ ELSE IF( lsame( side, 'R' ) ) THEN
+*
+* Form C * H or C * H**H where C = ( C1 C2 )
+*
+* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
+*
+* W := C1
+*
+ DO 160 j = 1, k
+ CALL zcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
+ 160 CONTINUE
+*
+* W := W * V1**H
+*
+ CALL ztrmm( 'Right', 'Upper', 'Conjugate transpose',
+ $ 'Unit', m, k, one, v, ldv, work, ldwork )
+ IF( n.GT.k ) THEN
+*
+* W := W + C2 * V2**H
+*
+ CALL zgemm( 'No transpose', 'Conjugate transpose', m,
+ $ k, n-k, one, c( 1, k+1 ), ldc,
+ $ v( 1, k+1 ), ldv, one, work, ldwork )
+ END IF
+*
+* W := W * T or W * T**H
+*
+ CALL ztrmm( 'Right', 'Upper', trans, 'Non-unit', m, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - W * V
+*
+ IF( n.GT.k ) THEN
+*
+* C2 := C2 - W * V2
+*
+ CALL zgemm( 'No transpose', 'No transpose', m, n-k, k,
+ $ -one, work, ldwork, v( 1, k+1 ), ldv, one,
+ $ c( 1, k+1 ), ldc )
+ END IF
+*
+* W := W * V1
+*
+ CALL ztrmm( 'Right', 'Upper', 'No transpose', 'Unit', m,
+ $ k, one, v, ldv, work, ldwork )
+*
+* C1 := C1 - W
+*
+ DO 180 j = 1, k
+ DO 170 i = 1, m
+ c( i, j ) = c( i, j ) - work( i, j )
+ 170 CONTINUE
+ 180 CONTINUE
+*
+ END IF
+*
+ ELSE
+*
+* Let V = ( V1 V2 ) (V2: last K columns)
+* where V2 is unit lower triangular.
+*
+ IF( lsame( side, 'L' ) ) THEN
+*
+* Form H * C or H**H * C where C = ( C1 )
+* ( C2 )
+*
+* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
+*
+* W := C2**H
+*
+ DO 190 j = 1, k
+ CALL zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
+ CALL zlacgv( n, work( 1, j ), 1 )
+ 190 CONTINUE
+*
+* W := W * V2**H
+*
+ CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose',
+ $ 'Unit', n, k, one, v( 1, m-k+1 ), ldv, work,
+ $ ldwork )
+ IF( m.GT.k ) THEN
+*
+* W := W + C1**H * V1**H
+*
+ CALL zgemm( 'Conjugate transpose',
+ $ 'Conjugate transpose', n, k, m-k, one, c,
+ $ ldc, v, ldv, one, work, ldwork )
+ END IF
+*
+* W := W * T**H or W * T
+*
+ CALL ztrmm( 'Right', 'Lower', transt, 'Non-unit', n, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - V**H * W**H
+*
+ IF( m.GT.k ) THEN
+*
+* C1 := C1 - V1**H * W**H
+*
+ CALL zgemm( 'Conjugate transpose',
+ $ 'Conjugate transpose', m-k, n, k, -one, v,
+ $ ldv, work, ldwork, one, c, ldc )
+ END IF
+*
+* W := W * V2
+*
+ CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', n,
+ $ k, one, v( 1, m-k+1 ), ldv, work, ldwork )
+*
+* C2 := C2 - W**H
+*
+ DO 210 j = 1, k
+ DO 200 i = 1, n
+ c( m-k+j, i ) = c( m-k+j, i ) -
+ $ dconjg( work( i, j ) )
+ 200 CONTINUE
+ 210 CONTINUE
+*
+ ELSE IF( lsame( side, 'R' ) ) THEN
+*
+* Form C * H or C * H**H where C = ( C1 C2 )
+*
+* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
+*
+* W := C2
+*
+ DO 220 j = 1, k
+ CALL zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
+ 220 CONTINUE
+*
+* W := W * V2**H
+*
+ CALL ztrmm( 'Right', 'Lower', 'Conjugate transpose',
+ $ 'Unit', m, k, one, v( 1, n-k+1 ), ldv, work,
+ $ ldwork )
+ IF( n.GT.k ) THEN
+*
+* W := W + C1 * V1**H
+*
+ CALL zgemm( 'No transpose', 'Conjugate transpose', m,
+ $ k, n-k, one, c, ldc, v, ldv, one, work,
+ $ ldwork )
+ END IF
+*
+* W := W * T or W * T**H
+*
+ CALL ztrmm( 'Right', 'Lower', trans, 'Non-unit', m, k,
+ $ one, t, ldt, work, ldwork )
+*
+* C := C - W * V
+*
+ IF( n.GT.k ) THEN
+*
+* C1 := C1 - W * V1
+*
+ CALL zgemm( 'No transpose', 'No transpose', m, n-k, k,
+ $ -one, work, ldwork, v, ldv, one, c, ldc )
+ END IF
+*
+* W := W * V2
+*
+ CALL ztrmm( 'Right', 'Lower', 'No transpose', 'Unit', m,
+ $ k, one, v( 1, n-k+1 ), ldv, work, ldwork )
+*
+* C1 := C1 - W
+*
+ DO 240 j = 1, k
+ DO 230 i = 1, m
+ c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
+ 230 CONTINUE
+ 240 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZLARFB
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLARF + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE
+* INTEGER INCV, LDC, M, N
+* COMPLEX*16 TAU
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLARF applies a complex elementary reflector H to a complex M-by-N
+*> matrix C, from either the left or the right. H is represented in the
+*> form
+*>
+*> H = I - tau * v * v**H
+*>
+*> where tau is a complex scalar and v is a complex vector.
+*>
+*> If tau = 0, then H is taken to be the unit matrix.
+*>
+*> To apply H**H, supply conjg(tau) instead
+*> tau.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': form H * C
+*> = 'R': form C * H
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension
+*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*> The vector v in the representation of H. V is not used if
+*> TAU = 0.
+*> \endverbatim
+*>
+*> \param[in] INCV
+*> \verbatim
+*> INCV is INTEGER
+*> The increment between elements of v. INCV <> 0.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16
+*> The value tau in the representation of H.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*> or C * H if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension
+*> (N) if SIDE = 'L'
+*> or (M) if SIDE = 'R'
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zlarf( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ COMPLEX*16 TAU
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 C( ldc, * ), V( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ parameter( one = ( 1.0d+0, 0.0d+0 ),
+ $ zero = ( 0.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL APPLYLEFT
+ INTEGER I, LASTV, LASTC
+* ..
+* .. External Subroutines ..
+ EXTERNAL zgemv, zgerc
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAZLR, ILAZLC
+ EXTERNAL lsame, ilazlr, ilazlc
+* ..
+* .. Executable Statements ..
+*
+ applyleft = lsame( side, 'L' )
+ lastv = 0
+ lastc = 0
+ IF( tau.NE.zero ) THEN
+* Set up variables for scanning V. LASTV begins pointing to the end
+* of V.
+ IF( applyleft ) THEN
+ lastv = m
+ ELSE
+ lastv = n
+ END IF
+ IF( incv.GT.0 ) THEN
+ i = 1 + (lastv-1) * incv
+ ELSE
+ i = 1
+ END IF
+* Look for the last non-zero row in V.
+ DO WHILE( lastv.GT.0 .AND. v( i ).EQ.zero )
+ lastv = lastv - 1
+ i = i - incv
+ END DO
+ IF( applyleft ) THEN
+* Scan for the last non-zero column in C(1:lastv,:).
+ lastc = ilazlc(lastv, n, c, ldc)
+ ELSE
+* Scan for the last non-zero row in C(:,1:lastv).
+ lastc = ilazlr(m, lastv, c, ldc)
+ END IF
+ END IF
+* Note that lastc.eq.0 renders the BLAS operations null; no special
+* case is needed at this level.
+ IF( applyleft ) THEN
+*
+* Form H * C
+*
+ IF( lastv.GT.0 ) THEN
+*
+* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
+*
+ CALL zgemv( 'Conjugate transpose', lastv, lastc, one,
+ $ c, ldc, v, incv, zero, work, 1 )
+*
+* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
+*
+ CALL zgerc( lastv, lastc, -tau, v, incv, work, 1, c, ldc )
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( lastv.GT.0 ) THEN
+*
+* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+ CALL zgemv( 'No transpose', lastc, lastv, one, c, ldc,
+ $ v, incv, zero, work, 1 )
+*
+* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
+*
+ CALL zgerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc )
+ END IF
+ END IF
+ RETURN
+*
+* End of ZLARF
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLARFG generates an elementary reflector (Householder matrix).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLARFG + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX, N
+* COMPLEX*16 ALPHA, TAU
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 X( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLARFG generates a complex elementary reflector H of order n, such
+*> that
+*>
+*> H**H * ( alpha ) = ( beta ), H**H * H = I.
+*> ( x ) ( 0 )
+*>
+*> where alpha and beta are scalars, with beta real, and x is an
+*> (n-1)-element complex vector. H is represented in the form
+*>
+*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
+*> ( v )
+*>
+*> where tau is a complex scalar and v is a complex (n-1)-element
+*> vector. Note that H is not hermitian.
+*>
+*> If the elements of x are all zero and alpha is real, then tau = 0
+*> and H is taken to be the unit matrix.
+*>
+*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the elementary reflector.
+*> \endverbatim
+*>
+*> \param[in,out] ALPHA
+*> \verbatim
+*> ALPHA is COMPLEX*16
+*> On entry, the value alpha.
+*> On exit, it is overwritten with the value beta.
+*> \endverbatim
+*>
+*> \param[in,out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension
+*> (1+(N-2)*abs(INCX))
+*> On entry, the vector x.
+*> On exit, it is overwritten with the vector v.
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> The increment between elements of X. INCX > 0.
+*> \endverbatim
+*>
+*> \param[out] TAU
+*> \verbatim
+*> TAU is COMPLEX*16
+*> The value tau.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zlarfg( N, ALPHA, X, INCX, TAU )
+*
+* -- LAPACK auxiliary routine (version 3.8.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ COMPLEX*16 ALPHA, TAU
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 X( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ parameter( one = 1.0d+0, zero = 0.0d+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J, KNT
+ DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
+ COMPLEX*16 ZLADIV
+ EXTERNAL dlamch, dlapy3, dznrm2, zladiv
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dimag, sign
+* ..
+* .. External Subroutines ..
+ EXTERNAL zdscal, zscal
+* ..
+* .. Executable Statements ..
+*
+ IF( n.LE.0 ) THEN
+ tau = zero
+ RETURN
+ END IF
+*
+ xnorm = dznrm2( n-1, x, incx )
+ alphr = dble( alpha )
+ alphi = dimag( alpha )
+*
+ IF( xnorm.EQ.zero .AND. alphi.EQ.zero ) THEN
+*
+* H = I
+*
+ tau = zero
+ ELSE
+*
+* general case
+*
+ beta = -sign( dlapy3( alphr, alphi, xnorm ), alphr )
+ safmin = dlamch( 'S' ) / dlamch( 'E' )
+ rsafmn = one / safmin
+*
+ knt = 0
+ IF( abs( beta ).LT.safmin ) THEN
+*
+* XNORM, BETA may be inaccurate; scale X and recompute them
+*
+ 10 CONTINUE
+ knt = knt + 1
+ CALL zdscal( n-1, rsafmn, x, incx )
+ beta = beta*rsafmn
+ alphi = alphi*rsafmn
+ alphr = alphr*rsafmn
+ IF( (abs( beta ).LT.safmin) .AND. (knt .LT. 20) )
+ $ GO TO 10
+*
+* New BETA is at most 1, at least SAFMIN
+*
+ xnorm = dznrm2( n-1, x, incx )
+ alpha = dcmplx( alphr, alphi )
+ beta = -sign( dlapy3( alphr, alphi, xnorm ), alphr )
+ END IF
+ tau = dcmplx( ( beta-alphr ) / beta, -alphi / beta )
+ alpha = zladiv( dcmplx( one ), alpha-beta )
+ CALL zscal( n-1, alpha, x, incx )
+*
+* If ALPHA is subnormal, it may lose relative accuracy
+*
+ DO 20 j = 1, knt
+ beta = beta*safmin
+ 20 CONTINUE
+ alpha = beta
+ END IF
+*
+ RETURN
+*
+* End of ZLARFG
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLARFT + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIRECT, STOREV
+* INTEGER K, LDT, LDV, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLARFT forms the triangular factor T of a complex block reflector H
+*> of order n, which is defined as a product of k elementary reflectors.
+*>
+*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*>
+*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*>
+*> If STOREV = 'C', the vector which defines the elementary reflector
+*> H(i) is stored in the i-th column of the array V, and
+*>
+*> H = I - V * T * V**H
+*>
+*> If STOREV = 'R', the vector which defines the elementary reflector
+*> H(i) is stored in the i-th row of the array V, and
+*>
+*> H = I - V**H * T * V
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DIRECT
+*> \verbatim
+*> DIRECT is CHARACTER*1
+*> Specifies the order in which the elementary reflectors are
+*> multiplied to form the block reflector:
+*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*> \endverbatim
+*>
+*> \param[in] STOREV
+*> \verbatim
+*> STOREV is CHARACTER*1
+*> Specifies how the vectors which define the elementary
+*> reflectors are stored (see also Further Details):
+*> = 'C': columnwise
+*> = 'R': rowwise
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the block reflector H. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The order of the triangular factor T (= the number of
+*> elementary reflectors). K >= 1.
+*> \endverbatim
+*>
+*> \param[in] V
+*> \verbatim
+*> V is COMPLEX*16 array, dimension
+*> (LDV,K) if STOREV = 'C'
+*> (LDV,N) if STOREV = 'R'
+*> The matrix V. See further details.
+*> \endverbatim
+*>
+*> \param[in] LDV
+*> \verbatim
+*> LDV is INTEGER
+*> The leading dimension of the array V.
+*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (K)
+*> TAU(i) must contain the scalar factor of the elementary
+*> reflector H(i).
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,K)
+*> The k by k triangular factor T of the block reflector.
+*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+*> lower triangular. The rest of the array is not used.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= K.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The shape of the matrix V and the storage of the vectors which define
+*> the H(i) is best illustrated by the following example with n = 5 and
+*> k = 3. The elements equal to 1 are not stored.
+*>
+*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
+*>
+*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
+*> ( v1 1 ) ( 1 v2 v2 v2 )
+*> ( v1 v2 1 ) ( 1 v3 v3 )
+*> ( v1 v2 v3 )
+*> ( v1 v2 v3 )
+*>
+*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
+*>
+*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
+*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
+*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
+*> ( 1 v3 )
+*> ( 1 )
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zlarft( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, STOREV
+ INTEGER K, LDT, LDV, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 T( ldt, * ), TAU( * ), V( ldv, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ parameter( one = ( 1.0d+0, 0.0d+0 ),
+ $ zero = ( 0.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, PREVLASTV, LASTV
+* ..
+* .. External Subroutines ..
+ EXTERNAL zgemv, ztrmv, zgemm
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( n.EQ.0 )
+ $ RETURN
+*
+ IF( lsame( direct, 'F' ) ) THEN
+ prevlastv = n
+ DO i = 1, k
+ prevlastv = max( prevlastv, i )
+ IF( tau( i ).EQ.zero ) THEN
+*
+* H(i) = I
+*
+ DO j = 1, i
+ t( j, i ) = zero
+ END DO
+ ELSE
+*
+* general case
+*
+ IF( lsame( storev, 'C' ) ) THEN
+* Skip any trailing zeros.
+ DO lastv = n, i+1, -1
+ IF( v( lastv, i ).NE.zero ) EXIT
+ END DO
+ DO j = 1, i-1
+ t( j, i ) = -tau( i ) * conjg( v( i , j ) )
+ END DO
+ j = min( lastv, prevlastv )
+*
+* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
+*
+ CALL zgemv( 'Conjugate transpose', j-i, i-1,
+ $ -tau( i ), v( i+1, 1 ), ldv,
+ $ v( i+1, i ), 1, one, t( 1, i ), 1 )
+ ELSE
+* Skip any trailing zeros.
+ DO lastv = n, i+1, -1
+ IF( v( i, lastv ).NE.zero ) EXIT
+ END DO
+ DO j = 1, i-1
+ t( j, i ) = -tau( i ) * v( j , i )
+ END DO
+ j = min( lastv, prevlastv )
+*
+* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
+*
+ CALL zgemm( 'N', 'C', i-1, 1, j-i, -tau( i ),
+ $ v( 1, i+1 ), ldv, v( i, i+1 ), ldv,
+ $ one, t( 1, i ), ldt )
+ END IF
+*
+* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
+*
+ CALL ztrmv( 'Upper', 'No transpose', 'Non-unit', i-1, t,
+ $ ldt, t( 1, i ), 1 )
+ t( i, i ) = tau( i )
+ IF( i.GT.1 ) THEN
+ prevlastv = max( prevlastv, lastv )
+ ELSE
+ prevlastv = lastv
+ END IF
+ END IF
+ END DO
+ ELSE
+ prevlastv = 1
+ DO i = k, 1, -1
+ IF( tau( i ).EQ.zero ) THEN
+*
+* H(i) = I
+*
+ DO j = i, k
+ t( j, i ) = zero
+ END DO
+ ELSE
+*
+* general case
+*
+ IF( i.LT.k ) THEN
+ IF( lsame( storev, 'C' ) ) THEN
+* Skip any leading zeros.
+ DO lastv = 1, i-1
+ IF( v( lastv, i ).NE.zero ) EXIT
+ END DO
+ DO j = i+1, k
+ t( j, i ) = -tau( i ) * conjg( v( n-k+i , j ) )
+ END DO
+ j = max( lastv, prevlastv )
+*
+* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
+*
+ CALL zgemv( 'Conjugate transpose', n-k+i-j, k-i,
+ $ -tau( i ), v( j, i+1 ), ldv, v( j, i ),
+ $ 1, one, t( i+1, i ), 1 )
+ ELSE
+* Skip any leading zeros.
+ DO lastv = 1, i-1
+ IF( v( i, lastv ).NE.zero ) EXIT
+ END DO
+ DO j = i+1, k
+ t( j, i ) = -tau( i ) * v( j, n-k+i )
+ END DO
+ j = max( lastv, prevlastv )
+*
+* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
+*
+ CALL zgemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ),
+ $ v( i+1, j ), ldv, v( i, j ), ldv,
+ $ one, t( i+1, i ), ldt )
+ END IF
+*
+* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+ CALL ztrmv( 'Lower', 'No transpose', 'Non-unit', k-i,
+ $ t( i+1, i+1 ), ldt, t( i+1, i ), 1 )
+ IF( i.GT.1 ) THEN
+ prevlastv = min( prevlastv, lastv )
+ ELSE
+ prevlastv = lastv
+ END IF
+ END IF
+ t( i, i ) = tau( i )
+ END IF
+ END DO
+ END IF
+ RETURN
+*
+* End of ZLARFT
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLARTG + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLARTG( F, G, CS, SN, R )
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION CS
+* COMPLEX*16 F, G, R, SN
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLARTG generates a plane rotation so that
+*>
+*> [ CS SN ] [ F ] [ R ]
+*> [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.
+*> [ -SN CS ] [ G ] [ 0 ]
+*>
+*> This is a faster version of the BLAS1 routine ZROTG, except for
+*> the following differences:
+*> F and G are unchanged on return.
+*> If G=0, then CS=1 and SN=0.
+*> If F=0, then CS=0 and SN is chosen so that R is real.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] F
+*> \verbatim
+*> F is COMPLEX*16
+*> The first component of vector to be rotated.
+*> \endverbatim
+*>
+*> \param[in] G
+*> \verbatim
+*> G is COMPLEX*16
+*> The second component of vector to be rotated.
+*> \endverbatim
+*>
+*> \param[out] CS
+*> \verbatim
+*> CS is DOUBLE PRECISION
+*> The cosine of the rotation.
+*> \endverbatim
+*>
+*> \param[out] SN
+*> \verbatim
+*> SN is COMPLEX*16
+*> The sine of the rotation.
+*> \endverbatim
+*>
+*> \param[out] R
+*> \verbatim
+*> R is COMPLEX*16
+*> The nonzero component of the rotated vector.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
+*>
+*> This version has a few statements commented out for thread safety
+*> (machine parameters are computed on each entry). 10 feb 03, SJH.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zlartg( F, G, CS, SN, R )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION CS
+ COMPLEX*16 F, G, R, SN
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION TWO, ONE, ZERO
+ parameter( two = 2.0d+0, one = 1.0d+0, zero = 0.0d+0 )
+ COMPLEX*16 CZERO
+ parameter( czero = ( 0.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+* LOGICAL FIRST
+ INTEGER COUNT, I
+ DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
+ $ safmn2, safmx2, scale
+ COMPLEX*16 FF, FS, GS
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ LOGICAL DISNAN
+ EXTERNAL dlamch, dlapy2, disnan
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dconjg, dimag, int, log,
+ $ max, sqrt
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION ABS1, ABSSQ
+* ..
+* .. Statement Function definitions ..
+ abs1( ff ) = max( abs( dble( ff ) ), abs( dimag( ff ) ) )
+ abssq( ff ) = dble( ff )**2 + dimag( ff )**2
+* ..
+* .. Executable Statements ..
+*
+ safmin = dlamch( 'S' )
+ eps = dlamch( 'E' )
+ safmn2 = dlamch( 'B' )**int( log( safmin / eps ) /
+ $ log( dlamch( 'B' ) ) / two )
+ safmx2 = one / safmn2
+ scale = max( abs1( f ), abs1( g ) )
+ fs = f
+ gs = g
+ count = 0
+ IF( scale.GE.safmx2 ) THEN
+ 10 CONTINUE
+ count = count + 1
+ fs = fs*safmn2
+ gs = gs*safmn2
+ scale = scale*safmn2
+ IF( scale.GE.safmx2 )
+ $ GO TO 10
+ ELSE IF( scale.LE.safmn2 ) THEN
+ IF( g.EQ.czero.OR.disnan( abs( g ) ) ) THEN
+ cs = one
+ sn = czero
+ r = f
+ RETURN
+ END IF
+ 20 CONTINUE
+ count = count - 1
+ fs = fs*safmx2
+ gs = gs*safmx2
+ scale = scale*safmx2
+ IF( scale.LE.safmn2 )
+ $ GO TO 20
+ END IF
+ f2 = abssq( fs )
+ g2 = abssq( gs )
+ IF( f2.LE.max( g2, one )*safmin ) THEN
+*
+* This is a rare case: F is very small.
+*
+ IF( f.EQ.czero ) THEN
+ cs = zero
+ r = dlapy2( dble( g ), dimag( g ) )
+* Do complex/real division explicitly with two real divisions
+ d = dlapy2( dble( gs ), dimag( gs ) )
+ sn = dcmplx( dble( gs ) / d, -dimag( gs ) / d )
+ RETURN
+ END IF
+ f2s = dlapy2( dble( fs ), dimag( fs ) )
+* G2 and G2S are accurate
+* G2 is at least SAFMIN, and G2S is at least SAFMN2
+ g2s = sqrt( g2 )
+* Error in CS from underflow in F2S is at most
+* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
+* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
+* and so CS .lt. sqrt(SAFMIN)
+* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
+* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
+* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
+ cs = f2s / g2s
+* Make sure abs(FF) = 1
+* Do complex/real division explicitly with 2 real divisions
+ IF( abs1( f ).GT.one ) THEN
+ d = dlapy2( dble( f ), dimag( f ) )
+ ff = dcmplx( dble( f ) / d, dimag( f ) / d )
+ ELSE
+ dr = safmx2*dble( f )
+ di = safmx2*dimag( f )
+ d = dlapy2( dr, di )
+ ff = dcmplx( dr / d, di / d )
+ END IF
+ sn = ff*dcmplx( dble( gs ) / g2s, -dimag( gs ) / g2s )
+ r = cs*f + sn*g
+ ELSE
+*
+* This is the most common case.
+* Neither F2 nor F2/G2 are less than SAFMIN
+* F2S cannot overflow, and it is accurate
+*
+ f2s = sqrt( one+g2 / f2 )
+* Do the F2S(real)*FS(complex) multiply with two real multiplies
+ r = dcmplx( f2s*dble( fs ), f2s*dimag( fs ) )
+ cs = one / f2s
+ d = f2 + g2
+* Do complex/real division explicitly with two real divisions
+ sn = dcmplx( dble( r ) / d, dimag( r ) / d )
+ sn = sn*dconjg( gs )
+ IF( count.NE.0 ) THEN
+ IF( count.GT.0 ) THEN
+ DO 30 i = 1, count
+ r = r*safmx2
+ 30 CONTINUE
+ ELSE
+ DO 40 i = 1, -count
+ r = r*safmn2
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ RETURN
+*
+* End of ZLARTG
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLASCL + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER TYPE
+* INTEGER INFO, KL, KU, LDA, M, N
+* DOUBLE PRECISION CFROM, CTO
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLASCL multiplies the M by N complex matrix A by the real scalar
+*> CTO/CFROM. This is done without over/underflow as long as the final
+*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
+*> A may be full, upper triangular, lower triangular, upper Hessenberg,
+*> or banded.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] TYPE
+*> \verbatim
+*> TYPE is CHARACTER*1
+*> TYPE indices the storage type of the input matrix.
+*> = 'G': A is a full matrix.
+*> = 'L': A is a lower triangular matrix.
+*> = 'U': A is an upper triangular matrix.
+*> = 'H': A is an upper Hessenberg matrix.
+*> = 'B': A is a symmetric band matrix with lower bandwidth KL
+*> and upper bandwidth KU and with the only the lower
+*> half stored.
+*> = 'Q': A is a symmetric band matrix with lower bandwidth KL
+*> and upper bandwidth KU and with the only the upper
+*> half stored.
+*> = 'Z': A is a band matrix with lower bandwidth KL and upper
+*> bandwidth KU. See ZGBTRF for storage details.
+*> \endverbatim
+*>
+*> \param[in] KL
+*> \verbatim
+*> KL is INTEGER
+*> The lower bandwidth of A. Referenced only if TYPE = 'B',
+*> 'Q' or 'Z'.
+*> \endverbatim
+*>
+*> \param[in] KU
+*> \verbatim
+*> KU is INTEGER
+*> The upper bandwidth of A. Referenced only if TYPE = 'B',
+*> 'Q' or 'Z'.
+*> \endverbatim
+*>
+*> \param[in] CFROM
+*> \verbatim
+*> CFROM is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] CTO
+*> \verbatim
+*> CTO is DOUBLE PRECISION
+*>
+*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
+*> without over/underflow if the final result CTO*A(I,J)/CFROM
+*> can be represented without over/underflow. CFROM must be
+*> nonzero.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The matrix to be multiplied by CTO/CFROM. See TYPE for the
+*> storage type.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
+*> TYPE = 'B', LDA >= KL+1;
+*> TYPE = 'Q', LDA >= KU+1;
+*> TYPE = 'Z', LDA >= 2*KL+KU+1.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> 0 - successful exit
+*> <0 - if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zlascl( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER TYPE
+ INTEGER INFO, KL, KU, LDA, M, N
+ DOUBLE PRECISION CFROM, CTO
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ parameter( zero = 0.0d0, one = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER I, ITYPE, J, K1, K2, K3, K4
+ DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, DISNAN
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL lsame, dlamch, disnan
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, max, min
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+*
+ IF( lsame( TYPE, 'G' ) ) then
+ itype = 0
+ ELSE IF( lsame( TYPE, 'L' ) ) then
+ itype = 1
+ ELSE IF( lsame( TYPE, 'U' ) ) then
+ itype = 2
+ ELSE IF( lsame( TYPE, 'H' ) ) then
+ itype = 3
+ ELSE IF( lsame( TYPE, 'B' ) ) then
+ itype = 4
+ ELSE IF( lsame( TYPE, 'Q' ) ) then
+ itype = 5
+ ELSE IF( lsame( TYPE, 'Z' ) ) then
+ itype = 6
+ ELSE
+ itype = -1
+ END IF
+*
+ IF( itype.EQ.-1 ) THEN
+ info = -1
+ ELSE IF( cfrom.EQ.zero .OR. disnan(cfrom) ) THEN
+ info = -4
+ ELSE IF( disnan(cto) ) THEN
+ info = -5
+ ELSE IF( m.LT.0 ) THEN
+ info = -6
+ ELSE IF( n.LT.0 .OR. ( itype.EQ.4 .AND. n.NE.m ) .OR.
+ $ ( itype.EQ.5 .AND. n.NE.m ) ) THEN
+ info = -7
+ ELSE IF( itype.LE.3 .AND. lda.LT.max( 1, m ) ) THEN
+ info = -9
+ ELSE IF( itype.GE.4 ) THEN
+ IF( kl.LT.0 .OR. kl.GT.max( m-1, 0 ) ) THEN
+ info = -2
+ ELSE IF( ku.LT.0 .OR. ku.GT.max( n-1, 0 ) .OR.
+ $ ( ( itype.EQ.4 .OR. itype.EQ.5 ) .AND. kl.NE.ku ) )
+ $ THEN
+ info = -3
+ ELSE IF( ( itype.EQ.4 .AND. lda.LT.kl+1 ) .OR.
+ $ ( itype.EQ.5 .AND. lda.LT.ku+1 ) .OR.
+ $ ( itype.EQ.6 .AND. lda.LT.2*kl+ku+1 ) ) THEN
+ info = -9
+ END IF
+ END IF
+*
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZLASCL', -info )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.EQ.0 .OR. m.EQ.0 )
+ $ RETURN
+*
+* Get machine parameters
+*
+ smlnum = dlamch( 'S' )
+ bignum = one / smlnum
+*
+ cfromc = cfrom
+ ctoc = cto
+*
+ 10 CONTINUE
+ cfrom1 = cfromc*smlnum
+ IF( cfrom1.EQ.cfromc ) THEN
+! CFROMC is an inf. Multiply by a correctly signed zero for
+! finite CTOC, or a NaN if CTOC is infinite.
+ mul = ctoc / cfromc
+ done = .true.
+ cto1 = ctoc
+ ELSE
+ cto1 = ctoc / bignum
+ IF( cto1.EQ.ctoc ) THEN
+! CTOC is either 0 or an inf. In both cases, CTOC itself
+! serves as the correct multiplication factor.
+ mul = ctoc
+ done = .true.
+ cfromc = one
+ ELSE IF( abs( cfrom1 ).GT.abs( ctoc ) .AND. ctoc.NE.zero ) THEN
+ mul = smlnum
+ done = .false.
+ cfromc = cfrom1
+ ELSE IF( abs( cto1 ).GT.abs( cfromc ) ) THEN
+ mul = bignum
+ done = .false.
+ ctoc = cto1
+ ELSE
+ mul = ctoc / cfromc
+ done = .true.
+ END IF
+ END IF
+*
+ IF( itype.EQ.0 ) THEN
+*
+* Full matrix
+*
+ DO 30 j = 1, n
+ DO 20 i = 1, m
+ a( i, j ) = a( i, j )*mul
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE IF( itype.EQ.1 ) THEN
+*
+* Lower triangular matrix
+*
+ DO 50 j = 1, n
+ DO 40 i = j, m
+ a( i, j ) = a( i, j )*mul
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ ELSE IF( itype.EQ.2 ) THEN
+*
+* Upper triangular matrix
+*
+ DO 70 j = 1, n
+ DO 60 i = 1, min( j, m )
+ a( i, j ) = a( i, j )*mul
+ 60 CONTINUE
+ 70 CONTINUE
+*
+ ELSE IF( itype.EQ.3 ) THEN
+*
+* Upper Hessenberg matrix
+*
+ DO 90 j = 1, n
+ DO 80 i = 1, min( j+1, m )
+ a( i, j ) = a( i, j )*mul
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ ELSE IF( itype.EQ.4 ) THEN
+*
+* Lower half of a symmetric band matrix
+*
+ k3 = kl + 1
+ k4 = n + 1
+ DO 110 j = 1, n
+ DO 100 i = 1, min( k3, k4-j )
+ a( i, j ) = a( i, j )*mul
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ ELSE IF( itype.EQ.5 ) THEN
+*
+* Upper half of a symmetric band matrix
+*
+ k1 = ku + 2
+ k3 = ku + 1
+ DO 130 j = 1, n
+ DO 120 i = max( k1-j, 1 ), k3
+ a( i, j ) = a( i, j )*mul
+ 120 CONTINUE
+ 130 CONTINUE
+*
+ ELSE IF( itype.EQ.6 ) THEN
+*
+* Band matrix
+*
+ k1 = kl + ku + 2
+ k2 = kl + 1
+ k3 = 2*kl + ku + 1
+ k4 = kl + ku + 1 + m
+ DO 150 j = 1, n
+ DO 140 i = max( k1-j, k2 ), min( k3, k4-j )
+ a( i, j ) = a( i, j )*mul
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ END IF
+*
+ IF( .NOT.done )
+ $ GO TO 10
+*
+ RETURN
+*
+* End of ZLASCL
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLASET + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, M, N
+* COMPLEX*16 ALPHA, BETA
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLASET initializes a 2-D array A to BETA on the diagonal and
+*> ALPHA on the offdiagonals.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies the part of the matrix A to be set.
+*> = 'U': Upper triangular part is set. The lower triangle
+*> is unchanged.
+*> = 'L': Lower triangular part is set. The upper triangle
+*> is unchanged.
+*> Otherwise: All of the matrix A is set.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> On entry, M specifies the number of rows of A.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> On entry, N specifies the number of columns of A.
+*> \endverbatim
+*>
+*> \param[in] ALPHA
+*> \verbatim
+*> ALPHA is COMPLEX*16
+*> All the offdiagonal array elements are set to ALPHA.
+*> \endverbatim
+*>
+*> \param[in] BETA
+*> \verbatim
+*> BETA is COMPLEX*16
+*> All the diagonal array elements are set to BETA.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the m by n matrix A.
+*> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
+*> A(i,i) = BETA , 1 <= i <= min(m,n)
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zlaset( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, M, N
+ COMPLEX*16 ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC min
+* ..
+* .. Executable Statements ..
+*
+ IF( lsame( uplo, 'U' ) ) THEN
+*
+* Set the diagonal to BETA and the strictly upper triangular
+* part of the array to ALPHA.
+*
+ DO 20 j = 2, n
+ DO 10 i = 1, min( j-1, m )
+ a( i, j ) = alpha
+ 10 CONTINUE
+ 20 CONTINUE
+ DO 30 i = 1, min( n, m )
+ a( i, i ) = beta
+ 30 CONTINUE
+*
+ ELSE IF( lsame( uplo, 'L' ) ) THEN
+*
+* Set the diagonal to BETA and the strictly lower triangular
+* part of the array to ALPHA.
+*
+ DO 50 j = 1, min( m, n )
+ DO 40 i = j + 1, m
+ a( i, j ) = alpha
+ 40 CONTINUE
+ 50 CONTINUE
+ DO 60 i = 1, min( n, m )
+ a( i, i ) = beta
+ 60 CONTINUE
+*
+ ELSE
+*
+* Set the array to BETA on the diagonal and ALPHA on the
+* offdiagonal.
+*
+ DO 80 j = 1, n
+ DO 70 i = 1, m
+ a( i, j ) = alpha
+ 70 CONTINUE
+ 80 CONTINUE
+ DO 90 i = 1, min( m, n )
+ a( i, i ) = beta
+ 90 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZLASET
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLASSQ updates a sum of squares represented in scaled form.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLASSQ + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX, N
+* DOUBLE PRECISION SCALE, SUMSQ
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 X( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLASSQ returns the values scl and ssq such that
+*>
+*> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
+*>
+*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
+*> assumed to be at least unity and the value of ssq will then satisfy
+*>
+*> 1.0 .le. ssq .le. ( sumsq + 2*n ).
+*>
+*> scale is assumed to be non-negative and scl returns the value
+*>
+*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
+*> i
+*>
+*> scale and sumsq must be supplied in SCALE and SUMSQ respectively.
+*> SCALE and SUMSQ are overwritten by scl and ssq respectively.
+*>
+*> The routine makes only one pass through the vector X.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of elements to be used from the vector X.
+*> \endverbatim
+*>
+*> \param[in] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (N)
+*> The vector x as described above.
+*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> The increment between successive values of the vector X.
+*> INCX > 0.
+*> \endverbatim
+*>
+*> \param[in,out] SCALE
+*> \verbatim
+*> SCALE is DOUBLE PRECISION
+*> On entry, the value scale in the equation above.
+*> On exit, SCALE is overwritten with the value scl .
+*> \endverbatim
+*>
+*> \param[in,out] SUMSQ
+*> \verbatim
+*> SUMSQ is DOUBLE PRECISION
+*> On entry, the value sumsq in the equation above.
+*> On exit, SUMSQ is overwritten with the value ssq .
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zlassq( N, X, INCX, SCALE, SUMSQ )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ DOUBLE PRECISION SCALE, SUMSQ
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 X( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ parameter( zero = 0.0d+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IX
+ DOUBLE PRECISION TEMP1
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ EXTERNAL disnan
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dimag
+* ..
+* .. Executable Statements ..
+*
+ IF( n.GT.0 ) THEN
+ DO 10 ix = 1, 1 + ( n-1 )*incx, incx
+ temp1 = abs( dble( x( ix ) ) )
+ IF( temp1.GT.zero.OR.disnan( temp1 ) ) THEN
+ IF( scale.LT.temp1 ) THEN
+ sumsq = 1 + sumsq*( scale / temp1 )**2
+ scale = temp1
+ ELSE
+ sumsq = sumsq + ( temp1 / scale )**2
+ END IF
+ END IF
+ temp1 = abs( dimag( x( ix ) ) )
+ IF( temp1.GT.zero.OR.disnan( temp1 ) ) THEN
+ IF( scale.LT.temp1 ) THEN
+ sumsq = 1 + sumsq*( scale / temp1 )**2
+ scale = temp1
+ ELSE
+ sumsq = sumsq + ( temp1 / scale )**2
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZLASSQ
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLATRS + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
+* CNORM, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER DIAG, NORMIN, TRANS, UPLO
+* INTEGER INFO, LDA, N
+* DOUBLE PRECISION SCALE
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION CNORM( * )
+* COMPLEX*16 A( LDA, * ), X( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZLATRS solves one of the triangular systems
+*>
+*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
+*>
+*> with scaling to prevent overflow. Here A is an upper or lower
+*> triangular matrix, A**T denotes the transpose of A, A**H denotes the
+*> conjugate transpose of A, x and b are n-element vectors, and s is a
+*> scaling factor, usually less than or equal to 1, chosen so that the
+*> components of x will be less than the overflow threshold. If the
+*> unscaled problem will not cause overflow, the Level 2 BLAS routine
+*> ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
+*> then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the matrix A is upper or lower triangular.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> Specifies the operation applied to A.
+*> = 'N': Solve A * x = s*b (No transpose)
+*> = 'T': Solve A**T * x = s*b (Transpose)
+*> = 'C': Solve A**H * x = s*b (Conjugate transpose)
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> Specifies whether or not the matrix A is unit triangular.
+*> = 'N': Non-unit triangular
+*> = 'U': Unit triangular
+*> \endverbatim
+*>
+*> \param[in] NORMIN
+*> \verbatim
+*> NORMIN is CHARACTER*1
+*> Specifies whether CNORM has been set or not.
+*> = 'Y': CNORM contains the column norms on entry
+*> = 'N': CNORM is not set on entry. On exit, the norms will
+*> be computed and stored in CNORM.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The triangular matrix A. If UPLO = 'U', the leading n by n
+*> upper triangular part of the array A contains the upper
+*> triangular matrix, and the strictly lower triangular part of
+*> A is not referenced. If UPLO = 'L', the leading n by n lower
+*> triangular part of the array A contains the lower triangular
+*> matrix, and the strictly upper triangular part of A is not
+*> referenced. If DIAG = 'U', the diagonal elements of A are
+*> also not referenced and are assumed to be 1.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max (1,N).
+*> \endverbatim
+*>
+*> \param[in,out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (N)
+*> On entry, the right hand side b of the triangular system.
+*> On exit, X is overwritten by the solution vector x.
+*> \endverbatim
+*>
+*> \param[out] SCALE
+*> \verbatim
+*> SCALE is DOUBLE PRECISION
+*> The scaling factor s for the triangular system
+*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b.
+*> If SCALE = 0, the matrix A is singular or badly scaled, and
+*> the vector x is an exact or approximate solution to A*x = 0.
+*> \endverbatim
+*>
+*> \param[in,out] CNORM
+*> \verbatim
+*> CNORM is DOUBLE PRECISION array, dimension (N)
+*>
+*> If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+*> contains the norm of the off-diagonal part of the j-th column
+*> of A. If TRANS = 'N', CNORM(j) must be greater than or equal
+*> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+*> must be greater than or equal to the 1-norm.
+*>
+*> If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+*> returns the 1-norm of the offdiagonal part of the j-th column
+*> of A.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -k, the k-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16OTHERauxiliary
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> A rough bound on x is computed; if that is less than overflow, ZTRSV
+*> is called, otherwise, specific code is used which checks for possible
+*> overflow or divide-by-zero at every operation.
+*>
+*> A columnwise scheme is used for solving A*x = b. The basic algorithm
+*> if A is lower triangular is
+*>
+*> x[1:n] := b[1:n]
+*> for j = 1, ..., n
+*> x(j) := x(j) / A(j,j)
+*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+*> end
+*>
+*> Define bounds on the components of x after j iterations of the loop:
+*> M(j) = bound on x[1:j]
+*> G(j) = bound on x[j+1:n]
+*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*>
+*> Then for iteration j+1 we have
+*> M(j+1) <= G(j) / | A(j+1,j+1) |
+*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*>
+*> where CNORM(j+1) is greater than or equal to the infinity-norm of
+*> column j+1 of A, not counting the diagonal. Hence
+*>
+*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+*> 1<=i<=j
+*> and
+*>
+*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+*> 1<=i< j
+*>
+*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the
+*> reciprocal of the largest M(j), j=1,..,n, is larger than
+*> max(underflow, 1/overflow).
+*>
+*> The bound on x(j) is also used to determine when a step in the
+*> columnwise method can be performed without fear of overflow. If
+*> the computed bound is greater than a large constant, x is scaled to
+*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*>
+*> Similarly, a row-wise scheme is used to solve A**T *x = b or
+*> A**H *x = b. The basic algorithm for A upper triangular is
+*>
+*> for j = 1, ..., n
+*> x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+*> end
+*>
+*> We simultaneously compute two bounds
+*> G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+*> M(j) = bound on x(i), 1<=i<=j
+*>
+*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+*> Then the bound on x(j) is
+*>
+*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*>
+*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+*> 1<=i<=j
+*>
+*> and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater
+*> than max(underflow, 1/overflow).
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zlatrs( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
+ $ CNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.8.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORMIN, TRANS, UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION SCALE
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION CNORM( * )
+ COMPLEX*16 A( lda, * ), X( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE, TWO
+ parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0,
+ $ two = 2.0d+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ INTEGER I, IMAX, J, JFIRST, JINC, JLAST
+ DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
+ $ xbnd, xj, xmax
+ COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX, IZAMAX
+ DOUBLE PRECISION DLAMCH, DZASUM
+ COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
+ EXTERNAL lsame, idamax, izamax, dlamch, dzasum, zdotc,
+ $ zdotu, zladiv
+* ..
+* .. External Subroutines ..
+ EXTERNAL dscal, xerbla, zaxpy, zdscal, ztrsv, dlabad
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1, CABS2
+* ..
+* .. Statement Function definitions ..
+ cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
+ cabs2( zdum ) = abs( dble( zdum ) / 2.d0 ) +
+ $ abs( dimag( zdum ) / 2.d0 )
+* ..
+* .. Executable Statements ..
+*
+ info = 0
+ upper = lsame( uplo, 'U' )
+ notran = lsame( trans, 'N' )
+ nounit = lsame( diag, 'N' )
+*
+* Test the input parameters.
+*
+ IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
+ info = -1
+ ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
+ $ lsame( trans, 'C' ) ) THEN
+ info = -2
+ ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
+ info = -3
+ ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT.
+ $ lsame( normin, 'N' ) ) THEN
+ info = -4
+ ELSE IF( n.LT.0 ) THEN
+ info = -5
+ ELSE IF( lda.LT.max( 1, n ) ) THEN
+ info = -7
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZLATRS', -info )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.EQ.0 )
+ $ RETURN
+*
+* Determine machine dependent parameters to control overflow.
+*
+ smlnum = dlamch( 'Safe minimum' )
+ bignum = one / smlnum
+ CALL dlabad( smlnum, bignum )
+ smlnum = smlnum / dlamch( 'Precision' )
+ bignum = one / smlnum
+ scale = one
+*
+ IF( lsame( normin, 'N' ) ) THEN
+*
+* Compute the 1-norm of each column, not including the diagonal.
+*
+ IF( upper ) THEN
+*
+* A is upper triangular.
+*
+ DO 10 j = 1, n
+ cnorm( j ) = dzasum( j-1, a( 1, j ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* A is lower triangular.
+*
+ DO 20 j = 1, n - 1
+ cnorm( j ) = dzasum( n-j, a( j+1, j ), 1 )
+ 20 CONTINUE
+ cnorm( n ) = zero
+ END IF
+ END IF
+*
+* Scale the column norms by TSCAL if the maximum element in CNORM is
+* greater than BIGNUM/2.
+*
+ imax = idamax( n, cnorm, 1 )
+ tmax = cnorm( imax )
+ IF( tmax.LE.bignum*half ) THEN
+ tscal = one
+ ELSE
+ tscal = half / ( smlnum*tmax )
+ CALL dscal( n, tscal, cnorm, 1 )
+ END IF
+*
+* Compute a bound on the computed solution vector to see if the
+* Level 2 BLAS routine ZTRSV can be used.
+*
+ xmax = zero
+ DO 30 j = 1, n
+ xmax = max( xmax, cabs2( x( j ) ) )
+ 30 CONTINUE
+ xbnd = xmax
+*
+ IF( notran ) THEN
+*
+* Compute the growth in A * x = b.
+*
+ IF( upper ) THEN
+ jfirst = n
+ jlast = 1
+ jinc = -1
+ ELSE
+ jfirst = 1
+ jlast = n
+ jinc = 1
+ END IF
+*
+ IF( tscal.NE.one ) THEN
+ grow = zero
+ GO TO 60
+ END IF
+*
+ IF( nounit ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, G(0) = max{x(i), i=1,...,n}.
+*
+ grow = half / max( xbnd, smlnum )
+ xbnd = grow
+ DO 40 j = jfirst, jlast, jinc
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( grow.LE.smlnum )
+ $ GO TO 60
+*
+ tjjs = a( j, j )
+ tjj = cabs1( tjjs )
+*
+ IF( tjj.GE.smlnum ) THEN
+*
+* M(j) = G(j-1) / abs(A(j,j))
+*
+ xbnd = min( xbnd, min( one, tjj )*grow )
+ ELSE
+*
+* M(j) could overflow, set XBND to 0.
+*
+ xbnd = zero
+ END IF
+*
+ IF( tjj+cnorm( j ).GE.smlnum ) THEN
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+ grow = grow*( tjj / ( tjj+cnorm( j ) ) )
+ ELSE
+*
+* G(j) could overflow, set GROW to 0.
+*
+ grow = zero
+ END IF
+ 40 CONTINUE
+ grow = xbnd
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ grow = min( one, half / max( xbnd, smlnum ) )
+ DO 50 j = jfirst, jlast, jinc
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( grow.LE.smlnum )
+ $ GO TO 60
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+ grow = grow*( one / ( one+cnorm( j ) ) )
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+*
+ ELSE
+*
+* Compute the growth in A**T * x = b or A**H * x = b.
+*
+ IF( upper ) THEN
+ jfirst = 1
+ jlast = n
+ jinc = 1
+ ELSE
+ jfirst = n
+ jlast = 1
+ jinc = -1
+ END IF
+*
+ IF( tscal.NE.one ) THEN
+ grow = zero
+ GO TO 90
+ END IF
+*
+ IF( nounit ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, M(0) = max{x(i), i=1,...,n}.
+*
+ grow = half / max( xbnd, smlnum )
+ xbnd = grow
+ DO 70 j = jfirst, jlast, jinc
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( grow.LE.smlnum )
+ $ GO TO 90
+*
+* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+ xj = one + cnorm( j )
+ grow = min( grow, xbnd / xj )
+*
+ tjjs = a( j, j )
+ tjj = cabs1( tjjs )
+*
+ IF( tjj.GE.smlnum ) THEN
+*
+* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+ IF( xj.GT.tjj )
+ $ xbnd = xbnd*( tjj / xj )
+ ELSE
+*
+* M(j) could overflow, set XBND to 0.
+*
+ xbnd = zero
+ END IF
+ 70 CONTINUE
+ grow = min( grow, xbnd )
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ grow = min( one, half / max( xbnd, smlnum ) )
+ DO 80 j = jfirst, jlast, jinc
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( grow.LE.smlnum )
+ $ GO TO 90
+*
+* G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+ xj = one + cnorm( j )
+ grow = grow / xj
+ 80 CONTINUE
+ END IF
+ 90 CONTINUE
+ END IF
+*
+ IF( ( grow*tscal ).GT.smlnum ) THEN
+*
+* Use the Level 2 BLAS solve if the reciprocal of the bound on
+* elements of X is not too small.
+*
+ CALL ztrsv( uplo, trans, diag, n, a, lda, x, 1 )
+ ELSE
+*
+* Use a Level 1 BLAS solve, scaling intermediate results.
+*
+ IF( xmax.GT.bignum*half ) THEN
+*
+* Scale X so that its components are less than or equal to
+* BIGNUM in absolute value.
+*
+ scale = ( bignum*half ) / xmax
+ CALL zdscal( n, scale, x, 1 )
+ xmax = bignum
+ ELSE
+ xmax = xmax*two
+ END IF
+*
+ IF( notran ) THEN
+*
+* Solve A * x = b
+*
+ DO 120 j = jfirst, jlast, jinc
+*
+* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+ xj = cabs1( x( j ) )
+ IF( nounit ) THEN
+ tjjs = a( j, j )*tscal
+ ELSE
+ tjjs = tscal
+ IF( tscal.EQ.one )
+ $ GO TO 110
+ END IF
+ tjj = cabs1( tjjs )
+ IF( tjj.GT.smlnum ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( tjj.LT.one ) THEN
+ IF( xj.GT.tjj*bignum ) THEN
+*
+* Scale x by 1/b(j).
+*
+ rec = one / xj
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ END IF
+ x( j ) = zladiv( x( j ), tjjs )
+ xj = cabs1( x( j ) )
+ ELSE IF( tjj.GT.zero ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( xj.GT.tjj*bignum ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+* to avoid overflow when dividing by A(j,j).
+*
+ rec = ( tjj*bignum ) / xj
+ IF( cnorm( j ).GT.one ) THEN
+*
+* Scale by 1/CNORM(j) to avoid overflow when
+* multiplying x(j) times column j.
+*
+ rec = rec / cnorm( j )
+ END IF
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ x( j ) = zladiv( x( j ), tjjs )
+ xj = cabs1( x( j ) )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A*x = 0.
+*
+ DO 100 i = 1, n
+ x( i ) = zero
+ 100 CONTINUE
+ x( j ) = one
+ xj = one
+ scale = zero
+ xmax = zero
+ END IF
+ 110 CONTINUE
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j of A.
+*
+ IF( xj.GT.one ) THEN
+ rec = one / xj
+ IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
+*
+* Scale x by 1/(2*abs(x(j))).
+*
+ rec = rec*half
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ END IF
+ ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
+*
+* Scale x by 1/2.
+*
+ CALL zdscal( n, half, x, 1 )
+ scale = scale*half
+ END IF
+*
+ IF( upper ) THEN
+ IF( j.GT.1 ) THEN
+*
+* Compute the update
+* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+ CALL zaxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,
+ $ 1 )
+ i = izamax( j-1, x, 1 )
+ xmax = cabs1( x( i ) )
+ END IF
+ ELSE
+ IF( j.LT.n ) THEN
+*
+* Compute the update
+* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+ CALL zaxpy( n-j, -x( j )*tscal, a( j+1, j ), 1,
+ $ x( j+1 ), 1 )
+ i = j + izamax( n-j, x( j+1 ), 1 )
+ xmax = cabs1( x( i ) )
+ END IF
+ END IF
+ 120 CONTINUE
+*
+ ELSE IF( lsame( trans, 'T' ) ) THEN
+*
+* Solve A**T * x = b
+*
+ DO 170 j = jfirst, jlast, jinc
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ xj = cabs1( x( j ) )
+ uscal = tscal
+ rec = one / max( xmax, one )
+ IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ rec = rec*half
+ IF( nounit ) THEN
+ tjjs = a( j, j )*tscal
+ ELSE
+ tjjs = tscal
+ END IF
+ tjj = cabs1( tjjs )
+ IF( tjj.GT.one ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ rec = min( one, rec*tjj )
+ uscal = zladiv( uscal, tjjs )
+ END IF
+ IF( rec.LT.one ) THEN
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ END IF
+*
+ csumj = zero
+ IF( uscal.EQ.dcmplx( one ) ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call ZDOTU to perform the dot product.
+*
+ IF( upper ) THEN
+ csumj = zdotu( j-1, a( 1, j ), 1, x, 1 )
+ ELSE IF( j.LT.n ) THEN
+ csumj = zdotu( n-j, a( j+1, j ), 1, x( j+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( upper ) THEN
+ DO 130 i = 1, j - 1
+ csumj = csumj + ( a( i, j )*uscal )*x( i )
+ 130 CONTINUE
+ ELSE IF( j.LT.n ) THEN
+ DO 140 i = j + 1, n
+ csumj = csumj + ( a( i, j )*uscal )*x( i )
+ 140 CONTINUE
+ END IF
+ END IF
+*
+ IF( uscal.EQ.dcmplx( tscal ) ) THEN
+*
+* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ x( j ) = x( j ) - csumj
+ xj = cabs1( x( j ) )
+ IF( nounit ) THEN
+ tjjs = a( j, j )*tscal
+ ELSE
+ tjjs = tscal
+ IF( tscal.EQ.one )
+ $ GO TO 160
+ END IF
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ tjj = cabs1( tjjs )
+ IF( tjj.GT.smlnum ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( tjj.LT.one ) THEN
+ IF( xj.GT.tjj*bignum ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ rec = one / xj
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ END IF
+ x( j ) = zladiv( x( j ), tjjs )
+ ELSE IF( tjj.GT.zero ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( xj.GT.tjj*bignum ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ rec = ( tjj*bignum ) / xj
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ x( j ) = zladiv( x( j ), tjjs )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0 and compute a solution to A**T *x = 0.
+*
+ DO 150 i = 1, n
+ x( i ) = zero
+ 150 CONTINUE
+ x( j ) = one
+ scale = zero
+ xmax = zero
+ END IF
+ 160 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
+* product has already been divided by 1/A(j,j).
+*
+ x( j ) = zladiv( x( j ), tjjs ) - csumj
+ END IF
+ xmax = max( xmax, cabs1( x( j ) ) )
+ 170 CONTINUE
+*
+ ELSE
+*
+* Solve A**H * x = b
+*
+ DO 220 j = jfirst, jlast, jinc
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ xj = cabs1( x( j ) )
+ uscal = tscal
+ rec = one / max( xmax, one )
+ IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ rec = rec*half
+ IF( nounit ) THEN
+ tjjs = dconjg( a( j, j ) )*tscal
+ ELSE
+ tjjs = tscal
+ END IF
+ tjj = cabs1( tjjs )
+ IF( tjj.GT.one ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ rec = min( one, rec*tjj )
+ uscal = zladiv( uscal, tjjs )
+ END IF
+ IF( rec.LT.one ) THEN
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ END IF
+*
+ csumj = zero
+ IF( uscal.EQ.dcmplx( one ) ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call ZDOTC to perform the dot product.
+*
+ IF( upper ) THEN
+ csumj = zdotc( j-1, a( 1, j ), 1, x, 1 )
+ ELSE IF( j.LT.n ) THEN
+ csumj = zdotc( n-j, a( j+1, j ), 1, x( j+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( upper ) THEN
+ DO 180 i = 1, j - 1
+ csumj = csumj + ( dconjg( a( i, j ) )*uscal )*
+ $ x( i )
+ 180 CONTINUE
+ ELSE IF( j.LT.n ) THEN
+ DO 190 i = j + 1, n
+ csumj = csumj + ( dconjg( a( i, j ) )*uscal )*
+ $ x( i )
+ 190 CONTINUE
+ END IF
+ END IF
+*
+ IF( uscal.EQ.dcmplx( tscal ) ) THEN
+*
+* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ x( j ) = x( j ) - csumj
+ xj = cabs1( x( j ) )
+ IF( nounit ) THEN
+ tjjs = dconjg( a( j, j ) )*tscal
+ ELSE
+ tjjs = tscal
+ IF( tscal.EQ.one )
+ $ GO TO 210
+ END IF
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ tjj = cabs1( tjjs )
+ IF( tjj.GT.smlnum ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( tjj.LT.one ) THEN
+ IF( xj.GT.tjj*bignum ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ rec = one / xj
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ END IF
+ x( j ) = zladiv( x( j ), tjjs )
+ ELSE IF( tjj.GT.zero ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( xj.GT.tjj*bignum ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ rec = ( tjj*bignum ) / xj
+ CALL zdscal( n, rec, x, 1 )
+ scale = scale*rec
+ xmax = xmax*rec
+ END IF
+ x( j ) = zladiv( x( j ), tjjs )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0 and compute a solution to A**H *x = 0.
+*
+ DO 200 i = 1, n
+ x( i ) = zero
+ 200 CONTINUE
+ x( j ) = one
+ scale = zero
+ xmax = zero
+ END IF
+ 210 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
+* product has already been divided by 1/A(j,j).
+*
+ x( j ) = zladiv( x( j ), tjjs ) - csumj
+ END IF
+ xmax = max( xmax, cabs1( x( j ) ) )
+ 220 CONTINUE
+ END IF
+ scale = scale / tscal
+ END IF
+*
+* Scale the column norms by 1/TSCAL for return.
+*
+ IF( tscal.NE.one ) THEN
+ CALL dscal( n, one / tscal, cnorm, 1 )
+ END IF
+*
+ RETURN
+*
+* End of ZLATRS
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZROT + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX, INCY, N
+* DOUBLE PRECISION C
+* COMPLEX*16 S
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 CX( * ), CY( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZROT applies a plane rotation, where the cos (C) is real and the
+*> sin (S) is complex, and the vectors CX and CY are complex.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of elements in the vectors CX and CY.
+*> \endverbatim
+*>
+*> \param[in,out] CX
+*> \verbatim
+*> CX is COMPLEX*16 array, dimension (N)
+*> On input, the vector X.
+*> On output, CX is overwritten with C*X + S*Y.
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> The increment between successive values of CY. INCX <> 0.
+*> \endverbatim
+*>
+*> \param[in,out] CY
+*> \verbatim
+*> CY is COMPLEX*16 array, dimension (N)
+*> On input, the vector Y.
+*> On output, CY is overwritten with -CONJG(S)*X + C*Y.
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> The increment between successive values of CY. INCX <> 0.
+*> \endverbatim
+*>
+*> \param[in] C
+*> \verbatim
+*> C is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] S
+*> \verbatim
+*> S is COMPLEX*16
+*> C and S define a rotation
+*> [ C S ]
+*> [ -conjg(S) C ]
+*> where C*C + S*CONJG(S) = 1.0.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE zrot( N, CX, INCX, CY, INCY, C, S )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, INCY, N
+ DOUBLE PRECISION C
+ COMPLEX*16 S
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 CX( * ), CY( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IX, IY
+ COMPLEX*16 STEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg
+* ..
+* .. Executable Statements ..
+*
+ IF( n.LE.0 )
+ $ RETURN
+ IF( incx.EQ.1 .AND. incy.EQ.1 )
+ $ GO TO 20
+*
+* Code for unequal increments or equal increments not equal to 1
+*
+ ix = 1
+ iy = 1
+ IF( incx.LT.0 )
+ $ ix = ( -n+1 )*incx + 1
+ IF( incy.LT.0 )
+ $ iy = ( -n+1 )*incy + 1
+ DO 10 i = 1, n
+ stemp = c*cx( ix ) + s*cy( iy )
+ cy( iy ) = c*cy( iy ) - dconjg( s )*cx( ix )
+ cx( ix ) = stemp
+ ix = ix + incx
+ iy = iy + incy
+ 10 CONTINUE
+ RETURN
+*
+* Code for both increments equal to 1
+*
+ 20 CONTINUE
+ DO 30 i = 1, n
+ stemp = c*cx( i ) + s*cy( i )
+ cy( i ) = c*cy( i ) - dconjg( s )*cx( i )
+ cx( i ) = stemp
+ 30 CONTINUE
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b ZTREVC
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZTREVC + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+* LDVR, MM, M, WORK, RWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER HOWMNY, SIDE
+* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+* LOGICAL SELECT( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+* $ WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZTREVC computes some or all of the right and/or left eigenvectors of
+*> a complex upper triangular matrix T.
+*> Matrices of this type are produced by the Schur factorization of
+*> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
+*>
+*> The right eigenvector x and the left eigenvector y of T corresponding
+*> to an eigenvalue w are defined by:
+*>
+*> T*x = w*x, (y**H)*T = w*(y**H)
+*>
+*> where y**H denotes the conjugate transpose of the vector y.
+*> The eigenvalues are not input to this routine, but are read directly
+*> from the diagonal of T.
+*>
+*> This routine returns the matrices X and/or Y of right and left
+*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
+*> input matrix. If Q is the unitary factor that reduces a matrix A to
+*> Schur form T, then Q*X and Q*Y are the matrices of right and left
+*> eigenvectors of A.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'R': compute right eigenvectors only;
+*> = 'L': compute left eigenvectors only;
+*> = 'B': compute both right and left eigenvectors.
+*> \endverbatim
+*>
+*> \param[in] HOWMNY
+*> \verbatim
+*> HOWMNY is CHARACTER*1
+*> = 'A': compute all right and/or left eigenvectors;
+*> = 'B': compute all right and/or left eigenvectors,
+*> backtransformed using the matrices supplied in
+*> VR and/or VL;
+*> = 'S': compute selected right and/or left eigenvectors,
+*> as indicated by the logical array SELECT.
+*> \endverbatim
+*>
+*> \param[in] SELECT
+*> \verbatim
+*> SELECT is LOGICAL array, dimension (N)
+*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be
+*> computed.
+*> The eigenvector corresponding to the j-th eigenvalue is
+*> computed if SELECT(j) = .TRUE..
+*> Not referenced if HOWMNY = 'A' or 'B'.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix T. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,N)
+*> The upper triangular matrix T. T is modified, but restored
+*> on exit.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] VL
+*> \verbatim
+*> VL is COMPLEX*16 array, dimension (LDVL,MM)
+*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+*> contain an N-by-N matrix Q (usually the unitary matrix Q of
+*> Schur vectors returned by ZHSEQR).
+*> On exit, if SIDE = 'L' or 'B', VL contains:
+*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
+*> if HOWMNY = 'B', the matrix Q*Y;
+*> if HOWMNY = 'S', the left eigenvectors of T specified by
+*> SELECT, stored consecutively in the columns
+*> of VL, in the same order as their
+*> eigenvalues.
+*> Not referenced if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDVL
+*> \verbatim
+*> LDVL is INTEGER
+*> The leading dimension of the array VL. LDVL >= 1, and if
+*> SIDE = 'L' or 'B', LDVL >= N.
+*> \endverbatim
+*>
+*> \param[in,out] VR
+*> \verbatim
+*> VR is COMPLEX*16 array, dimension (LDVR,MM)
+*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+*> contain an N-by-N matrix Q (usually the unitary matrix Q of
+*> Schur vectors returned by ZHSEQR).
+*> On exit, if SIDE = 'R' or 'B', VR contains:
+*> if HOWMNY = 'A', the matrix X of right eigenvectors of T;
+*> if HOWMNY = 'B', the matrix Q*X;
+*> if HOWMNY = 'S', the right eigenvectors of T specified by
+*> SELECT, stored consecutively in the columns
+*> of VR, in the same order as their
+*> eigenvalues.
+*> Not referenced if SIDE = 'L'.
+*> \endverbatim
+*>
+*> \param[in] LDVR
+*> \verbatim
+*> LDVR is INTEGER
+*> The leading dimension of the array VR. LDVR >= 1, and if
+*> SIDE = 'R' or 'B'; LDVR >= N.
+*> \endverbatim
+*>
+*> \param[in] MM
+*> \verbatim
+*> MM is INTEGER
+*> The number of columns in the arrays VL and/or VR. MM >= M.
+*> \endverbatim
+*>
+*> \param[out] M
+*> \verbatim
+*> M is INTEGER
+*> The number of columns in the arrays VL and/or VR actually
+*> used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
+*> is set to N. Each selected eigenvector occupies one
+*> column.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The algorithm used in this program is basically backward (forward)
+*> substitution, with scaling to make the the code robust against
+*> possible overflow.
+*>
+*> Each eigenvector is normalized so that the element of largest
+*> magnitude has magnitude 1; here the magnitude of a complex number
+*> (x,y) is taken to be |x| + |y|.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ztrevc( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+ $ LDVR, MM, M, WORK, RWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.8.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, SIDE
+ INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 T( ldt, * ), VL( ldvl, * ), VR( ldvr, * ),
+ $ work( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ parameter( zero = 0.0d+0, one = 1.0d+0 )
+ COMPLEX*16 CMZERO, CMONE
+ parameter( cmzero = ( 0.0d+0, 0.0d+0 ),
+ $ cmone = ( 1.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
+ INTEGER I, II, IS, J, K, KI
+ DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
+ COMPLEX*16 CDUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH, DZASUM
+ EXTERNAL lsame, izamax, dlamch, dzasum
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zcopy, zdscal, zgemv, zlatrs, dlabad
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, dconjg, dimag, max
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ bothv = lsame( side, 'B' )
+ rightv = lsame( side, 'R' ) .OR. bothv
+ leftv = lsame( side, 'L' ) .OR. bothv
+*
+ allv = lsame( howmny, 'A' )
+ over = lsame( howmny, 'B' )
+ somev = lsame( howmny, 'S' )
+*
+* Set M to the number of columns required to store the selected
+* eigenvectors.
+*
+ IF( somev ) THEN
+ m = 0
+ DO 10 j = 1, n
+ IF( SELECT( j ) )
+ $ m = m + 1
+ 10 CONTINUE
+ ELSE
+ m = n
+ END IF
+*
+ info = 0
+ IF( .NOT.rightv .AND. .NOT.leftv ) THEN
+ info = -1
+ ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
+ info = -2
+ ELSE IF( n.LT.0 ) THEN
+ info = -4
+ ELSE IF( ldt.LT.max( 1, n ) ) THEN
+ info = -6
+ ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
+ info = -8
+ ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
+ info = -10
+ ELSE IF( mm.LT.m ) THEN
+ info = -11
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZTREVC', -info )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( n.EQ.0 )
+ $ RETURN
+*
+* Set the constants to control overflow.
+*
+ unfl = dlamch( 'Safe minimum' )
+ ovfl = one / unfl
+ CALL dlabad( unfl, ovfl )
+ ulp = dlamch( 'Precision' )
+ smlnum = unfl*( n / ulp )
+*
+* Store the diagonal elements of T in working array WORK.
+*
+ DO 20 i = 1, n
+ work( i+n ) = t( i, i )
+ 20 CONTINUE
+*
+* Compute 1-norm of each column of strictly upper triangular
+* part of T to control overflow in triangular solver.
+*
+ rwork( 1 ) = zero
+ DO 30 j = 2, n
+ rwork( j ) = dzasum( j-1, t( 1, j ), 1 )
+ 30 CONTINUE
+*
+ IF( rightv ) THEN
+*
+* Compute right eigenvectors.
+*
+ is = m
+ DO 80 ki = n, 1, -1
+*
+ IF( somev ) THEN
+ IF( .NOT.SELECT( ki ) )
+ $ GO TO 80
+ END IF
+ smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
+*
+ work( 1 ) = cmone
+*
+* Form right-hand side.
+*
+ DO 40 k = 1, ki - 1
+ work( k ) = -t( k, ki )
+ 40 CONTINUE
+*
+* Solve the triangular system:
+* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
+*
+ DO 50 k = 1, ki - 1
+ t( k, k ) = t( k, k ) - t( ki, ki )
+ IF( cabs1( t( k, k ) ).LT.smin )
+ $ t( k, k ) = smin
+ 50 CONTINUE
+*
+ IF( ki.GT.1 ) THEN
+ CALL zlatrs( 'Upper', 'No transpose', 'Non-unit', 'Y',
+ $ ki-1, t, ldt, work( 1 ), scale, rwork,
+ $ info )
+ work( ki ) = scale
+ END IF
+*
+* Copy the vector x or Q*x to VR and normalize.
+*
+ IF( .NOT.over ) THEN
+ CALL zcopy( ki, work( 1 ), 1, vr( 1, is ), 1 )
+*
+ ii = izamax( ki, vr( 1, is ), 1 )
+ remax = one / cabs1( vr( ii, is ) )
+ CALL zdscal( ki, remax, vr( 1, is ), 1 )
+*
+ DO 60 k = ki + 1, n
+ vr( k, is ) = cmzero
+ 60 CONTINUE
+ ELSE
+ IF( ki.GT.1 )
+ $ CALL zgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),
+ $ 1, dcmplx( scale ), vr( 1, ki ), 1 )
+*
+ ii = izamax( n, vr( 1, ki ), 1 )
+ remax = one / cabs1( vr( ii, ki ) )
+ CALL zdscal( n, remax, vr( 1, ki ), 1 )
+ END IF
+*
+* Set back the original diagonal elements of T.
+*
+ DO 70 k = 1, ki - 1
+ t( k, k ) = work( k+n )
+ 70 CONTINUE
+*
+ is = is - 1
+ 80 CONTINUE
+ END IF
+*
+ IF( leftv ) THEN
+*
+* Compute left eigenvectors.
+*
+ is = 1
+ DO 130 ki = 1, n
+*
+ IF( somev ) THEN
+ IF( .NOT.SELECT( ki ) )
+ $ GO TO 130
+ END IF
+ smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
+*
+ work( n ) = cmone
+*
+* Form right-hand side.
+*
+ DO 90 k = ki + 1, n
+ work( k ) = -dconjg( t( ki, k ) )
+ 90 CONTINUE
+*
+* Solve the triangular system:
+* (T(KI+1:N,KI+1:N) - T(KI,KI))**H * X = SCALE*WORK.
+*
+ DO 100 k = ki + 1, n
+ t( k, k ) = t( k, k ) - t( ki, ki )
+ IF( cabs1( t( k, k ) ).LT.smin )
+ $ t( k, k ) = smin
+ 100 CONTINUE
+*
+ IF( ki.LT.n ) THEN
+ CALL zlatrs( 'Upper', 'Conjugate transpose', 'Non-unit',
+ $ 'Y', n-ki, t( ki+1, ki+1 ), ldt,
+ $ work( ki+1 ), scale, rwork, info )
+ work( ki ) = scale
+ END IF
+*
+* Copy the vector x or Q*x to VL and normalize.
+*
+ IF( .NOT.over ) THEN
+ CALL zcopy( n-ki+1, work( ki ), 1, vl( ki, is ), 1 )
+*
+ ii = izamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
+ remax = one / cabs1( vl( ii, is ) )
+ CALL zdscal( n-ki+1, remax, vl( ki, is ), 1 )
+*
+ DO 110 k = 1, ki - 1
+ vl( k, is ) = cmzero
+ 110 CONTINUE
+ ELSE
+ IF( ki.LT.n )
+ $ CALL zgemv( 'N', n, n-ki, cmone, vl( 1, ki+1 ), ldvl,
+ $ work( ki+1 ), 1, dcmplx( scale ),
+ $ vl( 1, ki ), 1 )
+*
+ ii = izamax( n, vl( 1, ki ), 1 )
+ remax = one / cabs1( vl( ii, ki ) )
+ CALL zdscal( n, remax, vl( 1, ki ), 1 )
+ END IF
+*
+* Set back the original diagonal elements of T.
+*
+ DO 120 k = ki + 1, n
+ t( k, k ) = work( k+n )
+ 120 CONTINUE
+*
+ is = is + 1
+ 130 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZTREVC
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZTREXC
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZTREXC + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER COMPQ
+* INTEGER IFST, ILST, INFO, LDQ, LDT, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 Q( LDQ, * ), T( LDT, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZTREXC reorders the Schur factorization of a complex matrix
+*> A = Q*T*Q**H, so that the diagonal element of T with row index IFST
+*> is moved to row ILST.
+*>
+*> The Schur form T is reordered by a unitary similarity transformation
+*> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
+*> postmultplying it with Z.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] COMPQ
+*> \verbatim
+*> COMPQ is CHARACTER*1
+*> = 'V': update the matrix Q of Schur vectors;
+*> = 'N': do not update Q.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix T. N >= 0.
+*> If N == 0 arguments ILST and IFST may be any value.
+*> \endverbatim
+*>
+*> \param[in,out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,N)
+*> On entry, the upper triangular matrix T.
+*> On exit, the reordered upper triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] Q
+*> \verbatim
+*> Q is COMPLEX*16 array, dimension (LDQ,N)
+*> On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+*> On exit, if COMPQ = 'V', Q has been postmultiplied by the
+*> unitary transformation matrix Z which reorders T.
+*> If COMPQ = 'N', Q is not referenced.
+*> \endverbatim
+*>
+*> \param[in] LDQ
+*> \verbatim
+*> LDQ is INTEGER
+*> The leading dimension of the array Q. LDQ >= 1, and if
+*> COMPQ = 'V', LDQ >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] IFST
+*> \verbatim
+*> IFST is INTEGER
+*> \endverbatim
+*>
+*> \param[in] ILST
+*> \verbatim
+*> ILST is INTEGER
+*>
+*> Specify the reordering of the diagonal elements of T:
+*> The element with row index IFST is moved to row ILST by a
+*> sequence of transpositions between adjacent elements.
+*> 1 <= IFST <= N; 1 <= ILST <= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE ztrexc( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ
+ INTEGER IFST, ILST, INFO, LDQ, LDT, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 Q( ldq, * ), T( ldt, * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL WANTQ
+ INTEGER K, M1, M2, M3
+ DOUBLE PRECISION CS
+ COMPLEX*16 SN, T11, T22, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zlartg, zrot
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg, max
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters.
+*
+ info = 0
+ wantq = lsame( compq, 'V' )
+ IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN
+ info = -1
+ ELSE IF( n.LT.0 ) THEN
+ info = -2
+ ELSE IF( ldt.LT.max( 1, n ) ) THEN
+ info = -4
+ ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.max( 1, n ) ) ) THEN
+ info = -6
+ ELSE IF(( ifst.LT.1 .OR. ifst.GT.n ).AND.( n.GT.0 )) THEN
+ info = -7
+ ELSE IF(( ilst.LT.1 .OR. ilst.GT.n ).AND.( n.GT.0 )) THEN
+ info = -8
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZTREXC', -info )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.LE.1 .OR. ifst.EQ.ilst )
+ $ RETURN
+*
+ IF( ifst.LT.ilst ) THEN
+*
+* Move the IFST-th diagonal element forward down the diagonal.
+*
+ m1 = 0
+ m2 = -1
+ m3 = 1
+ ELSE
+*
+* Move the IFST-th diagonal element backward up the diagonal.
+*
+ m1 = -1
+ m2 = 0
+ m3 = -1
+ END IF
+*
+ DO 10 k = ifst + m1, ilst + m2, m3
+*
+* Interchange the k-th and (k+1)-th diagonal elements.
+*
+ t11 = t( k, k )
+ t22 = t( k+1, k+1 )
+*
+* Determine the transformation to perform the interchange.
+*
+ CALL zlartg( t( k, k+1 ), t22-t11, cs, sn, temp )
+*
+* Apply transformation to the matrix T.
+*
+ IF( k+2.LE.n )
+ $ CALL zrot( n-k-1, t( k, k+2 ), ldt, t( k+1, k+2 ), ldt, cs,
+ $ sn )
+ CALL zrot( k-1, t( 1, k ), 1, t( 1, k+1 ), 1, cs,
+ $ dconjg( sn ) )
+*
+ t( k, k ) = t22
+ t( k+1, k+1 ) = t11
+*
+ IF( wantq ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL zrot( n, q( 1, k ), 1, q( 1, k+1 ), 1, cs,
+ $ dconjg( sn ) )
+ END IF
+*
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of ZTREXC
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZUNG2R
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNG2R + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
+*> which is defined as the first n columns of a product of k elementary
+*> reflectors of order m
+*>
+*> Q = H(1) H(2) . . . H(k)
+*>
+*> as returned by ZGEQRF.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix Q. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix Q. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines the
+*> matrix Q. N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the i-th column must contain the vector which
+*> defines the elementary reflector H(i), for i = 1,2,...,k, as
+*> returned by ZGEQRF in the first k columns of its array
+*> argument A.
+*> On exit, the m by n matrix Q.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The first dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (K)
+*> TAU(i) must contain the scalar factor of the elementary
+*> reflector H(i), as returned by ZGEQRF.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument has an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE zung2r( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ parameter( one = ( 1.0d+0, 0.0d+0 ),
+ $ zero = ( 0.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zlarf, zscal
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC max
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+ IF( m.LT.0 ) THEN
+ info = -1
+ ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
+ info = -2
+ ELSE IF( k.LT.0 .OR. k.GT.n ) THEN
+ info = -3
+ ELSE IF( lda.LT.max( 1, m ) ) THEN
+ info = -5
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZUNG2R', -info )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.LE.0 )
+ $ RETURN
+*
+* Initialise columns k+1:n to columns of the unit matrix
+*
+ DO 20 j = k + 1, n
+ DO 10 l = 1, m
+ a( l, j ) = zero
+ 10 CONTINUE
+ a( j, j ) = one
+ 20 CONTINUE
+*
+ DO 40 i = k, 1, -1
+*
+* Apply H(i) to A(i:m,i:n) from the left
+*
+ IF( i.LT.n ) THEN
+ a( i, i ) = one
+ CALL zlarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ),
+ $ a( i, i+1 ), lda, work )
+ END IF
+ IF( i.LT.m )
+ $ CALL zscal( m-i, -tau( i ), a( i+1, i ), 1 )
+ a( i, i ) = one - tau( i )
+*
+* Set A(1:i-1,i) to zero
+*
+ DO 30 l = 1, i - 1
+ a( l, i ) = zero
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of ZUNG2R
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZUNGHR
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNGHR + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZUNGHR generates a complex unitary matrix Q which is defined as the
+*> product of IHI-ILO elementary reflectors of order N, as returned by
+*> ZGEHRD:
+*>
+*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix Q. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*>
+*> ILO and IHI must have the same values as in the previous call
+*> of ZGEHRD. Q is equal to the unit matrix except in the
+*> submatrix Q(ilo+1:ihi,ilo+1:ihi).
+*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the vectors which define the elementary reflectors,
+*> as returned by ZGEHRD.
+*> On exit, the N-by-N unitary matrix Q.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (N-1)
+*> TAU(i) must contain the scalar factor of the elementary
+*> reflector H(i), as returned by ZGEHRD.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= IHI-ILO.
+*> For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
+*> the optimal blocksize.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE zunghr( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO, ONE
+ parameter( zero = ( 0.0d+0, 0.0d+0 ),
+ $ one = ( 1.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IINFO, J, LWKOPT, NB, NH
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zungqr
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ilaenv
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC max, min
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+ nh = ihi - ilo
+ lquery = ( lwork.EQ.-1 )
+ IF( n.LT.0 ) THEN
+ info = -1
+ ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
+ info = -2
+ ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
+ info = -3
+ ELSE IF( lda.LT.max( 1, n ) ) THEN
+ info = -5
+ ELSE IF( lwork.LT.max( 1, nh ) .AND. .NOT.lquery ) THEN
+ info = -8
+ END IF
+*
+ IF( info.EQ.0 ) THEN
+ nb = ilaenv( 1, 'ZUNGQR', ' ', nh, nh, nh, -1 )
+ lwkopt = max( 1, nh )*nb
+ work( 1 ) = lwkopt
+ END IF
+*
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZUNGHR', -info )
+ RETURN
+ ELSE IF( lquery ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.EQ.0 ) THEN
+ work( 1 ) = 1
+ RETURN
+ END IF
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the right, and set the first ilo and the last n-ihi
+* rows and columns to those of the unit matrix
+*
+ DO 40 j = ihi, ilo + 1, -1
+ DO 10 i = 1, j - 1
+ a( i, j ) = zero
+ 10 CONTINUE
+ DO 20 i = j + 1, ihi
+ a( i, j ) = a( i, j-1 )
+ 20 CONTINUE
+ DO 30 i = ihi + 1, n
+ a( i, j ) = zero
+ 30 CONTINUE
+ 40 CONTINUE
+ DO 60 j = 1, ilo
+ DO 50 i = 1, n
+ a( i, j ) = zero
+ 50 CONTINUE
+ a( j, j ) = one
+ 60 CONTINUE
+ DO 80 j = ihi + 1, n
+ DO 70 i = 1, n
+ a( i, j ) = zero
+ 70 CONTINUE
+ a( j, j ) = one
+ 80 CONTINUE
+*
+ IF( nh.GT.0 ) THEN
+*
+* Generate Q(ilo+1:ihi,ilo+1:ihi)
+*
+ CALL zungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),
+ $ work, lwork, iinfo )
+ END IF
+ work( 1 ) = lwkopt
+ RETURN
+*
+* End of ZUNGHR
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZUNGQR
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNGQR + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
+*> which is defined as the first N columns of a product of K elementary
+*> reflectors of order M
+*>
+*> Q = H(1) H(2) . . . H(k)
+*>
+*> as returned by ZGEQRF.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix Q. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix Q. M >= N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines the
+*> matrix Q. N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the i-th column must contain the vector which
+*> defines the elementary reflector H(i), for i = 1,2,...,k, as
+*> returned by ZGEQRF in the first k columns of its array
+*> argument A.
+*> On exit, the M-by-N matrix Q.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The first dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (K)
+*> TAU(i) must contain the scalar factor of the elementary
+*> reflector H(i), as returned by ZGEQRF.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= max(1,N).
+*> For optimum performance LWORK >= N*NB, where NB is the
+*> optimal blocksize.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument has an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE zungqr( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ parameter( zero = ( 0.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+ $ lwkopt, nb, nbmin, nx
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zlarfb, zlarft, zung2r
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC max, min
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ilaenv
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+ nb = ilaenv( 1, 'ZUNGQR', ' ', m, n, k, -1 )
+ lwkopt = max( 1, n )*nb
+ work( 1 ) = lwkopt
+ lquery = ( lwork.EQ.-1 )
+ IF( m.LT.0 ) THEN
+ info = -1
+ ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
+ info = -2
+ ELSE IF( k.LT.0 .OR. k.GT.n ) THEN
+ info = -3
+ ELSE IF( lda.LT.max( 1, m ) ) THEN
+ info = -5
+ ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
+ info = -8
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZUNGQR', -info )
+ RETURN
+ ELSE IF( lquery ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( n.LE.0 ) THEN
+ work( 1 ) = 1
+ RETURN
+ END IF
+*
+ nbmin = 2
+ nx = 0
+ iws = n
+ IF( nb.GT.1 .AND. nb.LT.k ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ nx = max( 0, ilaenv( 3, 'ZUNGQR', ' ', m, n, k, -1 ) )
+ IF( nx.LT.k ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ ldwork = n
+ iws = ldwork*nb
+ IF( lwork.LT.iws ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ nb = lwork / ldwork
+ nbmin = max( 2, ilaenv( 2, 'ZUNGQR', ' ', m, n, k, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
+*
+* Use blocked code after the last block.
+* The first kk columns are handled by the block method.
+*
+ ki = ( ( k-nx-1 ) / nb )*nb
+ kk = min( k, ki+nb )
+*
+* Set A(1:kk,kk+1:n) to zero.
+*
+ DO 20 j = kk + 1, n
+ DO 10 i = 1, kk
+ a( i, j ) = zero
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ kk = 0
+ END IF
+*
+* Use unblocked code for the last or only block.
+*
+ IF( kk.LT.n )
+ $ CALL zung2r( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,
+ $ tau( kk+1 ), work, iinfo )
+*
+ IF( kk.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 i = ki + 1, 1, -nb
+ ib = min( nb, k-i+1 )
+ IF( i+ib.LE.n ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL zlarft( 'Forward', 'Columnwise', m-i+1, ib,
+ $ a( i, i ), lda, tau( i ), work, ldwork )
+*
+* Apply H to A(i:m,i+ib:n) from the left
+*
+ CALL zlarfb( 'Left', 'No transpose', 'Forward',
+ $ 'Columnwise', m-i+1, n-i-ib+1, ib,
+ $ a( i, i ), lda, work, ldwork, a( i, i+ib ),
+ $ lda, work( ib+1 ), ldwork )
+ END IF
+*
+* Apply H to rows i:m of current block
+*
+ CALL zung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,
+ $ iinfo )
+*
+* Set rows 1:i-1 of current block to zero
+*
+ DO 40 j = i, i + ib - 1
+ DO 30 l = 1, i - 1
+ a( l, j ) = zero
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ work( 1 ) = iws
+ RETURN
+*
+* End of ZUNGQR
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b DLABAD
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLABAD + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLABAD( SMALL, LARGE )
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION LARGE, SMALL
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLABAD takes as input the values computed by DLAMCH for underflow and
+*> overflow, and returns the square root of each of these values if the
+*> log of LARGE is sufficiently large. This subroutine is intended to
+*> identify machines with a large exponent range, such as the Crays, and
+*> redefine the underflow and overflow limits to be the square roots of
+*> the values computed by DLAMCH. This subroutine is needed because
+*> DLAMCH does not compensate for poor arithmetic in the upper half of
+*> the exponent range, as is found on a Cray.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in,out] SMALL
+*> \verbatim
+*> SMALL is DOUBLE PRECISION
+*> On entry, the underflow threshold as computed by DLAMCH.
+*> On exit, if LOG10(LARGE) is sufficiently large, the square
+*> root of SMALL, otherwise unchanged.
+*> \endverbatim
+*>
+*> \param[in,out] LARGE
+*> \verbatim
+*> LARGE is DOUBLE PRECISION
+*> On entry, the overflow threshold as computed by DLAMCH.
+*> On exit, if LOG10(LARGE) is sufficiently large, the square
+*> root of LARGE, otherwise unchanged.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup OTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE dlabad( SMALL, LARGE )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION LARGE, SMALL
+* ..
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC log10, sqrt
+* ..
+* .. Executable Statements ..
+*
+* If it looks like we're on a Cray, take the square root of
+* SMALL and LARGE to avoid overflow and underflow problems.
+*
+ IF( log10( large ).GT.2000.d0 ) THEN
+ small = sqrt( small )
+ large = sqrt( large )
+ END IF
+*
+ RETURN
+*
+* End of DLABAD
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLADIV + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLADIV( A, B, C, D, P, Q )
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION A, B, C, D, P, Q
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLADIV performs complex division in real arithmetic
+*>
+*> a + i*b
+*> p + i*q = ---------
+*> c + i*d
+*>
+*> The algorithm is due to Michael Baudin and Robert L. Smith
+*> and can be found in the paper
+*> "A Robust Complex Division in Scilab"
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] B
+*> \verbatim
+*> B is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] C
+*> \verbatim
+*> C is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] D
+*> \verbatim
+*> D is DOUBLE PRECISION
+*> The scalars a, b, c, and d in the above expression.
+*> \endverbatim
+*>
+*> \param[out] P
+*> \verbatim
+*> P is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[out] Q
+*> \verbatim
+*> Q is DOUBLE PRECISION
+*> The scalars p and q in the above expression.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date January 2013
+*
+*> \ingroup doubleOTHERauxiliary
+*
+* =====================================================================
+ SUBROUTINE dladiv( A, B, C, D, P, Q )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* January 2013
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, D, P, Q
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION BS
+ parameter( bs = 2.0d0 )
+ DOUBLE PRECISION HALF
+ parameter( half = 0.5d0 )
+ DOUBLE PRECISION TWO
+ parameter( two = 2.0d0 )
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL dlamch
+* ..
+* .. External Subroutines ..
+ EXTERNAL dladiv1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, max
+* ..
+* .. Executable Statements ..
+*
+ aa = a
+ bb = b
+ cc = c
+ dd = d
+ ab = max( abs(a), abs(b) )
+ cd = max( abs(c), abs(d) )
+ s = 1.0d0
+
+ ov = dlamch( 'Overflow threshold' )
+ un = dlamch( 'Safe minimum' )
+ eps = dlamch( 'Epsilon' )
+ be = bs / (eps*eps)
+
+ IF( ab >= half*ov ) THEN
+ aa = half * aa
+ bb = half * bb
+ s = two * s
+ END IF
+ IF( cd >= half*ov ) THEN
+ cc = half * cc
+ dd = half * dd
+ s = half * s
+ END IF
+ IF( ab <= un*bs/eps ) THEN
+ aa = aa * be
+ bb = bb * be
+ s = s / be
+ END IF
+ IF( cd <= un*bs/eps ) THEN
+ cc = cc * be
+ dd = dd * be
+ s = s * be
+ END IF
+ IF( abs( d ).LE.abs( c ) ) THEN
+ CALL dladiv1(aa, bb, cc, dd, p, q)
+ ELSE
+ CALL dladiv1(bb, aa, dd, cc, p, q)
+ q = -q
+ END IF
+ p = p * s
+ q = q * s
+*
+ RETURN
+*
+* End of DLADIV
+*
+ END
+
+*> \ingroup doubleOTHERauxiliary
+
+
+ SUBROUTINE dladiv1( A, B, C, D, P, Q )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* January 2013
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, D, P, Q
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ parameter( one = 1.0d0 )
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION R, T
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLADIV2
+ EXTERNAL dladiv2
+* ..
+* .. Executable Statements ..
+*
+ r = d / c
+ t = one / (c + d * r)
+ p = dladiv2(a, b, c, d, r, t)
+ a = -a
+ q = dladiv2(b, a, c, d, r, t)
+*
+ RETURN
+*
+* End of DLADIV1
+*
+ END
+
+*> \ingroup doubleOTHERauxiliary
+
+ DOUBLE PRECISION FUNCTION dladiv2( A, B, C, D, R, T )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* January 2013
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, D, R, T
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ parameter( zero = 0.0d0 )
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION BR
+* ..
+* .. Executable Statements ..
+*
+ IF( r.NE.zero ) THEN
+ br = b * r
+ IF( br.NE.zero ) THEN
+ dladiv2 = (a + br) * t
+ ELSE
+ dladiv2 = a * t + (b * t) * r
+ END IF
+ ELSE
+ dladiv2 = (a + d * (b / c)) * t
+ END IF
+*
+ RETURN
+*
+* End of DLADIV12
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b DLAPY2 returns sqrt(x2+y2).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLAPY2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION X, Y
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
+*> overflow.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] X
+*> \verbatim
+*> X is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] Y
+*> \verbatim
+*> Y is DOUBLE PRECISION
+*> X and Y specify the values x and y.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2017
+*
+*> \ingroup OTHERauxiliary
+*
+* =====================================================================
+ DOUBLE PRECISION FUNCTION dlapy2( X, Y )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2017
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION X, Y
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ parameter( zero = 0.0d0 )
+ DOUBLE PRECISION ONE
+ parameter( one = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION W, XABS, YABS, Z
+ LOGICAL X_IS_NAN, Y_IS_NAN
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ EXTERNAL disnan
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, max, min, sqrt
+* ..
+* .. Executable Statements ..
+*
+ x_is_nan = disnan( x )
+ y_is_nan = disnan( y )
+ IF ( x_is_nan ) dlapy2 = x
+ IF ( y_is_nan ) dlapy2 = y
+*
+ IF ( .NOT.( x_is_nan.OR.y_is_nan ) ) THEN
+ xabs = abs( x )
+ yabs = abs( y )
+ w = max( xabs, yabs )
+ z = min( xabs, yabs )
+ IF( z.EQ.zero ) THEN
+ dlapy2 = w
+ ELSE
+ dlapy2 = w*sqrt( one+( z / w )**2 )
+ END IF
+ END IF
+ RETURN
+*
+* End of DLAPY2
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b DLAPY3 returns sqrt(x2+y2+z2).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLAPY3 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION X, Y, Z
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
+*> unnecessary overflow.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] X
+*> \verbatim
+*> X is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] Y
+*> \verbatim
+*> Y is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] Z
+*> \verbatim
+*> Z is DOUBLE PRECISION
+*> X, Y and Z specify the values x, y and z.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup OTHERauxiliary
+*
+* =====================================================================
+ DOUBLE PRECISION FUNCTION dlapy3( X, Y, Z )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION X, Y, Z
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ parameter( zero = 0.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION W, XABS, YABS, ZABS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, max, sqrt
+* ..
+* .. Executable Statements ..
+*
+ xabs = abs( x )
+ yabs = abs( y )
+ zabs = abs( z )
+ w = max( xabs, yabs, zabs )
+ IF( w.EQ.zero ) THEN
+* W can be zero for max(0,nan,0)
+* adding all three entries together will make sure
+* NaN will not disappear.
+ dlapy3 = xabs + yabs + zabs
+ ELSE
+ dlapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+
+ $ ( zabs / w )**2 )
+ END IF
+ RETURN
+*
+* End of DLAPY3
+*
+ END
+*
+************************************************************************
+*> \brief \b DLAMCHF77 deprecated
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DLAMCHF77 determines double precision machine parameters.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] CMACH
+*> \verbatim
+*> Specifies the value to be returned by DLAMCH:
+*> = 'E' or 'e', DLAMCH := eps
+*> = 'S' or 's , DLAMCH := sfmin
+*> = 'B' or 'b', DLAMCH := base
+*> = 'P' or 'p', DLAMCH := eps*base
+*> = 'N' or 'n', DLAMCH := t
+*> = 'R' or 'r', DLAMCH := rnd
+*> = 'M' or 'm', DLAMCH := emin
+*> = 'U' or 'u', DLAMCH := rmin
+*> = 'L' or 'l', DLAMCH := emax
+*> = 'O' or 'o', DLAMCH := rmax
+*> where
+*> eps = relative machine precision
+*> sfmin = safe minimum, such that 1/sfmin does not overflow
+*> base = base of the machine
+*> prec = eps*base
+*> t = number of (base) digits in the mantissa
+*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+*> emin = minimum exponent before (gradual) underflow
+*> rmin = underflow threshold - base**(emin-1)
+*> emax = largest exponent before overflow
+*> rmax = overflow threshold - (base**emax)*(1-eps)
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date April 2012
+*
+*> \ingroup auxOTHERauxiliary
+*
+* =====================================================================
+ DOUBLE PRECISION FUNCTION dlamch( CMACH )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* April 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER CMACH
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ parameter( one = 1.0d+0, zero = 0.0d+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRST, LRND
+ INTEGER BETA, IMAX, IMIN, IT
+ DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+ $ rnd, sfmin, small, t
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL dlamc2
+* ..
+* .. Save statement ..
+ SAVE first, eps, sfmin, base, t, rnd, emin, rmin,
+ $ emax, rmax, prec
+* ..
+* .. Data statements ..
+ DATA first / .true. /
+* ..
+* .. Executable Statements ..
+*
+ IF( first ) THEN
+ CALL dlamc2( beta, it, lrnd, eps, imin, rmin, imax, rmax )
+ base = beta
+ t = it
+ IF( lrnd ) THEN
+ rnd = one
+ eps = ( base**( 1-it ) ) / 2
+ ELSE
+ rnd = zero
+ eps = base**( 1-it )
+ END IF
+ prec = eps*base
+ emin = imin
+ emax = imax
+ sfmin = rmin
+ small = one / rmax
+ IF( small.GE.sfmin ) THEN
+*
+* Use SMALL plus a bit, to avoid the possibility of rounding
+* causing overflow when computing 1/sfmin.
+*
+ sfmin = small*( one+eps )
+ END IF
+ END IF
+*
+ IF( lsame( cmach, 'E' ) ) THEN
+ rmach = eps
+ ELSE IF( lsame( cmach, 'S' ) ) THEN
+ rmach = sfmin
+ ELSE IF( lsame( cmach, 'B' ) ) THEN
+ rmach = base
+ ELSE IF( lsame( cmach, 'P' ) ) THEN
+ rmach = prec
+ ELSE IF( lsame( cmach, 'N' ) ) THEN
+ rmach = t
+ ELSE IF( lsame( cmach, 'R' ) ) THEN
+ rmach = rnd
+ ELSE IF( lsame( cmach, 'M' ) ) THEN
+ rmach = emin
+ ELSE IF( lsame( cmach, 'U' ) ) THEN
+ rmach = rmin
+ ELSE IF( lsame( cmach, 'L' ) ) THEN
+ rmach = emax
+ ELSE IF( lsame( cmach, 'O' ) ) THEN
+ rmach = rmax
+ END IF
+*
+ dlamch = rmach
+ first = .false.
+ RETURN
+*
+* End of DLAMCH
+*
+ END
+*
+************************************************************************
+*
+*> \brief \b DLAMC1
+*> \details
+*> \b Purpose:
+*> \verbatim
+*> DLAMC1 determines the machine parameters given by BETA, T, RND, and
+*> IEEE1.
+*> \endverbatim
+*>
+*> \param[out] BETA
+*> \verbatim
+*> The base of the machine.
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> The number of ( BETA ) digits in the mantissa.
+*> \endverbatim
+*>
+*> \param[out] RND
+*> \verbatim
+*> Specifies whether proper rounding ( RND = .TRUE. ) or
+*> chopping ( RND = .FALSE. ) occurs in addition. This may not
+*> be a reliable guide to the way in which the machine performs
+*> its arithmetic.
+*> \endverbatim
+*>
+*> \param[out] IEEE1
+*> \verbatim
+*> Specifies whether rounding appears to be done in the IEEE
+*> 'round to nearest' style.
+*> \endverbatim
+*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
+*> \date April 2012
+*> \ingroup auxOTHERauxiliary
+*>
+*> \details \b Further \b Details
+*> \verbatim
+*>
+*> The routine is based on the routine ENVRON by Malcolm and
+*> incorporates suggestions by Gentleman and Marovich. See
+*>
+*> Malcolm M. A. (1972) Algorithms to reveal properties of
+*> floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*>
+*> Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+*> that reveal properties of floating point arithmetic units.
+*> Comms. of the ACM, 17, 276-277.
+*> \endverbatim
+*>
+ SUBROUTINE dlamc1( BETA, T, RND, IEEE1 )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2010
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE1, RND
+ INTEGER BETA, T
+* ..
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, LIEEE1, LRND
+ INTEGER LBETA, LT
+ DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL dlamc3
+* ..
+* .. Save statement ..
+ SAVE first, lieee1, lbeta, lrnd, lt
+* ..
+* .. Data statements ..
+ DATA first / .true. /
+* ..
+* .. Executable Statements ..
+*
+ IF( first ) THEN
+ one = 1
+*
+* LBETA, LIEEE1, LT and LRND are the local values of BETA,
+* IEEE1, T and RND.
+*
+* Throughout this routine we use the function DLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* Compute a = 2.0**m with the smallest positive integer m such
+* that
+*
+* fl( a + 1.0 ) = a.
+*
+ a = 1
+ c = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 10 CONTINUE
+ IF( c.EQ.one ) THEN
+ a = 2*a
+ c = dlamc3( a, one )
+ c = dlamc3( c, -a )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+* Now compute b = 2.0**m with the smallest positive integer m
+* such that
+*
+* fl( a + b ) .gt. a.
+*
+ b = 1
+ c = dlamc3( a, b )
+*
+*+ WHILE( C.EQ.A )LOOP
+ 20 CONTINUE
+ IF( c.EQ.a ) THEN
+ b = 2*b
+ c = dlamc3( a, b )
+ GO TO 20
+ END IF
+*+ END WHILE
+*
+* Now compute the base. a and c are neighbouring floating point
+* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
+* their difference is beta. Adding 0.25 to c is to ensure that it
+* is truncated to beta and not ( beta - 1 ).
+*
+ qtr = one / 4
+ savec = c
+ c = dlamc3( c, -a )
+ lbeta = c + qtr
+*
+* Now determine whether rounding or chopping occurs, by adding a
+* bit less than beta/2 and a bit more than beta/2 to a.
+*
+ b = lbeta
+ f = dlamc3( b / 2, -b / 100 )
+ c = dlamc3( f, a )
+ IF( c.EQ.a ) THEN
+ lrnd = .true.
+ ELSE
+ lrnd = .false.
+ END IF
+ f = dlamc3( b / 2, b / 100 )
+ c = dlamc3( f, a )
+ IF( ( lrnd ) .AND. ( c.EQ.a ) )
+ $ lrnd = .false.
+*
+* Try and decide whether rounding is done in the IEEE 'round to
+* nearest' style. B/2 is half a unit in the last place of the two
+* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
+* zero, and SAVEC is odd. Thus adding B/2 to A should not change
+* A, but adding B/2 to SAVEC should change SAVEC.
+*
+ t1 = dlamc3( b / 2, a )
+ t2 = dlamc3( b / 2, savec )
+ lieee1 = ( t1.EQ.a ) .AND. ( t2.GT.savec ) .AND. lrnd
+*
+* Now find the mantissa, t. It should be the integer part of
+* log to the base beta of a, however it is safer to determine t
+* by powering. So we find t as the smallest positive integer for
+* which
+*
+* fl( beta**t + 1.0 ) = 1.0.
+*
+ lt = 0
+ a = 1
+ c = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 30 CONTINUE
+ IF( c.EQ.one ) THEN
+ lt = lt + 1
+ a = a*lbeta
+ c = dlamc3( a, one )
+ c = dlamc3( c, -a )
+ GO TO 30
+ END IF
+*+ END WHILE
+*
+ END IF
+*
+ beta = lbeta
+ t = lt
+ rnd = lrnd
+ ieee1 = lieee1
+ first = .false.
+ RETURN
+*
+* End of DLAMC1
+*
+ END
+*
+************************************************************************
+*
+*> \brief \b DLAMC2
+*> \details
+*> \b Purpose:
+*> \verbatim
+*> DLAMC2 determines the machine parameters specified in its argument
+*> list.
+*> \endverbatim
+*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
+*> \date April 2012
+*> \ingroup auxOTHERauxiliary
+*>
+*> \param[out] BETA
+*> \verbatim
+*> The base of the machine.
+*> \endverbatim
+*>
+*> \param[out] T
+*> \verbatim
+*> The number of ( BETA ) digits in the mantissa.
+*> \endverbatim
+*>
+*> \param[out] RND
+*> \verbatim
+*> Specifies whether proper rounding ( RND = .TRUE. ) or
+*> chopping ( RND = .FALSE. ) occurs in addition. This may not
+*> be a reliable guide to the way in which the machine performs
+*> its arithmetic.
+*> \endverbatim
+*>
+*> \param[out] EPS
+*> \verbatim
+*> The smallest positive number such that
+*> fl( 1.0 - EPS ) .LT. 1.0,
+*> where fl denotes the computed value.
+*> \endverbatim
+*>
+*> \param[out] EMIN
+*> \verbatim
+*> The minimum exponent before (gradual) underflow occurs.
+*> \endverbatim
+*>
+*> \param[out] RMIN
+*> \verbatim
+*> The smallest normalized number for the machine, given by
+*> BASE**( EMIN - 1 ), where BASE is the floating point value
+*> of BETA.
+*> \endverbatim
+*>
+*> \param[out] EMAX
+*> \verbatim
+*> The maximum exponent before overflow occurs.
+*> \endverbatim
+*>
+*> \param[out] RMAX
+*> \verbatim
+*> The largest positive number for the machine, given by
+*> BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
+*> value of BETA.
+*> \endverbatim
+*>
+*> \details \b Further \b Details
+*> \verbatim
+*>
+*> The computation of EPS is based on a routine PARANOIA by
+*> W. Kahan of the University of California at Berkeley.
+*> \endverbatim
+ SUBROUTINE dlamc2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2010
+*
+* .. Scalar Arguments ..
+ LOGICAL RND
+ INTEGER BETA, EMAX, EMIN, T
+ DOUBLE PRECISION EPS, RMAX, RMIN
+* ..
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
+ INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+ $ ngnmin, ngpmin
+ DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+ $ sixth, small, third, two, zero
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL dlamc3
+* ..
+* .. External Subroutines ..
+ EXTERNAL dlamc1, dlamc4, dlamc5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, max, min
+* ..
+* .. Save statement ..
+ SAVE first, iwarn, lbeta, lemax, lemin, leps, lrmax,
+ $ lrmin, lt
+* ..
+* .. Data statements ..
+ DATA first / .true. / , iwarn / .false. /
+* ..
+* .. Executable Statements ..
+*
+ IF( first ) THEN
+ zero = 0
+ one = 1
+ two = 2
+*
+* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
+* BETA, T, RND, EPS, EMIN and RMIN.
+*
+* Throughout this routine we use the function DLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
+*
+ CALL dlamc1( lbeta, lt, lrnd, lieee1 )
+*
+* Start to find EPS.
+*
+ b = lbeta
+ a = b**( -lt )
+ leps = a
+*
+* Try some tricks to see whether or not this is the correct EPS.
+*
+ b = two / 3
+ half = one / 2
+ sixth = dlamc3( b, -half )
+ third = dlamc3( sixth, sixth )
+ b = dlamc3( third, -half )
+ b = dlamc3( b, sixth )
+ b = abs( b )
+ IF( b.LT.leps )
+ $ b = leps
+*
+ leps = 1
+*
+*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+ 10 CONTINUE
+ IF( ( leps.GT.b ) .AND. ( b.GT.zero ) ) THEN
+ leps = b
+ c = dlamc3( half*leps, ( two**5 )*( leps**2 ) )
+ c = dlamc3( half, -c )
+ b = dlamc3( half, c )
+ c = dlamc3( half, -b )
+ b = dlamc3( half, c )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ IF( a.LT.leps )
+ $ leps = a
+*
+* Computation of EPS complete.
+*
+* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
+* Keep dividing A by BETA until (gradual) underflow occurs. This
+* is detected when we cannot recover the previous A.
+*
+ rbase = one / lbeta
+ small = one
+ DO 20 i = 1, 3
+ small = dlamc3( small*rbase, zero )
+ 20 CONTINUE
+ a = dlamc3( one, small )
+ CALL dlamc4( ngpmin, one, lbeta )
+ CALL dlamc4( ngnmin, -one, lbeta )
+ CALL dlamc4( gpmin, a, lbeta )
+ CALL dlamc4( gnmin, -a, lbeta )
+ ieee = .false.
+*
+ IF( ( ngpmin.EQ.ngnmin ) .AND. ( gpmin.EQ.gnmin ) ) THEN
+ IF( ngpmin.EQ.gpmin ) THEN
+ lemin = ngpmin
+* ( Non twos-complement machines, no gradual underflow;
+* e.g., VAX )
+ ELSE IF( ( gpmin-ngpmin ).EQ.3 ) THEN
+ lemin = ngpmin - 1 + lt
+ ieee = .true.
+* ( Non twos-complement machines, with gradual underflow;
+* e.g., IEEE standard followers )
+ ELSE
+ lemin = min( ngpmin, gpmin )
+* ( A guess; no known machine )
+ iwarn = .true.
+ END IF
+*
+ ELSE IF( ( ngpmin.EQ.gpmin ) .AND. ( ngnmin.EQ.gnmin ) ) THEN
+ IF( abs( ngpmin-ngnmin ).EQ.1 ) THEN
+ lemin = max( ngpmin, ngnmin )
+* ( Twos-complement machines, no gradual underflow;
+* e.g., CYBER 205 )
+ ELSE
+ lemin = min( ngpmin, ngnmin )
+* ( A guess; no known machine )
+ iwarn = .true.
+ END IF
+*
+ ELSE IF( ( abs( ngpmin-ngnmin ).EQ.1 ) .AND.
+ $ ( gpmin.EQ.gnmin ) ) THEN
+ IF( ( gpmin-min( ngpmin, ngnmin ) ).EQ.3 ) THEN
+ lemin = max( ngpmin, ngnmin ) - 1 + lt
+* ( Twos-complement machines with gradual underflow;
+* no known machine )
+ ELSE
+ lemin = min( ngpmin, ngnmin )
+* ( A guess; no known machine )
+ iwarn = .true.
+ END IF
+*
+ ELSE
+ lemin = min( ngpmin, ngnmin, gpmin, gnmin )
+* ( A guess; no known machine )
+ iwarn = .true.
+ END IF
+ first = .false.
+***
+* Comment out this if block if EMIN is ok
+ IF( iwarn ) THEN
+ first = .true.
+ WRITE( 6, fmt = 9999 )lemin
+ END IF
+***
+*
+* Assume IEEE arithmetic if we found denormalised numbers above,
+* or if arithmetic seems to round in the IEEE style, determined
+* in routine DLAMC1. A true IEEE machine should have both things
+* true; however, faulty machines may have one or the other.
+*
+ ieee = ieee .OR. lieee1
+*
+* Compute RMIN by successive division by BETA. We could compute
+* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
+* this computation.
+*
+ lrmin = 1
+ DO 30 i = 1, 1 - lemin
+ lrmin = dlamc3( lrmin*rbase, zero )
+ 30 CONTINUE
+*
+* Finally, call DLAMC5 to compute EMAX and RMAX.
+*
+ CALL dlamc5( lbeta, lt, lemin, ieee, lemax, lrmax )
+ END IF
+*
+ beta = lbeta
+ t = lt
+ rnd = lrnd
+ eps = leps
+ emin = lemin
+ rmin = lrmin
+ emax = lemax
+ rmax = lrmax
+*
+ RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+ $ ' EMIN = ', i8, /
+ $ ' If, after inspection, the value EMIN looks',
+ $ ' acceptable please comment out ',
+ $ / ' the IF block as marked within the code of routine',
+ $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+* End of DLAMC2
+*
+ END
+*
+************************************************************************
+*
+*> \brief \b DLAMC3
+*> \details
+*> \b Purpose:
+*> \verbatim
+*> DLAMC3 is intended to force A and B to be stored prior to doing
+*> the addition of A and B , for use in situations where optimizers
+*> might hold one of these in a register.
+*> \endverbatim
+*>
+*> \param[in] A
+*>
+*> \param[in] B
+*> \verbatim
+*> The values A and B.
+*> \endverbatim
+
+ DOUBLE PRECISION FUNCTION dlamc3( A, B )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2010
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B
+* ..
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ dlamc3 = a + b
+*
+ RETURN
+*
+* End of DLAMC3
+*
+ END
+*
+************************************************************************
+*
+*> \brief \b DLAMC4
+*> \details
+*> \b Purpose:
+*> \verbatim
+*> DLAMC4 is a service routine for DLAMC2.
+*> \endverbatim
+*>
+*> \param[out] EMIN
+*> \verbatim
+*> The minimum exponent before (gradual) underflow, computed by
+*> setting A = START and dividing by BASE until the previous A
+*> can not be recovered.
+*> \endverbatim
+*>
+*> \param[in] START
+*> \verbatim
+*> The starting point for determining EMIN.
+*> \endverbatim
+*>
+*> \param[in] BASE
+*> \verbatim
+*> The base of the machine.
+*> \endverbatim
+*>
+ SUBROUTINE dlamc4( EMIN, START, BASE )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2010
+*
+* .. Scalar Arguments ..
+ INTEGER BASE, EMIN
+ DOUBLE PRECISION START
+* ..
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL dlamc3
+* ..
+* .. Executable Statements ..
+*
+ a = start
+ one = 1
+ rbase = one / base
+ zero = 0
+ emin = 1
+ b1 = dlamc3( a*rbase, zero )
+ c1 = a
+ c2 = a
+ d1 = a
+ d2 = a
+*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
+ 10 CONTINUE
+ IF( ( c1.EQ.a ) .AND. ( c2.EQ.a ) .AND. ( d1.EQ.a ) .AND.
+ $ ( d2.EQ.a ) ) THEN
+ emin = emin - 1
+ a = b1
+ b1 = dlamc3( a / base, zero )
+ c1 = dlamc3( b1*base, zero )
+ d1 = zero
+ DO 20 i = 1, base
+ d1 = d1 + b1
+ 20 CONTINUE
+ b2 = dlamc3( a*rbase, zero )
+ c2 = dlamc3( b2 / rbase, zero )
+ d2 = zero
+ DO 30 i = 1, base
+ d2 = d2 + b2
+ 30 CONTINUE
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ RETURN
+*
+* End of DLAMC4
+*
+ END
+*
+************************************************************************
+*
+*> \brief \b DLAMC5
+*> \details
+*> \b Purpose:
+*> \verbatim
+*> DLAMC5 attempts to compute RMAX, the largest machine floating-point
+*> number, without overflow. It assumes that EMAX + abs(EMIN) sum
+*> approximately to a power of 2. It will fail on machines where this
+*> assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+*> EMAX = 28718). It will also fail if the value supplied for EMIN is
+*> too large (i.e. too close to zero), probably with overflow.
+*> \endverbatim
+*>
+*> \param[in] BETA
+*> \verbatim
+*> The base of floating-point arithmetic.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> The number of base BETA digits in the mantissa of a
+*> floating-point value.
+*> \endverbatim
+*>
+*> \param[in] EMIN
+*> \verbatim
+*> The minimum exponent before (gradual) underflow.
+*> \endverbatim
+*>
+*> \param[in] IEEE
+*> \verbatim
+*> A logical flag specifying whether or not the arithmetic
+*> system is thought to comply with the IEEE standard.
+*> \endverbatim
+*>
+*> \param[out] EMAX
+*> \verbatim
+*> The largest exponent before overflow
+*> \endverbatim
+*>
+*> \param[out] RMAX
+*> \verbatim
+*> The largest machine floating-point number.
+*> \endverbatim
+*>
+ SUBROUTINE dlamc5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2010
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER BETA, EMAX, EMIN, P
+ DOUBLE PRECISION RMAX
+* ..
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ parameter( zero = 0.0d0, one = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+ DOUBLE PRECISION OLDY, RECBAS, Y, Z
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL dlamc3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC mod
+* ..
+* .. Executable Statements ..
+*
+* First compute LEXP and UEXP, two powers of 2 that bound
+* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+* approximately to the bound that is closest to abs(EMIN).
+* (EMAX is the exponent of the required number RMAX).
+*
+ lexp = 1
+ exbits = 1
+ 10 CONTINUE
+ try = lexp*2
+ IF( try.LE.( -emin ) ) THEN
+ lexp = try
+ exbits = exbits + 1
+ GO TO 10
+ END IF
+ IF( lexp.EQ.-emin ) THEN
+ uexp = lexp
+ ELSE
+ uexp = try
+ exbits = exbits + 1
+ END IF
+*
+* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+* than or equal to EMIN. EXBITS is the number of bits needed to
+* store the exponent.
+*
+ IF( ( uexp+emin ).GT.( -lexp-emin ) ) THEN
+ expsum = 2*lexp
+ ELSE
+ expsum = 2*uexp
+ END IF
+*
+* EXPSUM is the exponent range, approximately equal to
+* EMAX - EMIN + 1 .
+*
+ emax = expsum + emin - 1
+ nbits = 1 + exbits + p
+*
+* NBITS is the total number of bits needed to store a
+* floating-point number.
+*
+ IF( ( mod( nbits, 2 ).EQ.1 ) .AND. ( beta.EQ.2 ) ) THEN
+*
+* Either there are an odd number of bits used to store a
+* floating-point number, which is unlikely, or some bits are
+* not used in the representation of numbers, which is possible,
+* (e.g. Cray machines) or the mantissa has an implicit bit,
+* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+* most likely. We have to assume the last alternative.
+* If this is true, then we need to reduce EMAX by one because
+* there must be some way of representing zero in an implicit-bit
+* system. On machines like Cray, we are reducing EMAX by one
+* unnecessarily.
+*
+ emax = emax - 1
+ END IF
+*
+ IF( ieee ) THEN
+*
+* Assume we are on an IEEE machine which reserves one exponent
+* for infinity and NaN.
+*
+ emax = emax - 1
+ END IF
+*
+* Now create RMAX, the largest machine number, which should
+* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+* First compute 1.0 - BETA**(-P), being careful that the
+* result is less than 1.0 .
+*
+ recbas = one / beta
+ z = beta - one
+ y = zero
+ DO 20 i = 1, p
+ z = z*recbas
+ IF( y.LT.one )
+ $ oldy = y
+ y = dlamc3( y, z )
+ 20 CONTINUE
+ IF( y.GE.one )
+ $ y = oldy
+*
+* Now multiply by BETA**EMAX to get RMAX.
+*
+ DO 30 i = 1, emax
+ y = dlamc3( y*beta, zero )
+ 30 CONTINUE
+*
+ rmax = y
+ RETURN
+*
+* End of DLAMC5
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b DZNRM2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 X(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DZNRM2 returns the euclidean norm of a vector via the function
+*> name, so that
+*>
+*> DZNRM2 := sqrt( x**H*x )
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (N)
+*> complex vector with N elements
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of X
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup double_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> -- This version written on 25-October-1982.
+*> Modified on 14-October-1993 to inline the call to ZLASSQ.
+*> Sven Hammarling, Nag Ltd.
+*> \endverbatim
+*>
+* =====================================================================
+ DOUBLE PRECISION FUNCTION dznrm2(N,X,INCX)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 X(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ parameter(one=1.0d+0,zero=0.0d+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION NORM,SCALE,SSQ,TEMP
+ INTEGER IX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs,dble,dimag,sqrt
+* ..
+ IF (n.LT.1 .OR. incx.LT.1) THEN
+ norm = zero
+ ELSE
+ scale = zero
+ ssq = one
+* The following loop is equivalent to this call to the LAPACK
+* auxiliary routine:
+* CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
+*
+ DO 10 ix = 1,1 + (n-1)*incx,incx
+ IF (dble(x(ix)).NE.zero) THEN
+ temp = abs(dble(x(ix)))
+ IF (scale.LT.temp) THEN
+ ssq = one + ssq* (scale/temp)**2
+ scale = temp
+ ELSE
+ ssq = ssq + (temp/scale)**2
+ END IF
+ END IF
+ IF (dimag(x(ix)).NE.zero) THEN
+ temp = abs(dimag(x(ix)))
+ IF (scale.LT.temp) THEN
+ ssq = one + ssq* (scale/temp)**2
+ scale = temp
+ ELSE
+ ssq = ssq + (temp/scale)**2
+ END IF
+ END IF
+ 10 CONTINUE
+ norm = scale*sqrt(ssq)
+ END IF
+*
+ dznrm2 = norm
+ RETURN
+*
+* End of DZNRM2.
+*
+ END
+C
+C======================================================================
+C
+*> \brief \b ZDSCAL
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZDSCAL(N,DA,ZX,INCX)
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION DA
+* INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZDSCAL scales a vector by a constant.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] DA
+*> \verbatim
+*> DA is DOUBLE PRECISION
+*> On entry, DA specifies the scalar alpha.
+*> \endverbatim
+*>
+*> \param[in,out] ZX
+*> \verbatim
+*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 3/11/78.
+*> modified 3/93 to return if incx .le. 0.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zdscal(N,DA,ZX,INCX)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION DA
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I,NINCX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dcmplx
+* ..
+ IF (n.LE.0 .OR. incx.LE.0) RETURN
+ IF (incx.EQ.1) THEN
+*
+* code for increment equal to 1
+*
+ DO i = 1,n
+ zx(i) = dcmplx(da,0.0d0)*zx(i)
+ END DO
+ ELSE
+*
+* code for increment not equal to 1
+*
+ nincx = n*incx
+ DO i = 1,nincx,incx
+ zx(i) = dcmplx(da,0.0d0)*zx(i)
+ END DO
+ END IF
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b DZASUM
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and
+*> returns a single precision result.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in,out] ZX
+*> \verbatim
+*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup double_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 3/11/78.
+*> modified 3/93 to return if incx .le. 0.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ DOUBLE PRECISION FUNCTION dzasum(N,ZX,INCX)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION STEMP
+ INTEGER I,NINCX
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DCABS1
+ EXTERNAL dcabs1
+* ..
+ dzasum = 0.0d0
+ stemp = 0.0d0
+ IF (n.LE.0 .OR. incx.LE.0) RETURN
+ IF (incx.EQ.1) THEN
+*
+* code for increment equal to 1
+*
+ DO i = 1,n
+ stemp = stemp + dcabs1(zx(i))
+ END DO
+ ELSE
+*
+* code for increment not equal to 1
+*
+ nincx = n*incx
+ DO i = 1,nincx,incx
+ stemp = stemp + dcabs1(zx(i))
+ END DO
+ END IF
+ dzasum = stemp
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b IDAMAX
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* INTEGER FUNCTION IDAMAX(N,DX,INCX)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION DX(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> IDAMAX finds the index of the first element having maximum absolute value.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] DX
+*> \verbatim
+*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of SX
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup aux_blas
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, linpack, 3/11/78.
+*> modified 3/93 to return if incx .le. 0.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ INTEGER FUNCTION idamax(N,DX,INCX)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DMAX
+ INTEGER I,IX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dabs
+* ..
+ idamax = 0
+ IF (n.LT.1 .OR. incx.LE.0) RETURN
+ idamax = 1
+ IF (n.EQ.1) RETURN
+ IF (incx.EQ.1) THEN
+*
+* code for increment equal to 1
+*
+ dmax = dabs(dx(1))
+ DO i = 2,n
+ IF (dabs(dx(i)).GT.dmax) THEN
+ idamax = i
+ dmax = dabs(dx(i))
+ END IF
+ END DO
+ ELSE
+*
+* code for increment not equal to 1
+*
+ ix = 1
+ dmax = dabs(dx(1))
+ ix = ix + incx
+ DO i = 2,n
+ IF (dabs(dx(ix)).GT.dmax) THEN
+ idamax = i
+ dmax = dabs(dx(ix))
+ END IF
+ ix = ix + incx
+ END DO
+ END IF
+ RETURN
+ END
+C
+C======================================================================
+C
+*> \brief \b DSCAL
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSCAL(N,DA,DX,INCX)
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION DA
+* INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION DX(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSCAL scales a vector by a constant.
+*> uses unrolled loops for increment equal to 1.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] DA
+*> \verbatim
+*> DA is DOUBLE PRECISION
+*> On entry, DA specifies the scalar alpha.
+*> \endverbatim
+*>
+*> \param[in,out] DX
+*> \verbatim
+*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of DX
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup double_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, linpack, 3/11/78.
+*> modified 3/93 to return if incx .le. 0.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE dscal(N,DA,DX,INCX)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION DA
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I,M,MP1,NINCX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC mod
+* ..
+ IF (n.LE.0 .OR. incx.LE.0) RETURN
+ IF (incx.EQ.1) THEN
+*
+* code for increment equal to 1
+*
+*
+* clean-up loop
+*
+ m = mod(n,5)
+ IF (m.NE.0) THEN
+ DO i = 1,m
+ dx(i) = da*dx(i)
+ END DO
+ IF (n.LT.5) RETURN
+ END IF
+ mp1 = m + 1
+ DO i = mp1,n,5
+ dx(i) = da*dx(i)
+ dx(i+1) = da*dx(i+1)
+ dx(i+2) = da*dx(i+2)
+ dx(i+3) = da*dx(i+3)
+ dx(i+4) = da*dx(i+4)
+ END DO
+ ELSE
+*
+* code for increment not equal to 1
+*
+ nincx = n*incx
+ DO i = 1,nincx,incx
+ dx(i) = da*dx(i)
+ END DO
+ END IF
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZTRSV
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,LDA,N
+* CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A(LDA,*),X(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZTRSV solves one of the systems of equations
+*>
+*> A*x = b, or A**T*x = b, or A**H*x = b,
+*>
+*> where b and x are n element vectors and A is an n by n unit, or
+*> non-unit, upper or lower triangular matrix.
+*>
+*> No test for singularity or near-singularity is included in this
+*> routine. Such tests must be performed before calling this routine.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> On entry, UPLO specifies whether the matrix is an upper or
+*> lower triangular matrix as follows:
+*>
+*> UPLO = 'U' or 'u' A is an upper triangular matrix.
+*>
+*> UPLO = 'L' or 'l' A is a lower triangular matrix.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> On entry, TRANS specifies the equations to be solved as
+*> follows:
+*>
+*> TRANS = 'N' or 'n' A*x = b.
+*>
+*> TRANS = 'T' or 't' A**T*x = b.
+*>
+*> TRANS = 'C' or 'c' A**H*x = b.
+*> \endverbatim
+*>
+*> \param[in] DIAG
+*> \verbatim
+*> DIAG is CHARACTER*1
+*> On entry, DIAG specifies whether or not A is unit
+*> triangular as follows:
+*>
+*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*>
+*> DIAG = 'N' or 'n' A is not assumed to be unit
+*> triangular.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> On entry, N specifies the order of the matrix A.
+*> N must be at least zero.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension ( LDA, N )
+*> Before entry with UPLO = 'U' or 'u', the leading n by n
+*> upper triangular part of the array A must contain the upper
+*> triangular matrix and the strictly lower triangular part of
+*> A is not referenced.
+*> Before entry with UPLO = 'L' or 'l', the leading n by n
+*> lower triangular part of the array A must contain the lower
+*> triangular matrix and the strictly upper triangular part of
+*> A is not referenced.
+*> Note that when DIAG = 'U' or 'u', the diagonal elements of
+*> A are not referenced either, but are assumed to be unity.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> On entry, LDA specifies the first dimension of A as declared
+*> in the calling (sub) program. LDA must be at least
+*> max( 1, n ).
+*> \endverbatim
+*>
+*> \param[in,out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension at least
+*> ( 1 + ( n - 1 )*abs( INCX ) ).
+*> Before entry, the incremented array X must contain the n
+*> element right-hand side vector b. On exit, X is overwritten
+*> with the solution vector x.
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> On entry, INCX specifies the increment for the elements of
+*> X. INCX must not be zero.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16_blas_level2
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Level 2 Blas routine.
+*>
+*> -- Written on 22-October-1986.
+*> Jack Dongarra, Argonne National Lab.
+*> Jeremy Du Croz, Nag Central Office.
+*> Sven Hammarling, Nag Central Office.
+*> Richard Hanson, Sandia National Labs.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ztrsv(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+*
+* -- Reference BLAS level2 routine (version 3.7.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A(lda,*),X(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ parameter(zero= (0.0d+0,0.0d+0))
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+ LOGICAL NOCONJ,NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg,max
+* ..
+*
+* Test the input parameters.
+*
+ info = 0
+ IF (.NOT.lsame(uplo,'U') .AND. .NOT.lsame(uplo,'L')) THEN
+ info = 1
+ ELSE IF (.NOT.lsame(trans,'N') .AND. .NOT.lsame(trans,'T') .AND.
+ + .NOT.lsame(trans,'C')) THEN
+ info = 2
+ ELSE IF (.NOT.lsame(diag,'U') .AND. .NOT.lsame(diag,'N')) THEN
+ info = 3
+ ELSE IF (n.LT.0) THEN
+ info = 4
+ ELSE IF (lda.LT.max(1,n)) THEN
+ info = 6
+ ELSE IF (incx.EQ.0) THEN
+ info = 8
+ END IF
+ IF (info.NE.0) THEN
+ CALL xerbla('ZTRSV ',info)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (n.EQ.0) RETURN
+*
+ noconj = lsame(trans,'T')
+ nounit = lsame(diag,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (incx.LE.0) THEN
+ kx = 1 - (n-1)*incx
+ ELSE IF (incx.NE.1) THEN
+ kx = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (lsame(trans,'N')) THEN
+*
+* Form x := inv( A )*x.
+*
+ IF (lsame(uplo,'U')) THEN
+ IF (incx.EQ.1) THEN
+ DO 20 j = n,1,-1
+ IF (x(j).NE.zero) THEN
+ IF (nounit) x(j) = x(j)/a(j,j)
+ temp = x(j)
+ DO 10 i = j - 1,1,-1
+ x(i) = x(i) - temp*a(i,j)
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ jx = kx + (n-1)*incx
+ DO 40 j = n,1,-1
+ IF (x(jx).NE.zero) THEN
+ IF (nounit) x(jx) = x(jx)/a(j,j)
+ temp = x(jx)
+ ix = jx
+ DO 30 i = j - 1,1,-1
+ ix = ix - incx
+ x(ix) = x(ix) - temp*a(i,j)
+ 30 CONTINUE
+ END IF
+ jx = jx - incx
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (incx.EQ.1) THEN
+ DO 60 j = 1,n
+ IF (x(j).NE.zero) THEN
+ IF (nounit) x(j) = x(j)/a(j,j)
+ temp = x(j)
+ DO 50 i = j + 1,n
+ x(i) = x(i) - temp*a(i,j)
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ jx = kx
+ DO 80 j = 1,n
+ IF (x(jx).NE.zero) THEN
+ IF (nounit) x(jx) = x(jx)/a(j,j)
+ temp = x(jx)
+ ix = jx
+ DO 70 i = j + 1,n
+ ix = ix + incx
+ x(ix) = x(ix) - temp*a(i,j)
+ 70 CONTINUE
+ END IF
+ jx = jx + incx
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := inv( A**T )*x or x := inv( A**H )*x.
+*
+ IF (lsame(uplo,'U')) THEN
+ IF (incx.EQ.1) THEN
+ DO 110 j = 1,n
+ temp = x(j)
+ IF (noconj) THEN
+ DO 90 i = 1,j - 1
+ temp = temp - a(i,j)*x(i)
+ 90 CONTINUE
+ IF (nounit) temp = temp/a(j,j)
+ ELSE
+ DO 100 i = 1,j - 1
+ temp = temp - dconjg(a(i,j))*x(i)
+ 100 CONTINUE
+ IF (nounit) temp = temp/dconjg(a(j,j))
+ END IF
+ x(j) = temp
+ 110 CONTINUE
+ ELSE
+ jx = kx
+ DO 140 j = 1,n
+ ix = kx
+ temp = x(jx)
+ IF (noconj) THEN
+ DO 120 i = 1,j - 1
+ temp = temp - a(i,j)*x(ix)
+ ix = ix + incx
+ 120 CONTINUE
+ IF (nounit) temp = temp/a(j,j)
+ ELSE
+ DO 130 i = 1,j - 1
+ temp = temp - dconjg(a(i,j))*x(ix)
+ ix = ix + incx
+ 130 CONTINUE
+ IF (nounit) temp = temp/dconjg(a(j,j))
+ END IF
+ x(jx) = temp
+ jx = jx + incx
+ 140 CONTINUE
+ END IF
+ ELSE
+ IF (incx.EQ.1) THEN
+ DO 170 j = n,1,-1
+ temp = x(j)
+ IF (noconj) THEN
+ DO 150 i = n,j + 1,-1
+ temp = temp - a(i,j)*x(i)
+ 150 CONTINUE
+ IF (nounit) temp = temp/a(j,j)
+ ELSE
+ DO 160 i = n,j + 1,-1
+ temp = temp - dconjg(a(i,j))*x(i)
+ 160 CONTINUE
+ IF (nounit) temp = temp/dconjg(a(j,j))
+ END IF
+ x(j) = temp
+ 170 CONTINUE
+ ELSE
+ kx = kx + (n-1)*incx
+ jx = kx
+ DO 200 j = n,1,-1
+ ix = kx
+ temp = x(jx)
+ IF (noconj) THEN
+ DO 180 i = n,j + 1,-1
+ temp = temp - a(i,j)*x(ix)
+ ix = ix - incx
+ 180 CONTINUE
+ IF (nounit) temp = temp/a(j,j)
+ ELSE
+ DO 190 i = n,j + 1,-1
+ temp = temp - dconjg(a(i,j))*x(ix)
+ ix = ix - incx
+ 190 CONTINUE
+ IF (nounit) temp = temp/dconjg(a(j,j))
+ END IF
+ x(jx) = temp
+ jx = jx - incx
+ 200 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZTRSV .
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZAXPY
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY)
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 ZA
+* INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZAXPY constant times a vector plus a vector.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] ZA
+*> \verbatim
+*> ZA is COMPLEX*16
+*> On entry, ZA specifies the scalar alpha.
+*> \endverbatim
+*>
+*> \param[in] ZX
+*> \verbatim
+*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*>
+*> \param[in,out] ZY
+*> \verbatim
+*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> storage spacing between elements of ZY
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 3/11/78.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zaxpy(N,ZA,ZX,INCX,ZY,INCY)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 ZA
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I,IX,IY
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DCABS1
+ EXTERNAL dcabs1
+* ..
+ IF (n.LE.0) RETURN
+ IF (dcabs1(za).EQ.0.0d0) RETURN
+ IF (incx.EQ.1 .AND. incy.EQ.1) THEN
+*
+* code for both increments equal to 1
+*
+ DO i = 1,n
+ zy(i) = zy(i) + za*zx(i)
+ END DO
+ ELSE
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ ix = 1
+ iy = 1
+ IF (incx.LT.0) ix = (-n+1)*incx + 1
+ IF (incy.LT.0) iy = (-n+1)*incy + 1
+ DO i = 1,n
+ zy(iy) = zy(iy) + za*zx(ix)
+ ix = ix + incx
+ iy = iy + incy
+ END DO
+ END IF
+*
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZDOTU
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZDOTU forms the dot product of two complex vectors
+*> ZDOTU = X^T * Y
+*>
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] ZX
+*> \verbatim
+*> ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*>
+*> \param[in] ZY
+*> \verbatim
+*> ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> storage spacing between elements of ZY
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 3/11/78.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ COMPLEX*16 FUNCTION zdotu(N,ZX,INCX,ZY,INCY)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ COMPLEX*16 ZTEMP
+ INTEGER I,IX,IY
+* ..
+ ztemp = (0.0d0,0.0d0)
+ zdotu = (0.0d0,0.0d0)
+ IF (n.LE.0) RETURN
+ IF (incx.EQ.1 .AND. incy.EQ.1) THEN
+*
+* code for both increments equal to 1
+*
+ DO i = 1,n
+ ztemp = ztemp + zx(i)*zy(i)
+ END DO
+ ELSE
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ ix = 1
+ iy = 1
+ IF (incx.LT.0) ix = (-n+1)*incx + 1
+ IF (incy.LT.0) iy = (-n+1)*incy + 1
+ DO i = 1,n
+ ztemp = ztemp + zx(ix)*zy(iy)
+ ix = ix + incx
+ iy = iy + incy
+ END DO
+ END IF
+ zdotu = ztemp
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZDOTC
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZDOTC forms the dot product of two complex vectors
+*> ZDOTC = X^H * Y
+*>
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] ZX
+*> \verbatim
+*> ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*>
+*> \param[in] ZY
+*> \verbatim
+*> ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> storage spacing between elements of ZY
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, 3/11/78.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ COMPLEX*16 FUNCTION zdotc(N,ZX,INCX,ZY,INCY)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ COMPLEX*16 ZTEMP
+ INTEGER I,IX,IY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg
+* ..
+ ztemp = (0.0d0,0.0d0)
+ zdotc = (0.0d0,0.0d0)
+ IF (n.LE.0) RETURN
+ IF (incx.EQ.1 .AND. incy.EQ.1) THEN
+*
+* code for both increments equal to 1
+*
+ DO i = 1,n
+ ztemp = ztemp + dconjg(zx(i))*zy(i)
+ END DO
+ ELSE
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ ix = 1
+ iy = 1
+ IF (incx.LT.0) ix = (-n+1)*incx + 1
+ IF (incy.LT.0) iy = (-n+1)*incy + 1
+ DO i = 1,n
+ ztemp = ztemp + dconjg(zx(ix))*zy(iy)
+ ix = ix + incx
+ iy = iy + incy
+ END DO
+ END IF
+ zdotc = ztemp
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZCOPY
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY)
+*
+* .. Scalar Arguments ..
+* INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCOPY copies a vector, x, to a vector, y.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> number of elements in input vector(s)
+*> \endverbatim
+*>
+*> \param[in] ZX
+*> \verbatim
+*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> storage spacing between elements of ZX
+*> \endverbatim
+*>
+*> \param[out] ZY
+*> \verbatim
+*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> storage spacing between elements of ZY
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+*> \ingroup complex16_blas_level1
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> jack dongarra, linpack, 4/11/78.
+*> modified 12/3/93, array(1) declarations changed to array(*)
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zcopy(N,ZX,INCX,ZY,INCY)
+*
+* -- Reference BLAS level1 routine (version 3.8.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 ZX(*),ZY(*)
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I,IX,IY
+* ..
+ IF (n.LE.0) RETURN
+ IF (incx.EQ.1 .AND. incy.EQ.1) THEN
+*
+* code for both increments equal to 1
+*
+ DO i = 1,n
+ zy(i) = zx(i)
+ END DO
+ ELSE
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ ix = 1
+ iy = 1
+ IF (incx.LT.0) ix = (-n+1)*incx + 1
+ IF (incy.LT.0) iy = (-n+1)*incy + 1
+ DO i = 1,n
+ zy(iy) = zx(ix)
+ ix = ix + incx
+ iy = iy + incy
+ END DO
+ END IF
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZGERC
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+*
+* .. Scalar Arguments ..
+* COMPLEX*16 ALPHA
+* INTEGER INCX,INCY,LDA,M,N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A(LDA,*),X(*),Y(*)
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZGERC performs the rank 1 operation
+*>
+*> A := alpha*x*y**H + A,
+*>
+*> where alpha is a scalar, x is an m element vector, y is an n element
+*> vector and A is an m by n matrix.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> On entry, M specifies the number of rows of the matrix A.
+*> M must be at least zero.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> On entry, N specifies the number of columns of the matrix A.
+*> N must be at least zero.
+*> \endverbatim
+*>
+*> \param[in] ALPHA
+*> \verbatim
+*> ALPHA is COMPLEX*16
+*> On entry, ALPHA specifies the scalar alpha.
+*> \endverbatim
+*>
+*> \param[in] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension at least
+*> ( 1 + ( m - 1 )*abs( INCX ) ).
+*> Before entry, the incremented array X must contain the m
+*> element vector x.
+*> \endverbatim
+*>
+*> \param[in] INCX
+*> \verbatim
+*> INCX is INTEGER
+*> On entry, INCX specifies the increment for the elements of
+*> X. INCX must not be zero.
+*> \endverbatim
+*>
+*> \param[in] Y
+*> \verbatim
+*> Y is COMPLEX*16 array, dimension at least
+*> ( 1 + ( n - 1 )*abs( INCY ) ).
+*> Before entry, the incremented array Y must contain the n
+*> element vector y.
+*> \endverbatim
+*>
+*> \param[in] INCY
+*> \verbatim
+*> INCY is INTEGER
+*> On entry, INCY specifies the increment for the elements of
+*> Y. INCY must not be zero.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension ( LDA, N )
+*> Before entry, the leading m by n part of the array A must
+*> contain the matrix of coefficients. On exit, A is
+*> overwritten by the updated matrix.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> On entry, LDA specifies the first dimension of A as declared
+*> in the calling (sub) program. LDA must be at least
+*> max( 1, m ).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16_blas_level2
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Level 2 Blas routine.
+*>
+*> -- Written on 22-October-1986.
+*> Jack Dongarra, Argonne National Lab.
+*> Jeremy Du Croz, Nag Central Office.
+*> Sven Hammarling, Nag Central Office.
+*> Richard Hanson, Sandia National Labs.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE zgerc(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+*
+* -- Reference BLAS level2 routine (version 3.7.0) --
+* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ COMPLEX*16 ALPHA
+ INTEGER INCX,INCY,LDA,M,N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A(lda,*),X(*),Y(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ parameter(zero= (0.0d+0,0.0d+0))
+* ..
+* .. Local Scalars ..
+ COMPLEX*16 TEMP
+ INTEGER I,INFO,IX,J,JY,KX
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg,max
+* ..
+*
+* Test the input parameters.
+*
+ info = 0
+ IF (m.LT.0) THEN
+ info = 1
+ ELSE IF (n.LT.0) THEN
+ info = 2
+ ELSE IF (incx.EQ.0) THEN
+ info = 5
+ ELSE IF (incy.EQ.0) THEN
+ info = 7
+ ELSE IF (lda.LT.max(1,m)) THEN
+ info = 9
+ END IF
+ IF (info.NE.0) THEN
+ CALL xerbla('ZGERC ',info)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((m.EQ.0) .OR. (n.EQ.0) .OR. (alpha.EQ.zero)) RETURN
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (incy.GT.0) THEN
+ jy = 1
+ ELSE
+ jy = 1 - (n-1)*incy
+ END IF
+ IF (incx.EQ.1) THEN
+ DO 20 j = 1,n
+ IF (y(jy).NE.zero) THEN
+ temp = alpha*dconjg(y(jy))
+ DO 10 i = 1,m
+ a(i,j) = a(i,j) + x(i)*temp
+ 10 CONTINUE
+ END IF
+ jy = jy + incy
+ 20 CONTINUE
+ ELSE
+ IF (incx.GT.0) THEN
+ kx = 1
+ ELSE
+ kx = 1 - (m-1)*incx
+ END IF
+ DO 40 j = 1,n
+ IF (y(jy).NE.zero) THEN
+ temp = alpha*dconjg(y(jy))
+ ix = kx
+ DO 30 i = 1,m
+ a(i,j) = a(i,j) + x(ix)*temp
+ ix = ix + incx
+ 30 CONTINUE
+ END IF
+ jy = jy + incy
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZGERC .
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b DISNAN tests input for NaN.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DISNAN + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* LOGICAL FUNCTION DISNAN( DIN )
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION, INTENT(IN) :: DIN
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
+*> otherwise. To be replaced by the Fortran 2003 intrinsic in the
+*> future.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DIN
+*> \verbatim
+*> DIN is DOUBLE PRECISION
+*> Input to test for NaN.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2017
+*
+*> \ingroup OTHERauxiliary
+*
+* =====================================================================
+ LOGICAL FUNCTION disnan( DIN )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2017
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION, INTENT(IN) :: DIN
+* ..
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL DLAISNAN
+ EXTERNAL dlaisnan
+* ..
+* .. Executable Statements ..
+ disnan = dlaisnan(din,din)
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ILAZLC scans a matrix for its last non-zero column.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ILAZLC + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* INTEGER FUNCTION ILAZLC( M, N, A, LDA )
+*
+* .. Scalar Arguments ..
+* INTEGER M, N, LDA
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ILAZLC scans A for its last non-zero column.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The m by n matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ INTEGER FUNCTION ilazlc( M, N, A, LDA )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, LDA
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ parameter( zero = (0.0d+0, 0.0d+0) )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( n.EQ.0 ) THEN
+ ilazlc = n
+ ELSE IF( a(1, n).NE.zero .OR. a(m, n).NE.zero ) THEN
+ ilazlc = n
+ ELSE
+* Now scan each column from the end, returning with the first non-zero.
+ DO ilazlc = n, 1, -1
+ DO i = 1, m
+ IF( a(i, ilazlc).NE.zero ) RETURN
+ END DO
+ END DO
+ END IF
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ILAZLR scans a matrix for its last non-zero row.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ILAZLR + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* INTEGER FUNCTION ILAZLR( M, N, A, LDA )
+*
+* .. Scalar Arguments ..
+* INTEGER M, N, LDA
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ILAZLR scans A for its last non-zero row.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix A.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix A.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The m by n matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,M).
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERauxiliary
+*
+* =====================================================================
+ INTEGER FUNCTION ilazlr( M, N, A, LDA )
+*
+* -- LAPACK auxiliary routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, LDA
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ parameter( zero = (0.0d+0, 0.0d+0) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( m.EQ.0 ) THEN
+ ilazlr = m
+ ELSE IF( a(m, 1).NE.zero .OR. a(m, n).NE.zero ) THEN
+ ilazlr = m
+ ELSE
+* Scan up each column tracking the last zero row seen.
+ ilazlr = 0
+ DO j = 1, n
+ i=m
+ DO WHILE((a(max(i,1),j).EQ.zero).AND.(i.GE.1))
+ i=i-1
+ ENDDO
+ ilazlr = max( ilazlr, i )
+ END DO
+ END IF
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b IPARMQ
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download IPARMQ + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
+*
+* .. Scalar Arguments ..
+* INTEGER IHI, ILO, ISPEC, LWORK, N
+* CHARACTER NAME*( * ), OPTS*( * )
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> This program sets problem and machine dependent parameters
+*> useful for xHSEQR and related subroutines for eigenvalue
+*> problems. It is called whenever
+*> IPARMQ is called with 12 <= ISPEC <= 16
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] ISPEC
+*> \verbatim
+*> ISPEC is INTEGER
+*> ISPEC specifies which tunable parameter IPARMQ should
+*> return.
+*>
+*> ISPEC=12: (INMIN) Matrices of order nmin or less
+*> are sent directly to xLAHQR, the implicit
+*> double shift QR algorithm. NMIN must be
+*> at least 11.
+*>
+*> ISPEC=13: (INWIN) Size of the deflation window.
+*> This is best set greater than or equal to
+*> the number of simultaneous shifts NS.
+*> Larger matrices benefit from larger deflation
+*> windows.
+*>
+*> ISPEC=14: (INIBL) Determines when to stop nibbling and
+*> invest in an (expensive) multi-shift QR sweep.
+*> If the aggressive early deflation subroutine
+*> finds LD converged eigenvalues from an order
+*> NW deflation window and LD.GT.(NW*NIBBLE)/100,
+*> then the next QR sweep is skipped and early
+*> deflation is applied immediately to the
+*> remaining active diagonal block. Setting
+*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
+*> multi-shift QR sweep whenever early deflation
+*> finds a converged eigenvalue. Setting
+*> IPARMQ(ISPEC=14) greater than or equal to 100
+*> prevents TTQRE from skipping a multi-shift
+*> QR sweep.
+*>
+*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in
+*> a multi-shift QR iteration.
+*>
+*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
+*> following meanings.
+*> 0: During the multi-shift QR/QZ sweep,
+*> blocked eigenvalue reordering, blocked
+*> Hessenberg-triangular reduction,
+*> reflections and/or rotations are not
+*> accumulated when updating the
+*> far-from-diagonal matrix entries.
+*> 1: During the multi-shift QR/QZ sweep,
+*> blocked eigenvalue reordering, blocked
+*> Hessenberg-triangular reduction,
+*> reflections and/or rotations are
+*> accumulated, and matrix-matrix
+*> multiplication is used to update the
+*> far-from-diagonal matrix entries.
+*> 2: During the multi-shift QR/QZ sweep,
+*> blocked eigenvalue reordering, blocked
+*> Hessenberg-triangular reduction,
+*> reflections and/or rotations are
+*> accumulated, and 2-by-2 block structure
+*> is exploited during matrix-matrix
+*> multiplies.
+*> (If xTRMM is slower than xGEMM, then
+*> IPARMQ(ISPEC=16)=1 may be more efficient than
+*> IPARMQ(ISPEC=16)=2 despite the greater level of
+*> arithmetic work implied by the latter choice.)
+*> \endverbatim
+*>
+*> \param[in] NAME
+*> \verbatim
+*> NAME is character string
+*> Name of the calling subroutine
+*> \endverbatim
+*>
+*> \param[in] OPTS
+*> \verbatim
+*> OPTS is character string
+*> This is a concatenation of the string arguments to
+*> TTQRE.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> N is the order of the Hessenberg matrix H.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*> It is assumed that H is already upper triangular
+*> in rows and columns 1:ILO-1 and IHI+1:N.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The amount of workspace available.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2017
+*
+*> \ingroup OTHERauxiliary
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> Little is known about how best to choose these parameters.
+*> It is possible to use different values of the parameters
+*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
+*>
+*> It is probably best to choose different parameters for
+*> different matrices and different parameters at different
+*> times during the iteration, but this has not been
+*> implemented --- yet.
+*>
+*>
+*> The best choices of most of the parameters depend
+*> in an ill-understood way on the relative execution
+*> rate of xLAQR3 and xLAQR5 and on the nature of each
+*> particular eigenvalue problem. Experiment may be the
+*> only practical way to determine which choices are most
+*> effective.
+*>
+*> Following is a list of default values supplied by IPARMQ.
+*> These defaults may be adjusted in order to attain better
+*> performance in any particular computational environment.
+*>
+*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
+*> Default: 75. (Must be at least 11.)
+*>
+*> IPARMQ(ISPEC=13) Recommended deflation window size.
+*> This depends on ILO, IHI and NS, the
+*> number of simultaneous shifts returned
+*> by IPARMQ(ISPEC=15). The default for
+*> (IHI-ILO+1).LE.500 is NS. The default
+*> for (IHI-ILO+1).GT.500 is 3*NS/2.
+*>
+*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.
+*>
+*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
+*> a multi-shift QR iteration.
+*>
+*> If IHI-ILO+1 is ...
+*>
+*> greater than ...but less ... the
+*> or equal to ... than default is
+*>
+*> 0 30 NS = 2+
+*> 30 60 NS = 4+
+*> 60 150 NS = 10
+*> 150 590 NS = **
+*> 590 3000 NS = 64
+*> 3000 6000 NS = 128
+*> 6000 infinity NS = 256
+*>
+*> (+) By default matrices of this order are
+*> passed to the implicit double shift routine
+*> xLAHQR. See IPARMQ(ISPEC=12) above. These
+*> values of NS are used only in case of a rare
+*> xLAHQR failure.
+*>
+*> (**) The asterisks (**) indicate an ad-hoc
+*> function increasing from 10 to 64.
+*>
+*> IPARMQ(ISPEC=16) Select structured matrix multiply.
+*> (See ISPEC=16 above for details.)
+*> Default: 3.
+*> \endverbatim
+*>
+* =====================================================================
+ INTEGER FUNCTION iparmq( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2017
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, ISPEC, LWORK, N
+ CHARACTER NAME*( * ), OPTS*( * )
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22
+ parameter( inmin = 12, inwin = 13, inibl = 14,
+ $ ishfts = 15, iacc22 = 16 )
+ INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
+ parameter( nmin = 75, k22min = 14, kacmin = 14,
+ $ nibble = 14, knwswp = 500 )
+ REAL TWO
+ parameter( two = 2.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER NH, NS
+ INTEGER I, IC, IZ
+ CHARACTER SUBNAM*6
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC log, max, mod, nint, real
+* ..
+* .. Executable Statements ..
+ IF( ( ispec.EQ.ishfts ) .OR. ( ispec.EQ.inwin ) .OR.
+ $ ( ispec.EQ.iacc22 ) ) THEN
+*
+* ==== Set the number simultaneous shifts ====
+*
+ nh = ihi - ilo + 1
+ ns = 2
+ IF( nh.GE.30 )
+ $ ns = 4
+ IF( nh.GE.60 )
+ $ ns = 10
+ IF( nh.GE.150 )
+ $ ns = max( 10, nh / nint( log( REAL( NH ) ) / log( TWO ) ) )
+ IF( nh.GE.590 )
+ $ ns = 64
+ IF( nh.GE.3000 )
+ $ ns = 128
+ IF( nh.GE.6000 )
+ $ ns = 256
+ ns = max( 2, ns-mod( ns, 2 ) )
+ END IF
+*
+ IF( ispec.EQ.inmin ) THEN
+*
+*
+* ===== Matrices of order smaller than NMIN get sent
+* . to xLAHQR, the classic double shift algorithm.
+* . This must be at least 11. ====
+*
+ iparmq = nmin
+*
+ ELSE IF( ispec.EQ.inibl ) THEN
+*
+* ==== INIBL: skip a multi-shift qr iteration and
+* . whenever aggressive early deflation finds
+* . at least (NIBBLE*(window size)/100) deflations. ====
+*
+ iparmq = nibble
+*
+ ELSE IF( ispec.EQ.ishfts ) THEN
+*
+* ==== NSHFTS: The number of simultaneous shifts =====
+*
+ iparmq = ns
+*
+ ELSE IF( ispec.EQ.inwin ) THEN
+*
+* ==== NW: deflation window size. ====
+*
+ IF( nh.LE.knwswp ) THEN
+ iparmq = ns
+ ELSE
+ iparmq = 3*ns / 2
+ END IF
+*
+ ELSE IF( ispec.EQ.iacc22 ) THEN
+*
+* ==== IACC22: Whether to accumulate reflections
+* . before updating the far-from-diagonal elements
+* . and whether to use 2-by-2 block structure while
+* . doing it. A small amount of work could be saved
+* . by making this choice dependent also upon the
+* . NH=IHI-ILO+1.
+*
+*
+* Convert NAME to upper case if the first character is lower case.
+*
+ iparmq = 0
+ subnam = name
+ ic = ichar( subnam( 1: 1 ) )
+ iz = ichar( 'Z' )
+ IF( iz.EQ.90 .OR. iz.EQ.122 ) THEN
+*
+* ASCII character set
+*
+ IF( ic.GE.97 .AND. ic.LE.122 ) THEN
+ subnam( 1: 1 ) = char( ic-32 )
+ DO i = 2, 6
+ ic = ichar( subnam( i: i ) )
+ IF( ic.GE.97 .AND. ic.LE.122 )
+ $ subnam( i: i ) = char( ic-32 )
+ END DO
+ END IF
+*
+ ELSE IF( iz.EQ.233 .OR. iz.EQ.169 ) THEN
+*
+* EBCDIC character set
+*
+ IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
+ $ ( ic.GE.145 .AND. ic.LE.153 ) .OR.
+ $ ( ic.GE.162 .AND. ic.LE.169 ) ) THEN
+ subnam( 1: 1 ) = char( ic+64 )
+ DO i = 2, 6
+ ic = ichar( subnam( i: i ) )
+ IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
+ $ ( ic.GE.145 .AND. ic.LE.153 ) .OR.
+ $ ( ic.GE.162 .AND. ic.LE.169 ) )subnam( i:
+ $ i ) = char( ic+64 )
+ END DO
+ END IF
+*
+ ELSE IF( iz.EQ.218 .OR. iz.EQ.250 ) THEN
+*
+* Prime machines: ASCII+128
+*
+ IF( ic.GE.225 .AND. ic.LE.250 ) THEN
+ subnam( 1: 1 ) = char( ic-32 )
+ DO i = 2, 6
+ ic = ichar( subnam( i: i ) )
+ IF( ic.GE.225 .AND. ic.LE.250 )
+ $ subnam( i: i ) = char( ic-32 )
+ END DO
+ END IF
+ END IF
+*
+ IF( subnam( 2:6 ).EQ.'GGHRD' .OR.
+ $ subnam( 2:6 ).EQ.'GGHD3' ) THEN
+ iparmq = 1
+ IF( nh.GE.k22min )
+ $ iparmq = 2
+ ELSE IF ( subnam( 4:6 ).EQ.'EXC' ) THEN
+ IF( nh.GE.kacmin )
+ $ iparmq = 1
+ IF( nh.GE.k22min )
+ $ iparmq = 2
+ ELSE IF ( subnam( 2:6 ).EQ.'HSEQR' .OR.
+ $ subnam( 2:5 ).EQ.'LAQR' ) THEN
+ IF( ns.GE.kacmin )
+ $ iparmq = 1
+ IF( ns.GE.k22min )
+ $ iparmq = 2
+ END IF
+*
+ ELSE
+* ===== invalid value of ispec =====
+ iparmq = -1
+*
+ END IF
+*
+* ==== End of IPARMQ ====
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZUNMHR
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNMHR + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
+* LDC, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZUNMHR overwrites the general complex M-by-N matrix C with
+*>
+*> SIDE = 'L' SIDE = 'R'
+*> TRANS = 'N': Q * C C * Q
+*> TRANS = 'C': Q**H * C C * Q**H
+*>
+*> where Q is a complex unitary matrix of order nq, with nq = m if
+*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*> IHI-ILO elementary reflectors, as returned by ZGEHRD:
+*>
+*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**H from the Left;
+*> = 'R': apply Q or Q**H from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': apply Q (No transpose)
+*> = 'C': apply Q**H (Conjugate transpose)
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] ILO
+*> \verbatim
+*> ILO is INTEGER
+*> \endverbatim
+*>
+*> \param[in] IHI
+*> \verbatim
+*> IHI is INTEGER
+*>
+*> ILO and IHI must have the same values as in the previous call
+*> of ZGEHRD. Q is equal to the unit matrix except in the
+*> submatrix Q(ilo+1:ihi,ilo+1:ihi).
+*> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
+*> ILO = 1 and IHI = 0, if M = 0;
+*> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
+*> ILO = 1 and IHI = 0, if N = 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension
+*> (LDA,M) if SIDE = 'L'
+*> (LDA,N) if SIDE = 'R'
+*> The vectors which define the elementary reflectors, as
+*> returned by ZGEHRD.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension
+*> (M-1) if SIDE = 'L'
+*> (N-1) if SIDE = 'R'
+*> TAU(i) must contain the scalar factor of the elementary
+*> reflector H(i), as returned by ZGEHRD.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> If SIDE = 'L', LWORK >= max(1,N);
+*> if SIDE = 'R', LWORK >= max(1,M).
+*> For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*> blocksize.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE zunmhr( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
+ $ LDC, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), C( ldc, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY
+ INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL lsame, ilaenv
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zunmqr
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC max, min
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+ nh = ihi - ilo
+ left = lsame( side, 'L' )
+ lquery = ( lwork.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( left ) THEN
+ nq = m
+ nw = n
+ ELSE
+ nq = n
+ nw = m
+ END IF
+ IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
+ info = -1
+ ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
+ $ THEN
+ info = -2
+ ELSE IF( m.LT.0 ) THEN
+ info = -3
+ ELSE IF( n.LT.0 ) THEN
+ info = -4
+ ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, nq ) ) THEN
+ info = -5
+ ELSE IF( ihi.LT.min( ilo, nq ) .OR. ihi.GT.nq ) THEN
+ info = -6
+ ELSE IF( lda.LT.max( 1, nq ) ) THEN
+ info = -8
+ ELSE IF( ldc.LT.max( 1, m ) ) THEN
+ info = -11
+ ELSE IF( lwork.LT.max( 1, nw ) .AND. .NOT.lquery ) THEN
+ info = -13
+ END IF
+*
+ IF( info.EQ.0 ) THEN
+ IF( left ) THEN
+ nb = ilaenv( 1, 'ZUNMQR', side // trans, nh, n, nh, -1 )
+ ELSE
+ nb = ilaenv( 1, 'ZUNMQR', side // trans, m, nh, nh, -1 )
+ END IF
+ lwkopt = max( 1, nw )*nb
+ work( 1 ) = lwkopt
+ END IF
+*
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZUNMHR', -info )
+ RETURN
+ ELSE IF( lquery ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( m.EQ.0 .OR. n.EQ.0 .OR. nh.EQ.0 ) THEN
+ work( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( left ) THEN
+ mi = nh
+ ni = n
+ i1 = ilo + 1
+ i2 = 1
+ ELSE
+ mi = m
+ ni = nh
+ i1 = 1
+ i2 = ilo + 1
+ END IF
+*
+ CALL zunmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,
+ $ tau( ilo ), c( i1, i2 ), ldc, work, lwork, iinfo )
+*
+ work( 1 ) = lwkopt
+ RETURN
+*
+* End of ZUNMHR
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZTREVC3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZTREVC3 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+* $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
+*
+* .. Scalar Arguments ..
+* CHARACTER HOWMNY, SIDE
+* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N
+* ..
+* .. Array Arguments ..
+* LOGICAL SELECT( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+* $ WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZTREVC3 computes some or all of the right and/or left eigenvectors of
+*> a complex upper triangular matrix T.
+*> Matrices of this type are produced by the Schur factorization of
+*> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
+*>
+*> The right eigenvector x and the left eigenvector y of T corresponding
+*> to an eigenvalue w are defined by:
+*>
+*> T*x = w*x, (y**H)*T = w*(y**H)
+*>
+*> where y**H denotes the conjugate transpose of the vector y.
+*> The eigenvalues are not input to this routine, but are read directly
+*> from the diagonal of T.
+*>
+*> This routine returns the matrices X and/or Y of right and left
+*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
+*> input matrix. If Q is the unitary factor that reduces a matrix A to
+*> Schur form T, then Q*X and Q*Y are the matrices of right and left
+*> eigenvectors of A.
+*>
+*> This uses a Level 3 BLAS version of the back transformation.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'R': compute right eigenvectors only;
+*> = 'L': compute left eigenvectors only;
+*> = 'B': compute both right and left eigenvectors.
+*> \endverbatim
+*>
+*> \param[in] HOWMNY
+*> \verbatim
+*> HOWMNY is CHARACTER*1
+*> = 'A': compute all right and/or left eigenvectors;
+*> = 'B': compute all right and/or left eigenvectors,
+*> backtransformed using the matrices supplied in
+*> VR and/or VL;
+*> = 'S': compute selected right and/or left eigenvectors,
+*> as indicated by the logical array SELECT.
+*> \endverbatim
+*>
+*> \param[in] SELECT
+*> \verbatim
+*> SELECT is LOGICAL array, dimension (N)
+*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be
+*> computed.
+*> The eigenvector corresponding to the j-th eigenvalue is
+*> computed if SELECT(j) = .TRUE..
+*> Not referenced if HOWMNY = 'A' or 'B'.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix T. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] T
+*> \verbatim
+*> T is COMPLEX*16 array, dimension (LDT,N)
+*> The upper triangular matrix T. T is modified, but restored
+*> on exit.
+*> \endverbatim
+*>
+*> \param[in] LDT
+*> \verbatim
+*> LDT is INTEGER
+*> The leading dimension of the array T. LDT >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] VL
+*> \verbatim
+*> VL is COMPLEX*16 array, dimension (LDVL,MM)
+*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+*> contain an N-by-N matrix Q (usually the unitary matrix Q of
+*> Schur vectors returned by ZHSEQR).
+*> On exit, if SIDE = 'L' or 'B', VL contains:
+*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
+*> if HOWMNY = 'B', the matrix Q*Y;
+*> if HOWMNY = 'S', the left eigenvectors of T specified by
+*> SELECT, stored consecutively in the columns
+*> of VL, in the same order as their
+*> eigenvalues.
+*> Not referenced if SIDE = 'R'.
+*> \endverbatim
+*>
+*> \param[in] LDVL
+*> \verbatim
+*> LDVL is INTEGER
+*> The leading dimension of the array VL.
+*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N.
+*> \endverbatim
+*>
+*> \param[in,out] VR
+*> \verbatim
+*> VR is COMPLEX*16 array, dimension (LDVR,MM)
+*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+*> contain an N-by-N matrix Q (usually the unitary matrix Q of
+*> Schur vectors returned by ZHSEQR).
+*> On exit, if SIDE = 'R' or 'B', VR contains:
+*> if HOWMNY = 'A', the matrix X of right eigenvectors of T;
+*> if HOWMNY = 'B', the matrix Q*X;
+*> if HOWMNY = 'S', the right eigenvectors of T specified by
+*> SELECT, stored consecutively in the columns
+*> of VR, in the same order as their
+*> eigenvalues.
+*> Not referenced if SIDE = 'L'.
+*> \endverbatim
+*>
+*> \param[in] LDVR
+*> \verbatim
+*> LDVR is INTEGER
+*> The leading dimension of the array VR.
+*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N.
+*> \endverbatim
+*>
+*> \param[in] MM
+*> \verbatim
+*> MM is INTEGER
+*> The number of columns in the arrays VL and/or VR. MM >= M.
+*> \endverbatim
+*>
+*> \param[out] M
+*> \verbatim
+*> M is INTEGER
+*> The number of columns in the arrays VL and/or VR actually
+*> used to store the eigenvectors.
+*> If HOWMNY = 'A' or 'B', M is set to N.
+*> Each selected eigenvector occupies one column.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of array WORK. LWORK >= max(1,2*N).
+*> For optimum performance, LWORK >= N + 2*N*NB, where NB is
+*> the optimal blocksize.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (LRWORK)
+*> \endverbatim
+*>
+*> \param[in] LRWORK
+*> \verbatim
+*> LRWORK is INTEGER
+*> The dimension of array RWORK. LRWORK >= max(1,N).
+*>
+*> If LRWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the RWORK array, returns
+*> this value as the first entry of the RWORK array, and no error
+*> message related to LRWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2017
+*
+* @precisions fortran z -> c
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The algorithm used in this program is basically backward (forward)
+*> substitution, with scaling to make the the code robust against
+*> possible overflow.
+*>
+*> Each eigenvector is normalized so that the element of largest
+*> magnitude has magnitude 1; here the magnitude of a complex number
+*> (x,y) is taken to be |x| + |y|.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE ztrevc3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+ $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
+ IMPLICIT NONE
+*
+* -- LAPACK computational routine (version 3.8.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2017
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, SIDE
+ INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 T( ldt, * ), VL( ldvl, * ), VR( ldvr, * ),
+ $ work( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ parameter( zero = 0.0d+0, one = 1.0d+0 )
+ COMPLEX*16 CZERO, CONE
+ parameter( czero = ( 0.0d+0, 0.0d+0 ),
+ $ cone = ( 1.0d+0, 0.0d+0 ) )
+ INTEGER NBMIN, NBMAX
+ parameter( nbmin = 8, nbmax = 128 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV
+ INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB
+ DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
+ COMPLEX*16 CDUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV, IZAMAX
+ DOUBLE PRECISION DLAMCH, DZASUM
+ EXTERNAL lsame, ilaenv, izamax, dlamch, dzasum
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zcopy, zdscal, zgemv, zlatrs,
+ $ zgemm, dlabad, zlaset, zlacpy
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC abs, dble, dcmplx, conjg, aimag, max
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ cabs1( cdum ) = abs( dble( cdum ) ) + abs( aimag( cdum ) )
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ bothv = lsame( side, 'B' )
+ rightv = lsame( side, 'R' ) .OR. bothv
+ leftv = lsame( side, 'L' ) .OR. bothv
+*
+ allv = lsame( howmny, 'A' )
+ over = lsame( howmny, 'B' )
+ somev = lsame( howmny, 'S' )
+*
+* Set M to the number of columns required to store the selected
+* eigenvectors.
+*
+ IF( somev ) THEN
+ m = 0
+ DO 10 j = 1, n
+ IF( SELECT( j ) )
+ $ m = m + 1
+ 10 CONTINUE
+ ELSE
+ m = n
+ END IF
+*
+ info = 0
+ nb = ilaenv( 1, 'ZTREVC', side // howmny, n, -1, -1, -1 )
+ maxwrk = n + 2*n*nb
+ work(1) = maxwrk
+ rwork(1) = n
+ lquery = ( lwork.EQ.-1 .OR. lrwork.EQ.-1 )
+ IF( .NOT.rightv .AND. .NOT.leftv ) THEN
+ info = -1
+ ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
+ info = -2
+ ELSE IF( n.LT.0 ) THEN
+ info = -4
+ ELSE IF( ldt.LT.max( 1, n ) ) THEN
+ info = -6
+ ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
+ info = -8
+ ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
+ info = -10
+ ELSE IF( mm.LT.m ) THEN
+ info = -11
+ ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery ) THEN
+ info = -14
+ ELSE IF ( lrwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
+ info = -16
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZTREVC3', -info )
+ RETURN
+ ELSE IF( lquery ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( n.EQ.0 )
+ $ RETURN
+*
+* Use blocked version of back-transformation if sufficient workspace.
+* Zero-out the workspace to avoid potential NaN propagation.
+*
+ IF( over .AND. lwork .GE. n + 2*n*nbmin ) THEN
+ nb = (lwork - n) / (2*n)
+ nb = min( nb, nbmax )
+ CALL zlaset( 'F', n, 1+2*nb, czero, czero, work, n )
+ ELSE
+ nb = 1
+ END IF
+*
+* Set the constants to control overflow.
+*
+ unfl = dlamch( 'Safe minimum' )
+ ovfl = one / unfl
+ CALL dlabad( unfl, ovfl )
+ ulp = dlamch( 'Precision' )
+ smlnum = unfl*( n / ulp )
+*
+* Store the diagonal elements of T in working array WORK.
+*
+ DO 20 i = 1, n
+ work( i ) = t( i, i )
+ 20 CONTINUE
+*
+* Compute 1-norm of each column of strictly upper triangular
+* part of T to control overflow in triangular solver.
+*
+ rwork( 1 ) = zero
+ DO 30 j = 2, n
+ rwork( j ) = dzasum( j-1, t( 1, j ), 1 )
+ 30 CONTINUE
+*
+ IF( rightv ) THEN
+*
+* ============================================================
+* Compute right eigenvectors.
+*
+* IV is index of column in current block.
+* Non-blocked version always uses IV=NB=1;
+* blocked version starts with IV=NB, goes down to 1.
+* (Note the "0-th" column is used to store the original diagonal.)
+ iv = nb
+ is = m
+ DO 80 ki = n, 1, -1
+ IF( somev ) THEN
+ IF( .NOT.SELECT( ki ) )
+ $ GO TO 80
+ END IF
+ smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
+*
+* --------------------------------------------------------
+* Complex right eigenvector
+*
+ work( ki + iv*n ) = cone
+*
+* Form right-hand side.
+*
+ DO 40 k = 1, ki - 1
+ work( k + iv*n ) = -t( k, ki )
+ 40 CONTINUE
+*
+* Solve upper triangular system:
+* [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK.
+*
+ DO 50 k = 1, ki - 1
+ t( k, k ) = t( k, k ) - t( ki, ki )
+ IF( cabs1( t( k, k ) ).LT.smin )
+ $ t( k, k ) = smin
+ 50 CONTINUE
+*
+ IF( ki.GT.1 ) THEN
+ CALL zlatrs( 'Upper', 'No transpose', 'Non-unit', 'Y',
+ $ ki-1, t, ldt, work( 1 + iv*n ), scale,
+ $ rwork, info )
+ work( ki + iv*n ) = scale
+ END IF
+*
+* Copy the vector x or Q*x to VR and normalize.
+*
+ IF( .NOT.over ) THEN
+* ------------------------------
+* no back-transform: copy x to VR and normalize.
+ CALL zcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 )
+*
+ ii = izamax( ki, vr( 1, is ), 1 )
+ remax = one / cabs1( vr( ii, is ) )
+ CALL zdscal( ki, remax, vr( 1, is ), 1 )
+*
+ DO 60 k = ki + 1, n
+ vr( k, is ) = czero
+ 60 CONTINUE
+*
+ ELSE IF( nb.EQ.1 ) THEN
+* ------------------------------
+* version 1: back-transform each vector with GEMV, Q*x.
+ IF( ki.GT.1 )
+ $ CALL zgemv( 'N', n, ki-1, cone, vr, ldvr,
+ $ work( 1 + iv*n ), 1, dcmplx( scale ),
+ $ vr( 1, ki ), 1 )
+*
+ ii = izamax( n, vr( 1, ki ), 1 )
+ remax = one / cabs1( vr( ii, ki ) )
+ CALL zdscal( n, remax, vr( 1, ki ), 1 )
+*
+ ELSE
+* ------------------------------
+* version 2: back-transform block of vectors with GEMM
+* zero out below vector
+ DO k = ki + 1, n
+ work( k + iv*n ) = czero
+ END DO
+*
+* Columns IV:NB of work are valid vectors.
+* When the number of vectors stored reaches NB,
+* or if this was last vector, do the GEMM
+ IF( (iv.EQ.1) .OR. (ki.EQ.1) ) THEN
+ CALL zgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,
+ $ vr, ldvr,
+ $ work( 1 + (iv)*n ), n,
+ $ czero,
+ $ work( 1 + (nb+iv)*n ), n )
+* normalize vectors
+ DO k = iv, nb
+ ii = izamax( n, work( 1 + (nb+k)*n ), 1 )
+ remax = one / cabs1( work( ii + (nb+k)*n ) )
+ CALL zdscal( n, remax, work( 1 + (nb+k)*n ), 1 )
+ END DO
+ CALL zlacpy( 'F', n, nb-iv+1,
+ $ work( 1 + (nb+iv)*n ), n,
+ $ vr( 1, ki ), ldvr )
+ iv = nb
+ ELSE
+ iv = iv - 1
+ END IF
+ END IF
+*
+* Restore the original diagonal elements of T.
+*
+ DO 70 k = 1, ki - 1
+ t( k, k ) = work( k )
+ 70 CONTINUE
+*
+ is = is - 1
+ 80 CONTINUE
+ END IF
+*
+ IF( leftv ) THEN
+*
+* ============================================================
+* Compute left eigenvectors.
+*
+* IV is index of column in current block.
+* Non-blocked version always uses IV=1;
+* blocked version starts with IV=1, goes up to NB.
+* (Note the "0-th" column is used to store the original diagonal.)
+ iv = 1
+ is = 1
+ DO 130 ki = 1, n
+*
+ IF( somev ) THEN
+ IF( .NOT.SELECT( ki ) )
+ $ GO TO 130
+ END IF
+ smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
+*
+* --------------------------------------------------------
+* Complex left eigenvector
+*
+ work( ki + iv*n ) = cone
+*
+* Form right-hand side.
+*
+ DO 90 k = ki + 1, n
+ work( k + iv*n ) = -conjg( t( ki, k ) )
+ 90 CONTINUE
+*
+* Solve conjugate-transposed triangular system:
+* [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK.
+*
+ DO 100 k = ki + 1, n
+ t( k, k ) = t( k, k ) - t( ki, ki )
+ IF( cabs1( t( k, k ) ).LT.smin )
+ $ t( k, k ) = smin
+ 100 CONTINUE
+*
+ IF( ki.LT.n ) THEN
+ CALL zlatrs( 'Upper', 'Conjugate transpose', 'Non-unit',
+ $ 'Y', n-ki, t( ki+1, ki+1 ), ldt,
+ $ work( ki+1 + iv*n ), scale, rwork, info )
+ work( ki + iv*n ) = scale
+ END IF
+*
+* Copy the vector x or Q*x to VL and normalize.
+*
+ IF( .NOT.over ) THEN
+* ------------------------------
+* no back-transform: copy x to VL and normalize.
+ CALL zcopy( n-ki+1, work( ki + iv*n ), 1, vl(ki,is), 1 )
+*
+ ii = izamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
+ remax = one / cabs1( vl( ii, is ) )
+ CALL zdscal( n-ki+1, remax, vl( ki, is ), 1 )
+*
+ DO 110 k = 1, ki - 1
+ vl( k, is ) = czero
+ 110 CONTINUE
+*
+ ELSE IF( nb.EQ.1 ) THEN
+* ------------------------------
+* version 1: back-transform each vector with GEMV, Q*x.
+ IF( ki.LT.n )
+ $ CALL zgemv( 'N', n, n-ki, cone, vl( 1, ki+1 ), ldvl,
+ $ work( ki+1 + iv*n ), 1, dcmplx( scale ),
+ $ vl( 1, ki ), 1 )
+*
+ ii = izamax( n, vl( 1, ki ), 1 )
+ remax = one / cabs1( vl( ii, ki ) )
+ CALL zdscal( n, remax, vl( 1, ki ), 1 )
+*
+ ELSE
+* ------------------------------
+* version 2: back-transform block of vectors with GEMM
+* zero out above vector
+* could go from KI-NV+1 to KI-1
+ DO k = 1, ki - 1
+ work( k + iv*n ) = czero
+ END DO
+*
+* Columns 1:IV of work are valid vectors.
+* When the number of vectors stored reaches NB,
+* or if this was last vector, do the GEMM
+ IF( (iv.EQ.nb) .OR. (ki.EQ.n) ) THEN
+ CALL zgemm( 'N', 'N', n, iv, n-ki+iv, cone,
+ $ vl( 1, ki-iv+1 ), ldvl,
+ $ work( ki-iv+1 + (1)*n ), n,
+ $ czero,
+ $ work( 1 + (nb+1)*n ), n )
+* normalize vectors
+ DO k = 1, iv
+ ii = izamax( n, work( 1 + (nb+k)*n ), 1 )
+ remax = one / cabs1( work( ii + (nb+k)*n ) )
+ CALL zdscal( n, remax, work( 1 + (nb+k)*n ), 1 )
+ END DO
+ CALL zlacpy( 'F', n, iv,
+ $ work( 1 + (nb+1)*n ), n,
+ $ vl( 1, ki-iv+1 ), ldvl )
+ iv = 1
+ ELSE
+ iv = iv + 1
+ END IF
+ END IF
+*
+* Restore the original diagonal elements of T.
+*
+ DO 120 k = ki + 1, n
+ t( k, k ) = work( k )
+ 120 CONTINUE
+*
+ is = is + 1
+ 130 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZTREVC3
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLAISNAN + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
+*
+* .. Scalar Arguments ..
+* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> This routine is not for general use. It exists solely to avoid
+*> over-optimization in DISNAN.
+*>
+*> DLAISNAN checks for NaNs by comparing its two arguments for
+*> inequality. NaN is the only floating-point value where NaN != NaN
+*> returns .TRUE. To check for NaNs, pass the same variable as both
+*> arguments.
+*>
+*> A compiler must assume that the two arguments are
+*> not the same variable, and the test will not be optimized away.
+*> Interprocedural or whole-program optimization may delete this
+*> test. The ISNAN functions will be replaced by the correct
+*> Fortran 03 intrinsic once the intrinsic is widely available.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DIN1
+*> \verbatim
+*> DIN1 is DOUBLE PRECISION
+*> \endverbatim
+*>
+*> \param[in] DIN2
+*> \verbatim
+*> DIN2 is DOUBLE PRECISION
+*> Two numbers to compare for inequality.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date June 2017
+*
+*> \ingroup OTHERauxiliary
+*
+* =====================================================================
+ LOGICAL FUNCTION dlaisnan( DIN1, DIN2 )
+*
+* -- LAPACK auxiliary routine (version 3.7.1) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* June 2017
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
+* ..
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+ dlaisnan = (din1.NE.din2)
+ RETURN
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZUNMQR
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNMQR + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZUNMQR overwrites the general complex M-by-N matrix C with
+*>
+*> SIDE = 'L' SIDE = 'R'
+*> TRANS = 'N': Q * C C * Q
+*> TRANS = 'C': Q**H * C C * Q**H
+*>
+*> where Q is a complex unitary matrix defined as the product of k
+*> elementary reflectors
+*>
+*> Q = H(1) H(2) . . . H(k)
+*>
+*> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
+*> if SIDE = 'R'.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**H from the Left;
+*> = 'R': apply Q or Q**H from the Right.
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': No transpose, apply Q;
+*> = 'C': Conjugate transpose, apply Q**H.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> If SIDE = 'L', M >= K >= 0;
+*> if SIDE = 'R', N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,K)
+*> The i-th column must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> ZGEQRF in the first k columns of its array argument A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (K)
+*> TAU(i) must contain the scalar factor of the elementary
+*> reflector H(i), as returned by ZGEQRF.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the M-by-N matrix C.
+*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> If SIDE = 'L', LWORK >= max(1,N);
+*> if SIDE = 'R', LWORK >= max(1,M).
+*> For good performance, LWORK should generally be larger.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE zunmqr( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), C( ldc, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT, TSIZE
+ parameter( nbmax = 64, ldt = nbmax+1,
+ $ tsize = ldt*nbmax )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
+ $ lwkopt, mi, nb, nbmin, ni, nq, nw
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL lsame, ilaenv
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zlarfb, zlarft, zunm2r
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC max, min
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+ left = lsame( side, 'L' )
+ notran = lsame( trans, 'N' )
+ lquery = ( lwork.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( left ) THEN
+ nq = m
+ nw = n
+ ELSE
+ nq = n
+ nw = m
+ END IF
+ IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
+ info = -1
+ ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
+ info = -2
+ ELSE IF( m.LT.0 ) THEN
+ info = -3
+ ELSE IF( n.LT.0 ) THEN
+ info = -4
+ ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
+ info = -5
+ ELSE IF( lda.LT.max( 1, nq ) ) THEN
+ info = -7
+ ELSE IF( ldc.LT.max( 1, m ) ) THEN
+ info = -10
+ ELSE IF( lwork.LT.max( 1, nw ) .AND. .NOT.lquery ) THEN
+ info = -12
+ END IF
+*
+ IF( info.EQ.0 ) THEN
+*
+* Compute the workspace requirements
+*
+ nb = min( nbmax, ilaenv( 1, 'ZUNMQR', side // trans, m, n, k,
+ $ -1 ) )
+ lwkopt = max( 1, nw )*nb + tsize
+ work( 1 ) = lwkopt
+ END IF
+*
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZUNMQR', -info )
+ RETURN
+ ELSE IF( lquery ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) THEN
+ work( 1 ) = 1
+ RETURN
+ END IF
+*
+ nbmin = 2
+ ldwork = nw
+ IF( nb.GT.1 .AND. nb.LT.k ) THEN
+ IF( lwork.LT.nw*nb+tsize ) THEN
+ nb = (lwork-tsize) / ldwork
+ nbmin = max( 2, ilaenv( 2, 'ZUNMQR', side // trans, m, n, k,
+ $ -1 ) )
+ END IF
+ END IF
+*
+ IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
+*
+* Use unblocked code
+*
+ CALL zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,
+ $ iinfo )
+ ELSE
+*
+* Use blocked code
+*
+ iwt = 1 + nw*nb
+ IF( ( left .AND. .NOT.notran ) .OR.
+ $ ( .NOT.left .AND. notran ) ) THEN
+ i1 = 1
+ i2 = k
+ i3 = nb
+ ELSE
+ i1 = ( ( k-1 ) / nb )*nb + 1
+ i2 = 1
+ i3 = -nb
+ END IF
+*
+ IF( left ) THEN
+ ni = n
+ jc = 1
+ ELSE
+ mi = m
+ ic = 1
+ END IF
+*
+ DO 10 i = i1, i2, i3
+ ib = min( nb, k-i+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL zlarft( 'Forward', 'Columnwise', nq-i+1, ib, a( i, i ),
+ $ lda, tau( i ), work( iwt ), ldt )
+ IF( left ) THEN
+*
+* H or H**H is applied to C(i:m,1:n)
+*
+ mi = m - i + 1
+ ic = i
+ ELSE
+*
+* H or H**H is applied to C(1:m,i:n)
+*
+ ni = n - i + 1
+ jc = i
+ END IF
+*
+* Apply H or H**H
+*
+ CALL zlarfb( side, trans, 'Forward', 'Columnwise', mi, ni,
+ $ ib, a( i, i ), lda, work( iwt ), ldt,
+ $ c( ic, jc ), ldc, work, ldwork )
+ 10 CONTINUE
+ END IF
+ work( 1 ) = lwkopt
+ RETURN
+*
+* End of ZUNMQR
+*
+ END
+C
+C=======================================================================
+C
+*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNM2R + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
+*> [TXT]
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+* WORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER SIDE, TRANS
+* INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZUNM2R overwrites the general complex m-by-n matrix C with
+*>
+*> Q * C if SIDE = 'L' and TRANS = 'N', or
+*>
+*> Q**H* C if SIDE = 'L' and TRANS = 'C', or
+*>
+*> C * Q if SIDE = 'R' and TRANS = 'N', or
+*>
+*> C * Q**H if SIDE = 'R' and TRANS = 'C',
+*>
+*> where Q is a complex unitary matrix defined as the product of k
+*> elementary reflectors
+*>
+*> Q = H(1) H(2) . . . H(k)
+*>
+*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
+*> if SIDE = 'R'.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] SIDE
+*> \verbatim
+*> SIDE is CHARACTER*1
+*> = 'L': apply Q or Q**H from the Left
+*> = 'R': apply Q or Q**H from the Right
+*> \endverbatim
+*>
+*> \param[in] TRANS
+*> \verbatim
+*> TRANS is CHARACTER*1
+*> = 'N': apply Q (No transpose)
+*> = 'C': apply Q**H (Conjugate transpose)
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows of the matrix C. M >= 0.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns of the matrix C. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] K
+*> \verbatim
+*> K is INTEGER
+*> The number of elementary reflectors whose product defines
+*> the matrix Q.
+*> If SIDE = 'L', M >= K >= 0;
+*> if SIDE = 'R', N >= K >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,K)
+*> The i-th column must contain the vector which defines the
+*> elementary reflector H(i), for i = 1,2,...,k, as returned by
+*> ZGEQRF in the first k columns of its array argument A.
+*> A is modified by the routine but restored on exit.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A.
+*> If SIDE = 'L', LDA >= max(1,M);
+*> if SIDE = 'R', LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] TAU
+*> \verbatim
+*> TAU is COMPLEX*16 array, dimension (K)
+*> TAU(i) must contain the scalar factor of the elementary
+*> reflector H(i), as returned by ZGEQRF.
+*> \endverbatim
+*>
+*> \param[in,out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> On entry, the m-by-n matrix C.
+*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,M).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension
+*> (N) if SIDE = 'L',
+*> (M) if SIDE = 'R'
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date December 2016
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE zunm2r( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* December 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 A( lda, * ), C( ldc, * ), TAU( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ parameter( one = ( 1.0d+0, 0.0d+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
+ COMPLEX*16 AII, TAUI
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL lsame
+* ..
+* .. External Subroutines ..
+ EXTERNAL xerbla, zlarf
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC dconjg, max
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ info = 0
+ left = lsame( side, 'L' )
+ notran = lsame( trans, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( left ) THEN
+ nq = m
+ ELSE
+ nq = n
+ END IF
+ IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
+ info = -1
+ ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
+ info = -2
+ ELSE IF( m.LT.0 ) THEN
+ info = -3
+ ELSE IF( n.LT.0 ) THEN
+ info = -4
+ ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
+ info = -5
+ ELSE IF( lda.LT.max( 1, nq ) ) THEN
+ info = -7
+ ELSE IF( ldc.LT.max( 1, m ) ) THEN
+ info = -10
+ END IF
+ IF( info.NE.0 ) THEN
+ CALL xerbla( 'ZUNM2R', -info )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
+ $ RETURN
+*
+ IF( ( left .AND. .NOT.notran .OR. .NOT.left .AND. notran ) ) THEN
+ i1 = 1
+ i2 = k
+ i3 = 1
+ ELSE
+ i1 = k
+ i2 = 1
+ i3 = -1
+ END IF
+*
+ IF( left ) THEN
+ ni = n
+ jc = 1
+ ELSE
+ mi = m
+ ic = 1
+ END IF
+*
+ DO 10 i = i1, i2, i3
+ IF( left ) THEN
+*
+* H(i) or H(i)**H is applied to C(i:m,1:n)
+*
+ mi = m - i + 1
+ ic = i
+ ELSE
+*
+* H(i) or H(i)**H is applied to C(1:m,i:n)
+*
+ ni = n - i + 1
+ jc = i
+ END IF
+*
+* Apply H(i) or H(i)**H
+*
+ IF( notran ) THEN
+ taui = tau( i )
+ ELSE
+ taui = dconjg( tau( i ) )
+ END IF
+ aii = a( i, i )
+ a( i, i ) = one
+ CALL zlarf( side, mi, ni, a( i, i ), 1, taui, c( ic, jc ), ldc,
+ $ work )
+ a( i, i ) = aii
+ 10 CONTINUE
+ RETURN
+*
+* End of ZUNM2R
+*
+ END
+
+
diff --git a/src/msspec/spec/fortran/eig/common/plotfd.f b/src/msspec/spec/fortran/eig/common/plotfd.f
new file mode 100644
index 0000000..65fd858
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/common/plotfd.f
@@ -0,0 +1,103 @@
+C
+C=======================================================================
+C
+ SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
+C
+C This routine prepares the output for a plot of the scattering factor
+C
+C INCLUDE 'spec.inc'
+C
+C
+ USE APPROX_MOD
+ USE FDIF_MOD
+ USE INIT_L_MOD, L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 =>
+ &LF2, I10 => ISTEP_LF
+ USE INIT_J_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD, N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
+ USE TYPCAL_MOD, I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP,
+ & I13 => I_EXT, I14 => I_TEST
+ USE VALIN_MOD, U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVOL
+ USE VALFIN_MOD
+C
+ DIMENSION LMX(NATM,NE_M)
+C
+ COMPLEX FSPH,VKE
+C
+ DATA PI,CONV/3.141593,0.512314/
+C
+ OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
+ IF(ISPHER.EQ.0) THEN
+ L=0
+ LMAX=0
+ ELSE
+ LMAX=L
+ ENDIF
+ PHITOT=360.
+ THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
+ NPHI=(NFTHET+1)*IPHI+(1-IPHI)
+ NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
+ * (1-ITHETA)
+ NE=NFTHET*IE + (1-IE)
+ WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
+ DO 10 JT=1,NTHT
+ DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
+ RTHETA=DTHETA*PI/180.
+ TEST=SIN(RTHETA)
+ IF(TEST.GE.0.) THEN
+ POZ=PI
+ EPS=1.
+ ELSE
+ POZ=0.
+ EPS=-1.
+ ENDIF
+ BETA=RTHETA*EPS
+ IF(ABS(TEST).LT.0.0001) THEN
+ NPHIM=1
+ ELSE
+ NPHIM=NPHI
+ ENDIF
+ DO 20 JP=1,NPHIM
+ DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
+ RPHI=DPHI*PI/180.
+ GAMMA=POZ-RPHI
+ DO 30 JE=1,NE
+ IF(NE.EQ.1) THEN
+ ECIN=E0
+ ELSE
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ENDIF
+ IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
+ DO 40 JAT=1,NAT
+ IF(L.GT.LMX(JAT,JE)) GOTO 90
+ DO 50 M=-LMAX,LMAX
+ CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,
+ & GAMMA,L,M,FSPH,JAT,JE,*60)
+ GOTO 70
+ 60 WRITE(IUO1,80)
+ STOP
+ 70 REFTH=REAL(FSPH)
+ XIMFTH=AIMAG(FSPH)
+ WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,
+ & DPHI,ECIN
+ 50 CONTINUE
+ GOTO 40
+ 90 WRITE(IUO1,100) JAT
+ STOP
+ 40 CONTINUE
+ 30 CONTINUE
+ 20 CONTINUE
+ 10 CONTINUE
+ CLOSE(IUO3)
+ 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
+ 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,
+ &1X,F8.2)
+ 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS
+ &ZERO >>>>>')
+ 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' :
+ &',I2,' >>>>>')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/acc_conv.f b/src/msspec/spec/fortran/eig/mi/acc_conv.f
new file mode 100644
index 0000000..f4e9e6b
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/acc_conv.f
@@ -0,0 +1,189 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ &R_SN,SN,METH)
+C
+C Use of the various acceleration scheme on a scalar series
+C
+C AITK : Aitken, modified Aitken
+C RICH : Richardson
+C SALZ : Salzer
+C EPSI : epsilon
+C EPSG : generalized epsilon
+C RHOA : rho
+C THET : theta
+C LEGE : Legendre-Toeplitz
+C CHEB : Chebyshev-Toeplitz
+C OVER : Overholt
+C DURB : Durbin
+C DLEV : Levin d-transform !! differ by the
+C TLEV : Levin t-transform !! choice of w_n
+C ULEV : Levin u-transform !! the remainder
+C VLEV : Levin v-transform !! estimate given
+C ELEV : Levin e-transform !! by I_WN
+C EULE : generalized Euler transform
+C GBWT : Germain-Bronne-Wimp transform
+C VARI : various algorithms : Weniger, BDG, iterated rho
+C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2
+C EALG : E-algorithm
+C
+C SN : series to be accelerated
+C XN : auxilliary series (chosen with I_XN) : interpolation points
+C GN : auxilliary series (chosen with I_GN) ---> E algorithm
+C
+C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1)
+C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K)
+C so N_DIV=2
+C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are
+C meaningful. Hence the K_MAX size
+C
+C COL_M : type of columns meaningful in the (n,k) table (example: even columns
+C for the epsilon algorithm)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 1 Mar 2013
+C
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVACC_MOD, L => LEVIN
+ USE CONVTYP_MOD
+C
+ PARAMETER (N_METH=24)
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ COMPLEX*16 ZEROC,ONEC
+C
+ REAL*8 R2_SN(N_ORD_M),RHO
+C
+ REAL R_SN(N_ORD_M)
+C
+ INTEGER N_DIV(N_METH)
+C
+ CHARACTER*3 COL_M(N_METH)
+ CHARACTER*4 SCHE(N_METH)
+ CHARACTER*10 NAME(N_METH),METH
+C
+C
+ DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE','CHEB',
+ & 'OVER','DURB','DLEV','TLEV','ULEV','VLEV','ELEV',
+ & 'EULE','GBWT','EALG','SALZ','VARI','ITHE','EPSG',
+ & 'NONE','NONE','NONE'/
+ DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ',' RHO ',
+ & ' THETA ',' LEGENDRE ','CHEBYSHEV ',' OVERHOLT ',
+ & ' DURBIN ',' D LEVIN ',' T LEVIN ',' U LEVIN ',
+ & ' V LEVIN ',' E LEVIN ',' EULER ',' GBW ',
+ & ' E ',' SALZER ',' VARIA ','ITER THETA',
+ & ' EPSILON G',' ',' ',' '/
+ DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL','ALL','ALL',
+ & 'ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL',
+ & 'ALL','ALL','ALL','ALL','EVE','ALL','ALL','ALL'/
+ DATA N_DIV /2,1,1,2,2,1,1,1,4,1,1,1,1,1,1,1,1,1,2,4,1,1,1,1/
+C
+ J_NAME=0
+ I_COL=0
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ DO J=J_INI,J_FIN
+ R2_SN(J)=DBLE(R_SN(J))
+ ENDDO
+C
+C Finding the name of the method
+C
+ DO JM=1,N_METH
+C
+ IF(METHOD.EQ.SCHE(JM)) THEN
+ J_NAME=JM
+ K_MAX=N_MAX/N_DIV(JM)
+ N_COEF=N_DIV(JM)
+ IF(COL_M(JM).EQ.'EVE') I_COL=2
+ ENDIF
+C
+ ENDDO
+C
+C Initialization of array SN
+C
+ DO N=J_INI,J_FIN
+C
+ DO K=-1,J_FIN
+C
+ SN(N,K)=ZEROC
+C
+ ENDDO
+C
+ ENDDO
+C
+C Initialisation of the schemes :
+C
+C -- SN(N,0) is the series to be accelerated --
+C
+ SN(0,-1)=ZEROC
+ SN(0,0)=ONEC
+C
+ DO N=J_INI,J_FIN
+C
+ SN(N,-1)=ZEROC
+ SN(N,0)=R2_SN(N)
+C
+ ENDDO
+C
+ CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C Check for convergence : all results equal within ACC
+C in a N_TABLE x N_TABLE square
+C
+ IF(I_CONV.EQ.0) THEN
+ CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX,
+ & N_COEF,I_COL,ACC,RHO,SN)
+ ENDIF
+C
+ IF(METHOD(2:4).EQ.'LEV') THEN
+ METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN)
+ ELSE
+ METH=NAME(J_NAME)
+ ENDIF
+C
+C Incrementation of the number of calls to this subroutine
+C if convergence has not been achieved
+C
+ IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN
+ N_CALL=N_CALL+1
+ ELSE
+ GOTO 10
+ ENDIF
+C
+C Printing the results in the check file
+C
+ 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',5X,'*')
+ 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*')
+ 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*')
+ 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6,
+ &',',E12.6,')',5X,'*')
+ 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*')
+ 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <---
+ &convergence',2X,'*')
+ 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',3X,' * <--- convergence')
+ 35 FORMAT(2X,'***************************************','************
+ &************************')
+ 45 FORMAT(2X,'* ','
+ & *')
+ 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,')
+ & *')
+ 75 FORMAT(2X,'* Order Taylor ',20X,A10,'
+ & *')
+ 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'*
+ & order ',60X,'*')
+ 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ',
+ &'>>>>>>>>>>',//)
+C
+ 10 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/acc_scal.f b/src/msspec/spec/fortran/eig/mi/acc_scal.f
new file mode 100644
index 0000000..7b25042
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/acc_scal.f
@@ -0,0 +1,693 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C This subroutine computes the scalar convergence acceleration
+C for various methods
+C
+C Note: let us consider that the (n,k) space pattern indicates
+C that we need S(n,k),...,S(n+p,k) in order to compute
+C S(n,k+1). We call N the maximum value of n for which
+C the S(n,0) are known. Then, to compute S(n,k+1), we
+C we need to know up to S(n+pk+p,0). This means that
+C the value of n is limited to N-pk-p.
+C
+C Author : D. Sebilleau
+C
+C Last modified : 14 Mar 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE CONVACC_MOD, L => LEVIN
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5
+ COMPLEX*16 NUM,DEN,FIR
+ COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK
+C
+ REAL*8 EPS,EPSS,MUL
+C
+ CHARACTER*4 METHOD
+C
+ DATA EPS,EPSS /1.D-12,1.D-150/
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ N_APP=J_FIN
+ N_INI=0
+C
+ IF(METHOD.EQ.'AITK') THEN
+C
+C The iterated Aitken and modified Aitken schemes
+C
+C H. H. H. Homeier, Num. Alg. 8, 47 (1994)
+C
+C I_VA = 1 : iterated Aitken (p 49 eq 5)
+C I_VA = 2 : modified iterated Aitken (p 49 eq 9)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ IF(I_VA.EQ.1) THEN
+ XK=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1)
+ ENDIF
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ IF(CDABS(DELTA2).LT.EPSS) THEN
+ DELTA3=ZEROC
+ ELSE
+ DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1)
+ ENDIF
+ SN(N,K+1)=SN(N,K)-XK*DELTA3
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RICH') THEN
+C
+C The Richardson scheme
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=SN(N+1,0)-SN(N,0)
+ DELTA2=SN(N+K+2,0)-SN(N+K+1,0)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 10 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'SALZ') THEN
+C
+C The Salzer scheme
+C
+C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=DFLOAT(N+K+2)
+ DELTA2=DFLOAT(N+1)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 11 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'GBWT') THEN
+C
+C The GBW scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C (eq 6.1-5 p33)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=XN(N)
+ DELTA2=XN(N+K+1)
+ IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 80 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSI') THEN
+C
+C The epsilon scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1)
+C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 20
+ IF(I_VA.EQ.1) THEN
+ VAR=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ VAR=XN(N+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ VAR=XN(N+K+1)-XN(N+K)
+ ENDIF
+ SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+C
+ 20 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSG') THEN
+C
+C The generalized epsilon scheme
+C
+C M. N. Barber and C. J. Hamer,
+C J. Austral. Math. Soc. (Series B) 23, 229 (1982)
+C
+C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed)
+C DELTA2 = 0 implies SN(N+1,K) = SN(N,K)
+C ---> convergence achieved for (N,K)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP,2
+C
+ IF(I_VA.EQ.1) THEN
+ SI(K)=ALPHA
+ SI(K+1)=ALPHA
+ ELSEIF(I_VA.EQ.2) THEN
+ SI(K)=ZEROC
+ SI(K+1)=-ONEC
+ ENDIF
+C
+ ENDDO
+C
+ VAR=ONEC
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ NK(N,-1)=ZEROC
+ DELTA2=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 23
+ NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2
+ DELTA1=(NK(N,K)-NK(N-1,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 23
+ SN(N,K+1)=SN(N,K)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+ 23 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RHOA') THEN
+C
+C The rho scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1)
+C I_VA = 2 : Standard rho (p 34 eq 6.2-2)
+C I_VA = 3 : (p 37 eq 6.3-3) ???????
+C
+C ALPHA is the decay parameter. It is
+C generally advised to take it as
+C an integer to ensure convergence
+C
+ IF(DREAL(ALPHA).LT.0.0D0) THEN
+C
+C Drummond approximation to alpha :
+C
+C (non valid for the Taylor expansion
+C of 1/1+x as in this case the denominator
+C is always zero)
+C
+ DO N=N_INI,N_APP
+C
+ DELTA1=SN(N+3,1)-SN(N+2,1)
+ DELTA2=SN(N+2,1)-SN(N+1,1)
+ DELTA3=SN(N+1,1)-SN(N,1)
+C
+ NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2)
+ DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1
+ ALPHA=NUM/DEN-ONEC
+C
+ ENDDO
+C
+ ENDIF
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ IF(I_VA.NE.3) THEN
+ DEN=(SN(N+1,K)-SN(N,K))
+ ELSE
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ DELTA3=(SN(N+1,K)-SN(N,K))
+ DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)-
+ & XN(N))*DELTA2
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPS) GOTO 30
+ IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=(DFLOAT(K+1)+ALPHA)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+K+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3
+ ENDIF
+C
+ SN(N,K+1)=SN(N+1,K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 30 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'THET') THEN
+C
+C The theta scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C E. Calicetti et al, Phys. Rep. 446, 1 (2007)
+C
+C I_VA = 1 : standard formulation (eq 71 p 19)
+C I_VA = 2 : generalized formulation (eq 10.1-10 p 74)
+C
+ KMAX2=(N_APP-2)/2
+C
+ N_COUNT=0
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,KMAX2
+C
+ IF(I_VA.EQ.3) GOTO 51
+C
+ DO N=N_INI,N_APP-2*K-1
+C
+ DEN=SN(N+1,2*K)-SN(N,2*K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 40
+ IF(I_VA.EQ.1) THEN
+ NUM=1.D0
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+2*K+1)-XN(N)
+ ENDIF
+ SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 40 CONTINUE
+C
+ ENDDO
+C
+ DO N=N_INI,N_APP-4*K-2
+C
+ DELTA2=SN(N+2,2*K)-SN(N+1,2*K)
+ DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1)
+ DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1)
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=DELTA2*DELTA4
+ DEN=DELTA4-DELTA3
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4
+ DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN(
+ & N))*DELTA4
+ ENDIF
+ IF(CDABS(DEN).LT.EPSS) GOTO 50
+C
+ SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 50 CONTINUE
+C
+ ENDDO
+ GOTO 52
+C
+ 51 DO N=N_INI,N_APP-4*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ DELTA4=DELTA3-DELTA2
+ DELTA5=DELTA2-DELTA1
+ DEN=DELTA3*DELTA5-DELTA1*DELTA4
+ IF(CDABS(DEN).LT.EPSS) GOTO 53
+C
+ NUM=DELTA1*DELTA2*DELTA4
+ SN(N,K+1)=SN(N+1,K)-NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 53 CONTINUE
+C
+ ENDDO
+C
+ 52 CONTINUE
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'LEGE') THEN
+C
+C The Legendre-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.3), (4.4) p. 231
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1)
+ DELTA2=DFLOAT(K)/DFLOAT(K+1)
+C
+ DO N=N_INI,N_APP-K-1
+ SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN(
+ & N,K-1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'CHEB') THEN
+C
+C The Chebyshev-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.4) - (4.9) p. 231
+C
+ SI(0)=ONEC
+ SI(1)=3.D0*ONEC
+C
+ DO N=N_INI,N_APP-1
+C
+ TN(N,0)=SN(N,0)
+ TN(N,1)=SN(N,0)+2.D0*TN(N+1,0)
+ SN(N,0)=TN(N,0)/SI(0)
+ SN(N,1)=TN(N,1)/SI(1)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=1,N_APP-1
+C
+ SI(K+1)=6.D0*SI(K)-SI(K-1)
+C
+ DO N=N_INI,N_APP-K-1
+C
+ TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1)
+ SN(N,K+1)=TN(N,K+1)/SI(K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'OVER') THEN
+C
+C The Overholt scheme
+C
+C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996)
+C (eq 36 p 85)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=ONEC
+ DELTA2=ONEC
+ MUL=1.D0
+C
+ DO I=1,K+1
+C
+ DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0))
+ DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0))
+ MUL=MUL*EPS
+C
+ ENDDO
+C
+ IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 60 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'DURB') THEN
+C
+C The Durbin scheme
+C
+C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007)
+C (eq 25 p 185)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-4*K-4
+C
+ DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+
+ & 3,K)+SN(N,K)*SN(N+4,K)
+ DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN(
+ & N,K)+SN(N+4,K)
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 70
+ SN(N,K+1)=DELTA1/DELTA2
+ N_COUNT=N_COUNT+1
+C
+ 70 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD(2:4).EQ.'LEV') THEN
+C
+C The Levin schemes
+C
+ CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ & METHOD(1:1))
+C
+ ELSEIF(METHOD.EQ.'EULE') THEN
+C
+C The generalized Euler scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'VARI') THEN
+C
+C Various schemes
+C
+C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1)
+C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2)
+C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3)
+C I_VA = 4 : iterated rho scheme
+C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ IF(I_VA.EQ.1) THEN
+ A=BETA+DFLOAT(N)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.2) THEN
+ A=ALPHA+DFLOAT(N+K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.3) THEN
+ A=ALPHA+DFLOAT(N-K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.4) THEN
+ A=XN(N+2*K+2)-XN(N)
+ B=XN(N+2*K+1)-XN(N)
+ C=XN(N+2*K+2)-XN(N+1)
+ ELSEIF(I_VA.EQ.5) THEN
+ A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA)
+ B=ONEC
+ C=ONEC
+ ENDIF
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DEN=B*DELTA2-C*DELTA1
+ IF(CDABS(DEN).LT.EPSS) GOTO 81
+ SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN
+ N_COUNT=N_COUNT+1
+C
+ 81 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'ITHE') THEN
+C
+C Iterated theta schemes
+C
+C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6)
+C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5)
+C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-3*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ IF(I_VA.EQ.1) THEN
+ NUM=-DELTA1*DELTA2*(DELTA3-DELTA2)
+ DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2)
+ DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2)
+ DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+2,K)
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPSS) GOTO 90
+ SN(N,K+1)=FIR+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 90 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EALG') THEN
+C
+C E algorithm
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+ CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C Computing the GN(N,K,I)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 91
+ DELTA1=GN(N,K-1,K)/DEN
+C
+ DO I=0,N_APP
+C
+ NUM=GN(N+1,K-1,I)-GN(N,K-1,I)
+ GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1
+C
+ ENDDO
+C
+ 91 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computing SN(N,K)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP-K
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 92
+ DELTA1=GN(N,K-1,K)/DEN
+ SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1
+C
+ 92 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/check_conv.f b/src/msspec/spec/fortran/eig/mi/check_conv.f
new file mode 100644
index 0000000..0d4ee3e
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/check_conv.f
@@ -0,0 +1,96 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,
+ &K_MAX,N_COEF,I_COL,ACC,RHO,SN)
+C
+C This subroutine checks the convergence of the acceleration process.
+C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table
+C of SN(n,k)that contains equal values (SMALL being the accepted error)
+C
+C This way, both the column convergence (k fixed and n increasing)
+C and the diagonal convergence (n=k increasing) are considered
+C
+C Important note: in some algorithms, such as the epsilon one, only
+C odd columns are meaningful. If I_COL = 0, all
+C columns are taken into account while for I_COL = 2
+C only even columns are considered
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2011
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ REAL*8 ACC,REF,COMP,RHO
+C
+C Step for the columns comparison and change of the size
+C of the square when only even columns should be considered
+C
+ IF(I_COL.EQ.0) THEN
+ I_STEP=1
+ N_SQUARE=N_TABLE
+ N_START=N_TABLE
+ ELSEIF(I_COL.EQ.2) THEN
+ I_STEP=2
+ N_SQUARE=N_TABLE+N_TABLE-1
+ IF(MOD(N_SQUARE,2).EQ.0) THEN
+ N_START=N_SQUARE
+ ELSE
+ N_START=N_SQUARE+1
+ ENDIF
+ ENDIF
+C
+C Positionning the bottom right corner of the square: (N,K),
+C starting from (N_START,N_START). If only even columns
+C should be considered, N_START must be even
+C
+ K_FIN=J_FIN/N_COEF
+ IF(K_FIN.LT.N_START) THEN
+ I_CONV=0
+ GOTO 10
+ ENDIF
+C
+ DO K=N_START,K_FIN+N_START-1,I_STEP
+ IF(K.GT.K_MAX) GOTO 20
+ DO N=N_START,K_FIN-K,I_STEP
+C
+C Checking the values (N1,K1) in the selected square
+C
+ REF=CDABS(SN(N,K))
+ I_CONV=1
+C
+ DO N1=0,N_START,I_STEP
+ NN=N-N1
+ DO K1=0,N_START,I_STEP
+C
+ KK=K-K1
+ COMP=CDABS(REF-SN(NN,KK))
+ IF(COMP.GT.ACC) THEN
+ I_CONV=0
+ ENDIF
+C
+ ENDDO
+ ENDDO
+C
+ IF(I_CONV.EQ.1) THEN
+C
+C All values in the square are equal (within ACC):
+C Spectral radius taken as the left top corner value
+C
+ N_ACC=N-N_START+I_STEP
+ K_ACC=K-N_START+I_STEP
+ RHO=REF
+ GOTO 10
+ ENDIF
+C
+ ENDDO
+ 20 CONTINUE
+ ENDDO
+C
+ 10 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/coefficients.f b/src/msspec/spec/fortran/eig/mi/coefficients.f
new file mode 100644
index 0000000..54f36e8
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/coefficients.f
@@ -0,0 +1,89 @@
+C
+C=======================================================================
+C
+ SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH)
+C
+C Binomial coefficients ---> ISWITCH = 1
+C Power coefficients ---> ISWITCH = 2
+C Pochhammer coefficients ---> ISWITCH = 3
+C Pochhammer coefficients ---> ISWITCH = 4 (negative argument)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Sep 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC
+C
+ ONEC=(1.D0,0.D0)
+C
+ COEF(0,0)=ONEC
+ COEF(1,0)=ONEC
+ COEF(1,1)=ONEC
+C
+ IF(I_SWITCH.EQ.1) THEN
+C
+ DO N=2,N_APP-1
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=DCMPLX(N)
+C
+ DO K=2,N
+C
+ COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K)
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.2) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=BETA+DFLOAT(N)
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.3) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.4) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/conv_series.f b/src/msspec/spec/fortran/eig/mi/conv_series.f
new file mode 100644
index 0000000..82f3de7
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/conv_series.f
@@ -0,0 +1,32 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*)
+C
+C This subroutine checks the convergence of the power method or of
+C the Rayleigh quotient method at level JORD without convergence
+C acceleration. For convergence, there must be N_TABLE equal values
+C (ACC being the accepted error) of SN
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ REAL ACC,COMP,R_SN(N_ORD_M)
+C
+ NCONV=0
+ DO J=JORD,JORD-N_TABLE,-1
+ COMP=ABS(R_SN(J)-R_SN(J-1))
+ IF(COMP.LE.ACC) THEN
+ NCONV=NCONV+1
+ ENDIF
+ ENDDO
+C
+ IF(NCONV.EQ.N_TABLE-1) RETURN 1
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/do_main.f b/src/msspec/spec/fortran/eig/mi/do_main.f
new file mode 100644
index 0000000..12d6d13
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/do_main.f
@@ -0,0 +1,1557 @@
+C
+C
+C ************************************************************
+C * ******************************************************** *
+C * * * *
+C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * *
+C * * EIGENVALUE CALCULATION CODE * *
+C * * * *
+C * ******************************************************** *
+C ************************************************************
+C
+C
+C
+C
+C Written by D. Sebilleau, Groupe Theorie,
+C Departement Materiaux-Nanosciences,
+C Institut de Physique de Rennes,
+C UMR CNRS-Universite 6251,
+C Universite de Rennes-1,
+C 35042 Rennes-Cedex,
+C France
+C
+C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada
+C
+C-----------------------------------------------------------------------
+C
+C As a general rule in this code, although there might be a few
+C exceptions (...), a variable whose name starts with a 'I' is a
+C switch, with a 'J' is a loop index and with a 'N' is a number.
+C
+C The main subroutines are :
+C
+C * PHDDIF : computes the photoelectron diffraction
+C formula
+C
+C * XASDIF : computes the EXAFS or XANES formula
+C depending on the energy
+C
+C * AEDDIF : computes the Auger electron diffraction
+C formula
+C
+C * FINDPATHS : generates the multiple scattering
+C paths the electron will follow
+C
+C * PATHOP : calculates the contribution of a given
+C path to the scattering path operator
+C
+C * MATDIF : computes the Rehr-Albers scattering
+C matrices
+C
+C A subroutine called NAME_A is the Auger equivalent of subroutine
+C NAME. The essentail difference between NAME and NAME_A is that
+C they do not contain the same arrays.
+C
+C Always remember, when changing the input data file, to keep the
+C format. The rule here is that the last digit of any integer or
+C character data must correspond to the tab (+) while for real data,
+C the tab precedes the point.
+C
+C Do not forget, before submitting a calculation, to check the
+C consistency of the input data with the corresponding maximal
+C values in the include file.
+C
+C-----------------------------------------------------------------------
+C
+C Please report any bug or problem to me at :
+C
+C didier.sebilleau@univ-rennes1.fr
+C
+C
+C
+C Last modified : 10 Jan 2016
+C
+C=======================================================================
+C
+ SUBROUTINE DO_MAIN()
+C
+C This routine reads the various input files and calls the subroutine
+C performing the requested calculation
+C
+C INCLUDE 'spec.inc'
+C
+
+
+ USE DIM_MOD
+ USE ADSORB_MOD
+ USE APPROX_MOD
+ USE ATOMS_MOD
+ USE AUGER_MOD
+ USE BASES_MOD
+ USE CLUSLIM_MOD
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INDAT_MOD
+ USE INIT_A_MOD
+ USE INIT_L_MOD
+ USE INIT_J_MOD
+ USE INIT_M_MOD
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE LIMAMA_MOD
+ USE LPMOY_MOD
+ USE MASSAT_MOD
+ USE MILLER_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD
+ USE PARCAL_A_MOD
+ USE RELADS_MOD
+ USE RELAX_MOD
+ USE RESEAU_MOD
+ USE SPIN_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE TL_AED_MOD
+ USE TYPCAL_MOD
+ USE TYPCAL_A_MOD
+ USE TYPEM_MOD
+ USE TYPEXP_MOD
+ USE VALIN_MOD
+ USE XMRHO_MOD
+C
+ DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3)
+ DIMENSION ROT(3,3),EMET(3)
+ DIMENSION VAL2(NATCLU_M)
+ DIMENSION IRE(NATCLU_M,2)
+ DIMENSION REL(NATCLU_M),RHOT(NATM)
+ DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M)
+ DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM)
+ DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M)
+ DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M)
+ DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM)
+C
+ COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M)
+ COMPLEX TLSTAR_A
+ COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E
+ COMPLEX RHOR1STAR,RHOR2STAR
+C
+C
+C
+ CHARACTER RIEN
+ CHARACTER*1 B
+ CHARACTER*2 R
+C
+C
+C
+C
+C
+C
+ CHARACTER*30 TUNIT,DUMMY
+C
+ DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/
+ DATA INV /1/
+C
+C! READ(*,776) NFICHLEC
+C! READ(*,776) ICOM
+C! DO JF=1,NFICHLEC
+C! READ(*,777) INDATA(JF)
+C! ENDDO
+C
+C.......... Loop on the data files ..........
+C
+ NFICHLEC=1
+ ICOM = 5
+ DO JFICH=1,NFICHLEC
+C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
+ OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD')
+ CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*
+ &520,*540,*550,*570,*580,*590,*630)
+C
+C.......... Atomic case index ..........
+C
+ I_AT=0
+ IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1
+ IF(SPECTRO.EQ.'APC') THEN
+ IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1
+ ENDIF
+C
+ IF(IBAS.EQ.1) THEN
+ IF(ITEST.EQ.0) THEN
+ NEQ=(2*NIV+1)**3
+ ELSE
+ NEQ=(2*NIV+3)**3
+ ENDIF
+ IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518
+ ENDIF
+C
+ IF(SPECTRO.EQ.'APC') THEN
+ N_EL=2
+ ELSE
+ N_EL=1
+ ENDIF
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IF(I_MULT.EQ.0) THEN
+ LE_MIN=ABS(LI_C-ABS(LI_I-LI_A))
+ LE_MAX=LI_C+LI_A+LI_I
+ ELSE
+ LE_MIN=ABS(LI_C-L_MUL)
+ LE_MAX=LI_C+L_MUL
+ ENDIF
+ ENDIF
+ IF(SPECTRO.EQ.'EIG') THEN
+ LE_MIN=1
+ LE_MAX=1
+ ENDIF
+C
+C.......... Test of the dimensions against the input values ..........
+C
+ IF(NO.GT.NO_ST_M) GOTO 600
+ IF(LE_MAX.GT.LI_M) GOTO 620
+C
+ OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD')
+ OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD')
+ IF(INTERACT.EQ.'DIPCOUL') THEN
+ OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD')
+ OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD')
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (dipolar excitation case) ..........
+C
+ IF((INTERACT.NE.'COULOMB')) THEN
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,418)
+ READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1
+ ENDIF
+ ENDIF
+ IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IUI2,530) E_MIN,E_MAX,DE
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN
+ NLG=INT(NAT1-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1
+ READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX. Waiting for a version of PHAGEN
+C with LMAX dependent on the energy
+C
+ DO JE=1,NE
+ DO JAT=1,NAT1
+ LMAX(JAT,JE)=LMAX(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1=1
+ DO JAT=1,NAT1
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL.EQ.0) READ(IUI3,101) NATR,NER
+ IF(ISPIN.EQ.1) THEN
+ READ(IUI3,106) L_IN,NATR,NER
+ IF(LI.NE.L_IN) GOTO 606
+ ENDIF
+ NAT2=NAT+NATA
+ IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180
+ IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL.EQ.0) THEN
+ DO JAT=1,NAT2
+ IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ ENDIF
+ DO JE=1,NE
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121
+ READ(IUI3,103) ENERGIE
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ 121 CONTINUE
+ DO L=0,LMAX(JAT,JE)
+ READ(IUI2,7) VK(JE),TL(L,1,JAT,JE)
+ TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,
+ & 1.)*TL(L,1,JAT,JE))
+ ENDDO
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5
+ DO LL=1,18
+ READ(IUI3,104) RH1,RH2,DEF1,DEF2
+ RHOR(JE,JAT,LL,1,1)=CMPLX(RH1)
+ RHOR(JE,JAT,LL,2,1)=CMPLX(RH2)
+ DLT(JE,JAT,LL,1)=CMPLX(DEF1)
+ DLT(JE,JAT,LL,2)=CMPLX(DEF2)
+ ENDDO
+ 5 CONTINUE
+ ENDDO
+ ENDDO
+ ELSE
+C
+C.......... TL and RHOR calculated by PHAGEN ..........
+C
+ DO JE=1,NE
+ NLG=INT(NAT2-0.0001)/4 +1
+ IF(NE.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2
+ READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ NL1=1
+ DO JAT=1,NAT2
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ DO JAT=1,NAT2
+ READ(IUI2,*) DUMMY
+ DO L=0,LMAX(JAT,JE)
+ IF(LMAX_MODE.EQ.0) THEN
+ READ(IUI2,9) VK(JE),TLSTAR
+ ELSE
+ READ(IUI2,9) VK(JE),TLSTAR
+ ENDIF
+ TL(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK(JE)=CONJG(VK(JE))
+ ENDDO
+ ENDDO
+C
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333
+ IF(JE.EQ.1) THEN
+ DO JDUM=1,7
+ READ(IUI3,102) RIEN
+ ENDDO
+ ENDIF
+ DO JEMET=1,NEMET
+ JM=IEMET(JEMET)
+ READ(IUI3,105) RHOR1STAR,RHOR2STAR
+ RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR)
+ RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR)
+ ENDDO
+ 333 VK(JE)=VK(JE)*A
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IUI2)
+ CLOSE(IUI3)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN
+ CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL)
+ ENDIF
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (Coulomb excitation case) ..........
+C
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IERR=0
+ IF(INTERACT.EQ.'COULOMB') THEN
+ IRD1=IUI2
+ IRD2=IUI3
+ ELSEIF(INTERACT.EQ.'DIPCOUL') THEN
+ IRD1=IUI7
+ IRD2=IUI8
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,419)
+ READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1_A.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1_A
+ ENDIF
+ ENDIF
+ IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A
+ ENDIF
+ IF(ITL_A.EQ.1) THEN
+ READ(IRD2,107) LI_C2,LI_I2,LI_A2
+ READ(IRD2,117) LE_MIN1,N_CHANNEL
+ LE_MAX1=LE_MIN1+N_CHANNEL-1
+ IF(I_TEST_A.NE.1) THEN
+ IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO
+ & 610
+ ELSE
+ LI_C2=0
+ LI_I2=1
+ LI_A2=0
+ LE_MIN1=1
+ N_CHANNEL=1
+ ENDIF
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN
+ NLG=INT(NAT1_A-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1_A
+ READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX_A. Waiting for a version of PHAGEN
+C with LMAX_A dependent on the energy
+C
+ DO JE=1,NE1_A
+ DO JAT=1,NAT1_A
+ LMAX_A(JAT,JE)=LMAX_A(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1_A=1
+ DO JAT=1,NAT1_A
+ NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1)
+ ENDDO
+ IF(NL1_A.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A
+ IF(ISPIN.EQ.1) THEN
+ READ(IRD2,106) L_IN_A,NATR_A,NER_A
+ IF(LI_C.NE.L_IN_A) GOTO 606
+ ENDIF
+ NAT2_A=NAT+NATA
+ NAT2=NAT2_A
+ IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180
+ IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE)))
+ & GOTO 182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL_A.EQ.0) THEN
+ CONTINUE
+ ELSE
+C
+C.......... TL_A and RHOR_A calculated by PHAGEN ..........
+C
+ DO JE=1,NE_A
+ NLG=INT(NAT2_A-0.0001)/4 +1
+ IF(NE_A.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2_A
+ READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ DO JAT=1,NAT2_A
+ READ(IRD1,*) DUMMY
+ DO L=0,LMAX_A(JAT,JE)
+ IF(LMAX_MODE_A.EQ.0) THEN
+ READ(IRD1,9) VK_A(JE),TLSTAR
+ ELSE
+ READ(IRD1,7) VK_A(JE),TLSTAR
+ ENDIF
+ TL_A(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK_A(JE)=CONJG(VK_A(JE))
+ ENDDO
+ ENDDO
+C
+ IF(IFTHET_A.EQ.1) GOTO 331
+ DO LE=LE_MIN,LE_MAX
+ DO JEMET=1,NEMET
+ JM=IEMET(JEMET)
+ READ(IRD2,109) L_E,LB_MIN,LB_MAX
+ IF(I_TEST_A.EQ.1) THEN
+ L_E=1
+ LB_MIN=0
+ LB_MAX=1
+ ENDIF
+ IF(LE.NE.L_E) IERR=1
+ L_BOUNDS(L_E,1)=LB_MIN
+ L_BOUNDS(L_E,2)=LB_MAX
+ DO LB=LB_MIN,LB_MAX
+ READ(IRD2,108) L_A,RAD_D,RAD_E
+ RHOR_A(LE,JM,L_A,1,1)=RAD_D
+ RHOR_A(LE,JM,L_A,2,1)=RAD_E
+ IF(I_TEST_A.EQ.1) THEN
+ IF(LB.EQ.LB_MIN) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0)
+ ELSEIF(LB.EQ.LB_MAX) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ 331 VK_A(JE)=VK_A(JE)*A
+ VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IRD1)
+ CLOSE(IRD2)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN
+ CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL)
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,420)
+C
+ ENDIF
+C
+C.......... Check of the consistency of the two TL and radial ..........
+C.......... matrix elements for APECS ..........
+C
+ IF(SPECTRO.EQ.'APC') THEN
+C
+ I_TL_FILE=0
+ I_RD_FILE=0
+C
+ IF(NAT1.NE.NAT1_A) I_TL_FILE=1
+ IF(NE1.NE.NE1_A) I_TL_FILE=1
+ IF(ITL.NE.ITL_A) I_TL_FILE=1
+ IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1
+C
+ IF(LI_C.NE.LI_C2) I_RD_FILE=1
+ IF(LI_I.NE.LI_I2) I_RD_FILE=1
+ IF(LI_A.NE.LI_A2) I_RD_FILE=1
+C
+ IF(I_TL_FILE.EQ.1) GOTO 608
+ IF(I_RD_FILE.EQ.1) GOTO 610
+ IF(IERR.EQ.1) GOTO 610
+C
+ ENDIF
+C
+C.......... Calculation of the scattering factor (only) ..........
+C
+ IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8
+ IF(IFTHET.EQ.1) THEN
+ CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
+ ELSEIF(IFTHET_A.EQ.1) THEN
+c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A)
+ ENDIF
+ WRITE(IUO1,57)
+ STOP
+C
+ 8 IF(IBAS.EQ.0) THEN
+C
+C............... Reading of an external cluster ...............
+C
+C
+C Cluster originating from CLUSTER_NEW.F : IPHA=0
+C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems)
+C Other cluster : the first line must be text; then
+C free format : Atomic number,X,Y,Z,number
+C of the corresponding prototypical atom ;
+C All atoms corresponding to the same
+C prototypical atom must follow each other.
+C Moreover, the blocks of equivalent atoms
+C must be ordered by increasing number of
+C prototypical atom.
+C
+ VALZ_MIN=1000.0
+ VALZ_MAX=-1000.0
+C
+ OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD')
+ READ(IUI4,778,ERR=892) IPHA
+ GOTO 893
+ 892 IPHA=3
+ IF(UNIT.EQ.'ANG') THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ ELSEIF(UNIT.EQ.'LPU') THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(UNIT.EQ.'ATU') THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ ELSE
+ GOTO 890
+ ENDIF
+ 893 NATCLU=0
+ DO JAT=1,NAT2
+ NATYP(JAT)=0
+ ENDDO
+ IF(IPHA.EQ.0) THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(IPHA.EQ.1) THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ IEMET(1)=1
+ ELSEIF(IPHA.EQ.2) THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ IEMET(1)=1
+ ENDIF
+ IF(IPRINT.EQ.2) THEN
+ IF(I_AT.NE.1) THEN
+ WRITE(IUO1,558) IUI4,TUNIT
+ IF(IPHA.EQ.3) WRITE(IUO1,549)
+ ENDIF
+ ENDIF
+ JATM=0
+ DO JLINE=1,10000
+ IF(IPHA.EQ.0) THEN
+ READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.1) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.2) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.3) THEN
+ READ(IUI4,*,END=780) NN,X,Y,Z,JAT
+ ENDIF
+ JATM=MAX0(JAT,JATM)
+ NATCLU=NATCLU+1
+ IF(IPHA.NE.3) THEN
+ CHEM(JAT)=R
+ ELSE
+ CHEM(JAT)='XX'
+ ENDIF
+ NZAT(JAT)=NN
+ NATYP(JAT)=NATYP(JAT)+1
+ COORD(1,NATCLU)=X*CUNIT
+ COORD(2,NATCLU)=Y*CUNIT
+ COORD(3,NATCLU)=Z*CUNIT
+ VALZ(NATCLU)=Z*CUNIT
+c IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN
+ IF(IPRINT.GE.2) THEN
+ WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,
+ & NATCLU),COORD(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT)
+ ENDIF
+ ENDDO
+ 780 NBZ=NATCLU
+ IF(JATM.NE.NAT) GOTO 514
+ CLOSE(IUI4)
+C
+ IF(NATCLU.GT.NATCLU_M) GOTO 510
+ DO JA1=1,NATCLU
+ DO JA2=1,NATCLU
+ DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(
+ & COORD(2,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**
+ & 2)
+ IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO
+ & 895
+ ENDDO
+ ENDDO
+C
+ D_UP=VALZ_MAX-VALZ(1)
+ D_DO=VALZ(1)-VALZ_MIN
+ IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN
+ I_INV=1
+ ELSE
+ I_INV=0
+ ENDIF
+ ELSE
+C
+C............... Construction of an internal cluster ...............
+C
+ CALL BASE
+ CALL ROTBAS(ROT)
+ IF(IVG0.EQ.2) THEN
+ NMAX=NIV+1
+ ELSE
+ NMAX=(2*NIV+1)**3
+ ENDIF
+ IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN
+ WRITE(IUO1,37)
+ WRITE(IUO1,38) NIV
+ DO NUM=1,NMAX
+ CALL NUMAT(NUM,NIV,IA,IB,IC)
+ WRITE(IUO1,17) NUM,IA,IB,IC
+ ENDDO
+ WRITE(IUO1,39)
+ ENDIF
+ CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,
+ & NBZ,NAT2,NCOUCH,NMAX)
+ IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN
+ CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,
+ & NCOUCH)
+ IF(IREL.EQ.1) THEN
+ DO JP=1,NPLAN
+ VAL(JP)=VAL2(JP)
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C Storage of the extremal values of x and y for each plane. They define
+C the exterior of the cluster when a new cluster has to be build to
+C support a point-group
+C
+ IF(I_GR.GE.1) THEN
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ WRITE(IUO1,29) K,VAL(K)
+ X_MAX(K)=0.
+ X_MIN(K)=0.
+ Y_MAX(K)=0.
+ Y_MIN(K)=0.
+ ENDDO
+ ENDIF
+ DO JAT=1,NATCLU
+ X=COORD(1,JAT)
+ Y=COORD(2,JAT)
+ Z=COORD(3,JAT)
+ DO JPLAN=1,NPLAN
+ IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN
+ X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN))
+ X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN))
+ Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN))
+ Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN))
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Instead of the symmetrization of the cluster (this version only)
+C
+ N_PROT=NAT
+ NAT_ST=0
+ DO JTYP=1,JATM
+ NB_AT=NATYP(JTYP)
+ IF(NB_AT.GT.NAT_EQ_M) GOTO 614
+ DO JA=1,NB_AT
+ NAT_ST=NAT_ST+1
+ NCORR(JA,JTYP)=NAT_ST
+ ENDDO
+ ENDDO
+ DO JC=1,3
+ DO JA=1,NATCLU
+ SYM_AT(JC,JA)=COORD(JC,JA)
+ ENDDO
+ ENDDO
+C
+C Checking surface-like atoms for mean square displacements
+C calculations
+C
+ CALL CHECK_VIB(NAT2)
+C
+C.......... Set up of the variables used for an internal ..........
+C.......... calculation of the mean free path and/or of ..........
+C.......... the mean square displacements ..........
+C
+ IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN
+ DO JTYP=1,NAT2
+ XMT(JTYP)=XMAT(NZAT(JTYP))
+ RHOT(JTYP)=RHOAT(NZAT(JTYP))
+ ENDDO
+ XMTA=XMT(1)
+ RHOTA=RHOT(1)
+ NZA=NZAT(1)
+ ENDIF
+ IF(IDCM.GT.0) THEN
+ CALL CHNOT(3,VECBAS,VEC)
+ DO J=1,3
+ VB1(J)=VEC(J,1)
+ VB2(J)=VEC(J,2)
+ VB3(J)=VEC(J,3)
+ ENDDO
+ CPR=1.
+ CALL PRVECT(VB2,VB3,VBS,CPR)
+ VM=PRSCAL(VB1,VBS)
+ QD=(6.*PI*PI*NAT/VM)**(1./3.)
+ ENDIF
+C
+C.......... Writing of the contents of the cluster, ..........
+C.......... of the position of the different planes ..........
+C.......... and of their respective absorbers in ..........
+C.......... the control file IUO1 ..........
+C
+ IF(I_AT.EQ.1) GOTO 153
+ IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN
+ WRITE(IUO1,40)
+ NCA=0
+ DO J=1,NAT
+ DO I=1,NMAX
+ NCA=NCA+1
+ WRITE(IUO1,20) J,I
+ WRITE(IUO1,21) (ATOME(L,NCA),L=1,3)
+ K=IRE(NCA,1)
+ IF(K.EQ.0) THEN
+ WRITE(IUO1,22)
+ ELSE
+ WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2)
+ ENDIF
+ ENDDO
+ ENDDO
+ WRITE(IUO1,41)
+ ENDIF
+ IF(IBAS.EQ.1) THEN
+ WRITE(IUO1,24)
+ NATCLU=0
+ DO I=1,NAT
+ NN=NATYP(I)
+ NATCLU=NATCLU+NATYP(I)
+ WRITE(IUO1,26) NN,I
+ ENDDO
+ IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3
+ WRITE(IUO1,782) NATCLU
+ IF(NATCLU.GT.NATCLU_M) GOTO 516
+ IF(IPRINT.EQ.3) WRITE(IUO1,559)
+ IF(IPRINT.EQ.3) THEN
+ NBTA=0
+ DO JT=1,NAT2
+ NBJT=NATYP(JT)
+ DO JN=1,NBJT
+ NBTA=NBTA+1
+ WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),
+ & COORD(3,NBTA),JT,JN,CHEM(JT)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+ 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN
+ CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56)
+ ENDIF
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K)
+ ENDDO
+ ENDIF
+C
+ IF(SPECTRO.NE.'EIG') THEN
+ IF(I_AT.EQ.0) WRITE(IUO1,30)
+ IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN
+ WRITE(IUO1,31) (IEMET(J),J=1,NEMET)
+ ENDIF
+ ZEM=1.E+20
+ DO L=1,NPLAN
+ Z=VAL(L)
+ DO JEMED=1,NEMET
+ CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*
+ & 93)
+ IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),
+ & EMET(3)
+ IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3)
+ GO TO 33
+ 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM
+ 33 CONTINUE
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C.......... Loop on the electrons involved in the ..........
+C.......... spectroscopy : N_EL = 1 for PHD, XAS ..........
+C.......... or AED and N_EL = 2 for APC ..........
+C
+ DO J_EL=1,N_EL
+C
+C.......... Writing the information on the spectroscopies ..........
+C.......... in the control file IUO1 ..........
+C
+ IF(SPECTRO.EQ.'EIG') WRITE(IUO1,252)
+ IF(SPECTRO.EQ.'XAS') GOTO 566
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,236)
+ ELSE
+ WRITE(IUO1,248)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,245)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+C
+C---------- Photoelectron diffraction case (PHD) ----------
+C
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,35)
+ ELSE
+ WRITE(IUO1,246)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,44)
+ IF(IE.EQ.1) WRITE(IUO1,58)
+ IF(INITL.EQ.0) WRITE(IUO1,118)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ WRITE(IUO1,418)
+ WRITE(IUO1,18)
+ ENDIF
+ IF(J_EL.EQ.2) GOTO 222
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(INITL.NE.0) THEN
+ WRITE(IUO1,337)
+ WRITE(IUO1,91)
+ IF(IPOL.EQ.0) THEN
+ WRITE(IUO1,88)
+ ELSEIF(ABS(IPOL).EQ.1) THEN
+ WRITE(IUO1,87)
+ ELSEIF(IPOL.EQ.2) THEN
+ WRITE(IUO1,89)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IDICHR.GT.0) THEN
+ WRITE(IUO1,338)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,90)
+ WRITE(IUO1,43) THLUM,PHILUM
+ IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN
+ WRITE(IUO1,45)
+ ENDIF
+ ENDIF
+C
+ IF(INITL.EQ.2) THEN
+ WRITE(IUO1,79) LI,LI-1,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,
+ & 1,1),RHOR(JE,JTE,NNL,2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,444) JTE,DLT(JE,JTE,
+ & NNL,1),DLT(JE,JTE,NNL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.-1) THEN
+ WRITE(IUO1,82) LI,LI-1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,
+ & 1,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,
+ & NNL,1)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.1) THEN
+ WRITE(IUO1,82) LI,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,
+ & 2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,
+ & NNL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV.EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ 222 CONTINUE
+ ENDIF
+C
+C---------- Auger diffraction case (AED) ----------
+C
+ IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,235)
+ ELSE
+ WRITE(IUO1,247)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,244)
+ IF(I_TEST_A.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN
+ WRITE(IUO1,419)
+ WRITE(IUO1,18)
+ ENDIF
+ IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC_A.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,95) AUGER
+ CALL AUGER_MULT
+ IF(I_MULT.EQ.0) THEN
+ WRITE(IUO1,154)
+ ELSE
+ WRITE(IUO1,155) MULTIPLET
+ ENDIF
+C
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ WRITE(IUO1,112) JTE
+ DO LE=LE_MIN,LE_MAX
+ WRITE(IUO1,119) LE
+ LA_MIN=L_BOUNDS(LE,1)
+ LA_MAX=L_BOUNDS(LE,2)
+ DO LA=LA_MIN,LA_MAX
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,115) LA,RHOR_A(LE,JTE,
+ & LA,1,1),RHOR_A(LE,JTE,LA,2,1)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV.EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C.......... Check of the dimensioning of the treatment routine ..........
+C
+ CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,
+ & NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
+C
+C.......... Call of the subroutine performing either ..........
+C.......... the PhD, AED, EXAFS or APECS calculation ..........
+C
+ 566 IF(ISPIN.EQ.0) THEN
+ IF(SPECTRO.EQ.'EIG') THEN
+ CALL EIGDIF_MI
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+c IF(J_EL.EQ.1) THEN
+c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(J_EL.EQ.2) THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+c ENDIF
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF(SPECTRO.EQ.'PHD') THEN
+c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SP
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SP
+c ENDIF
+ continue
+ ENDIF
+C
+C.......... End of the MS calculation : ..........
+C.......... direct exit or treatment of the results ..........
+C
+C
+C.......... End of the loop on the electrons ..........
+C
+ ENDDO
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,52)
+ ELSE
+ WRITE(IUO1,249)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,49)
+ IF(IE.EQ.1) WRITE(IUO1,59)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ WRITE(IUO1,51)
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,237)
+ ELSE
+ WRITE(IUO1,250)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,238)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,239)
+ ELSE
+ WRITE(IUO1,251)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,240)
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+ WRITE(IUO1,253)
+ ENDIF
+C
+ CLOSE(ICOM)
+ IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
+ WRITE(IUO1,562)
+ ENDIF
+ IF(ISOM.EQ.0) CLOSE(IUO2)
+C! IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
+C
+C.......... End of the loop on the data files ..........
+C
+ ENDDO
+C
+ IF(ISOM.NE.0) THEN
+ JFF=1
+ IF(ISPIN.EQ.0) THEN
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+c CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL TREAT_XAS(ISOM,NFICHLEC,NP)
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP)
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP)
+c ENDIF
+ continue
+ ENDIF
+ ENDIF
+C
+C! IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
+ IF(ISOM.NE.0) CLOSE(IUO2)
+ STOP
+C
+ 1 WRITE(IUO1,60)
+ STOP
+ 2 WRITE(IUO1,61)
+ STOP
+ 55 WRITE(IUO1,65)
+ STOP
+ 56 WRITE(IUO1,64)
+ STOP
+ 74 WRITE(IUO1,75)
+ STOP
+ 99 WRITE(IUO1,100)
+ STOP
+ 180 WRITE(IUO1,181)
+ STOP
+ 182 WRITE(IUO1,183)
+ STOP
+ 184 WRITE(IUO1,185)
+ STOP
+ 504 WRITE(IUO1,505)
+ STOP
+ 510 WRITE(IUO1,511) IUI4
+ STOP
+ 514 WRITE(IUO1,515)
+ STOP
+ 516 WRITE(IUO1,517)
+ STOP
+ 518 WRITE(IUO1,519)
+ WRITE(IUO1,889)
+ STOP
+ 520 WRITE(IUO1,521)
+ STOP
+ 540 WRITE(IUO1,541)
+ STOP
+ 550 WRITE(IUO1,551)
+ STOP
+ 570 WRITE(IUO1,571)
+ STOP
+ 580 WRITE(IUO1,581)
+ STOP
+ 590 WRITE(IUO1,591)
+ STOP
+ 600 WRITE(IUO1,601)
+ STOP
+ 602 WRITE(IUO1,603)
+ STOP
+ 604 WRITE(IUO1,605)
+ STOP
+ 606 WRITE(IUO1,607)
+ STOP
+ 608 WRITE(IUO1,609)
+ STOP
+ 610 WRITE(IUO1,611)
+ STOP
+ 614 WRITE(IUO1,615) NB_AT
+ STOP
+ 620 WRITE(IUO1,621) LE_MAX
+ STOP
+ 630 WRITE(IUO1,631)
+ STOP
+ 890 WRITE(IUO1,891)
+ STOP
+ 895 WRITE(IUO1,896) JA1,JA2
+C
+ 3 FORMAT(5(5X,I4))
+ 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9)
+ 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6)
+ 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',':
+ & (',I3,',',I3,',',I3,')')
+ 18 FORMAT(' ',/)
+ 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5)
+ 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,
+ &',',F7.3,')')
+ 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER')
+ 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,
+ &',',F7.3,')',5X,'NEW NUMBER : ',I4)
+ 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/)
+ 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2)
+ 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3)
+ 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/)
+ 31 FORMAT(38X,10(I2,3X),//)
+ 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS
+ &POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')')
+ 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
+ 36 FORMAT(/////,'########## BEGINNING ', 'OF THE
+ &EXAFS CALCULATION ##########',/////)
+ 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE
+ &ATOMS GENERATED +++++++++++++++++++')
+ 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///)
+ 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++',
+ & '++++++++++++++++++++++++++++++++',/////)
+ 40 FORMAT(/////,'======================', ' CONTENTS OF THE
+ &REDUCED CLUSTER ======================',///)
+ 41 FORMAT(///,'====================================================
+ &','============================',/////)
+ 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,
+ &' DEGREES')
+ 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR
+ &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
+ 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE
+ &SURFACE)')
+ 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON
+ &DIFFRACTION CALCULATION ##########')
+ 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :')
+ 51 FORMAT(/////,'########## END OF THE ', 'EXAFS
+ &CALCULATION ##########')
+ 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON
+ &DIFFRACTION CALCULATION #####','#####')
+ 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE')
+ 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE
+ &STRUCTURE OSCILLATIONS CALCULATION #####', '#####',/////)
+ 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE
+ &OSCILLATIONS CALCULATION #####','#####')
+ 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M)
+ & - CHECK THE DIMENSIONING >>>>>>>>>>')
+ 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ',
+ &' >>>>>>>>>>')
+ 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ',
+ &'CLUSTER HAS NOT CONVERGED YET >>>>>>>>>>')
+ 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ',
+ & 'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>')
+ 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ',
+ & 'IN MAIN ET READ_DATA >>>>>>>>>>')
+ 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ',
+ & I1,',',I1,/)
+ 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',
+ &A3,')',//)
+ 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)')
+ 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1)
+ 83 FORMAT(//,32X,'(SPHERICAL WAVES)')
+ 84 FORMAT(//,34X,'(PLANE WAVES)')
+ 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)')
+ 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)')
+ 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +')
+ 88 FORMAT(24X,'+ NON POLARIZED LIGHT +')
+ 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +')
+ 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/)
+ 91 FORMAT(24X,'+',35X,'+')
+ 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++')
+ 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS
+ &PRESENT IN THIS PLANE')
+ 95 FORMAT(////,31X,'AUGER LINE :',A6,//)
+ 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')
+ &')
+ 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',
+ &I1,')')
+ 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE','
+ &>>>>>>>>>>')
+ 101 FORMAT(24X,I3,24X,I3)
+ 102 FORMAT(A1)
+ 103 FORMAT(31X,F7.2)
+ 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5)
+ 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,
+ &E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9)
+ 106 FORMAT(12X,I3,12X,I3,12X,I3)
+ 107 FORMAT(5X,I2,5X,I2,5X,I2)
+ 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5)
+ 109 FORMAT(5X,I2,12X,I2,11X,I2)
+ 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//)
+ 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' : (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')')
+ 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' : ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)
+ &',/,8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//)
+ 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ',
+ * 'TYPE ',I2,' : (',F8.5,',',F8.5,')')
+ 114 FORMAT(/)
+ 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.
+ &5,')')
+ 117 FORMAT(12X,I2,5X,I2)
+ 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/)
+ 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE
+ &INTEGRAL')
+ 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ',
+ &'INVERSION)')
+ 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ',
+ &'INVERSION)')
+ 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4)
+ 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,
+ &' ',/,' ')
+ 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ',
+ &'LINE',' ',/,' ',/,' ')
+ 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ',
+ &'AND PHASE SHIFTS FILES >>>>>>>>>>')
+ 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ',
+ &'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>')
+ 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ',
+ &'FILE >>>>>>>>>>')
+ 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX
+ &ELEMENTS TAKEN INTO ACCOUNT <-----',///)
+ 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &AUGER DIFFRACTION CALCULATION #####', '#####',/////)
+ 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &APECS DIFFRACTION CALCULATION #####', '#####',/////)
+ 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &PHOTOELECTRON DIFFRACTION CALCULATION ','##########',/////)
+ 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &AUGER DIFFRACTION CALCULATION ', '##########',/////)
+ 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &APECS DIFFRACTION CALCULATION ', '##########',/////)
+ 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON
+ &DIFFRACTION CALCULATION #####','#####')
+ 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 252 FORMAT(/////,'########## BEGINNING ', 'OF THE MULTIPLE
+ &SCATTERING EIGENVALUE CALCULATION #####', '#####',/////)
+ 253 FORMAT(/////,'########## END ', 'OF THE MULTIPLE SCATTERING
+ &EIGENVALUE CALCULATION #####', '#####',/////)
+ 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +')
+ 335 FORMAT(24X,'+ STANDARD +')
+ 336 FORMAT(24X,'+ SPIN-POLARIZED +')
+ 337 FORMAT(24X,'+ WITH +')
+ 338 FORMAT(24X,'+ IN DICHROIC MODE +')
+ 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +')
+ 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','----
+ &--------------------')
+ 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','----
+ &--------------------')
+ 420 FORMAT(///,9X,'----------------------------------------------','-
+ &---------------------')
+ 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(
+ &',F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')')
+ 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.
+ &5,',',F8.5,')')
+ 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE
+ &DIMENSIONING >>>>>>>>>>')
+ 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ',
+ &'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,'
+ &>>>>>>>>>>')
+ 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ',
+ &'NAT IN THE DATA AND CLUSTER FILES >>>>>>>>>>')
+ 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ',
+ &'IBWD >>>>>>>>>>')
+ 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT','
+ &CONSISTENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE
+ &>>>>>>>>>>')
+ 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT
+ &WITH',' THE VALUE OF LI >>>>>>>>>>')
+ 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4)
+ 535 FORMAT(29X,F8.5,1X,F8.5)
+ 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 543 FORMAT(5X,F12.9,5X,F12.9)
+ 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,
+ &'SYM',/)
+ 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 555 FORMAT(4(7X,I2))
+ 556 FORMAT(28X,4(I2,5X))
+ 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,
+ &A2)
+ 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' :
+ & ',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,
+ &'ATOM',/)
+ 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,'
+ &No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/)
+ 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL
+ &ATOMS : ',//)
+ 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM
+ &: ',//)
+ 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',
+ &13X,'oooooooooooooooo',///)
+ 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/)
+ 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD
+ &AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>')
+ 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT
+ &CONSISTENT WITH THE INPUT DATA FILE >>>>>>>>>>')
+ 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ',
+ &'>>>>>>>>>>',//)
+ 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE
+ &','.inc FILE >>>>>>>>>>',//)
+ 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ',
+ &'>>>>>>>>>>',//)
+ 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA
+ &','FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS
+ &FILE >>>>>>>>>>',//)
+ 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ',
+ &'>>>>>>>>>>',//)
+ 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ',
+ &'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',
+ &17X,'WITH THE INPUT DATA FILE ',16X,'>>>>>>>>>>',//)
+ 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE
+ &IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH
+ &ELECTRONS IN CLUSTER ROTATION MODE',' >>>>>>>>>>',//)
+ 776 FORMAT(I2)
+ 777 FORMAT(A24)
+ 778 FORMAT(30X,I1)
+ 779 FORMAT(11X,A2,5X,I2,3F10.4,I5)
+ 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,'
+ &ATOMS')
+ 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M
+ &>>>>>>>>>>')
+ 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''',
+ &'UNITS >>>>>>>>>>')
+ 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE','
+ &ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,'
+ &ARE IDENTICAL >>>>>>>>>>')
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/eigdif_mi.f b/src/msspec/spec/fortran/eig/mi/eigdif_mi.f
new file mode 100644
index 0000000..fddcf4e
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/eigdif_mi.f
@@ -0,0 +1,104 @@
+C
+C=======================================================================
+C
+ SUBROUTINE EIGDIF_MI
+C
+C This subroutine computes the eigenvalues of the
+C multiple scattering matrix to obtain its spectral radius
+C
+C The eigenvalue calculation is performed using the LAPACK
+C eigenvalue routines for a general complex matrix (I_PWM = 0)
+C or using the power method (I_PWM > 0)
+C
+C Last modified : 26 Apr 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP
+ USE DEBWAL_MOD
+ USE EIGEN_MOD, NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE RESEAU_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE VALIN_MOD, E1 => E0, PHLUM => PHILUM
+C
+ COMPLEX IC,ONEC
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M)
+C
+C
+ DATA CONV /0.512314/
+C
+ IC=(0.,1.)
+ ONEC=(1.,0.)
+C
+ OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN')
+C
+C Loop over the energies
+C
+ DO JE=1,NE
+ IF(NE.GT.1) THEN
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ELSEIF(NE.EQ.1) THEN
+ ECIN=E0
+ ENDIF
+ CALL LPM(ECIN,XLPM,*6)
+ XLPM1=XLPM/A
+ IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
+ IF(ITL.EQ.0) THEN
+ VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ GAMMA=1./(2.*XLPM1)
+ IF(IPOTC.EQ.0) THEN
+ VK(JE)=VK(JE)+IC*GAMMA
+ ENDIF
+ IF(I_MFP.EQ.0) THEN
+ VK(JE)=CMPLX(REAL(VK(JE)))
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ IF(I_VIB.EQ.1) THEN
+ IF(IDCM.GE.1) WRITE(IUO1,22)
+ DO JAT=1,N_PROT
+ IF(IDCM.EQ.0) THEN
+ XK2UJ2=VK2(JE)*UJ2(JAT)
+ ELSE
+ XK2UJ2=VK2(JE)*UJ_SQ(JAT)
+ WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
+ ENDIF
+ CALL DWSPH(JAT,JE,XK2UJ2,TLT,I_VIB)
+ DO LAT=0,LMAX(JAT,JE)
+ TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Eigenvalue calculation
+C
+ IF(I_PWM.EQ.0) THEN
+ CALL EIG_MAT_MS(JE,ECIN)
+ ELSE
+ CALL SPEC_RAD_POWER(JE,ECIN)
+ ENDIF
+C
+C
+C End of the loop on the energy
+C
+ ENDDO
+ GOTO 7
+C
+ 6 WRITE(IUO1,55)
+C
+ 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,
+ &25X,' BY DEBYE UNCORRELATED MODEL:',/)
+ 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
+ 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
+ &'AVAILABLE >>>>>>>>>>')
+ 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
+ *'MEAN FREE PATH = ',F6.3,' * A',//)
+C
+ 7 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/interp_points.f b/src/msspec/spec/fortran/eig/mi/interp_points.f
new file mode 100644
index 0000000..c8eb7f7
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/interp_points.f
@@ -0,0 +1,38 @@
+C
+C=======================================================================
+C
+ SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+C This subroutine computes the interpolation
+C points used in some algorithms
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 ALPHA,BETA
+C
+ DO N=0,N_APP
+C
+ IF(I_XN.EQ.1) THEN
+ XN(N)=(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.2) THEN
+ XN(N)=BETA+DFLOAT(N)
+ ELSEIF(I_XN.EQ.3) THEN
+ XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.4) THEN
+ XN(N)=(BETA+DFLOAT(N))**ALPHA
+ ELSEIF(I_XN.EQ.5) THEN
+ XN(N)=((2.D0**N)/BETA)**ALPHA
+ ENDIF
+C
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/levin.f b/src/msspec/spec/fortran/eig/mi/levin.f
new file mode 100644
index 0000000..c7cc914
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/levin.f
@@ -0,0 +1,191 @@
+C
+C=======================================================================
+C
+ SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ &OMEGA)
+C
+C This subroutine computes Levin-type transforms of
+C a given sequence SN(N,1)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1:
+ &N_ORD_M)
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC
+ COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2
+C
+ CHARACTER*1 OMEGA
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Recovery of the original series elements
+C
+ DO N=N_INI,N_APP
+C
+ AN(N)=SN(N,0)-SN(N-1,0)
+C
+ ENDDO
+C
+C
+C Choice of the remainder estimate omega_n
+C
+C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000)
+C
+C
+ IF(OMEGA.EQ.'U') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*(DFLOAT(N)+BETA)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'V') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1))
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'T') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'D') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N+1)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'E') THEN
+C
+ MAX_N=N_APP-2
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+2)/AN(N+1)
+ ENDDO
+C
+ ENDIF
+C
+C Choice of the Levin-type transform
+C
+C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10)
+C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10)
+C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10)
+C I_WN = 4 ---> C-type (eq 3-16c p 11)
+C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70)
+C I_WN = 6 ---> R-type (eq 7.14-12 p 47)
+C
+C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004)
+C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989)
+C
+C
+C Check for the possibility of L extension (the standard case is L = 0)
+C
+ IF(L.GT.0) THEN
+ IF(I_WN.EQ.1) THEN
+ CALL COEFFICIENTS(MAX_N,COEL,BETA,2)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.2) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,3)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.3) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,4)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ENDIF
+ ENDIF
+C
+ DO N=N_INI,MAX_N
+C
+ X=BETA+DFLOAT(N)
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ XK=DFLOAT(K)
+ XXK=X+XK
+C
+ IF(I_WN.EQ.1) THEN
+ INC=XXK/(XXK+ONEC)
+ COEF(N,K)=X*(INC**K)/XXK
+ ELSEIF(I_WN.EQ.2) THEN
+ COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK))
+ ELSEIF(I_WN.EQ.3) THEN
+ COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC)
+ ELSEIF(I_WN.EQ.4) THEN
+ SUM_1=ZEROC
+ SUM_2=ZEROC
+ DO J=0,K
+ SUM_1=SUM_1+ALPHA*XXK
+ SUM_2=SUM_2+ALPHA*(XXK+ONEC)
+ ENDDO
+ COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2)
+ ELSEIF(I_WN.EQ.5) THEN
+ COEF(N,K)=ONEC
+ ELSEIF(I_WN.EQ.6) THEN
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computation of the recurrence relation for numerator
+C and denominator
+C
+ DO N=N_INI,MAX_N
+C
+C Starting values
+C
+ NUM(N,0)=SN(N,0)/WN(N)
+ DEN(N,0)=ONEC/WN(N)
+ SN(N,0)=NUM(N,0)/DEN(N,0)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,MAX_N-K-1
+C
+ IF(I_WN.NE.6) THEN
+ NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K)
+ DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K)
+ ELSE
+ NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N))
+ DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N))
+ ENDIF
+ SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/main.f b/src/msspec/spec/fortran/eig/mi/main.f
similarity index 100%
rename from src/msspec/spec/fortran/main.f
rename to src/msspec/spec/fortran/eig/mi/main.f
diff --git a/src/msspec/spec/fortran/eig/mi/new.f.hidden b/src/msspec/spec/fortran/eig/mi/new.f.hidden
new file mode 100644
index 0000000..1c93f94
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/new.f.hidden
@@ -0,0 +1,3972 @@
+C
+C
+C ************************************************************
+C * ******************************************************** *
+C * * * *
+C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * *
+C * * EIGENVALUE CALCULATION CODE * *
+C * * * *
+C * ******************************************************** *
+C ************************************************************
+C
+C
+C
+C
+C Written by D. Sebilleau, Groupe Theorie,
+C Departement Materiaux-Nanosciences,
+C Institut de Physique de Rennes,
+C UMR CNRS-Universite 6251,
+C Universite de Rennes-1,
+C 35042 Rennes-Cedex,
+C France
+C
+C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada
+C
+C-----------------------------------------------------------------------
+C
+C As a general rule in this code, although there might be a few
+C exceptions (...), a variable whose name starts with a 'I' is a
+C switch, with a 'J' is a loop index and with a 'N' is a number.
+C
+C The main subroutines are :
+C
+C * PHDDIF : computes the photoelectron diffraction
+C formula
+C
+C * XASDIF : computes the EXAFS or XANES formula
+C depending on the energy
+C
+C * AEDDIF : computes the Auger electron diffraction
+C formula
+C
+C * FINDPATHS : generates the multiple scattering
+C paths the electron will follow
+C
+C * PATHOP : calculates the contribution of a given
+C path to the scattering path operator
+C
+C * MATDIF : computes the Rehr-Albers scattering
+C matrices
+C
+C A subroutine called NAME_A is the Auger equivalent of subroutine
+C NAME. The essentail difference between NAME and NAME_A is that
+C they do not contain the same arrays.
+C
+C Always remember, when changing the input data file, to keep the
+C format. The rule here is that the last digit of any integer or
+C character data must correspond to the tab (+) while for real data,
+C the tab precedes the point.
+C
+C Do not forget, before submitting a calculation, to check the
+C consistency of the input data with the corresponding maximal
+C values in the include file.
+C
+C-----------------------------------------------------------------------
+C
+C Please report any bug or problem to me at :
+C
+C didier.sebilleau@univ-rennes1.fr
+C
+C
+C
+C Last modified : 10 Jan 2016
+C
+C=======================================================================
+C
+ PROGRAM MAIN
+C
+C This routine reads the various input files and calls the subroutine
+C performing the requested calculation
+C
+C INCLUDE 'spec.inc'
+C
+ USE ADSORB_MOD
+ USE APPROX_MOD
+ USE ATOMS_MOD
+ USE AUGER_MOD
+ USE BASES_MOD
+ USE CLUSLIM_MOD
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INDAT_MOD
+ USE INIT_A_MOD
+ USE INIT_L_MOD
+ USE INIT_J_MOD
+ USE INIT_M_MOD
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE LIMAMA_MOD
+ USE LPMOY_MOD
+ USE MASSAT_MOD
+ USE MILLER_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD
+ USE PARCAL_A_MOD
+ USE RELADS_MOD
+ USE RELAX_MOD
+ USE RESEAU_MOD
+ USE SPIN_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE TL_AED_MOD
+ USE TYPCAL_MOD
+ USE TYPCAL_A_MOD
+ USE TYPEM_MOD
+ USE TYPEXP_MOD
+ USE VALIN_MOD
+ USE XMRHO_MOD
+C
+ DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3)
+ DIMENSION ROT(3,3),EMET(3)
+ DIMENSION VAL2(NATCLU_M)
+ DIMENSION IRE(NATCLU_M,2)
+ DIMENSION REL(NATCLU_M),RHOT(NATM)
+ DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M)
+ DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM)
+ DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M)
+ DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M)
+ DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM)
+C
+ COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M)
+ COMPLEX TLSTAR_A
+ COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E
+ COMPLEX RHOR1STAR,RHOR2STAR
+C
+C
+C
+ CHARACTER RIEN
+ CHARACTER*1 B
+ CHARACTER*2 R
+C
+C
+C
+C
+C
+C
+ CHARACTER*30 TUNIT,DUMMY
+C
+ DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/
+ DATA INV /1/
+C
+ READ(*,776) NFICHLEC
+ READ(*,776) ICOM
+ DO JF=1,NFICHLEC
+ READ(*,777) INDATA(JF)
+ ENDDO
+C
+C.......... Loop on the data files ..........
+C
+ DO JFICH=1,NFICHLEC
+ OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
+ CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*
+ &520,*540,*550,*570,*580,*590,*630)
+C
+C.......... Atomic case index ..........
+C
+ I_AT=0
+ IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1
+ IF(SPECTRO.EQ.'APC') THEN
+ IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1
+ ENDIF
+C
+ IF(IBAS.EQ.1) THEN
+ IF(ITEST.EQ.0) THEN
+ NEQ=(2*NIV+1)**3
+ ELSE
+ NEQ=(2*NIV+3)**3
+ ENDIF
+ IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518
+ ENDIF
+C
+ IF(SPECTRO.EQ.'APC') THEN
+ N_EL=2
+ ELSE
+ N_EL=1
+ ENDIF
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IF(I_MULT.EQ.0) THEN
+ LE_MIN=ABS(LI_C-ABS(LI_I-LI_A))
+ LE_MAX=LI_C+LI_A+LI_I
+ ELSE
+ LE_MIN=ABS(LI_C-L_MUL)
+ LE_MAX=LI_C+L_MUL
+ ENDIF
+ ENDIF
+ IF(SPECTRO.EQ.'EIG') THEN
+ LE_MIN=1
+ LE_MAX=1
+ ENDIF
+C
+C.......... Test of the dimensions against the input values ..........
+C
+ IF(NO.GT.NO_ST_M) GOTO 600
+ IF(LE_MAX.GT.LI_M) GOTO 620
+C
+ OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD')
+ OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD')
+ IF(INTERACT.EQ.'DIPCOUL') THEN
+ OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD')
+ OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD')
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (dipolar excitation case) ..........
+C
+ IF((INTERACT.NE.'COULOMB')) THEN
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,418)
+ READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1
+ ENDIF
+ ENDIF
+ IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IUI2,530) E_MIN,E_MAX,DE
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN
+ NLG=INT(NAT1-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1
+ READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX. Waiting for a version of PHAGEN
+C with LMAX dependent on the energy
+C
+ DO JE=1,NE
+ DO JAT=1,NAT1
+ LMAX(JAT,JE)=LMAX(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1=1
+ DO JAT=1,NAT1
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL.EQ.0) READ(IUI3,101) NATR,NER
+ IF(ISPIN.EQ.1) THEN
+ READ(IUI3,106) L_IN,NATR,NER
+ IF(LI.NE.L_IN) GOTO 606
+ ENDIF
+ NAT2=NAT+NATA
+ IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180
+ IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL.EQ.0) THEN
+ DO JAT=1,NAT2
+ IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ ENDIF
+ DO JE=1,NE
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121
+ READ(IUI3,103) ENERGIE
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ 121 CONTINUE
+ DO L=0,LMAX(JAT,JE)
+ READ(IUI2,7) VK(JE),TL(L,1,JAT,JE)
+ TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,
+ & 1.)*TL(L,1,JAT,JE))
+ ENDDO
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5
+ DO LL=1,18
+ READ(IUI3,104) RH1,RH2,DEF1,DEF2
+ RHOR(JE,JAT,LL,1,1)=CMPLX(RH1)
+ RHOR(JE,JAT,LL,2,1)=CMPLX(RH2)
+ DLT(JE,JAT,LL,1)=CMPLX(DEF1)
+ DLT(JE,JAT,LL,2)=CMPLX(DEF2)
+ ENDDO
+ 5 CONTINUE
+ ENDDO
+ ENDDO
+ ELSE
+C
+C.......... TL and RHOR calculated by PHAGEN ..........
+C
+ DO JE=1,NE
+ NLG=INT(NAT2-0.0001)/4 +1
+ IF(NE.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2
+ READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ NL1=1
+ DO JAT=1,NAT2
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ DO JAT=1,NAT2
+ READ(IUI2,*) DUMMY
+ DO L=0,LMAX(JAT,JE)
+ IF(LMAX_MODE.EQ.0) THEN
+ READ(IUI2,9) VK(JE),TLSTAR
+ ELSE
+ READ(IUI2,9) VK(JE),TLSTAR
+ ENDIF
+ TL(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK(JE)=CONJG(VK(JE))
+ ENDDO
+ ENDDO
+C
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333
+ IF(JE.EQ.1) THEN
+ DO JDUM=1,7
+ READ(IUI3,102) RIEN
+ ENDDO
+ ENDIF
+ DO JEMET=1,NEMET
+ JM=IEMET(JEMET)
+ READ(IUI3,105) RHOR1STAR,RHOR2STAR
+ RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR)
+ RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR)
+ ENDDO
+ 333 VK(JE)=VK(JE)*A
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IUI2)
+ CLOSE(IUI3)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN
+ CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL)
+ ENDIF
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (Coulomb excitation case) ..........
+C
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IERR=0
+ IF(INTERACT.EQ.'COULOMB') THEN
+ IRD1=IUI2
+ IRD2=IUI3
+ ELSEIF(INTERACT.EQ.'DIPCOUL') THEN
+ IRD1=IUI7
+ IRD2=IUI8
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,419)
+ READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1_A.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1_A
+ ENDIF
+ ENDIF
+ IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A
+ ENDIF
+ IF(ITL_A.EQ.1) THEN
+ READ(IRD2,107) LI_C2,LI_I2,LI_A2
+ READ(IRD2,117) LE_MIN1,N_CHANNEL
+ LE_MAX1=LE_MIN1+N_CHANNEL-1
+ IF(I_TEST_A.NE.1) THEN
+ IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO
+ & 610
+ ELSE
+ LI_C2=0
+ LI_I2=1
+ LI_A2=0
+ LE_MIN1=1
+ N_CHANNEL=1
+ ENDIF
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN
+ NLG=INT(NAT1_A-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1_A
+ READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX_A. Waiting for a version of PHAGEN
+C with LMAX_A dependent on the energy
+C
+ DO JE=1,NE1_A
+ DO JAT=1,NAT1_A
+ LMAX_A(JAT,JE)=LMAX_A(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1_A=1
+ DO JAT=1,NAT1_A
+ NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1)
+ ENDDO
+ IF(NL1_A.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A
+ IF(ISPIN.EQ.1) THEN
+ READ(IRD2,106) L_IN_A,NATR_A,NER_A
+ IF(LI_C.NE.L_IN_A) GOTO 606
+ ENDIF
+ NAT2_A=NAT+NATA
+ NAT2=NAT2_A
+ IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180
+ IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE)))
+ & GOTO 182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL_A.EQ.0) THEN
+ CONTINUE
+ ELSE
+C
+C.......... TL_A and RHOR_A calculated by PHAGEN ..........
+C
+ DO JE=1,NE_A
+ NLG=INT(NAT2_A-0.0001)/4 +1
+ IF(NE_A.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2_A
+ READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ DO JAT=1,NAT2_A
+ READ(IRD1,*) DUMMY
+ DO L=0,LMAX_A(JAT,JE)
+ IF(LMAX_MODE_A.EQ.0) THEN
+ READ(IRD1,9) VK_A(JE),TLSTAR
+ ELSE
+ READ(IRD1,7) VK_A(JE),TLSTAR
+ ENDIF
+ TL_A(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK_A(JE)=CONJG(VK_A(JE))
+ ENDDO
+ ENDDO
+C
+ IF(IFTHET_A.EQ.1) GOTO 331
+ DO LE=LE_MIN,LE_MAX
+ DO JEMET=1,NEMET
+ JM=IEMET(JEMET)
+ READ(IRD2,109) L_E,LB_MIN,LB_MAX
+ IF(I_TEST_A.EQ.1) THEN
+ L_E=1
+ LB_MIN=0
+ LB_MAX=1
+ ENDIF
+ IF(LE.NE.L_E) IERR=1
+ L_BOUNDS(L_E,1)=LB_MIN
+ L_BOUNDS(L_E,2)=LB_MAX
+ DO LB=LB_MIN,LB_MAX
+ READ(IRD2,108) L_A,RAD_D,RAD_E
+ RHOR_A(LE,JM,L_A,1,1)=RAD_D
+ RHOR_A(LE,JM,L_A,2,1)=RAD_E
+ IF(I_TEST_A.EQ.1) THEN
+ IF(LB.EQ.LB_MIN) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0)
+ ELSEIF(LB.EQ.LB_MAX) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ 331 VK_A(JE)=VK_A(JE)*A
+ VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IRD1)
+ CLOSE(IRD2)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN
+ CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL)
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,420)
+C
+ ENDIF
+C
+C.......... Check of the consistency of the two TL and radial ..........
+C.......... matrix elements for APECS ..........
+C
+ IF(SPECTRO.EQ.'APC') THEN
+C
+ I_TL_FILE=0
+ I_RD_FILE=0
+C
+ IF(NAT1.NE.NAT1_A) I_TL_FILE=1
+ IF(NE1.NE.NE1_A) I_TL_FILE=1
+ IF(ITL.NE.ITL_A) I_TL_FILE=1
+ IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1
+C
+ IF(LI_C.NE.LI_C2) I_RD_FILE=1
+ IF(LI_I.NE.LI_I2) I_RD_FILE=1
+ IF(LI_A.NE.LI_A2) I_RD_FILE=1
+C
+ IF(I_TL_FILE.EQ.1) GOTO 608
+ IF(I_RD_FILE.EQ.1) GOTO 610
+ IF(IERR.EQ.1) GOTO 610
+C
+ ENDIF
+C
+C.......... Calculation of the scattering factor (only) ..........
+C
+ IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8
+ IF(IFTHET.EQ.1) THEN
+ CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
+ ELSEIF(IFTHET_A.EQ.1) THEN
+c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A)
+ ENDIF
+ WRITE(IUO1,57)
+ STOP
+C
+ 8 IF(IBAS.EQ.0) THEN
+C
+C............... Reading of an external cluster ...............
+C
+C
+C Cluster originating from CLUSTER_NEW.F : IPHA=0
+C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems)
+C Other cluster : the first line must be text; then
+C free format : Atomic number,X,Y,Z,number
+C of the corresponding prototypical atom ;
+C All atoms corresponding to the same
+C prototypical atom must follow each other.
+C Moreover, the blocks of equivalent atoms
+C must be ordered by increasing number of
+C prototypical atom.
+C
+ VALZ_MIN=1000.0
+ VALZ_MAX=-1000.0
+C
+ OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD')
+ READ(IUI4,778,ERR=892) IPHA
+ GOTO 893
+ 892 IPHA=3
+ IF(UNIT.EQ.'ANG') THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ ELSEIF(UNIT.EQ.'LPU') THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(UNIT.EQ.'ATU') THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ ELSE
+ GOTO 890
+ ENDIF
+ 893 NATCLU=0
+ DO JAT=1,NAT2
+ NATYP(JAT)=0
+ ENDDO
+ IF(IPHA.EQ.0) THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(IPHA.EQ.1) THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ IEMET(1)=1
+ ELSEIF(IPHA.EQ.2) THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ IEMET(1)=1
+ ENDIF
+ IF(IPRINT.EQ.2) THEN
+ IF(I_AT.NE.1) THEN
+ WRITE(IUO1,558) IUI4,TUNIT
+ IF(IPHA.EQ.3) WRITE(IUO1,549)
+ ENDIF
+ ENDIF
+ JATM=0
+ DO JLINE=1,10000
+ IF(IPHA.EQ.0) THEN
+ READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.1) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.2) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.3) THEN
+ READ(IUI4,*,END=780) NN,X,Y,Z,JAT
+ ENDIF
+ JATM=MAX0(JAT,JATM)
+ NATCLU=NATCLU+1
+ IF(IPHA.NE.3) THEN
+ CHEM(JAT)=R
+ ELSE
+ CHEM(JAT)='XX'
+ ENDIF
+ NZAT(JAT)=NN
+ NATYP(JAT)=NATYP(JAT)+1
+ COORD(1,NATCLU)=X*CUNIT
+ COORD(2,NATCLU)=Y*CUNIT
+ COORD(3,NATCLU)=Z*CUNIT
+ VALZ(NATCLU)=Z*CUNIT
+c IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN
+ IF(IPRINT.GE.2) THEN
+ WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,
+ & NATCLU),COORD(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT)
+ ENDIF
+ ENDDO
+ 780 NBZ=NATCLU
+ IF(JATM.NE.NAT) GOTO 514
+ CLOSE(IUI4)
+C
+ IF(NATCLU.GT.NATCLU_M) GOTO 510
+ DO JA1=1,NATCLU
+ DO JA2=1,NATCLU
+ DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(
+ & COORD(2,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**
+ & 2)
+ IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO
+ & 895
+ ENDDO
+ ENDDO
+C
+ D_UP=VALZ_MAX-VALZ(1)
+ D_DO=VALZ(1)-VALZ_MIN
+ IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN
+ I_INV=1
+ ELSE
+ I_INV=0
+ ENDIF
+ ELSE
+C
+C............... Construction of an internal cluster ...............
+C
+ CALL BASE
+ CALL ROTBAS(ROT)
+ IF(IVG0.EQ.2) THEN
+ NMAX=NIV+1
+ ELSE
+ NMAX=(2*NIV+1)**3
+ ENDIF
+ IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN
+ WRITE(IUO1,37)
+ WRITE(IUO1,38) NIV
+ DO NUM=1,NMAX
+ CALL NUMAT(NUM,NIV,IA,IB,IC)
+ WRITE(IUO1,17) NUM,IA,IB,IC
+ ENDDO
+ WRITE(IUO1,39)
+ ENDIF
+ CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,
+ & NBZ,NAT2,NCOUCH,NMAX)
+ IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN
+ CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,
+ & NCOUCH)
+ IF(IREL.EQ.1) THEN
+ DO JP=1,NPLAN
+ VAL(JP)=VAL2(JP)
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C Storage of the extremal values of x and y for each plane. They define
+C the exterior of the cluster when a new cluster has to be build to
+C support a point-group
+C
+ IF(I_GR.GE.1) THEN
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ WRITE(IUO1,29) K,VAL(K)
+ X_MAX(K)=0.
+ X_MIN(K)=0.
+ Y_MAX(K)=0.
+ Y_MIN(K)=0.
+ ENDDO
+ ENDIF
+ DO JAT=1,NATCLU
+ X=COORD(1,JAT)
+ Y=COORD(2,JAT)
+ Z=COORD(3,JAT)
+ DO JPLAN=1,NPLAN
+ IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN
+ X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN))
+ X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN))
+ Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN))
+ Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN))
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Instead of the symmetrization of the cluster (this version only)
+C
+ N_PROT=NAT
+ NAT_ST=0
+ DO JTYP=1,JATM
+ NB_AT=NATYP(JTYP)
+ IF(NB_AT.GT.NAT_EQ_M) GOTO 614
+ DO JA=1,NB_AT
+ NAT_ST=NAT_ST+1
+ NCORR(JA,JTYP)=NAT_ST
+ ENDDO
+ ENDDO
+ DO JC=1,3
+ DO JA=1,NATCLU
+ SYM_AT(JC,JA)=COORD(JC,JA)
+ ENDDO
+ ENDDO
+C
+C Checking surface-like atoms for mean square displacements
+C calculations
+C
+ CALL CHECK_VIB(NAT2)
+C
+C.......... Set up of the variables used for an internal ..........
+C.......... calculation of the mean free path and/or of ..........
+C.......... the mean square displacements ..........
+C
+ IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN
+ DO JTYP=1,NAT2
+ XMT(JTYP)=XMAT(NZAT(JTYP))
+ RHOT(JTYP)=RHOAT(NZAT(JTYP))
+ ENDDO
+ XMTA=XMT(1)
+ RHOTA=RHOT(1)
+ NZA=NZAT(1)
+ ENDIF
+ IF(IDCM.GT.0) THEN
+ CALL CHNOT(3,VECBAS,VEC)
+ DO J=1,3
+ VB1(J)=VEC(J,1)
+ VB2(J)=VEC(J,2)
+ VB3(J)=VEC(J,3)
+ ENDDO
+ CPR=1.
+ CALL PRVECT(VB2,VB3,VBS,CPR)
+ VM=PRSCAL(VB1,VBS)
+ QD=(6.*PI*PI*NAT/VM)**(1./3.)
+ ENDIF
+C
+C.......... Writing of the contents of the cluster, ..........
+C.......... of the position of the different planes ..........
+C.......... and of their respective absorbers in ..........
+C.......... the control file IUO1 ..........
+C
+ IF(I_AT.EQ.1) GOTO 153
+ IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN
+ WRITE(IUO1,40)
+ NCA=0
+ DO J=1,NAT
+ DO I=1,NMAX
+ NCA=NCA+1
+ WRITE(IUO1,20) J,I
+ WRITE(IUO1,21) (ATOME(L,NCA),L=1,3)
+ K=IRE(NCA,1)
+ IF(K.EQ.0) THEN
+ WRITE(IUO1,22)
+ ELSE
+ WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2)
+ ENDIF
+ ENDDO
+ ENDDO
+ WRITE(IUO1,41)
+ ENDIF
+ IF(IBAS.EQ.1) THEN
+ WRITE(IUO1,24)
+ NATCLU=0
+ DO I=1,NAT
+ NN=NATYP(I)
+ NATCLU=NATCLU+NATYP(I)
+ WRITE(IUO1,26) NN,I
+ ENDDO
+ IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3
+ WRITE(IUO1,782) NATCLU
+ IF(NATCLU.GT.NATCLU_M) GOTO 516
+ IF(IPRINT.EQ.3) WRITE(IUO1,559)
+ IF(IPRINT.EQ.3) THEN
+ NBTA=0
+ DO JT=1,NAT2
+ NBJT=NATYP(JT)
+ DO JN=1,NBJT
+ NBTA=NBTA+1
+ WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),
+ & COORD(3,NBTA),JT,JN,CHEM(JT)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+ 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN
+ CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56)
+ ENDIF
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K)
+ ENDDO
+ ENDIF
+C
+ IF(SPECTRO.NE.'EIG') THEN
+ IF(I_AT.EQ.0) WRITE(IUO1,30)
+ IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN
+ WRITE(IUO1,31) (IEMET(J),J=1,NEMET)
+ ENDIF
+ ZEM=1.E+20
+ DO L=1,NPLAN
+ Z=VAL(L)
+ DO JEMED=1,NEMET
+ CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*
+ & 93)
+ IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),
+ & EMET(3)
+ IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3)
+ GO TO 33
+ 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM
+ 33 CONTINUE
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C.......... Loop on the electrons involved in the ..........
+C.......... spectroscopy : N_EL = 1 for PHD, XAS ..........
+C.......... or AED and N_EL = 2 for APC ..........
+C
+ DO J_EL=1,N_EL
+C
+C.......... Writing the information on the spectroscopies ..........
+C.......... in the control file IUO1 ..........
+C
+ IF(SPECTRO.EQ.'EIG') WRITE(IUO1,252)
+ IF(SPECTRO.EQ.'XAS') GOTO 566
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,236)
+ ELSE
+ WRITE(IUO1,248)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,245)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+C
+C---------- Photoelectron diffraction case (PHD) ----------
+C
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,35)
+ ELSE
+ WRITE(IUO1,246)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,44)
+ IF(IE.EQ.1) WRITE(IUO1,58)
+ IF(INITL.EQ.0) WRITE(IUO1,118)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ WRITE(IUO1,418)
+ WRITE(IUO1,18)
+ ENDIF
+ IF(J_EL.EQ.2) GOTO 222
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(INITL.NE.0) THEN
+ WRITE(IUO1,337)
+ WRITE(IUO1,91)
+ IF(IPOL.EQ.0) THEN
+ WRITE(IUO1,88)
+ ELSEIF(ABS(IPOL).EQ.1) THEN
+ WRITE(IUO1,87)
+ ELSEIF(IPOL.EQ.2) THEN
+ WRITE(IUO1,89)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IDICHR.GT.0) THEN
+ WRITE(IUO1,338)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,90)
+ WRITE(IUO1,43) THLUM,PHILUM
+ IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN
+ WRITE(IUO1,45)
+ ENDIF
+ ENDIF
+C
+ IF(INITL.EQ.2) THEN
+ WRITE(IUO1,79) LI,LI-1,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,
+ & 1,1),RHOR(JE,JTE,NNL,2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,444) JTE,DLT(JE,JTE,
+ & NNL,1),DLT(JE,JTE,NNL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.-1) THEN
+ WRITE(IUO1,82) LI,LI-1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,
+ & 1,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,
+ & NNL,1)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.1) THEN
+ WRITE(IUO1,82) LI,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,
+ & 2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,
+ & NNL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV.EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ 222 CONTINUE
+ ENDIF
+C
+C---------- Auger diffraction case (AED) ----------
+C
+ IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,235)
+ ELSE
+ WRITE(IUO1,247)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,244)
+ IF(I_TEST_A.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN
+ WRITE(IUO1,419)
+ WRITE(IUO1,18)
+ ENDIF
+ IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC_A.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,95) AUGER
+ CALL AUGER_MULT
+ IF(I_MULT.EQ.0) THEN
+ WRITE(IUO1,154)
+ ELSE
+ WRITE(IUO1,155) MULTIPLET
+ ENDIF
+C
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ WRITE(IUO1,112) JTE
+ DO LE=LE_MIN,LE_MAX
+ WRITE(IUO1,119) LE
+ LA_MIN=L_BOUNDS(LE,1)
+ LA_MAX=L_BOUNDS(LE,2)
+ DO LA=LA_MIN,LA_MAX
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,115) LA,RHOR_A(LE,JTE,
+ & LA,1,1),RHOR_A(LE,JTE,LA,2,1)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV.EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C.......... Check of the dimensioning of the treatment routine ..........
+C
+ CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,
+ & NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
+C
+C.......... Call of the subroutine performing either ..........
+C.......... the PhD, AED, EXAFS or APECS calculation ..........
+C
+ 566 IF(ISPIN.EQ.0) THEN
+ IF(SPECTRO.EQ.'EIG') THEN
+ CALL EIGDIF_MI
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+c IF(J_EL.EQ.1) THEN
+c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(J_EL.EQ.2) THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+c ENDIF
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF(SPECTRO.EQ.'PHD') THEN
+c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SP
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SP
+c ENDIF
+ continue
+ ENDIF
+C
+C.......... End of the MS calculation : ..........
+C.......... direct exit or treatment of the results ..........
+C
+C
+C.......... End of the loop on the electrons ..........
+C
+ ENDDO
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,52)
+ ELSE
+ WRITE(IUO1,249)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,49)
+ IF(IE.EQ.1) WRITE(IUO1,59)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ WRITE(IUO1,51)
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,237)
+ ELSE
+ WRITE(IUO1,250)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,238)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,239)
+ ELSE
+ WRITE(IUO1,251)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,240)
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+ WRITE(IUO1,253)
+ ENDIF
+C
+ CLOSE(ICOM)
+ IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
+ WRITE(IUO1,562)
+ ENDIF
+ IF(ISOM.EQ.0) CLOSE(IUO2)
+ IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
+C
+C.......... End of the loop on the data files ..........
+C
+ ENDDO
+C
+ IF(ISOM.NE.0) THEN
+ JFF=1
+ IF(ISPIN.EQ.0) THEN
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+c CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL TREAT_XAS(ISOM,NFICHLEC,NP)
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP)
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP)
+c ENDIF
+ continue
+ ENDIF
+ ENDIF
+C
+ IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
+ IF(ISOM.NE.0) CLOSE(IUO2)
+ STOP
+C
+ 1 WRITE(IUO1,60)
+ STOP
+ 2 WRITE(IUO1,61)
+ STOP
+ 55 WRITE(IUO1,65)
+ STOP
+ 56 WRITE(IUO1,64)
+ STOP
+ 74 WRITE(IUO1,75)
+ STOP
+ 99 WRITE(IUO1,100)
+ STOP
+ 180 WRITE(IUO1,181)
+ STOP
+ 182 WRITE(IUO1,183)
+ STOP
+ 184 WRITE(IUO1,185)
+ STOP
+ 504 WRITE(IUO1,505)
+ STOP
+ 510 WRITE(IUO1,511) IUI4
+ STOP
+ 514 WRITE(IUO1,515)
+ STOP
+ 516 WRITE(IUO1,517)
+ STOP
+ 518 WRITE(IUO1,519)
+ WRITE(IUO1,889)
+ STOP
+ 520 WRITE(IUO1,521)
+ STOP
+ 540 WRITE(IUO1,541)
+ STOP
+ 550 WRITE(IUO1,551)
+ STOP
+ 570 WRITE(IUO1,571)
+ STOP
+ 580 WRITE(IUO1,581)
+ STOP
+ 590 WRITE(IUO1,591)
+ STOP
+ 600 WRITE(IUO1,601)
+ STOP
+ 602 WRITE(IUO1,603)
+ STOP
+ 604 WRITE(IUO1,605)
+ STOP
+ 606 WRITE(IUO1,607)
+ STOP
+ 608 WRITE(IUO1,609)
+ STOP
+ 610 WRITE(IUO1,611)
+ STOP
+ 614 WRITE(IUO1,615) NB_AT
+ STOP
+ 620 WRITE(IUO1,621) LE_MAX
+ STOP
+ 630 WRITE(IUO1,631)
+ STOP
+ 890 WRITE(IUO1,891)
+ STOP
+ 895 WRITE(IUO1,896) JA1,JA2
+C
+ 3 FORMAT(5(5X,I4))
+ 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9)
+ 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6)
+ 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',':
+ & (',I3,',',I3,',',I3,')')
+ 18 FORMAT(' ',/)
+ 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5)
+ 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,
+ &',',F7.3,')')
+ 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER')
+ 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,
+ &',',F7.3,')',5X,'NEW NUMBER : ',I4)
+ 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/)
+ 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2)
+ 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3)
+ 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/)
+ 31 FORMAT(38X,10(I2,3X),//)
+ 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS
+ &POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')')
+ 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
+ 36 FORMAT(/////,'########## BEGINNING ', 'OF THE
+ &EXAFS CALCULATION ##########',/////)
+ 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE
+ &ATOMS GENERATED +++++++++++++++++++')
+ 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///)
+ 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++',
+ & '++++++++++++++++++++++++++++++++',/////)
+ 40 FORMAT(/////,'======================', ' CONTENTS OF THE
+ &REDUCED CLUSTER ======================',///)
+ 41 FORMAT(///,'====================================================
+ &','============================',/////)
+ 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,
+ &' DEGREES')
+ 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR
+ &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
+ 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE
+ &SURFACE)')
+ 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON
+ &DIFFRACTION CALCULATION ##########')
+ 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :')
+ 51 FORMAT(/////,'########## END OF THE ', 'EXAFS
+ &CALCULATION ##########')
+ 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON
+ &DIFFRACTION CALCULATION #####','#####')
+ 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE')
+ 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE
+ &STRUCTURE OSCILLATIONS CALCULATION #####', '#####',/////)
+ 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE
+ &OSCILLATIONS CALCULATION #####','#####')
+ 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M)
+ & - CHECK THE DIMENSIONING >>>>>>>>>>')
+ 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ',
+ &' >>>>>>>>>>')
+ 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ',
+ &'CLUSTER HAS NOT CONVERGED YET >>>>>>>>>>')
+ 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ',
+ & 'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>')
+ 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ',
+ & 'IN MAIN ET READ_DATA >>>>>>>>>>')
+ 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ',
+ & I1,',',I1,/)
+ 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',
+ &A3,')',//)
+ 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)')
+ 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1)
+ 83 FORMAT(//,32X,'(SPHERICAL WAVES)')
+ 84 FORMAT(//,34X,'(PLANE WAVES)')
+ 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)')
+ 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)')
+ 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +')
+ 88 FORMAT(24X,'+ NON POLARIZED LIGHT +')
+ 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +')
+ 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/)
+ 91 FORMAT(24X,'+',35X,'+')
+ 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++')
+ 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS
+ &PRESENT IN THIS PLANE')
+ 95 FORMAT(////,31X,'AUGER LINE :',A6,//)
+ 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')
+ &')
+ 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',
+ &I1,')')
+ 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE','
+ &>>>>>>>>>>')
+ 101 FORMAT(24X,I3,24X,I3)
+ 102 FORMAT(A1)
+ 103 FORMAT(31X,F7.2)
+ 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5)
+ 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,
+ &E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9)
+ 106 FORMAT(12X,I3,12X,I3,12X,I3)
+ 107 FORMAT(5X,I2,5X,I2,5X,I2)
+ 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5)
+ 109 FORMAT(5X,I2,12X,I2,11X,I2)
+ 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//)
+ 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' : (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')')
+ 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' : ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)
+ &',/,8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//)
+ 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ',
+ * 'TYPE ',I2,' : (',F8.5,',',F8.5,')')
+ 114 FORMAT(/)
+ 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.
+ &5,')')
+ 117 FORMAT(12X,I2,5X,I2)
+ 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/)
+ 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE
+ &INTEGRAL')
+ 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ',
+ &'INVERSION)')
+ 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ',
+ &'INVERSION)')
+ 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4)
+ 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,
+ &' ',/,' ')
+ 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ',
+ &'LINE',' ',/,' ',/,' ')
+ 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ',
+ &'AND PHASE SHIFTS FILES >>>>>>>>>>')
+ 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ',
+ &'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>')
+ 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ',
+ &'FILE >>>>>>>>>>')
+ 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX
+ &ELEMENTS TAKEN INTO ACCOUNT <-----',///)
+ 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &AUGER DIFFRACTION CALCULATION #####', '#####',/////)
+ 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &APECS DIFFRACTION CALCULATION #####', '#####',/////)
+ 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &PHOTOELECTRON DIFFRACTION CALCULATION ','##########',/////)
+ 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &AUGER DIFFRACTION CALCULATION ', '##########',/////)
+ 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &APECS DIFFRACTION CALCULATION ', '##########',/////)
+ 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON
+ &DIFFRACTION CALCULATION #####','#####')
+ 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 252 FORMAT(/////,'########## BEGINNING ', 'OF THE MULTIPLE
+ &SCATTERING EIGENVALUE CALCULATION #####', '#####',/////)
+ 253 FORMAT(/////,'########## END ', 'OF THE MULTIPLE SCATTERING
+ &EIGENVALUE CALCULATION #####', '#####',/////)
+ 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +')
+ 335 FORMAT(24X,'+ STANDARD +')
+ 336 FORMAT(24X,'+ SPIN-POLARIZED +')
+ 337 FORMAT(24X,'+ WITH +')
+ 338 FORMAT(24X,'+ IN DICHROIC MODE +')
+ 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +')
+ 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','----
+ &--------------------')
+ 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','----
+ &--------------------')
+ 420 FORMAT(///,9X,'----------------------------------------------','-
+ &---------------------')
+ 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(
+ &',F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')')
+ 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.
+ &5,',',F8.5,')')
+ 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE
+ &DIMENSIONING >>>>>>>>>>')
+ 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ',
+ &'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,'
+ &>>>>>>>>>>')
+ 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ',
+ &'NAT IN THE DATA AND CLUSTER FILES >>>>>>>>>>')
+ 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ',
+ &'IBWD >>>>>>>>>>')
+ 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT','
+ &CONSISTENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE
+ &>>>>>>>>>>')
+ 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT
+ &WITH',' THE VALUE OF LI >>>>>>>>>>')
+ 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4)
+ 535 FORMAT(29X,F8.5,1X,F8.5)
+ 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 543 FORMAT(5X,F12.9,5X,F12.9)
+ 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,
+ &'SYM',/)
+ 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 555 FORMAT(4(7X,I2))
+ 556 FORMAT(28X,4(I2,5X))
+ 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,
+ &A2)
+ 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' :
+ & ',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,
+ &'ATOM',/)
+ 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,'
+ &No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/)
+ 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL
+ &ATOMS : ',//)
+ 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM
+ &: ',//)
+ 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',
+ &13X,'oooooooooooooooo',///)
+ 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/)
+ 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD
+ &AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>')
+ 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT
+ &CONSISTENT WITH THE INPUT DATA FILE >>>>>>>>>>')
+ 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ',
+ &'>>>>>>>>>>',//)
+ 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE
+ &','.inc FILE >>>>>>>>>>',//)
+ 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ',
+ &'>>>>>>>>>>',//)
+ 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA
+ &','FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS
+ &FILE >>>>>>>>>>',//)
+ 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ',
+ &'>>>>>>>>>>',//)
+ 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ',
+ &'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',
+ &17X,'WITH THE INPUT DATA FILE ',16X,'>>>>>>>>>>',//)
+ 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE
+ &IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH
+ &ELECTRONS IN CLUSTER ROTATION MODE',' >>>>>>>>>>',//)
+ 776 FORMAT(I2)
+ 777 FORMAT(A24)
+ 778 FORMAT(30X,I1)
+ 779 FORMAT(11X,A2,5X,I2,3F10.4,I5)
+ 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,'
+ &ATOMS')
+ 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M
+ &>>>>>>>>>>')
+ 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''',
+ &'UNITS >>>>>>>>>>')
+ 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE','
+ &ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,'
+ &ARE IDENTICAL >>>>>>>>>>')
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
+C
+C This routine recomputes the T-matrix elements taking into account the
+C mean square displacements.
+C
+C When the argument X is tiny, no vibrations are taken into account
+C
+C Last modified : 25 Apr 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE TRANS_MOD
+C
+ DIMENSION GNT(0:N_GAUNT)
+C
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC
+C
+ COMPLEX*16 FFL(0:2*NL_M)
+C
+ DATA PI4,EPS /12.566371,1.0E-10/
+C
+ ZEROC=(0.,0.)
+C
+ IF(X.GT.EPS) THEN
+C
+C Standard case: vibrations
+C
+ IF(ISPEED.LT.0) THEN
+ NSUM_LB=ABS(ISPEED)
+ ENDIF
+C
+ COEF=PI4*EXP(-X)
+ NL2=2*LMAX(JTYP,JE)+2
+ IBESP=5
+ MG1=0
+ MG2=0
+C
+ CALL BESPHE(NL2,IBESP,X,FFL)
+C
+ DO L=0,LMAX(JTYP,JE)
+ XL=FLOAT(L+L+1)
+ SL1=ZEROC
+C
+ DO L1=0,LMAX(JTYP,JE)
+ XL1=FLOAT(L1+L1+1)
+ CALL GAUNT(L,MG1,L1,MG2,GNT)
+ L2MIN=ABS(L1-L)
+ IF(ISPEED.GE.0) THEN
+ L2MAX=L1+L
+ ELSEIF(ISPEED.LT.0) THEN
+ L2MAX=L2MIN+2*(NSUM_LB-1)
+ ENDIF
+ SL2=0.
+C
+ DO L2=L2MIN,L2MAX,2
+ XL2=FLOAT(L2+L2+1)
+ C=SQRT(XL1*XL2/(PI4*XL))
+ SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2)))
+ ENDDO
+C
+ SL1=SL1+SL2*TL(L1,1,JTYP,JE)
+ ENDDO
+C
+ TLT(L,1,JTYP,JE)=COEF*SL1
+C
+ ENDDO
+C
+ ELSE
+C
+C Argument X tiny: no vibrations
+C
+ DO L=0,LMAX(JTYP,JE)
+C
+ TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE)
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE EIG_MAT_MS(JE,E_KIN)
+C
+C This subroutine stores the G_o T kernel matrix and computes
+C its eigenvalues to check the larger ones. If one or more
+C of these eigenvalues are larger than or equal to 1, no
+C series expansion can converge
+C
+C Last modified : 20 Jul 2009
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE COOR_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE TRANS_MOD
+C
+ PARAMETER(NLTWO=2*NL_M)
+C
+ CHARACTER*24 OUTFILE,PATH
+C
+ COMPLEX*16 HL1(0:NLTWO),SM(LINMAX*NATCLU_M,LINMAX*NATCLU_M)
+ COMPLEX*16 SUM_L,IC,ZEROC,WORK(32*LINMAX*NATCLU_M)
+ COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO),TLK,EXPKJ
+ COMPLEX*16 W(LINMAX*NATCLU_M)
+ COMPLEX*16 VL(1,1),VR(1,1)
+C
+ DOUBLE PRECISION RWORK(2*LINMAX*NATCLU_M)
+C
+ REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
+C
+ REAL W1(LINMAX*NATCLU_M),W2(LINMAX*NATCLU_M)
+C
+ DATA PI,SMALL /3.1415926535898D0,0.0001/
+C
+ IC=(0.D0,1.D0)
+ ZEROC=(0.D0,0.D0)
+ IBESS=3
+ NPRINT=10
+C
+ WRITE(IUO1,5)
+ IF(JE.EQ.1) THEN
+C
+C Name of the second output file where all the eigenvalues
+C will be written
+C
+ IOUT2=55
+ IOUT3=60
+ N_DOT=1
+ DO J_CHAR=1,24
+ IF(OUTFILE2(J_CHAR:J_CHAR).EQ.'.') GOTO 888
+ N_DOT=N_DOT+1
+ ENDDO
+ 888 CONTINUE
+ OUTFILE=OUTFILE2(1:N_DOT)//'egv'
+ PATH=OUTFILE2(1:N_DOT)//'pth'
+ OPEN(UNIT=IOUT2, FILE=OUTFILE, STATUS='UNKNOWN')
+ OPEN(UNIT=IOUT3, FILE=PATH, STATUS='UNKNOWN')
+ ENDIF
+C
+C Construction of the multiple scattering kernel matrix G_o T.
+C Elements are stored using a linear index LINJ
+C representing (J,LJ)
+C
+ JLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ XJ=SYM_AT(1,JATL)
+ YJ=SYM_AT(2,JATL)
+ ZJ=SYM_AT(3,JATL)
+C
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ JLIN=JLIN+1
+C
+ KLIN=0
+ DO KTYP=1,N_PROT
+ NBTYPK=NATYP(KTYP)
+ LMK=LMAX(KTYP,JE)
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.NE.JATL) THEN
+ XKJ=DBLE(SYM_AT(1,KATL)-XJ)
+ YKJ=DBLE(SYM_AT(2,KATL)-YJ)
+ ZKJ=DBLE(SYM_AT(3,KATL)-ZJ)
+ RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
+ KRKJ=DBLE(VK(JE))*RKJ
+ ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*
+ & RKJ)
+ EXPKJ=(XKJ+IC*YKJ)/RKJ
+ ZDKJ=ZKJ/RKJ
+ CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,
+ & LMJ+LMK)
+ CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,
+ & HL1)
+ ENDIF
+C
+ DO LK=0,LMK
+ L_MIN=ABS(LK-LJ)
+ L_MAX=LK+LJ
+ TLK=DCMPLX(TL(LK,1,KTYP,JE))
+ DO MK=-LK,LK
+ KLIN=KLIN+1
+ SM(KLIN,JLIN)=ZEROC
+ SUM_L=ZEROC
+ IF(KATL.NE.JATL) THEN
+ CALL GAUNT2(LK,MK,LJ,MJ,GNT)
+C
+ DO L=L_MIN,L_MAX,2
+ M=MJ-MK
+ IF(ABS(M).LE.L) THEN
+ SUM_L=SUM_L+(IC**L)*
+ & HL1(L)*YLM(L,M)*GNT(L)
+ ENDIF
+ ENDDO
+ SUM_L=SUM_L*ATTKJ*4.D0*PI*IC
+ ELSE
+ SUM_L=ZEROC
+ ENDIF
+C
+ SM(KLIN,JLIN)=TLK*SUM_L
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ N_DIM=LINMAX*NATCLU_M
+C
+C Eigenvalues of the kernel multiple scattering matrix SM
+C
+ CALL ZGEEV('N','N',JLIN,SM,N_DIM,W,VL,1,VR,1,WORK,34*N_DIM,RWORK,
+ &INFO)
+ IF(INFO.NE.0) THEN
+ WRITE(IUO1,*) ' '
+ WRITE(IUO1,*) ' ---> WORK(1),INFO =',WORK(1),INFO
+ WRITE(IUO1,*) ' '
+ ENDIF
+C
+ N_EIG=0
+C
+ WRITE(IOUT2,75)
+ WRITE(IOUT2,110)
+ WRITE(IOUT2,80) E_KIN
+ WRITE(IOUT2,110)
+ WRITE(IOUT2,75)
+ WRITE(IOUT2,105)
+ WRITE(IOUT2,75)
+ XMAX_L=0.
+ N_XMAX=0
+C
+ DO LIN=1,JLIN
+ EIG=REAL(CDABS(W(LIN)))
+ WRITE(IOUT2,100) REAL(DBLE(W(LIN))),REAL(DIMAG(W(LIN))),EIG
+ IF((EIG-XMAX_L).GT.0.0001) N_XMAX=LIN
+ XMAX_L=MAX(XMAX_L,EIG)
+ W1(LIN)=EIG
+ IF(EIG.GT.1.000) THEN
+ N_EIG=N_EIG+1
+ ENDIF
+ ENDDO
+C
+ WRITE(IOUT2,75)
+ WRITE(IOUT2,85) XMAX_L
+ WRITE(IOUT2,90) N_XMAX
+ WRITE(IOUT2,95) W(N_XMAX)
+ WRITE(IOUT2,75)
+C
+ CALL ORDRE(JLIN,W1,NFIN,W2)
+C
+C
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,15) W2(1)
+ WRITE(IUO1,20) W2(NFIN)
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ IF(N_EIG.GE.1) THEN
+ IF(N_EIG.EQ.1) THEN
+ WRITE(IUO1,25) JLIN
+ ELSE
+ WRITE(IUO1,30) N_EIG,JLIN
+ ENDIF
+ ENDIF
+C
+ WRITE(IUO1,65) N_XMAX
+ WRITE(IUO1,70) W(N_XMAX)
+ WRITE(IUO1,10)
+ WRITE(IOUT3,100) REAL(DBLE(W(N_XMAX))),REAL(DIMAG(W(N_XMAX)))
+C
+ NPR=NPRINT/5
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,35) 5*NPR
+ WRITE(IUO1,10)
+C
+ DO JP=0,NPR-1
+ J=5*JP
+ WRITE(IUO1,40) W2(J+1),W2(J+2),W2(J+3),W2(J+4),W2(J+5)
+ ENDDO
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,45) W2(1)
+ WRITE(IUO2,*) E_KIN,W2(1)
+ IF(N_EIG.EQ.0) THEN
+ WRITE(IUO1,50)
+ ELSE
+ WRITE(IUO1,55)
+ ENDIF
+ WRITE(IUO1,10)
+ WRITE(IUO1,10)
+ WRITE(IUO1,60)
+C
+ RETURN
+C
+ 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','---------
+ &--------')
+ 10 FORMAT(11X,'-',54X,'-')
+ 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-')
+ 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-')
+ 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-')
+ 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X,
+ &'-')
+ 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-')
+ 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-')
+ 45 FORMAT(11X,'-',5X,'SPECTRAL RADIUS OF THE KERNEL MATRIX :',F6.3,
+ &5X,'-')
+ 50 FORMAT(11X,'-',5X,'---> THE MULTIPLE SCATTERING SERIES ',
+ &'CONVERGES',4X,'-')
+ 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/
+ &,11X,'-',18X,'SCATTERING SERIES',19X,'-')
+ 60 FORMAT(11X,'----------------------------------------','----------
+ &------',/)
+ 65 FORMAT(11X,'-',5X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,'-
+ &')
+ 70 FORMAT(11X,'-',5X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.3,
+ &')',8X,'-')
+ 75 FORMAT(' ')
+ 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV')
+ 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3)
+ 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5)
+ 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,')
+ &')
+ 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3)
+ 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :')
+ 110 FORMAT(2X,'-------------------------------')
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,
+ &JE,*)
+C
+C This routine computes a spherical wave scattering factor
+C
+C Last modified : 03/04/2006
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE APPROX_MOD
+ USE EXPFAC_MOD
+ USE TRANS_MOD
+ USE TYPCAL_MOD I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD,
+ &I6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
+
+ DIMENSION PLMM(0:100,0:100)
+ DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
+C
+ COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
+ COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
+ COMPLEX RHOJK
+C
+C
+ DATA PI/3.141593/
+C
+ A=1.
+ INTER=0
+ IF(ITL.EQ.1) VKE=VK(JE)
+ RHOJ=VKE*RJ
+ RHOJK=VKE*RJK
+ HLM1=(1.,0.)
+ HLM2=(1.,0.)
+ HLM3=(1.,0.)
+ HLM4=(1.,0.)
+ IEM=1
+ CSTH=COS(BETA)
+ IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN
+ INTER=1
+ BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI))
+ ENDIF
+ CALL PLM(CSTH,PLMM,LMAX(JAT,JE))
+ IF(ISPHER.EQ.0) NO1=0
+ IF(ISPHER.EQ.1) THEN
+ IF(NO.EQ.8) THEN
+ NO1=LMAX(JAT,JE)+1
+ ELSE
+ NO1=NO
+ ENDIF
+ CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM)
+ IF(IEM.EQ.0) THEN
+ HLM4=HLM(0,L)
+ ENDIF
+ IF(RJK.GT.0.0001) THEN
+ NDUM=0
+ CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN)
+ ENDIF
+ CALL DJMN(THRJ,D,L)
+ A1=ABS(D(0,M,L))
+ IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0))
+ & RETURN 1
+ ENDIF
+ MUMAX=MIN0(L,NO1)
+ SMU=(0.,0.)
+ DO 10 MU=0,MUMAX
+ IF(MOD(MU,2).EQ.0) THEN
+ B=1.
+ ELSE
+ B=-1.
+ IF(SIN(BETA).LT.0.) THEN
+ A=-1.
+ ENDIF
+ ENDIF
+ IF(ISPHER.LE.1) THEN
+ ALMU=(1.,0.)
+ C=1.
+ ENDIF
+ IF(ISPHER.EQ.0) GOTO 40
+ IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L))
+ IF(MU.GT.0) THEN
+ C=B*FLOAT(L+L+1)/EXPF(MU,L)
+ ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B*
+ * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU
+ ELSE
+ C=1.
+ ALMU=CMPLX(D(M,0,L))/BLMU
+ ENDIF
+ 40 SNU=(0.,0.)
+ NU1=INT(0.5*(NO1-MU)+0.0001)
+ NUMAX=MIN0(NU1,L-MU)
+ DO 20 NU=0,NUMAX
+ SLP=(0.,0.)
+ LPMIN=MAX0(MU,NU)
+ DO 30 LP=LPMIN,LMAX(JAT,JE)
+ IF(ISPHER.EQ.1) THEN
+ HLM1=HLM(NU,LP)
+ IF(RJK.GT.0.0001) HLM3=HLN(0,LP)
+ ENDIF
+ SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,
+ & MU)*HLM3
+ 30 CONTINUE
+ IF(ISPHER.EQ.1) THEN
+ HLM2=HLM(MU+NU,L)
+ ENDIF
+ SNU=SNU+SLP*HLM2
+ 20 CONTINUE
+ SMU=SMU+SNU*C*ALMU*A*B
+ 10 CONTINUE
+ FSPH=SMU/(VKE*HLM4)
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
+C
+C This routine prepares the output for a plot of the scattering factor
+C
+C INCLUDE 'spec.inc'
+C
+C
+ USE APPROX_MOD
+ USE FDIF_MOD
+ USE INIT_L_MOD L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 =>
+ &LF2, I10 => ISTEP_LF
+ USE INIT_J_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
+ USE TYPCAL_MOD I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP,
+ & I13 => I_EXT, I14 => I_TEST
+ USE VALIN_MOD U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVOL
+ USE VALFIN_MOD
+C
+ DIMENSION LMX(NATM,NE_M)
+C
+ COMPLEX FSPH,VKE
+C
+ DATA PI,CONV/3.141593,0.512314/
+C
+ OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
+ IF(ISPHER.EQ.0) THEN
+ L=0
+ LMAX=0
+ ELSE
+ LMAX=L
+ ENDIF
+ PHITOT=360.
+ THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
+ NPHI=(NFTHET+1)*IPHI+(1-IPHI)
+ NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
+ * (1-ITHETA)
+ NE=NFTHET*IE + (1-IE)
+ WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
+ DO 10 JT=1,NTHT
+ DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
+ RTHETA=DTHETA*PI/180.
+ TEST=SIN(RTHETA)
+ IF(TEST.GE.0.) THEN
+ POZ=PI
+ EPS=1.
+ ELSE
+ POZ=0.
+ EPS=-1.
+ ENDIF
+ BETA=RTHETA*EPS
+ IF(ABS(TEST).LT.0.0001) THEN
+ NPHIM=1
+ ELSE
+ NPHIM=NPHI
+ ENDIF
+ DO 20 JP=1,NPHIM
+ DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
+ RPHI=DPHI*PI/180.
+ GAMMA=POZ-RPHI
+ DO 30 JE=1,NE
+ IF(NE.EQ.1) THEN
+ ECIN=E0
+ ELSE
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ENDIF
+ IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
+ DO 40 JAT=1,NAT
+ IF(L.GT.LMX(JAT,JE)) GOTO 90
+ DO 50 M=-LMAX,LMAX
+ CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,
+ & GAMMA,L,M,FSPH,JAT,JE,*60)
+ GOTO 70
+ 60 WRITE(IUO1,80)
+ STOP
+ 70 REFTH=REAL(FSPH)
+ XIMFTH=AIMAG(FSPH)
+ WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,
+ & DPHI,ECIN
+ 50 CONTINUE
+ GOTO 40
+ 90 WRITE(IUO1,100) JAT
+ STOP
+ 40 CONTINUE
+ 30 CONTINUE
+ 20 CONTINUE
+ 10 CONTINUE
+ CLOSE(IUO3)
+ 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
+ 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,
+ &1X,F8.2)
+ 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS
+ &ZERO >>>>>')
+ 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' :
+ &',I2,' >>>>>')
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE EIGDIF_MI
+C
+C This subroutine computes the eigenvalues of the
+C multiple scattering matrix to obtain its spectral radius
+C
+C The eigenvalue calculation is performed using the LAPACK
+C eigenvalue routines for a general complex matrix (I_PWM = 0)
+C or using the power method (I_PWM > 0)
+C
+C Last modified : 26 Apr 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD NTCLU => NATCLU, NTP => NATYP
+ USE DEBWAL_MOD
+ USE EIGEN_MOD NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE RESEAU_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE VALIN_MOD E1 => E0, PHLUM => PHILUM
+C
+ COMPLEX IC,ONEC
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M)
+C
+C
+ DATA CONV /0.512314/
+C
+ IC=(0.,1.)
+ ONEC=(1.,0.)
+C
+ OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN')
+C
+C Loop over the energies
+C
+ DO JE=1,NE
+ IF(NE.GT.1) THEN
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ELSEIF(NE.EQ.1) THEN
+ ECIN=E0
+ ENDIF
+ CALL LPM(ECIN,XLPM,*6)
+ XLPM1=XLPM/A
+ IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
+ IF(ITL.EQ.0) THEN
+ VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ GAMMA=1./(2.*XLPM1)
+ IF(IPOTC.EQ.0) THEN
+ VK(JE)=VK(JE)+IC*GAMMA
+ ENDIF
+ IF(I_MFP.EQ.0) THEN
+ VK(JE)=CMPLX(REAL(VK(JE)))
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ IF(I_VIB.EQ.1) THEN
+ IF(IDCM.GE.1) WRITE(IUO1,22)
+ DO JAT=1,N_PROT
+ IF(IDCM.EQ.0) THEN
+ XK2UJ2=VK2(JE)*UJ2(JAT)
+ ELSE
+ XK2UJ2=VK2(JE)*UJ_SQ(JAT)
+ WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
+ ENDIF
+ CALL DWSPH(JAT,JE,XK2UJ2,TLT,I_VIB)
+ DO LAT=0,LMAX(JAT,JE)
+ TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Eigenvalue calculation
+C
+ IF(I_PWM.EQ.0) THEN
+ CALL EIG_MAT_MS(JE,ECIN)
+ ELSE
+ CALL SPEC_RAD_POWER(JE,ECIN)
+ ENDIF
+C
+C
+C End of the loop on the energy
+C
+ ENDDO
+ GOTO 7
+C
+ 6 WRITE(IUO1,55)
+C
+ 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,
+ &25X,' BY DEBYE UNCORRELATED MODEL:',/)
+ 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
+ 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
+ &'AVAILABLE >>>>>>>>>>')
+ 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
+ *'MEAN FREE PATH = ',F6.3,' * A',//)
+C
+ 7 RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE SPEC_RAD_POWER(JE,E_KIN)
+C
+C This subroutine stores the G_o T kernel matrix and computes
+C its spectral radius using the power method. In addition,
+C a scalar convergence acceleration method can be used to
+C refine the results.
+C
+C Author : D. Sebilleau
+C
+C Last modified : 4 Feb 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE TRANS_MOD
+C
+C
+ PARAMETER(NLTWO=2*NL_M)
+C
+ INTEGER NN(0:N_ORD_M)
+C
+ REAL R_SN(N_ORD_M),R_SN1(N_ORD_M),R_SN2(N_ORD_M)
+C
+ COMPLEX*16 TLK,SUM_L,EXPKJ,ONEC,MULT
+ COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO)
+ COMPLEX*16 X(LINMAX*NATCLU_M),Y(LINMAX*NATCLU_M)
+ COMPLEX*16 AX(LINMAX*NATCLU_M),AY(LINMAX*NATCLU_M),SUM_AX,SUM_AY
+ COMPLEX*16 HL1(0:NLTWO),A(LINMAX*NATCLU_M,LINMAX*NATCLU_M)
+ COMPLEX*16 ZEROC,IC,JC,JMULT
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
+ REAL*8 NORMX2,NORMY2,NORMAX2,NORMAY2,RLIN
+C
+C
+ CHARACTER*10 METH
+ CHARACTER*24 OUTFILE,PATH
+C
+ DATA PI /3.1415926535898D0/
+C
+ ONEC=(1.D0,0.D0)
+ IC=(0.0D0,1.0D0)
+ ZEROC=(0.D0,0.D0)
+ IBESS=3
+ N_CALL=0
+ N_ACC=0
+ K_ACC=0
+ I_CONV=0
+C
+ IF(N_MAX.GT.N_ORD_M) THEN
+ WRITE(IUO1,99) N_MAX
+ STOP
+ ENDIF
+C
+C Starting vector for power method:
+C
+C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO
+C
+ JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0)
+ JMULT=JC**EXPO
+C
+ WRITE(IUO1,6)
+C
+C Construction of the the multiple scattering kernel matrix G_o T
+C
+C Elements are stored in A(KLIN,JLIN) using linear indices
+C JLIN and KLIN representing (J,LJ) and (K,LK)
+C
+ JLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ XJ=SYM_AT(1,JATL)
+ YJ=SYM_AT(2,JATL)
+ ZJ=SYM_AT(3,JATL)
+C
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ JLIN=JLIN+1
+C
+ KLIN=0
+ DO KTYP=1,N_PROT
+ NBTYPK=NATYP(KTYP)
+ LMK=LMAX(KTYP,JE)
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.NE.JATL) THEN
+ XKJ=DBLE(SYM_AT(1,KATL)-XJ)
+ YKJ=DBLE(SYM_AT(2,KATL)-YJ)
+ ZKJ=DBLE(SYM_AT(3,KATL)-ZJ)
+ RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
+ KRKJ=DBLE(VK(JE))*RKJ
+ ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*
+ & RKJ)
+ EXPKJ=(XKJ+IC*YKJ)/RKJ
+ ZDKJ=ZKJ/RKJ
+ CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,
+ & LMJ+LMK)
+ CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,
+ & HL1)
+ ENDIF
+C
+ DO LK=0,LMK
+ L_MIN=ABS(LK-LJ)
+ L_MAX=LK+LJ
+ TLK=DCMPLX(TL(LK,1,KTYP,JE))
+ DO MK=-LK,LK
+ KLIN=KLIN+1
+ A(KLIN,JLIN)=ZEROC
+ SUM_L=ZEROC
+ IF(KATL.NE.JATL) THEN
+ CALL GAUNT2(LK,MK,LJ,MJ,GNT)
+C
+ DO L=L_MIN,L_MAX,2
+ M=MJ-MK
+ IF(ABS(M).LE.L) THEN
+ SUM_L=SUM_L+(IC**L)*
+ & HL1(L)*YLM(L,M)*GNT(L)
+ ENDIF
+ ENDDO
+ SUM_L=SUM_L*ATTKJ*4.D0*PI*IC
+ ELSE
+ SUM_L=ZEROC
+ ENDIF
+C
+ IF(KATL.NE.JATL) THEN
+ A(KLIN,JLIN)=TLK*SUM_L
+ ENDIF
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ NLIN=JLIN
+C
+C Power method approximation of the spectral radius :
+C
+C SR(A) = lim ||A x||^n / ||x||^n
+C n --> +infty
+C for any starting vector x
+C
+ RLIN=DFLOAT(NLIN)
+C
+C Initialization the vectors and their squared norm
+C
+ MULT=JMULT
+C
+ AX(1)=ONEC
+ AY(1)=ONEC
+C
+ NORMAX2=1.D0
+ NORMAY2=1.D0
+C
+ DO ILIN=2,NLIN
+C
+ AX(ILIN)=AX(ILIN-1)*MULT
+ AY(ILIN)=AY(ILIN-1)*MULT
+ NORMAX2=NORMAX2+DREAL(AX(ILIN)*DCONJG(AX(ILIN)))
+ NORMAY2=NORMAY2+DREAL(AY(ILIN)*DCONJG(AY(ILIN)))
+C
+ ENDDO
+C
+C Computation of the vectors and their squared norm
+C
+C X ---> A*X
+C
+ 120 IF(N_CALL.EQ.0) THEN
+ J_INI=1
+ ELSE
+ J_INI=N_CALL*N_ITER+1
+ ENDIF
+ J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX)
+C
+ IF(J_INI.GT.J_FIN) GOTO 112
+C
+ DO JORD=J_INI,J_FIN
+C
+ NORMX2=NORMAX2
+ NORMY2=NORMAY2
+C
+ DO JLIN=1,NLIN
+C
+ X(JLIN)=AX(JLIN)
+ Y(JLIN)=AY(JLIN)
+C
+ ENDDO
+C
+ NORMAX2=0.D0
+ NORMAY2=0.D0
+C
+ DO ILIN=1,NLIN
+C
+ SUM_AX=ZEROC
+ SUM_AY=ZEROC
+C
+ DO JLIN=1,NLIN
+C
+ SUM_AX=SUM_AX+A(ILIN,JLIN)*X(JLIN)
+ SUM_AY=SUM_AY+A(JLIN,ILIN)*Y(JLIN)
+C
+ ENDDO
+C
+ AX(ILIN)=SUM_AX
+ AY(ILIN)=SUM_AY
+ NORMAX2=NORMAX2+DREAL(SUM_AX*DCONJG(SUM_AX))
+ NORMAY2=NORMAY2+DREAL(SUM_AY*DCONJG(SUM_AY))
+C
+ ENDDO
+C
+ R_SN1(JORD)=SQRT(REAL(NORMAX2/NORMX2))
+ R_SN2(JORD)=SQRT(REAL(NORMAY2/NORMY2))
+ R_SN(JORD)=SQRT(R_SN1(JORD)*R_SN2(JORD))
+C
+ ENDDO
+C
+ IF(J_INI.EQ.1) THEN
+ WRITE(IUO1,10)
+ WRITE(IUO1,46) NLIN
+ WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ ENDIF
+C
+ WRITE(IUO1,10)
+ WRITE(IUO1,44) R_SN(JORD-1)
+ WRITE(IUO1,47) JORD-1
+C
+ 112 IF(I_ACC.GE.1) THEN
+C
+C Convergence acceleration on the results whenever necessary
+C
+ CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ & R_SN,SN,METH)
+ IF((I_CONV.EQ.1).AND.(I_ACC.EQ.1)) GOTO 111
+ IF((I_CONV.EQ.0).OR.(I_ACC.EQ.2)) GOTO 120
+C
+ 111 WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ WRITE(IUO1,10)
+ WRITE(IUO1,52) METH
+ WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC))
+ WRITE(IUO1,49) N_ACC
+ WRITE(IUO1,51) K_ACC
+C
+ IF(I_ACC.EQ.2) THEN
+ OPEN(UNIT=35, FILE='div/n_k_table.lis', STATUS='unknown')
+ DO L=0,K_MAX
+ NN(L)=L
+ ENDDO
+ WRITE(35,*) ' '
+ WRITE(35,*) ' (N,K) TABLE OF ',METH,'
+ & METHOD'
+ WRITE(35,*) ' '
+ WRITE(35,198) (NN(K),K=0,K_MAX)
+ WRITE(35,199)
+ WRITE(35,*) ' '
+ DO N=0,K_MAX
+ WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N)
+ WRITE(35,*) ' '
+ ENDDO
+ ENDIF
+C
+ WRITE(IUO1,10)
+ WRITE(IUO1,60)
+ IF(I_ACC.EQ.2) THEN
+ WRITE(IUO1,210)
+ ENDIF
+C
+ ENDIF
+C
+ WRITE(IUO2,*) E_KIN,R_SN(JORD-1)
+C
+ RETURN
+C
+ 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','---------
+ &--------')
+ 6 FORMAT(/,11X,'---------------- POWER METHOD ANALYSIS ','--------
+ &--------')
+ 10 FORMAT(11X,'-',54X,'-')
+ 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-')
+ 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-')
+ 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-')
+ 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X,
+ &'-')
+ 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-')
+ 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-')
+ 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5,
+ &3X,'-')
+ 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5,
+ &3X,'-')
+ 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8,
+ &3X,'-')
+ 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8,
+ &3X,'-')
+ 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5,
+ &3X,'-')
+ 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8,
+ &3X,'-')
+ 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ',
+ &'CONVERGES ',4X,'-')
+ 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8,
+ &3X,'-')
+ 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10,
+ &1X,'-')
+ 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/
+ &,11X,'-',18X,'SCATTERING SERIES',19X,'-')
+ 60 FORMAT(11X,'----------------------------------------','----------
+ &------',/)
+ 61 FORMAT(11X,'----------------------------------------','----------
+ &------')
+ 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,
+ &'-')
+ 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.
+ &3,')',8X,'-')
+ 75 FORMAT(' ')
+ 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV')
+ 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3)
+ 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5)
+ 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,')
+ &')
+ 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE','
+ &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ',
+ &I5, 6X,' >>>>>>>>>>',///)
+ 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3)
+ 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :')
+ 110 FORMAT(2X,'-------------------------------')
+ 198 FORMAT(' K',50(I3,4X))
+ 199 FORMAT(' N')
+ 200 FORMAT(I3,50(2X,F5.3))
+ 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ',
+ &'IN /div/n_k_table.lis',//)
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ &R_SN,SN,METH)
+C
+C Use of the various acceleration scheme on a scalar series
+C
+C AITK : Aitken, modified Aitken
+C RICH : Richardson
+C SALZ : Salzer
+C EPSI : epsilon
+C EPSG : generalized epsilon
+C RHOA : rho
+C THET : theta
+C LEGE : Legendre-Toeplitz
+C CHEB : Chebyshev-Toeplitz
+C OVER : Overholt
+C DURB : Durbin
+C DLEV : Levin d-transform !! differ by the
+C TLEV : Levin t-transform !! choice of w_n
+C ULEV : Levin u-transform !! the remainder
+C VLEV : Levin v-transform !! estimate given
+C ELEV : Levin e-transform !! by I_WN
+C EULE : generalized Euler transform
+C GBWT : Germain-Bronne-Wimp transform
+C VARI : various algorithms : Weniger, BDG, iterated rho
+C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2
+C EALG : E-algorithm
+C
+C SN : series to be accelerated
+C XN : auxilliary series (chosen with I_XN) : interpolation points
+C GN : auxilliary series (chosen with I_GN) ---> E algorithm
+C
+C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1)
+C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K)
+C so N_DIV=2
+C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are
+C meaningful. Hence the K_MAX size
+C
+C COL_M : type of columns meaningful in the (n,k) table (example: even columns
+C for the epsilon algorithm)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 1 Mar 2013
+C
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVACC_MOD L => LEVIN
+ USE CONVTYP_MOD
+C
+ PARAMETER (N_METH=24)
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ COMPLEX*16 ZEROC,ONEC
+C
+ REAL*8 R2_SN(N_ORD_M),RHO
+C
+ REAL R_SN(N_ORD_M)
+C
+ INTEGER N_DIV(N_METH)
+C
+ CHARACTER*3 COL_M(N_METH)
+ CHARACTER*4 SCHE(N_METH)
+ CHARACTER*10 NAME(N_METH),METH
+C
+C
+ DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE','CHEB',
+ &'OVER','DURB','DLEV','TLEV','ULEV','VLEV','ELEV','EULE','GBWT',
+ &'EALG','SALZ','VARI','ITHE','EPSG','NONE','NONE','NONE'/
+ DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ',' RHO ','
+ & THETA ',' LEGENDRE ','CHEBYSHEV ',' OVERHOLT ',' DURBIN ','
+ &D LEVIN ',' T LEVIN ',' U LEVIN ',' V LEVIN ',' E LEVIN ','
+ & EULER ',' GBW ',' E ',' SALZER ',' VARIA ',
+ &'ITER THETA',' EPSILON G',' ',' ',' '/
+ DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL','ALL','ALL',
+ &'ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL','ALL',
+ &'ALL','ALL','EVE','ALL','ALL','ALL'/
+ DATA N_DIV /2,1,1,2,2,1,1,1,4,1,1,1,1,1,1,1,1,1,2,4,1,1,1,1/
+C
+ J_NAME=0
+ I_COL=0
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ DO J=J_INI,J_FIN
+ R2_SN(J)=DBLE(R_SN(J))
+ ENDDO
+C
+C Finding the name of the method
+C
+ DO JM=1,N_METH
+C
+ IF(METHOD.EQ.SCHE(JM)) THEN
+ J_NAME=JM
+ K_MAX=N_MAX/N_DIV(JM)
+ N_COEF=N_DIV(JM)
+ IF(COL_M(JM).EQ.'EVE') I_COL=2
+ ENDIF
+C
+ ENDDO
+C
+C Initialization of array SN
+C
+ DO N=J_INI,J_FIN
+C
+ DO K=-1,J_FIN
+C
+ SN(N,K)=ZEROC
+C
+ ENDDO
+C
+ ENDDO
+C
+C Initialisation of the schemes :
+C
+C -- SN(N,0) is the series to be accelerated --
+C
+ SN(0,-1)=ZEROC
+ SN(0,0)=ONEC
+C
+ DO N=J_INI,J_FIN
+C
+ SN(N,-1)=ZEROC
+ SN(N,0)=R2_SN(N)
+C
+ ENDDO
+C
+ CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C Check for convergence : all results equal within ACC
+C in a N_TABLE x N_TABLE square
+C
+ IF(I_CONV.EQ.0) THEN
+ CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX,
+ & N_COEF,I_COL,ACC,RHO,SN)
+ ENDIF
+C
+ IF(METHOD(2:4).EQ.'LEV') THEN
+ METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN)
+ ELSE
+ METH=NAME(J_NAME)
+ ENDIF
+C
+C Incrementation of the number of calls to this subroutine
+C if convergence has not been achieved
+C
+ IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN
+ N_CALL=N_CALL+1
+ ELSE
+ GOTO 10
+ ENDIF
+C
+C Printing the results in the check file
+C
+ 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',5X,'*')
+ 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*')
+ 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*')
+ 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6,
+ &',',E12.6,')',5X,'*')
+ 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*')
+ 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <---
+ &convergence',2X,'*')
+ 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',3X,' * <--- convergence')
+ 35 FORMAT(2X,'***************************************','************
+ &************************')
+ 45 FORMAT(2X,'* ','
+ & *')
+ 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,')
+ & *')
+ 75 FORMAT(2X,'* Order Taylor ',20X,A10,'
+ & *')
+ 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'*
+ & order ',60X,'*')
+ 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ',
+ &'>>>>>>>>>>',//)
+C
+ 10 RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C This subroutine computes the scalar convergence acceleration
+C for various methods
+C
+C Note: let us consider that the (n,k) space pattern indicates
+C that we need S(n,k),...,S(n+p,k) in order to compute
+C S(n,k+1). We call N the maximum value of n for which
+C the S(n,0) are known. Then, to compute S(n,k+1), we
+C we need to know up to S(n+pk+p,0). This means that
+C the value of n is limited to N-pk-p.
+C
+C Author : D. Sebilleau
+C
+C Last modified : 14 Mar 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE CONVACC_MOD L => LEVIN
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5
+ COMPLEX*16 NUM,DEN,FIR
+ COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK
+C
+ REAL*8 EPS,EPSS,MUL
+C
+ CHARACTER*4 METHOD
+C
+ DATA EPS,EPSS /1.D-12,1.D-150/
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ N_APP=J_FIN
+ N_INI=0
+C
+ IF(METHOD.EQ.'AITK') THEN
+C
+C The iterated Aitken and modified Aitken schemes
+C
+C H. H. H. Homeier, Num. Alg. 8, 47 (1994)
+C
+C I_VA = 1 : iterated Aitken (p 49 eq 5)
+C I_VA = 2 : modified iterated Aitken (p 49 eq 9)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ IF(I_VA.EQ.1) THEN
+ XK=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1)
+ ENDIF
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ IF(CDABS(DELTA2).LT.EPSS) THEN
+ DELTA3=ZEROC
+ ELSE
+ DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1)
+ ENDIF
+ SN(N,K+1)=SN(N,K)-XK*DELTA3
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RICH') THEN
+C
+C The Richardson scheme
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=SN(N+1,0)-SN(N,0)
+ DELTA2=SN(N+K+2,0)-SN(N+K+1,0)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 10 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'SALZ') THEN
+C
+C The Salzer scheme
+C
+C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=DFLOAT(N+K+2)
+ DELTA2=DFLOAT(N+1)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 11 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'GBWT') THEN
+C
+C The GBW scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C (eq 6.1-5 p33)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=XN(N)
+ DELTA2=XN(N+K+1)
+ IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 80 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSI') THEN
+C
+C The epsilon scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1)
+C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 20
+ IF(I_VA.EQ.1) THEN
+ VAR=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ VAR=XN(N+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ VAR=XN(N+K+1)-XN(N+K)
+ ENDIF
+ SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+C
+ 20 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSG') THEN
+C
+C The generalized epsilon scheme
+C
+C M. N. Barber and C. J. Hamer,
+C J. Austral. Math. Soc. (Series B) 23, 229 (1982)
+C
+C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed)
+C DELTA2 = 0 implies SN(N+1,K) = SN(N,K)
+C ---> convergence achieved for (N,K)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP,2
+C
+ IF(I_VA.EQ.1) THEN
+ SI(K)=ALPHA
+ SI(K+1)=ALPHA
+ ELSEIF(I_VA.EQ.2) THEN
+ SI(K)=ZEROC
+ SI(K+1)=-ONEC
+ ENDIF
+C
+ ENDDO
+C
+ VAR=ONEC
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ NK(N,-1)=ZEROC
+ DELTA2=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 23
+ NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2
+ DELTA1=(NK(N,K)-NK(N-1,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 23
+ SN(N,K+1)=SN(N,K)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+ 23 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RHOA') THEN
+C
+C The rho scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1)
+C I_VA = 2 : Standard rho (p 34 eq 6.2-2)
+C I_VA = 3 : (p 37 eq 6.3-3) ???????
+C
+C ALPHA is the decay parameter. It is
+C generally advised to take it as
+C an integer to ensure convergence
+C
+ IF(DREAL(ALPHA).LT.0.0D0) THEN
+C
+C Drummond approximation to alpha :
+C
+C (non valid for the Taylor expansion
+C of 1/1+x as in this case the denominator
+C is always zero)
+C
+ DO N=N_INI,N_APP
+C
+ DELTA1=SN(N+3,1)-SN(N+2,1)
+ DELTA2=SN(N+2,1)-SN(N+1,1)
+ DELTA3=SN(N+1,1)-SN(N,1)
+C
+ NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2)
+ DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1
+ ALPHA=NUM/DEN-ONEC
+C
+ ENDDO
+C
+ ENDIF
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ IF(I_VA.NE.3) THEN
+ DEN=(SN(N+1,K)-SN(N,K))
+ ELSE
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ DELTA3=(SN(N+1,K)-SN(N,K))
+ DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)-
+ & XN(N))*DELTA2
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPS) GOTO 30
+ IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=(DFLOAT(K+1)+ALPHA)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+K+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3
+ ENDIF
+C
+ SN(N,K+1)=SN(N+1,K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 30 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'THET') THEN
+C
+C The theta scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C E. Calicetti et al, Phys. Rep. 446, 1 (2007)
+C
+C I_VA = 1 : standard formulation (eq 71 p 19)
+C I_VA = 2 : generalized formulation (eq 10.1-10 p 74)
+C
+ KMAX2=(N_APP-2)/2
+C
+ N_COUNT=0
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,KMAX2
+C
+ IF(I_VA.EQ.3) GOTO 51
+C
+ DO N=N_INI,N_APP-2*K-1
+C
+ DEN=SN(N+1,2*K)-SN(N,2*K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 40
+ IF(I_VA.EQ.1) THEN
+ NUM=1.D0
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+2*K+1)-XN(N)
+ ENDIF
+ SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 40 CONTINUE
+C
+ ENDDO
+C
+ DO N=N_INI,N_APP-4*K-2
+C
+ DELTA2=SN(N+2,2*K)-SN(N+1,2*K)
+ DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1)
+ DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1)
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=DELTA2*DELTA4
+ DEN=DELTA4-DELTA3
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4
+ DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN(
+ & N))*DELTA4
+ ENDIF
+ IF(CDABS(DEN).LT.EPSS) GOTO 50
+C
+ SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 50 CONTINUE
+C
+ ENDDO
+ GOTO 52
+C
+ 51 DO N=N_INI,N_APP-4*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ DELTA4=DELTA3-DELTA2
+ DELTA5=DELTA2-DELTA1
+ DEN=DELTA3*DELTA5-DELTA1*DELTA4
+ IF(CDABS(DEN).LT.EPSS) GOTO 53
+C
+ NUM=DELTA1*DELTA2*DELTA4
+ SN(N,K+1)=SN(N+1,K)-NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 53 CONTINUE
+C
+ ENDDO
+C
+ 52 CONTINUE
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'LEGE') THEN
+C
+C The Legendre-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.3), (4.4) p. 231
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1)
+ DELTA2=DFLOAT(K)/DFLOAT(K+1)
+C
+ DO N=N_INI,N_APP-K-1
+ SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN(
+ & N,K-1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'CHEB') THEN
+C
+C The Chebyshev-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.4) - (4.9) p. 231
+C
+ SI(0)=ONEC
+ SI(1)=3.D0*ONEC
+C
+ DO N=N_INI,N_APP-1
+C
+ TN(N,0)=SN(N,0)
+ TN(N,1)=SN(N,0)+2.D0*TN(N+1,0)
+ SN(N,0)=TN(N,0)/SI(0)
+ SN(N,1)=TN(N,1)/SI(1)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=1,N_APP-1
+C
+ SI(K+1)=6.D0*SI(K)-SI(K-1)
+C
+ DO N=N_INI,N_APP-K-1
+C
+ TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1)
+ SN(N,K+1)=TN(N,K+1)/SI(K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'OVER') THEN
+C
+C The Overholt scheme
+C
+C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996)
+C (eq 36 p 85)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=ONEC
+ DELTA2=ONEC
+ MUL=1.D0
+C
+ DO I=1,K+1
+C
+ DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0))
+ DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0))
+ MUL=MUL*EPS
+C
+ ENDDO
+C
+ IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 60 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'DURB') THEN
+C
+C The Durbin scheme
+C
+C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007)
+C (eq 25 p 185)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-4*K-4
+C
+ DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+
+ & 3,K)+SN(N,K)*SN(N+4,K)
+ DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN(
+ & N,K)+SN(N+4,K)
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 70
+ SN(N,K+1)=DELTA1/DELTA2
+ N_COUNT=N_COUNT+1
+C
+ 70 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD(2:4).EQ.'LEV') THEN
+C
+C The Levin schemes
+C
+ CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ & METHOD(1:1))
+C
+ ELSEIF(METHOD.EQ.'EULE') THEN
+C
+C The generalized Euler scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'VARI') THEN
+C
+C Various schemes
+C
+C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1)
+C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2)
+C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3)
+C I_VA = 4 : iterated rho scheme
+C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ IF(I_VA.EQ.1) THEN
+ A=BETA+DFLOAT(N)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.2) THEN
+ A=ALPHA+DFLOAT(N+K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.3) THEN
+ A=ALPHA+DFLOAT(N-K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.4) THEN
+ A=XN(N+2*K+2)-XN(N)
+ B=XN(N+2*K+1)-XN(N)
+ C=XN(N+2*K+2)-XN(N+1)
+ ELSEIF(I_VA.EQ.5) THEN
+ A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA)
+ B=ONEC
+ C=ONEC
+ ENDIF
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DEN=B*DELTA2-C*DELTA1
+ IF(CDABS(DEN).LT.EPSS) GOTO 81
+ SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN
+ N_COUNT=N_COUNT+1
+C
+ 81 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'ITHE') THEN
+C
+C Iterated theta schemes
+C
+C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6)
+C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5)
+C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-3*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ IF(I_VA.EQ.1) THEN
+ NUM=-DELTA1*DELTA2*(DELTA3-DELTA2)
+ DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2)
+ DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2)
+ DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+2,K)
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPSS) GOTO 90
+ SN(N,K+1)=FIR+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 90 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EALG') THEN
+C
+C E algorithm
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+ CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C Computing the GN(N,K,I)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 91
+ DELTA1=GN(N,K-1,K)/DEN
+C
+ DO I=0,N_APP
+C
+ NUM=GN(N+1,K-1,I)-GN(N,K-1,I)
+ GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1
+C
+ ENDDO
+C
+ 91 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computing SN(N,K)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP-K
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 92
+ DELTA1=GN(N,K-1,K)/DEN
+ SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1
+C
+ 92 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH)
+C
+C Binomial coefficients ---> ISWITCH = 1
+C Power coefficients ---> ISWITCH = 2
+C Pochhammer coefficients ---> ISWITCH = 3
+C Pochhammer coefficients ---> ISWITCH = 4 (negative argument)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Sep 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC
+C
+ ONEC=(1.D0,0.D0)
+C
+ COEF(0,0)=ONEC
+ COEF(1,0)=ONEC
+ COEF(1,1)=ONEC
+C
+ IF(I_SWITCH.EQ.1) THEN
+C
+ DO N=2,N_APP-1
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=DCMPLX(N)
+C
+ DO K=2,N
+C
+ COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K)
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.2) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=BETA+DFLOAT(N)
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.3) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.4) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ &OMEGA)
+C
+C This subroutine computes Levin-type transforms of
+C a given sequence SN(N,1)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1:
+ &N_ORD_M)
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC
+ COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2
+C
+ CHARACTER*1 OMEGA
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Recovery of the original series elements
+C
+ DO N=N_INI,N_APP
+C
+ AN(N)=SN(N,0)-SN(N-1,0)
+C
+ ENDDO
+C
+C
+C Choice of the remainder estimate omega_n
+C
+C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000)
+C
+C
+ IF(OMEGA.EQ.'U') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*(DFLOAT(N)+BETA)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'V') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1))
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'T') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'D') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N+1)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'E') THEN
+C
+ MAX_N=N_APP-2
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+2)/AN(N+1)
+ ENDDO
+C
+ ENDIF
+C
+C Choice of the Levin-type transform
+C
+C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10)
+C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10)
+C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10)
+C I_WN = 4 ---> C-type (eq 3-16c p 11)
+C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70)
+C I_WN = 6 ---> R-type (eq 7.14-12 p 47)
+C
+C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004)
+C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989)
+C
+C
+C Check for the possibility of L extension (the standard case is L = 0)
+C
+ IF(L.GT.0) THEN
+ IF(I_WN.EQ.1) THEN
+ CALL COEFFICIENTS(MAX_N,COEL,BETA,2)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.2) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,3)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.3) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,4)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ENDIF
+ ENDIF
+C
+ DO N=N_INI,MAX_N
+C
+ X=BETA+DFLOAT(N)
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ XK=DFLOAT(K)
+ XXK=X+XK
+C
+ IF(I_WN.EQ.1) THEN
+ INC=XXK/(XXK+ONEC)
+ COEF(N,K)=X*(INC**K)/XXK
+ ELSEIF(I_WN.EQ.2) THEN
+ COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK))
+ ELSEIF(I_WN.EQ.3) THEN
+ COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC)
+ ELSEIF(I_WN.EQ.4) THEN
+ SUM_1=ZEROC
+ SUM_2=ZEROC
+ DO J=0,K
+ SUM_1=SUM_1+ALPHA*XXK
+ SUM_2=SUM_2+ALPHA*(XXK+ONEC)
+ ENDDO
+ COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2)
+ ELSEIF(I_WN.EQ.5) THEN
+ COEF(N,K)=ONEC
+ ELSEIF(I_WN.EQ.6) THEN
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computation of the recurrence relation for numerator
+C and denominator
+C
+ DO N=N_INI,MAX_N
+C
+C Starting values
+C
+ NUM(N,0)=SN(N,0)/WN(N)
+ DEN(N,0)=ONEC/WN(N)
+ SN(N,0)=NUM(N,0)/DEN(N,0)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,MAX_N-K-1
+C
+ IF(I_WN.NE.6) THEN
+ NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K)
+ DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K)
+ ELSE
+ NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N))
+ DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N))
+ ENDIF
+ SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+C This subroutine computes the interpolation
+C points used in some algorithms
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 ALPHA,BETA
+C
+ DO N=0,N_APP
+C
+ IF(I_XN.EQ.1) THEN
+ XN(N)=(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.2) THEN
+ XN(N)=BETA+DFLOAT(N)
+ ELSEIF(I_XN.EQ.3) THEN
+ XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.4) THEN
+ XN(N)=(BETA+DFLOAT(N))**ALPHA
+ ELSEIF(I_XN.EQ.5) THEN
+ XN(N)=((2.D0**N)/BETA)**ALPHA
+ ENDIF
+C
+ ENDDO
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C This subroutine computes the G_N series used to describe
+C the correction on the remainder estimate
+C
+C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n}
+C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation)
+C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.)
+C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n}
+C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n}
+C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne)
+C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Computing binomial coefficients
+C
+ IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1)
+C
+ DO N=0,N_APP
+C
+ GN(N,0,-1)=ZEROC
+ GN(N,0,0)=ONEC
+ MONE=-ONEC
+C
+ DO I=1,N_APP
+C
+ IF(I_GN.EQ.1) THEN
+ GN(N,0,I)=GN(N,0,I-1)*XN(N)
+ ELSEIF(I_GN.EQ.2) THEN
+ GN(N,0,I)=XN(N+I-1)
+ ELSEIF(I_GN.EQ.3) THEN
+ GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0)
+ ELSEIF(I_GN.EQ.4) THEN
+ GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N)
+ ELSEIF(I_GN.EQ.5) THEN
+ GN(N,0,I)=GN(N,0,I-1)/XN(N)
+ ELSEIF(I_GN.EQ.6) THEN
+ MONE=-MONE
+ SUM_J=ZEROC
+ ONE=-ONEC
+ DO J=0,I
+ ONE=-ONE
+ SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0)
+ ENDDO
+ GN(N,0,I)=MONE*SUM_J
+ ELSEIF(I_GN.EQ.7) THEN
+ IF(I.GT.1) THEN
+ GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0)
+ ELSE
+ GN(N,0,I)=SN(N,0)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,
+ &K_MAX,N_COEF,I_COL,ACC,RHO,SN)
+C
+C This subroutine checks the convergence of the acceleration process.
+C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table
+C of SN(n,k)that contains equal values (SMALL being the accepted error)
+C
+C This way, both the column convergence (k fixed and n increasing)
+C and the diagonal convergence (n=k increasing) are considered
+C
+C Important note: in some algorithms, such as the epsilon one, only
+C odd columns are meaningful. If I_COL = 0, all
+C columns are taken into account while for I_COL = 2
+C only even columns are considered
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2011
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ REAL*8 ACC,REF,COMP,RHO
+C
+C Step for the columns comparison and change of the size
+C of the square when only even columns should be considered
+C
+ IF(I_COL.EQ.0) THEN
+ I_STEP=1
+ N_SQUARE=N_TABLE
+ N_START=N_TABLE
+ ELSEIF(I_COL.EQ.2) THEN
+ I_STEP=2
+ N_SQUARE=N_TABLE+N_TABLE-1
+ IF(MOD(N_SQUARE,2).EQ.0) THEN
+ N_START=N_SQUARE
+ ELSE
+ N_START=N_SQUARE+1
+ ENDIF
+ ENDIF
+C
+C Positionning the bottom right corner of the square: (N,K),
+C starting from (N_START,N_START). If only even columns
+C should be considered, N_START must be even
+C
+ K_FIN=J_FIN/N_COEF
+ IF(K_FIN.LT.N_START) THEN
+ I_CONV=0
+ GOTO 10
+ ENDIF
+C
+ DO K=N_START,K_FIN+N_START-1,I_STEP
+ IF(K.GT.K_MAX) GOTO 20
+ DO N=N_START,K_FIN-K,I_STEP
+C
+C Checking the values (N1,K1) in the selected square
+C
+ REF=CDABS(SN(N,K))
+ I_CONV=1
+C
+ DO N1=0,N_START,I_STEP
+ NN=N-N1
+ DO K1=0,N_START,I_STEP
+C
+ KK=K-K1
+ COMP=CDABS(REF-SN(NN,KK))
+ IF(COMP.GT.ACC) THEN
+ I_CONV=0
+ ENDIF
+C
+ ENDDO
+ ENDDO
+C
+ IF(I_CONV.EQ.1) THEN
+C
+C All values in the square are equal (within ACC):
+C Spectral radius taken as the left top corner value
+C
+ N_ACC=N-N_START+I_STEP
+ K_ACC=K-N_START+I_STEP
+ RHO=REF
+ GOTO 10
+ ENDIF
+C
+ ENDDO
+ 20 CONTINUE
+ ENDDO
+C
+ 10 RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*)
+C
+C This subroutine checks the convergence of the power method or of
+C the Rayleigh quotient method at level JORD without convergence
+C acceleration. For convergence, there must be N_TABLE equal values
+C (ACC being the accepted error) of SN
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ REAL ACC,COMP,R_SN(N_ORD_M)
+C
+ NCONV=0
+ DO J=JORD,JORD-N_TABLE,-1
+ COMP=ABS(R_SN(J)-R_SN(J-1))
+ IF(COMP.LE.ACC) THEN
+ NCONV=NCONV+1
+ ENDIF
+ ENDDO
+C
+ IF(NCONV.EQ.N_TABLE-1) RETURN 1
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/remain_series.f b/src/msspec/spec/fortran/eig/mi/remain_series.f
new file mode 100644
index 0000000..0500645
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/remain_series.f
@@ -0,0 +1,78 @@
+C
+C=======================================================================
+C
+ SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C This subroutine computes the G_N series used to describe
+C the correction on the remainder estimate
+C
+C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n}
+C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation)
+C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.)
+C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n}
+C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n}
+C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne)
+C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Computing binomial coefficients
+C
+ IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1)
+C
+ DO N=0,N_APP
+C
+ GN(N,0,-1)=ZEROC
+ GN(N,0,0)=ONEC
+ MONE=-ONEC
+C
+ DO I=1,N_APP
+C
+ IF(I_GN.EQ.1) THEN
+ GN(N,0,I)=GN(N,0,I-1)*XN(N)
+ ELSEIF(I_GN.EQ.2) THEN
+ GN(N,0,I)=XN(N+I-1)
+ ELSEIF(I_GN.EQ.3) THEN
+ GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0)
+ ELSEIF(I_GN.EQ.4) THEN
+ GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N)
+ ELSEIF(I_GN.EQ.5) THEN
+ GN(N,0,I)=GN(N,0,I-1)/XN(N)
+ ELSEIF(I_GN.EQ.6) THEN
+ MONE=-MONE
+ SUM_J=ZEROC
+ ONE=-ONEC
+ DO J=0,I
+ ONE=-ONE
+ SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0)
+ ENDDO
+ GN(N,0,I)=MONE*SUM_J
+ ELSEIF(I_GN.EQ.7) THEN
+ IF(I.GT.1) THEN
+ GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0)
+ ELSE
+ GN(N,0,I)=SN(N,0)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/mi/spec_rad_power.f b/src/msspec/spec/fortran/eig/mi/spec_rad_power.f
new file mode 100644
index 0000000..a9e222a
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/mi/spec_rad_power.f
@@ -0,0 +1,348 @@
+C
+C=======================================================================
+C
+ SUBROUTINE SPEC_RAD_POWER(JE,E_KIN)
+C
+C This subroutine stores the G_o T kernel matrix and computes
+C its spectral radius using the power method. In addition,
+C a scalar convergence acceleration method can be used to
+C refine the results.
+C
+C Author : D. Sebilleau
+C
+C Last modified : 4 Feb 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE TRANS_MOD
+C
+C
+C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD
+C
+ INTEGER NN(0:N_ORD_M)
+C
+ REAL R_SN(N_ORD_M),R_SN1(N_ORD_M),R_SN2(N_ORD_M)
+C
+ COMPLEX*16 TLK,SUM_L,EXPKJ,ONEC,MULT
+ COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO)
+ COMPLEX*16 X(LINMAX*NATCLU_M),Y(LINMAX*NATCLU_M)
+ COMPLEX*16 AX(LINMAX*NATCLU_M),AY(LINMAX*NATCLU_M),SUM_AX,SUM_AY
+ COMPLEX*16 HL1(0:NLTWO),A(LINMAX*NATCLU_M,LINMAX*NATCLU_M)
+ COMPLEX*16 ZEROC,IC,JC,JMULT
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
+ REAL*8 NORMX2,NORMY2,NORMAX2,NORMAY2,RLIN
+C
+C
+ CHARACTER*10 METH
+ CHARACTER*24 OUTFILE,PATH
+C
+ DATA PI /3.1415926535898D0/
+C
+ ONEC=(1.D0,0.D0)
+ IC=(0.0D0,1.0D0)
+ ZEROC=(0.D0,0.D0)
+ IBESS=3
+ N_CALL=0
+ N_ACC=0
+ K_ACC=0
+ I_CONV=0
+C
+ IF(N_MAX.GT.N_ORD_M) THEN
+ WRITE(IUO1,99) N_MAX
+ STOP
+ ENDIF
+C
+C Starting vector for power method:
+C
+C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO
+C
+ JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0)
+ JMULT=JC**EXPO
+C
+ WRITE(IUO1,6)
+C
+C Construction of the the multiple scattering kernel matrix G_o T
+C
+C Elements are stored in A(KLIN,JLIN) using linear indices
+C JLIN and KLIN representing (J,LJ) and (K,LK)
+C
+ JLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ XJ=SYM_AT(1,JATL)
+ YJ=SYM_AT(2,JATL)
+ ZJ=SYM_AT(3,JATL)
+C
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ JLIN=JLIN+1
+C
+ KLIN=0
+ DO KTYP=1,N_PROT
+ NBTYPK=NATYP(KTYP)
+ LMK=LMAX(KTYP,JE)
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.NE.JATL) THEN
+ XKJ=DBLE(SYM_AT(1,KATL)-XJ)
+ YKJ=DBLE(SYM_AT(2,KATL)-YJ)
+ ZKJ=DBLE(SYM_AT(3,KATL)-ZJ)
+ RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
+ KRKJ=DBLE(VK(JE))*RKJ
+ ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*
+ & RKJ)
+ EXPKJ=(XKJ+IC*YKJ)/RKJ
+ ZDKJ=ZKJ/RKJ
+ CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,
+ & LMJ+LMK)
+ CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,
+ & HL1)
+ ENDIF
+C
+ DO LK=0,LMK
+ L_MIN=ABS(LK-LJ)
+ L_MAX=LK+LJ
+ TLK=DCMPLX(TL(LK,1,KTYP,JE))
+ DO MK=-LK,LK
+ KLIN=KLIN+1
+ A(KLIN,JLIN)=ZEROC
+ SUM_L=ZEROC
+ IF(KATL.NE.JATL) THEN
+ CALL GAUNT2(LK,MK,LJ,MJ,GNT)
+C
+ DO L=L_MIN,L_MAX,2
+ M=MJ-MK
+ IF(ABS(M).LE.L) THEN
+ SUM_L=SUM_L+(IC**L)*
+ & HL1(L)*YLM(L,M)*GNT(L)
+ ENDIF
+ ENDDO
+ SUM_L=SUM_L*ATTKJ*4.D0*PI*IC
+ ELSE
+ SUM_L=ZEROC
+ ENDIF
+C
+ IF(KATL.NE.JATL) THEN
+ A(KLIN,JLIN)=TLK*SUM_L
+ ENDIF
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ NLIN=JLIN
+C
+C Power method approximation of the spectral radius :
+C
+C SR(A) = lim ||A x||^n / ||x||^n
+C n --> +infty
+C for any starting vector x
+C
+ RLIN=DFLOAT(NLIN)
+C
+C Initialization the vectors and their squared norm
+C
+ MULT=JMULT
+C
+ AX(1)=ONEC
+ AY(1)=ONEC
+C
+ NORMAX2=1.D0
+ NORMAY2=1.D0
+C
+ DO ILIN=2,NLIN
+C
+ AX(ILIN)=AX(ILIN-1)*MULT
+ AY(ILIN)=AY(ILIN-1)*MULT
+ NORMAX2=NORMAX2+DREAL(AX(ILIN)*DCONJG(AX(ILIN)))
+ NORMAY2=NORMAY2+DREAL(AY(ILIN)*DCONJG(AY(ILIN)))
+C
+ ENDDO
+C
+C Computation of the vectors and their squared norm
+C
+C X ---> A*X
+C
+ 120 IF(N_CALL.EQ.0) THEN
+ J_INI=1
+ ELSE
+ J_INI=N_CALL*N_ITER+1
+ ENDIF
+ J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX)
+C
+ IF(J_INI.GT.J_FIN) GOTO 112
+C
+ DO JORD=J_INI,J_FIN
+C
+ NORMX2=NORMAX2
+ NORMY2=NORMAY2
+C
+ DO JLIN=1,NLIN
+C
+ X(JLIN)=AX(JLIN)
+ Y(JLIN)=AY(JLIN)
+C
+ ENDDO
+C
+ NORMAX2=0.D0
+ NORMAY2=0.D0
+C
+ DO ILIN=1,NLIN
+C
+ SUM_AX=ZEROC
+ SUM_AY=ZEROC
+C
+ DO JLIN=1,NLIN
+C
+ SUM_AX=SUM_AX+A(ILIN,JLIN)*X(JLIN)
+ SUM_AY=SUM_AY+A(JLIN,ILIN)*Y(JLIN)
+C
+ ENDDO
+C
+ AX(ILIN)=SUM_AX
+ AY(ILIN)=SUM_AY
+ NORMAX2=NORMAX2+DREAL(SUM_AX*DCONJG(SUM_AX))
+ NORMAY2=NORMAY2+DREAL(SUM_AY*DCONJG(SUM_AY))
+C
+ ENDDO
+C
+ R_SN1(JORD)=SQRT(REAL(NORMAX2/NORMX2))
+ R_SN2(JORD)=SQRT(REAL(NORMAY2/NORMY2))
+ R_SN(JORD)=SQRT(R_SN1(JORD)*R_SN2(JORD))
+C
+ ENDDO
+C
+ IF(J_INI.EQ.1) THEN
+ WRITE(IUO1,10)
+ WRITE(IUO1,46) NLIN
+ WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ ENDIF
+C
+ WRITE(IUO1,10)
+ WRITE(IUO1,44) R_SN(JORD-1)
+ WRITE(IUO1,47) JORD-1
+C
+ 112 IF(I_ACC.GE.1) THEN
+C
+C Convergence acceleration on the results whenever necessary
+C
+ CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ & R_SN,SN,METH)
+ IF((I_CONV.EQ.1).AND.(I_ACC.EQ.1)) GOTO 111
+ IF((I_CONV.EQ.0).OR.(I_ACC.EQ.2)) GOTO 120
+C
+ 111 WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ WRITE(IUO1,10)
+ WRITE(IUO1,52) METH
+ WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC))
+ WRITE(IUO1,49) N_ACC
+ WRITE(IUO1,51) K_ACC
+C
+ IF(I_ACC.EQ.2) THEN
+ OPEN(UNIT=35, FILE='div/n_k_table.lis', STATUS='unknown')
+ DO L=0,K_MAX
+ NN(L)=L
+ ENDDO
+ WRITE(35,*) ' '
+ WRITE(35,*) ' (N,K) TABLE OF ',METH,'
+ & METHOD'
+ WRITE(35,*) ' '
+ WRITE(35,198) (NN(K),K=0,K_MAX)
+ WRITE(35,199)
+ WRITE(35,*) ' '
+ DO N=0,K_MAX
+ WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N)
+ WRITE(35,*) ' '
+ ENDDO
+ ENDIF
+C
+ WRITE(IUO1,10)
+ WRITE(IUO1,60)
+ IF(I_ACC.EQ.2) THEN
+ WRITE(IUO1,210)
+ ENDIF
+C
+ ENDIF
+C
+ WRITE(IUO2,*) E_KIN,R_SN(JORD-1)
+C
+ RETURN
+C
+ 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','---------
+ &--------')
+ 6 FORMAT(/,11X,'---------------- POWER METHOD ANALYSIS ','--------
+ &--------')
+ 10 FORMAT(11X,'-',54X,'-')
+ 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-')
+ 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-')
+ 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-')
+ 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X,
+ &'-')
+ 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-')
+ 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-')
+ 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5,
+ &3X,'-')
+ 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5,
+ &3X,'-')
+ 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8,
+ &3X,'-')
+ 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8,
+ &3X,'-')
+ 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5,
+ &3X,'-')
+ 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8,
+ &3X,'-')
+ 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ',
+ &'CONVERGES ',4X,'-')
+ 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8,
+ &3X,'-')
+ 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10,
+ &1X,'-')
+ 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/
+ &,11X,'-',18X,'SCATTERING SERIES',19X,'-')
+ 60 FORMAT(11X,'----------------------------------------','----------
+ &------',/)
+ 61 FORMAT(11X,'----------------------------------------','----------
+ &------')
+ 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,
+ &'-')
+ 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.
+ &3,')',8X,'-')
+ 75 FORMAT(' ')
+ 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV')
+ 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3)
+ 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5)
+ 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,')
+ &')
+ 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE','
+ &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ',
+ &I5, 6X,' >>>>>>>>>>',///)
+ 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3)
+ 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :')
+ 110 FORMAT(2X,'-------------------------------')
+ 198 FORMAT(' K',50(I3,4X))
+ 199 FORMAT(' N')
+ 200 FORMAT(I3,50(2X,F5.3))
+ 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ',
+ &'IN /div/n_k_table.lis',//)
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/acc_conv.f b/src/msspec/spec/fortran/eig/pw/acc_conv.f
new file mode 100644
index 0000000..5466ae0
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/acc_conv.f
@@ -0,0 +1,194 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ &R_SN,SN,METH)
+C
+C Use of the various acceleration scheme on a scalar series
+C
+C AITK : Aitken, modified Aitken
+C RICH : Richardson
+C SALZ : Salzer
+C EPSI : epsilon
+C EPSG : generalized epsilon
+C RHOA : rho
+C THET : theta
+C LEGE : Legendre-Toeplitz
+C CHEB : Chebyshev-Toeplitz
+C OVER : Overholt
+C DURB : Durbin
+C DLEV : Levin d-transform !! differ by the
+C TLEV : Levin t-transform !! choice of w_n
+C ULEV : Levin u-transform !! the remainder
+C VLEV : Levin v-transform !! estimate given
+C ELEV : Levin e-transform !! by I_WN
+C EULE : generalized Euler transform
+C GBWT : Germain-Bronne-Wimp transform
+C VARI : various algorithms : Weniger, BDG, iterated rho
+C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2
+C EALG : E-algorithm
+C
+C SN : series to be accelerated
+C XN : auxilliary series (chosen with I_XN) : interpolation points
+C GN : auxilliary series (chosen with I_GN) ---> E algorithm
+C
+C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1)
+C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K)
+C so N_DIV=2
+C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are
+C meaningful. Hence the K_MAX size
+C
+C COL_M : type of columns meaningful in the (n,k) table (example: even columns
+C for the epsilon algorithm)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 1 Mar 2013
+C
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVACC_MOD, L => LEVIN
+ USE CONVTYP_MOD
+C
+ PARAMETER (N_METH=24)
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ COMPLEX*16 ZEROC,ONEC
+C
+ REAL*8 R2_SN(N_ORD_M),RHO
+C
+ REAL R_SN(N_ORD_M)
+C
+ INTEGER N_DIV(N_METH)
+C
+ CHARACTER*3 COL_M(N_METH)
+ CHARACTER*4 SCHE(N_METH)
+ CHARACTER*10 NAME(N_METH),METH
+C
+ DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE',
+ 1 'CHEB','OVER','DURB','DLEV','TLEV','ULEV',
+ 2 'VLEV','ELEV','EULE','GBWT','EALG','SALZ',
+ 3 'VARI','ITHE','EPSG','NONE','NONE','NONE'/
+ DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ',
+ 1 ' RHO ',' THETA ',' LEGENDRE ',
+ 2 'CHEBYSHEV ',' OVERHOLT ',' DURBIN ',
+ 3 ' D LEVIN ',' T LEVIN ',' U LEVIN ',
+ 4 ' V LEVIN ',' E LEVIN ',' EULER ',
+ 5 ' GBW ',' E ',' SALZER ',
+ 6 ' VARIA ','ITER THETA',' EPSILON G',
+ 7 ' ',' ',' '/
+ DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL',
+ 1 'ALL','ALL','ALL','ALL','ALL','ALL',
+ 2 'ALL','ALL','ALL','ALL','ALL','ALL',
+ 3 'ALL','ALL','EVE','ALL','ALL','ALL'/
+ DATA N_DIV /2,1,1,2,2,1,
+ 1 1,1,4,1,1,1,
+ 2 1,1,1,1,1,1,
+ 3 2,4,1,1,1,1/
+C
+ J_NAME=0
+ I_COL=0
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ DO J=J_INI,J_FIN
+ R2_SN(J)=DBLE(R_SN(J))
+ ENDDO
+C
+C Finding the name of the method
+C
+ DO JM=1,N_METH
+C
+ IF(METHOD.EQ.SCHE(JM)) THEN
+ J_NAME=JM
+ K_MAX=N_MAX/N_DIV(JM)
+ N_COEF=N_DIV(JM)
+ IF(COL_M(JM).EQ.'EVE') I_COL=2
+ ENDIF
+C
+ ENDDO
+C
+C Initialization of array SN
+C
+ DO N=J_INI,J_FIN
+C
+ DO K=-1,J_FIN
+C
+ SN(N,K)=ZEROC
+C
+ ENDDO
+C
+ ENDDO
+C
+C Initialisation of the schemes :
+C
+C -- SN(N,0) is the series to be accelerated --
+C
+ SN(0,-1)=ZEROC
+ SN(0,0)=ONEC
+C
+ DO N=J_INI,J_FIN
+C
+ SN(N,-1)=ZEROC
+ SN(N,0)=R2_SN(N)
+C
+ ENDDO
+C
+ CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C Check for convergence : all results equal within ACC
+C in a N_TABLE x N_TABLE square
+C
+ IF(I_CONV.EQ.0) THEN
+ CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX,
+ & N_COEF,I_COL,ACC,RHO,SN)
+ ENDIF
+C
+ IF(METHOD(2:4).EQ.'LEV') THEN
+ METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN)
+ ELSE
+ METH=NAME(J_NAME)
+ ENDIF
+C
+C Incrementation of the number of calls to this subroutine
+C if convergence has not been achieved
+C
+ IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN
+ N_CALL=N_CALL+1
+ ELSE
+ GOTO 10
+ ENDIF
+C
+C Printing the results in the check file
+C
+ 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',5X,'*')
+ 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*')
+ 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*')
+ 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6,
+ &',',E12.6,')',5X,'*')
+ 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*')
+ 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <---
+ &convergence',2X,'*')
+ 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',3X,' * <--- convergence')
+ 35 FORMAT(2X,'***************************************','************
+ &************************')
+ 45 FORMAT(2X,'* ','
+ & *')
+ 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,')
+ & *')
+ 75 FORMAT(2X,'* Order Taylor ',20X,A10,'
+ & *')
+ 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'*
+ & order ',60X,'*')
+ 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ',
+ &'>>>>>>>>>>',//)
+C
+ 10 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/acc_scal.f b/src/msspec/spec/fortran/eig/pw/acc_scal.f
new file mode 100644
index 0000000..7b25042
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/acc_scal.f
@@ -0,0 +1,693 @@
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C This subroutine computes the scalar convergence acceleration
+C for various methods
+C
+C Note: let us consider that the (n,k) space pattern indicates
+C that we need S(n,k),...,S(n+p,k) in order to compute
+C S(n,k+1). We call N the maximum value of n for which
+C the S(n,0) are known. Then, to compute S(n,k+1), we
+C we need to know up to S(n+pk+p,0). This means that
+C the value of n is limited to N-pk-p.
+C
+C Author : D. Sebilleau
+C
+C Last modified : 14 Mar 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE CONVACC_MOD, L => LEVIN
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5
+ COMPLEX*16 NUM,DEN,FIR
+ COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK
+C
+ REAL*8 EPS,EPSS,MUL
+C
+ CHARACTER*4 METHOD
+C
+ DATA EPS,EPSS /1.D-12,1.D-150/
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ N_APP=J_FIN
+ N_INI=0
+C
+ IF(METHOD.EQ.'AITK') THEN
+C
+C The iterated Aitken and modified Aitken schemes
+C
+C H. H. H. Homeier, Num. Alg. 8, 47 (1994)
+C
+C I_VA = 1 : iterated Aitken (p 49 eq 5)
+C I_VA = 2 : modified iterated Aitken (p 49 eq 9)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ IF(I_VA.EQ.1) THEN
+ XK=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1)
+ ENDIF
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ IF(CDABS(DELTA2).LT.EPSS) THEN
+ DELTA3=ZEROC
+ ELSE
+ DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1)
+ ENDIF
+ SN(N,K+1)=SN(N,K)-XK*DELTA3
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RICH') THEN
+C
+C The Richardson scheme
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=SN(N+1,0)-SN(N,0)
+ DELTA2=SN(N+K+2,0)-SN(N+K+1,0)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 10 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'SALZ') THEN
+C
+C The Salzer scheme
+C
+C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=DFLOAT(N+K+2)
+ DELTA2=DFLOAT(N+1)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 11 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'GBWT') THEN
+C
+C The GBW scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C (eq 6.1-5 p33)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=XN(N)
+ DELTA2=XN(N+K+1)
+ IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 80 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSI') THEN
+C
+C The epsilon scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1)
+C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 20
+ IF(I_VA.EQ.1) THEN
+ VAR=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ VAR=XN(N+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ VAR=XN(N+K+1)-XN(N+K)
+ ENDIF
+ SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+C
+ 20 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSG') THEN
+C
+C The generalized epsilon scheme
+C
+C M. N. Barber and C. J. Hamer,
+C J. Austral. Math. Soc. (Series B) 23, 229 (1982)
+C
+C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed)
+C DELTA2 = 0 implies SN(N+1,K) = SN(N,K)
+C ---> convergence achieved for (N,K)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP,2
+C
+ IF(I_VA.EQ.1) THEN
+ SI(K)=ALPHA
+ SI(K+1)=ALPHA
+ ELSEIF(I_VA.EQ.2) THEN
+ SI(K)=ZEROC
+ SI(K+1)=-ONEC
+ ENDIF
+C
+ ENDDO
+C
+ VAR=ONEC
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ NK(N,-1)=ZEROC
+ DELTA2=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 23
+ NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2
+ DELTA1=(NK(N,K)-NK(N-1,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 23
+ SN(N,K+1)=SN(N,K)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+ 23 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RHOA') THEN
+C
+C The rho scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1)
+C I_VA = 2 : Standard rho (p 34 eq 6.2-2)
+C I_VA = 3 : (p 37 eq 6.3-3) ???????
+C
+C ALPHA is the decay parameter. It is
+C generally advised to take it as
+C an integer to ensure convergence
+C
+ IF(DREAL(ALPHA).LT.0.0D0) THEN
+C
+C Drummond approximation to alpha :
+C
+C (non valid for the Taylor expansion
+C of 1/1+x as in this case the denominator
+C is always zero)
+C
+ DO N=N_INI,N_APP
+C
+ DELTA1=SN(N+3,1)-SN(N+2,1)
+ DELTA2=SN(N+2,1)-SN(N+1,1)
+ DELTA3=SN(N+1,1)-SN(N,1)
+C
+ NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2)
+ DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1
+ ALPHA=NUM/DEN-ONEC
+C
+ ENDDO
+C
+ ENDIF
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ IF(I_VA.NE.3) THEN
+ DEN=(SN(N+1,K)-SN(N,K))
+ ELSE
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ DELTA3=(SN(N+1,K)-SN(N,K))
+ DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)-
+ & XN(N))*DELTA2
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPS) GOTO 30
+ IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=(DFLOAT(K+1)+ALPHA)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+K+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3
+ ENDIF
+C
+ SN(N,K+1)=SN(N+1,K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 30 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'THET') THEN
+C
+C The theta scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C E. Calicetti et al, Phys. Rep. 446, 1 (2007)
+C
+C I_VA = 1 : standard formulation (eq 71 p 19)
+C I_VA = 2 : generalized formulation (eq 10.1-10 p 74)
+C
+ KMAX2=(N_APP-2)/2
+C
+ N_COUNT=0
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,KMAX2
+C
+ IF(I_VA.EQ.3) GOTO 51
+C
+ DO N=N_INI,N_APP-2*K-1
+C
+ DEN=SN(N+1,2*K)-SN(N,2*K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 40
+ IF(I_VA.EQ.1) THEN
+ NUM=1.D0
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+2*K+1)-XN(N)
+ ENDIF
+ SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 40 CONTINUE
+C
+ ENDDO
+C
+ DO N=N_INI,N_APP-4*K-2
+C
+ DELTA2=SN(N+2,2*K)-SN(N+1,2*K)
+ DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1)
+ DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1)
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=DELTA2*DELTA4
+ DEN=DELTA4-DELTA3
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4
+ DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN(
+ & N))*DELTA4
+ ENDIF
+ IF(CDABS(DEN).LT.EPSS) GOTO 50
+C
+ SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 50 CONTINUE
+C
+ ENDDO
+ GOTO 52
+C
+ 51 DO N=N_INI,N_APP-4*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ DELTA4=DELTA3-DELTA2
+ DELTA5=DELTA2-DELTA1
+ DEN=DELTA3*DELTA5-DELTA1*DELTA4
+ IF(CDABS(DEN).LT.EPSS) GOTO 53
+C
+ NUM=DELTA1*DELTA2*DELTA4
+ SN(N,K+1)=SN(N+1,K)-NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 53 CONTINUE
+C
+ ENDDO
+C
+ 52 CONTINUE
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'LEGE') THEN
+C
+C The Legendre-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.3), (4.4) p. 231
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1)
+ DELTA2=DFLOAT(K)/DFLOAT(K+1)
+C
+ DO N=N_INI,N_APP-K-1
+ SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN(
+ & N,K-1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'CHEB') THEN
+C
+C The Chebyshev-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.4) - (4.9) p. 231
+C
+ SI(0)=ONEC
+ SI(1)=3.D0*ONEC
+C
+ DO N=N_INI,N_APP-1
+C
+ TN(N,0)=SN(N,0)
+ TN(N,1)=SN(N,0)+2.D0*TN(N+1,0)
+ SN(N,0)=TN(N,0)/SI(0)
+ SN(N,1)=TN(N,1)/SI(1)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=1,N_APP-1
+C
+ SI(K+1)=6.D0*SI(K)-SI(K-1)
+C
+ DO N=N_INI,N_APP-K-1
+C
+ TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1)
+ SN(N,K+1)=TN(N,K+1)/SI(K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'OVER') THEN
+C
+C The Overholt scheme
+C
+C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996)
+C (eq 36 p 85)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=ONEC
+ DELTA2=ONEC
+ MUL=1.D0
+C
+ DO I=1,K+1
+C
+ DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0))
+ DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0))
+ MUL=MUL*EPS
+C
+ ENDDO
+C
+ IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 60 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'DURB') THEN
+C
+C The Durbin scheme
+C
+C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007)
+C (eq 25 p 185)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-4*K-4
+C
+ DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+
+ & 3,K)+SN(N,K)*SN(N+4,K)
+ DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN(
+ & N,K)+SN(N+4,K)
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 70
+ SN(N,K+1)=DELTA1/DELTA2
+ N_COUNT=N_COUNT+1
+C
+ 70 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD(2:4).EQ.'LEV') THEN
+C
+C The Levin schemes
+C
+ CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ & METHOD(1:1))
+C
+ ELSEIF(METHOD.EQ.'EULE') THEN
+C
+C The generalized Euler scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'VARI') THEN
+C
+C Various schemes
+C
+C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1)
+C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2)
+C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3)
+C I_VA = 4 : iterated rho scheme
+C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ IF(I_VA.EQ.1) THEN
+ A=BETA+DFLOAT(N)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.2) THEN
+ A=ALPHA+DFLOAT(N+K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.3) THEN
+ A=ALPHA+DFLOAT(N-K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.4) THEN
+ A=XN(N+2*K+2)-XN(N)
+ B=XN(N+2*K+1)-XN(N)
+ C=XN(N+2*K+2)-XN(N+1)
+ ELSEIF(I_VA.EQ.5) THEN
+ A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA)
+ B=ONEC
+ C=ONEC
+ ENDIF
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DEN=B*DELTA2-C*DELTA1
+ IF(CDABS(DEN).LT.EPSS) GOTO 81
+ SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN
+ N_COUNT=N_COUNT+1
+C
+ 81 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'ITHE') THEN
+C
+C Iterated theta schemes
+C
+C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6)
+C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5)
+C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-3*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ IF(I_VA.EQ.1) THEN
+ NUM=-DELTA1*DELTA2*(DELTA3-DELTA2)
+ DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2)
+ DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2)
+ DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+2,K)
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPSS) GOTO 90
+ SN(N,K+1)=FIR+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 90 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EALG') THEN
+C
+C E algorithm
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+ CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C Computing the GN(N,K,I)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 91
+ DELTA1=GN(N,K-1,K)/DEN
+C
+ DO I=0,N_APP
+C
+ NUM=GN(N+1,K-1,I)-GN(N,K-1,I)
+ GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1
+C
+ ENDDO
+C
+ 91 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computing SN(N,K)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP-K
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 92
+ DELTA1=GN(N,K-1,K)/DEN
+ SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1
+C
+ 92 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/check_conv.f b/src/msspec/spec/fortran/eig/pw/check_conv.f
new file mode 100644
index 0000000..2553cbf
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/check_conv.f
@@ -0,0 +1,97 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,
+ &K_MAX,N_COEF,I_COL,ACC,RHO,SN)
+C
+C This subroutine checks the convergence of the acceleration process.
+C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table
+C of SN(n,k)that contains equal values (SMALL being the accepted error)
+C
+C This way, both the column convergence (k fixed and n increasing)
+C and the diagonal convergence (n=k increasing) are considered
+C
+C Important note: in some algorithms, such as the epsilon one, only
+C odd columns are meaningful. If I_COL = 0, all
+C columns are taken into account while for I_COL = 2
+C only even columns are considered
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2011
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ REAL*8 ACC,REF,COMP,RHO
+C
+C Step for the columns comparison and change of the size
+C of the square when only even columns should be considered
+C
+ IF(I_COL.EQ.0) THEN
+ I_STEP=1
+ N_SQUARE=N_TABLE
+ N_START=N_TABLE
+ ELSEIF(I_COL.EQ.2) THEN
+ I_STEP=2
+ N_SQUARE=N_TABLE+N_TABLE-1
+ IF(MOD(N_SQUARE,2).EQ.0) THEN
+ N_START=N_SQUARE
+ ELSE
+ N_START=N_SQUARE+1
+ ENDIF
+ ENDIF
+C
+C Positionning the bottom right corner of the square: (N,K),
+C starting from (N_START,N_START). If only even columns
+C should be considered, N_START must be even
+C
+ K_FIN=J_FIN/N_COEF
+ IF(K_FIN.LT.N_START) THEN
+ I_CONV=0
+ GOTO 10
+ ENDIF
+C
+ DO K=N_START,K_FIN+N_START-1,I_STEP
+ IF(K.GT.K_MAX) GOTO 20
+ DO N=N_START,K_FIN-K,I_STEP
+C
+C Checking the values (N1,K1) in the selected square
+C
+ REF=CDABS(SN(N,K))
+ I_CONV=1
+C
+ DO N1=0,N_START,I_STEP
+ NN=N-N1
+ DO K1=0,N_START,I_STEP
+C
+ KK=K-K1
+ COMP=CDABS(REF-SN(NN,KK))
+ IF(COMP.GT.ACC) THEN
+ I_CONV=0
+ ENDIF
+C
+ ENDDO
+ ENDDO
+C
+ IF(I_CONV.EQ.1) THEN
+C
+C All values in the square are equal (within ACC):
+C Spectral radius taken as the left top corner value
+C
+ N_ACC=N-N_START+I_STEP
+ K_ACC=K-N_START+I_STEP
+ RHO=REF
+ GOTO 10
+ ENDIF
+C
+ ENDDO
+ 20 CONTINUE
+ ENDDO
+C
+ 10 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/coefficients.f b/src/msspec/spec/fortran/eig/pw/coefficients.f
new file mode 100644
index 0000000..5d79c8b
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/coefficients.f
@@ -0,0 +1,90 @@
+C
+C=======================================================================
+C
+ SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH)
+C
+C Binomial coefficients ---> ISWITCH = 1
+C Power coefficients ---> ISWITCH = 2
+C Pochhammer coefficients ---> ISWITCH = 3
+C Pochhammer coefficients ---> ISWITCH = 4 (negative argument)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Sep 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC
+C
+ ONEC=(1.D0,0.D0)
+C
+ COEF(0,0)=ONEC
+ COEF(1,0)=ONEC
+ COEF(1,1)=ONEC
+C
+ IF(I_SWITCH.EQ.1) THEN
+C
+ DO N=2,N_APP-1
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=DCMPLX(N)
+C
+ DO K=2,N
+C
+ COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K)
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.2) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=BETA+DFLOAT(N)
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.3) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.4) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/conv_series.f b/src/msspec/spec/fortran/eig/pw/conv_series.f
new file mode 100644
index 0000000..ead0873
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/conv_series.f
@@ -0,0 +1,33 @@
+C
+C=======================================================================
+C
+ SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*)
+C
+C This subroutine checks the convergence of the power method or of
+C the Rayleigh quotient method at level JORD without convergence
+C acceleration. For convergence, there must be N_TABLE equal values
+C (ACC being the accepted error) of SN
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ REAL ACC,COMP,R_SN(N_ORD_M)
+C
+ NCONV=0
+ DO J=JORD,JORD-N_TABLE,-1
+ COMP=ABS(R_SN(J)-R_SN(J-1))
+ IF(COMP.LE.ACC) THEN
+ NCONV=NCONV+1
+ ENDIF
+ ENDDO
+C
+ IF(NCONV.EQ.N_TABLE-1) RETURN 1
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/do_main.f b/src/msspec/spec/fortran/eig/pw/do_main.f
new file mode 100644
index 0000000..32d8d6f
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/do_main.f
@@ -0,0 +1,1558 @@
+C
+C
+C ************************************************************
+C * ******************************************************** *
+C * * * *
+C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * *
+C * * EIGENVALUE CALCULATION CODE * *
+C * * * *
+C * ******************************************************** *
+C ************************************************************
+C
+C
+C
+C
+C Written by D. Sebilleau, Groupe Theorie,
+C Departement Materiaux-Nanosciences,
+C Institut de Physique de Rennes,
+C UMR CNRS-Universite 6251,
+C Universite de Rennes-1,
+C 35042 Rennes-Cedex,
+C France
+C
+C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada
+C
+C-----------------------------------------------------------------------
+C
+C As a general rule in this code, although there might be a few
+C exceptions (...), a variable whose name starts with a 'I' is a
+C switch, with a 'J' is a loop index and with a 'N' is a number.
+C
+C The main subroutines are :
+C
+C * PHDDIF : computes the photoelectron diffraction
+C formula
+C
+C * XASDIF : computes the EXAFS or XANES formula
+C depending on the energy
+C
+C * AEDDIF : computes the Auger electron diffraction
+C formula
+C
+C * FINDPATHS : generates the multiple scattering
+C paths the electron will follow
+C
+C * PATHOP : calculates the contribution of a given
+C path to the scattering path operator
+C
+C * MATDIF : computes the Rehr-Albers scattering
+C matrices
+C
+C A subroutine called NAME_A is the Auger equivalent of subroutine
+C NAME. The essentail difference between NAME and NAME_A is that
+C they do not contain the same arrays.
+C
+C Always remember, when changing the input data file, to keep the
+C format. The rule here is that the last digit of any integer or
+C character data must correspond to the tab (+) while for real data,
+C the tab precedes the point.
+C
+C Do not forget, before submitting a calculation, to check the
+C consistency of the input data with the corresponding maximal
+C values in the include file.
+C
+C-----------------------------------------------------------------------
+C
+C Please report any bug or problem to me at :
+C
+C didier.sebilleau@univ-rennes1.fr
+C
+C
+C
+C Last modified : 10 Jan 2016
+C
+C=======================================================================
+C
+ SUBROUTINE DO_MAIN()
+C
+C This routine reads the various input files and calls the subroutine
+C performing the requested calculation
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE ADSORB_MOD
+ USE APPROX_MOD
+ USE ATOMS_MOD
+ USE AUGER_MOD
+ USE BASES_MOD
+ USE CLUSLIM_MOD
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INDAT_MOD
+ USE INIT_A_MOD
+ USE INIT_L_MOD
+ USE INIT_J_MOD
+ USE INIT_M_MOD
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE LIMAMA_MOD
+ USE LPMOY_MOD
+ USE MASSAT_MOD
+ USE MILLER_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD
+ USE PARCAL_A_MOD
+ USE RELADS_MOD
+ USE RELAX_MOD
+ USE RESEAU_MOD
+ USE SPIN_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE TL_AED_MOD
+ USE TYPCAL_MOD
+ USE TYPCAL_A_MOD
+ USE TYPEM_MOD
+ USE TYPEXP_MOD
+ USE VALIN_MOD
+ USE XMRHO_MOD
+C
+ DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3)
+ DIMENSION ROT(3,3),EMET(3)
+ DIMENSION VAL2(NATCLU_M)
+ DIMENSION IRE(NATCLU_M,2)
+ DIMENSION REL(NATCLU_M),RHOT(NATM)
+ DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M)
+ DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM)
+ DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M)
+ DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M)
+ DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM)
+C
+ COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M)
+ COMPLEX TLSTAR_A
+ COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E
+ COMPLEX RHOR1STAR,RHOR2STAR
+C
+C
+C
+ CHARACTER RIEN
+ CHARACTER*1 B
+ CHARACTER*2 R
+C
+C
+C
+C
+C
+C
+ CHARACTER*30 TUNIT,DUMMY
+C
+ DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/
+ DATA INV /1/
+C
+C! READ(*,776) NFICHLEC
+C! READ(*,776) ICOM
+C! DO JF=1,NFICHLEC
+C! READ(*,777) INDATA(JF)
+C! ENDDO
+C
+C.......... Loop on the data files ..........
+C
+ NFICHLEC=1
+ ICOM=5
+ DO JFICH=1,NFICHLEC
+C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
+ OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD')
+ CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*
+ &520,*540,*550,*570,*580,*590,*630)
+C
+C.......... Atomic case index ..........
+C
+ I_AT=0
+ IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1
+ IF(SPECTRO.EQ.'APC') THEN
+ IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1
+ ENDIF
+C
+ IF(IBAS.EQ.1) THEN
+ IF(ITEST.EQ.0) THEN
+ NEQ=(2*NIV+1)**3
+ ELSE
+ NEQ=(2*NIV+3)**3
+ ENDIF
+ IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518
+ ENDIF
+C
+ IF(SPECTRO.EQ.'APC') THEN
+ N_EL=2
+ ELSE
+ N_EL=1
+ ENDIF
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IF(I_MULT.EQ.0) THEN
+ LE_MIN=ABS(LI_C-ABS(LI_I-LI_A))
+ LE_MAX=LI_C+LI_A+LI_I
+ ELSE
+ LE_MIN=ABS(LI_C-L_MUL)
+ LE_MAX=LI_C+L_MUL
+ ENDIF
+ ENDIF
+ IF(SPECTRO.EQ.'EIG') THEN
+ LE_MIN=1
+ LE_MAX=1
+ ENDIF
+C
+C.......... Test of the dimensions against the input values ..........
+C
+ IF(NO.GT.NO_ST_M) GOTO 600
+ IF(LE_MAX.GT.LI_M) GOTO 620
+C
+ OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD')
+ OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD')
+ IF(INTERACT.EQ.'DIPCOUL') THEN
+ OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD')
+ OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD')
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (dipolar excitation case) ..........
+C
+ IF((INTERACT.NE.'COULOMB')) THEN
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,418)
+ READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1
+ ENDIF
+ ENDIF
+ IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IUI2,530) E_MIN,E_MAX,DE
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN
+ NLG=INT(NAT1-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1
+ READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX. Waiting for a version of PHAGEN
+C with LMAX dependent on the energy
+C
+ DO JE=1,NE
+ DO JAT=1,NAT1
+ LMAX(JAT,JE)=LMAX(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1=1
+ DO JAT=1,NAT1
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL.EQ.0) READ(IUI3,101) NATR,NER
+ IF(ISPIN.EQ.1) THEN
+ READ(IUI3,106) L_IN,NATR,NER
+ IF(LI.NE.L_IN) GOTO 606
+ ENDIF
+ NAT2=NAT+NATA
+ IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180
+ IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL.EQ.0) THEN
+ DO JAT=1,NAT2
+ IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ ENDIF
+ DO JE=1,NE
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121
+ READ(IUI3,103) ENERGIE
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ 121 CONTINUE
+ DO L=0,LMAX(JAT,JE)
+ READ(IUI2,7) VK(JE),TL(L,1,JAT,JE)
+ TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,
+ & 1.)*TL(L,1,JAT,JE))
+ ENDDO
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5
+ DO LL=1,18
+ READ(IUI3,104) RH1,RH2,DEF1,DEF2
+ RHOR(JE,JAT,LL,1,1)=CMPLX(RH1)
+ RHOR(JE,JAT,LL,2,1)=CMPLX(RH2)
+ DLT(JE,JAT,LL,1)=CMPLX(DEF1)
+ DLT(JE,JAT,LL,2)=CMPLX(DEF2)
+ ENDDO
+ 5 CONTINUE
+ ENDDO
+ ENDDO
+ ELSE
+C
+C.......... TL and RHOR calculated by PHAGEN ..........
+C
+ DO JE=1,NE
+ NLG=INT(NAT2-0.0001)/4 +1
+ IF(NE.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2
+ READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ NL1=1
+ DO JAT=1,NAT2
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ DO JAT=1,NAT2
+ READ(IUI2,*) DUMMY
+ DO L=0,LMAX(JAT,JE)
+ IF(LMAX_MODE.EQ.0) THEN
+ READ(IUI2,9) VK(JE),TLSTAR
+ ELSE
+ READ(IUI2,9) VK(JE),TLSTAR
+ ENDIF
+ TL(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK(JE)=CONJG(VK(JE))
+ ENDDO
+ ENDDO
+C
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333
+ IF(JE.EQ.1) THEN
+ DO JDUM=1,7
+ READ(IUI3,102) RIEN
+ ENDDO
+ ENDIF
+ DO JEMET=1,NEMET
+ JM=IEMET(JEMET)
+ READ(IUI3,105) RHOR1STAR,RHOR2STAR
+ RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR)
+ RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR)
+ ENDDO
+ 333 VK(JE)=VK(JE)*A
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IUI2)
+ CLOSE(IUI3)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN
+ CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL)
+ ENDIF
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (Coulomb excitation case) ..........
+C
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IERR=0
+ IF(INTERACT.EQ.'COULOMB') THEN
+ IRD1=IUI2
+ IRD2=IUI3
+ ELSEIF(INTERACT.EQ.'DIPCOUL') THEN
+ IRD1=IUI7
+ IRD2=IUI8
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,419)
+ READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1_A.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1_A
+ ENDIF
+ ENDIF
+ IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A
+ ENDIF
+ IF(ITL_A.EQ.1) THEN
+ READ(IRD2,107) LI_C2,LI_I2,LI_A2
+ READ(IRD2,117) LE_MIN1,N_CHANNEL
+ LE_MAX1=LE_MIN1+N_CHANNEL-1
+ IF(I_TEST_A.NE.1) THEN
+ IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO
+ & 610
+ ELSE
+ LI_C2=0
+ LI_I2=1
+ LI_A2=0
+ LE_MIN1=1
+ N_CHANNEL=1
+ ENDIF
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN
+ NLG=INT(NAT1_A-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1_A
+ READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX_A. Waiting for a version of PHAGEN
+C with LMAX_A dependent on the energy
+C
+ DO JE=1,NE1_A
+ DO JAT=1,NAT1_A
+ LMAX_A(JAT,JE)=LMAX_A(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1_A=1
+ DO JAT=1,NAT1_A
+ NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1)
+ ENDDO
+ IF(NL1_A.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A
+ IF(ISPIN.EQ.1) THEN
+ READ(IRD2,106) L_IN_A,NATR_A,NER_A
+ IF(LI_C.NE.L_IN_A) GOTO 606
+ ENDIF
+ NAT2_A=NAT+NATA
+ NAT2=NAT2_A
+ IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180
+ IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE)))
+ & GOTO 182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL_A.EQ.0) THEN
+ CONTINUE
+ ELSE
+C
+C.......... TL_A and RHOR_A calculated by PHAGEN ..........
+C
+ DO JE=1,NE_A
+ NLG=INT(NAT2_A-0.0001)/4 +1
+ IF(NE_A.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2_A
+ READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ DO JAT=1,NAT2_A
+ READ(IRD1,*) DUMMY
+ DO L=0,LMAX_A(JAT,JE)
+ IF(LMAX_MODE_A.EQ.0) THEN
+ READ(IRD1,9) VK_A(JE),TLSTAR
+ ELSE
+ READ(IRD1,7) VK_A(JE),TLSTAR
+ ENDIF
+ TL_A(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK_A(JE)=CONJG(VK_A(JE))
+ ENDDO
+ ENDDO
+C
+ IF(IFTHET_A.EQ.1) GOTO 331
+ DO LE=LE_MIN,LE_MAX
+ DO JEMET=1,NEMET
+ JM=IEMET(JEMET)
+ READ(IRD2,109) L_E,LB_MIN,LB_MAX
+ IF(I_TEST_A.EQ.1) THEN
+ L_E=1
+ LB_MIN=0
+ LB_MAX=1
+ ENDIF
+ IF(LE.NE.L_E) IERR=1
+ L_BOUNDS(L_E,1)=LB_MIN
+ L_BOUNDS(L_E,2)=LB_MAX
+ DO LB=LB_MIN,LB_MAX
+ READ(IRD2,108) L_A,RAD_D,RAD_E
+ RHOR_A(LE,JM,L_A,1,1)=RAD_D
+ RHOR_A(LE,JM,L_A,2,1)=RAD_E
+ IF(I_TEST_A.EQ.1) THEN
+ IF(LB.EQ.LB_MIN) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0)
+ ELSEIF(LB.EQ.LB_MAX) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ 331 VK_A(JE)=VK_A(JE)*A
+ VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IRD1)
+ CLOSE(IRD2)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN
+ CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL)
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,420)
+C
+ ENDIF
+C
+C.......... Check of the consistency of the two TL and radial ..........
+C.......... matrix elements for APECS ..........
+C
+ IF(SPECTRO.EQ.'APC') THEN
+C
+ I_TL_FILE=0
+ I_RD_FILE=0
+C
+ IF(NAT1.NE.NAT1_A) I_TL_FILE=1
+ IF(NE1.NE.NE1_A) I_TL_FILE=1
+ IF(ITL.NE.ITL_A) I_TL_FILE=1
+ IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1
+C
+ IF(LI_C.NE.LI_C2) I_RD_FILE=1
+ IF(LI_I.NE.LI_I2) I_RD_FILE=1
+ IF(LI_A.NE.LI_A2) I_RD_FILE=1
+C
+ IF(I_TL_FILE.EQ.1) GOTO 608
+ IF(I_RD_FILE.EQ.1) GOTO 610
+ IF(IERR.EQ.1) GOTO 610
+C
+ ENDIF
+C
+C.......... Calculation of the scattering factor (only) ..........
+C
+ IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8
+ IF(IFTHET.EQ.1) THEN
+ CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
+ ELSEIF(IFTHET_A.EQ.1) THEN
+c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A)
+ ENDIF
+ WRITE(IUO1,57)
+ STOP
+C
+ 8 IF(IBAS.EQ.0) THEN
+C
+C............... Reading of an external cluster ...............
+C
+C
+C Cluster originating from CLUSTER_NEW.F : IPHA=0
+C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems)
+C Other cluster : the first line must be text; then
+C free format : Atomic number,X,Y,Z,number
+C of the corresponding prototypical atom ;
+C All atoms corresponding to the same
+C prototypical atom must follow each other.
+C Moreover, the blocks of equivalent atoms
+C must be ordered by increasing number of
+C prototypical atom.
+C
+ VALZ_MIN=1000.0
+ VALZ_MAX=-1000.0
+C
+ OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD')
+ READ(IUI4,778,ERR=892) IPHA
+ GOTO 893
+ 892 IPHA=3
+ IF(UNIT.EQ.'ANG') THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ ELSEIF(UNIT.EQ.'LPU') THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(UNIT.EQ.'ATU') THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ ELSE
+ GOTO 890
+ ENDIF
+ 893 NATCLU=0
+ DO JAT=1,NAT2
+ NATYP(JAT)=0
+ ENDDO
+ IF(IPHA.EQ.0) THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(IPHA.EQ.1) THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ IEMET(1)=1
+ ELSEIF(IPHA.EQ.2) THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ IEMET(1)=1
+ ENDIF
+ IF(IPRINT.EQ.2) THEN
+ IF(I_AT.NE.1) THEN
+ WRITE(IUO1,558) IUI4,TUNIT
+ IF(IPHA.EQ.3) WRITE(IUO1,549)
+ ENDIF
+ ENDIF
+ JATM=0
+ DO JLINE=1,10000
+ IF(IPHA.EQ.0) THEN
+ READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.1) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.2) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.3) THEN
+ READ(IUI4,*,END=780) NN,X,Y,Z,JAT
+ ENDIF
+ JATM=MAX0(JAT,JATM)
+ NATCLU=NATCLU+1
+ IF(IPHA.NE.3) THEN
+ CHEM(JAT)=R
+ ELSE
+ CHEM(JAT)='XX'
+ ENDIF
+ NZAT(JAT)=NN
+ NATYP(JAT)=NATYP(JAT)+1
+ COORD(1,NATCLU)=X*CUNIT
+ COORD(2,NATCLU)=Y*CUNIT
+ COORD(3,NATCLU)=Z*CUNIT
+ VALZ(NATCLU)=Z*CUNIT
+c IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN
+ IF(IPRINT.GE.2) THEN
+ WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,
+ & NATCLU),COORD(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT)
+ ENDIF
+ ENDDO
+ 780 NBZ=NATCLU
+ IF(JATM.NE.NAT) GOTO 514
+ CLOSE(IUI4)
+C
+ IF(NATCLU.GT.NATCLU_M) GOTO 510
+ DO JA1=1,NATCLU
+ DO JA2=1,NATCLU
+ DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(
+ & COORD(2,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**
+ & 2)
+ IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO
+ & 895
+ ENDDO
+ ENDDO
+C
+ D_UP=VALZ_MAX-VALZ(1)
+ D_DO=VALZ(1)-VALZ_MIN
+ IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN
+ I_INV=1
+ ELSE
+ I_INV=0
+ ENDIF
+ ELSE
+C
+C............... Construction of an internal cluster ...............
+C
+ CALL BASE
+ CALL ROTBAS(ROT)
+ IF(IVG0.EQ.2) THEN
+ NMAX=NIV+1
+ ELSE
+ NMAX=(2*NIV+1)**3
+ ENDIF
+ IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN
+ WRITE(IUO1,37)
+ WRITE(IUO1,38) NIV
+ DO NUM=1,NMAX
+ CALL NUMAT(NUM,NIV,IA,IB,IC)
+ WRITE(IUO1,17) NUM,IA,IB,IC
+ ENDDO
+ WRITE(IUO1,39)
+ ENDIF
+ CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,
+ & NBZ,NAT2,NCOUCH,NMAX)
+ IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN
+ CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,
+ & NCOUCH)
+ IF(IREL.EQ.1) THEN
+ DO JP=1,NPLAN
+ VAL(JP)=VAL2(JP)
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C Storage of the extremal values of x and y for each plane. They define
+C the exterior of the cluster when a new cluster has to be build to
+C support a point-group
+C
+ IF(I_GR.GE.1) THEN
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ WRITE(IUO1,29) K,VAL(K)
+ X_MAX(K)=0.
+ X_MIN(K)=0.
+ Y_MAX(K)=0.
+ Y_MIN(K)=0.
+ ENDDO
+ ENDIF
+ DO JAT=1,NATCLU
+ X=COORD(1,JAT)
+ Y=COORD(2,JAT)
+ Z=COORD(3,JAT)
+ DO JPLAN=1,NPLAN
+ IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN
+ X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN))
+ X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN))
+ Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN))
+ Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN))
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Instead of the symmetrization of the cluster (this version only)
+C
+ N_PROT=NAT
+ NAT_ST=0
+ DO JTYP=1,JATM
+ NB_AT=NATYP(JTYP)
+ IF(NB_AT.GT.NAT_EQ_M) GOTO 614
+ DO JA=1,NB_AT
+ NAT_ST=NAT_ST+1
+ NCORR(JA,JTYP)=NAT_ST
+ ENDDO
+ ENDDO
+ DO JC=1,3
+ DO JA=1,NATCLU
+ SYM_AT(JC,JA)=COORD(JC,JA)
+ ENDDO
+ ENDDO
+C
+C Checking surface-like atoms for mean square displacements
+C calculations
+C
+ CALL CHECK_VIB(NAT2)
+C
+C.......... Set up of the variables used for an internal ..........
+C.......... calculation of the mean free path and/or of ..........
+C.......... the mean square displacements ..........
+C
+ IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN
+ DO JTYP=1,NAT2
+ XMT(JTYP)=XMAT(NZAT(JTYP))
+ RHOT(JTYP)=RHOAT(NZAT(JTYP))
+ ENDDO
+ XMTA=XMT(1)
+ RHOTA=RHOT(1)
+ NZA=NZAT(1)
+ ENDIF
+ IF(IDCM.GT.0) THEN
+ CALL CHNOT(3,VECBAS,VEC)
+ DO J=1,3
+ VB1(J)=VEC(J,1)
+ VB2(J)=VEC(J,2)
+ VB3(J)=VEC(J,3)
+ ENDDO
+ CPR=1.
+ CALL PRVECT(VB2,VB3,VBS,CPR)
+ VM=PRSCAL(VB1,VBS)
+ QD=(6.*PI*PI*NAT/VM)**(1./3.)
+ ENDIF
+C
+C.......... Writing of the contents of the cluster, ..........
+C.......... of the position of the different planes ..........
+C.......... and of their respective absorbers in ..........
+C.......... the control file IUO1 ..........
+C
+ IF(I_AT.EQ.1) GOTO 153
+ IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN
+ WRITE(IUO1,40)
+ NCA=0
+ DO J=1,NAT
+ DO I=1,NMAX
+ NCA=NCA+1
+ WRITE(IUO1,20) J,I
+ WRITE(IUO1,21) (ATOME(L,NCA),L=1,3)
+ K=IRE(NCA,1)
+ IF(K.EQ.0) THEN
+ WRITE(IUO1,22)
+ ELSE
+ WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2)
+ ENDIF
+ ENDDO
+ ENDDO
+ WRITE(IUO1,41)
+ ENDIF
+ IF(IBAS.EQ.1) THEN
+ WRITE(IUO1,24)
+ NATCLU=0
+ DO I=1,NAT
+ NN=NATYP(I)
+ NATCLU=NATCLU+NATYP(I)
+ WRITE(IUO1,26) NN,I
+ ENDDO
+ IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3
+ WRITE(IUO1,782) NATCLU
+ IF(NATCLU.GT.NATCLU_M) GOTO 516
+ IF(IPRINT.EQ.3) WRITE(IUO1,559)
+ IF(IPRINT.EQ.3) THEN
+ NBTA=0
+ DO JT=1,NAT2
+ NBJT=NATYP(JT)
+ DO JN=1,NBJT
+ NBTA=NBTA+1
+ WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),
+ & COORD(3,NBTA),JT,JN,CHEM(JT)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+ 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN
+ CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56)
+ ENDIF
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K)
+ ENDDO
+ ENDIF
+C
+ IF(SPECTRO.NE.'EIG') THEN
+ IF(I_AT.EQ.0) WRITE(IUO1,30)
+ IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN
+ WRITE(IUO1,31) (IEMET(J),J=1,NEMET)
+ ENDIF
+ ZEM=1.E+20
+ DO L=1,NPLAN
+ Z=VAL(L)
+ DO JEMED=1,NEMET
+ CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*
+ & 93)
+ IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),
+ & EMET(3)
+ IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3)
+ GO TO 33
+ 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM
+ 33 CONTINUE
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C.......... Loop on the electrons involved in the ..........
+C.......... spectroscopy : N_EL = 1 for PHD, XAS ..........
+C.......... or AED and N_EL = 2 for APC ..........
+C
+ DO J_EL=1,N_EL
+C
+C.......... Writing the information on the spectroscopies ..........
+C.......... in the control file IUO1 ..........
+C
+ IF(SPECTRO.EQ.'EIG') WRITE(IUO1,252)
+ IF(SPECTRO.EQ.'XAS') GOTO 566
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,236)
+ ELSE
+ WRITE(IUO1,248)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,245)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+C
+C---------- Photoelectron diffraction case (PHD) ----------
+C
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,35)
+ ELSE
+ WRITE(IUO1,246)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,44)
+ IF(IE.EQ.1) WRITE(IUO1,58)
+ IF(INITL.EQ.0) WRITE(IUO1,118)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ WRITE(IUO1,418)
+ WRITE(IUO1,18)
+ ENDIF
+ IF(J_EL.EQ.2) GOTO 222
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(INITL.NE.0) THEN
+ WRITE(IUO1,337)
+ WRITE(IUO1,91)
+ IF(IPOL.EQ.0) THEN
+ WRITE(IUO1,88)
+ ELSEIF(ABS(IPOL).EQ.1) THEN
+ WRITE(IUO1,87)
+ ELSEIF(IPOL.EQ.2) THEN
+ WRITE(IUO1,89)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IDICHR.GT.0) THEN
+ WRITE(IUO1,338)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,90)
+ WRITE(IUO1,43) THLUM,PHILUM
+ IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN
+ WRITE(IUO1,45)
+ ENDIF
+ ENDIF
+C
+ IF(INITL.EQ.2) THEN
+ WRITE(IUO1,79) LI,LI-1,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,
+ & 1,1),RHOR(JE,JTE,NNL,2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,444) JTE,DLT(JE,JTE,
+ & NNL,1),DLT(JE,JTE,NNL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.-1) THEN
+ WRITE(IUO1,82) LI,LI-1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,
+ & 1,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,
+ & NNL,1)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.1) THEN
+ WRITE(IUO1,82) LI,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,
+ & 2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,
+ & NNL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV.EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ 222 CONTINUE
+ ENDIF
+C
+C---------- Auger diffraction case (AED) ----------
+C
+ IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,235)
+ ELSE
+ WRITE(IUO1,247)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,244)
+ IF(I_TEST_A.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN
+ WRITE(IUO1,419)
+ WRITE(IUO1,18)
+ ENDIF
+ IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC_A.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,95) AUGER
+ CALL AUGER_MULT
+ IF(I_MULT.EQ.0) THEN
+ WRITE(IUO1,154)
+ ELSE
+ WRITE(IUO1,155) MULTIPLET
+ ENDIF
+C
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ WRITE(IUO1,112) JTE
+ DO LE=LE_MIN,LE_MAX
+ WRITE(IUO1,119) LE
+ LA_MIN=L_BOUNDS(LE,1)
+ LA_MAX=L_BOUNDS(LE,2)
+ DO LA=LA_MIN,LA_MAX
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,115) LA,RHOR_A(LE,JTE,
+ & LA,1,1),RHOR_A(LE,JTE,LA,2,1)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV.EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C.......... Check of the dimensioning of the treatment routine ..........
+C
+ CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,
+ & NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
+C
+C.......... Call of the subroutine performing either ..........
+C.......... the PhD, AED, EXAFS or APECS calculation ..........
+C
+ 566 IF(ISPIN.EQ.0) THEN
+ IF(SPECTRO.EQ.'EIG') THEN
+ CALL EIGDIF_MI
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+c IF(J_EL.EQ.1) THEN
+c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(J_EL.EQ.2) THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+c ENDIF
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF(SPECTRO.EQ.'PHD') THEN
+c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SP
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SP
+c ENDIF
+ continue
+ ENDIF
+C
+C.......... End of the MS calculation : ..........
+C.......... direct exit or treatment of the results ..........
+C
+C
+C.......... End of the loop on the electrons ..........
+C
+ ENDDO
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,52)
+ ELSE
+ WRITE(IUO1,249)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,49)
+ IF(IE.EQ.1) WRITE(IUO1,59)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ WRITE(IUO1,51)
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,237)
+ ELSE
+ WRITE(IUO1,250)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,238)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,239)
+ ELSE
+ WRITE(IUO1,251)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,240)
+ ELSEIF(SPECTRO.EQ.'EIG') THEN
+ WRITE(IUO1,253)
+ ENDIF
+C
+ CLOSE(ICOM)
+ IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
+ WRITE(IUO1,562)
+ ENDIF
+ IF(ISOM.EQ.0) CLOSE(IUO2)
+ IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
+C
+C.......... End of the loop on the data files ..........
+C
+ ENDDO
+C
+ IF(ISOM.NE.0) THEN
+ JFF=1
+ IF(ISPIN.EQ.0) THEN
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+c CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL TREAT_XAS(ISOM,NFICHLEC,NP)
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP)
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP)
+c ENDIF
+ continue
+ ENDIF
+ ENDIF
+C
+ IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
+ IF(ISOM.NE.0) CLOSE(IUO2)
+ STOP
+C
+ 1 WRITE(IUO1,60)
+ STOP
+ 2 WRITE(IUO1,61)
+ STOP
+ 55 WRITE(IUO1,65)
+ STOP
+ 56 WRITE(IUO1,64)
+ STOP
+ 74 WRITE(IUO1,75)
+ STOP
+ 99 WRITE(IUO1,100)
+ STOP
+ 180 WRITE(IUO1,181)
+ STOP
+ 182 WRITE(IUO1,183)
+ STOP
+ 184 WRITE(IUO1,185)
+ STOP
+ 504 WRITE(IUO1,505)
+ STOP
+ 510 WRITE(IUO1,511) IUI4
+ STOP
+ 514 WRITE(IUO1,515)
+ STOP
+ 516 WRITE(IUO1,517)
+ STOP
+ 518 WRITE(IUO1,519)
+ WRITE(IUO1,889)
+ STOP
+ 520 WRITE(IUO1,521)
+ STOP
+ 540 WRITE(IUO1,541)
+ STOP
+ 550 WRITE(IUO1,551)
+ STOP
+ 570 WRITE(IUO1,571)
+ STOP
+ 580 WRITE(IUO1,581)
+ STOP
+ 590 WRITE(IUO1,591)
+ STOP
+ 600 WRITE(IUO1,601)
+ STOP
+ 602 WRITE(IUO1,603)
+ STOP
+ 604 WRITE(IUO1,605)
+ STOP
+ 606 WRITE(IUO1,607)
+ STOP
+ 608 WRITE(IUO1,609)
+ STOP
+ 610 WRITE(IUO1,611)
+ STOP
+ 614 WRITE(IUO1,615) NB_AT
+ STOP
+ 620 WRITE(IUO1,621) LE_MAX
+ STOP
+ 630 WRITE(IUO1,631)
+ STOP
+ 890 WRITE(IUO1,891)
+ STOP
+ 895 WRITE(IUO1,896) JA1,JA2
+C
+ 3 FORMAT(5(5X,I4))
+ 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9)
+ 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6)
+ 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',':
+ & (',I3,',',I3,',',I3,')')
+ 18 FORMAT(' ',/)
+ 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5)
+ 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,
+ &',',F7.3,')')
+ 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER')
+ 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,
+ &',',F7.3,')',5X,'NEW NUMBER : ',I4)
+ 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/)
+ 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2)
+ 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3)
+ 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/)
+ 31 FORMAT(38X,10(I2,3X),//)
+ 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS
+ &POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')')
+ 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
+ 36 FORMAT(/////,'########## BEGINNING ', 'OF THE
+ &EXAFS CALCULATION ##########',/////)
+ 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE
+ &ATOMS GENERATED +++++++++++++++++++')
+ 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///)
+ 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++',
+ & '++++++++++++++++++++++++++++++++',/////)
+ 40 FORMAT(/////,'======================', ' CONTENTS OF THE
+ &REDUCED CLUSTER ======================',///)
+ 41 FORMAT(///,'====================================================
+ &','============================',/////)
+ 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,
+ &' DEGREES')
+ 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR
+ &PHOTOELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
+ 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE
+ &SURFACE)')
+ 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON
+ &DIFFRACTION CALCULATION ##########')
+ 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :')
+ 51 FORMAT(/////,'########## END OF THE ', 'EXAFS
+ &CALCULATION ##########')
+ 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON
+ &DIFFRACTION CALCULATION #####','#####')
+ 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE')
+ 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE
+ &STRUCTURE OSCILLATIONS CALCULATION #####', '#####',/////)
+ 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE
+ &OSCILLATIONS CALCULATION #####','#####')
+ 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M)
+ & - CHECK THE DIMENSIONING >>>>>>>>>>')
+ 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ',
+ &' >>>>>>>>>>')
+ 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ',
+ &'CLUSTER HAS NOT CONVERGED YET >>>>>>>>>>')
+ 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ',
+ & 'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>')
+ 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ',
+ & 'IN MAIN ET READ_DATA >>>>>>>>>>')
+ 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ',
+ & I1,',',I1,/)
+ 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',
+ &A3,')',//)
+ 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)')
+ 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1)
+ 83 FORMAT(//,32X,'(SPHERICAL WAVES)')
+ 84 FORMAT(//,34X,'(PLANE WAVES)')
+ 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)')
+ 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)')
+ 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +')
+ 88 FORMAT(24X,'+ NON POLARIZED LIGHT +')
+ 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +')
+ 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/)
+ 91 FORMAT(24X,'+',35X,'+')
+ 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++')
+ 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS
+ &PRESENT IN THIS PLANE')
+ 95 FORMAT(////,31X,'AUGER LINE :',A6,//)
+ 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')
+ &')
+ 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',
+ &I1,')')
+ 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE','
+ &>>>>>>>>>>')
+ 101 FORMAT(24X,I3,24X,I3)
+ 102 FORMAT(A1)
+ 103 FORMAT(31X,F7.2)
+ 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5)
+ 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,
+ &E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9)
+ 106 FORMAT(12X,I3,12X,I3,12X,I3)
+ 107 FORMAT(5X,I2,5X,I2,5X,I2)
+ 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5)
+ 109 FORMAT(5X,I2,12X,I2,11X,I2)
+ 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//)
+ 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' : (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')')
+ 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,
+ &' : ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)
+ &',/,8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//)
+ 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ',
+ * 'TYPE ',I2,' : (',F8.5,',',F8.5,')')
+ 114 FORMAT(/)
+ 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.
+ &5,')')
+ 117 FORMAT(12X,I2,5X,I2)
+ 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/)
+ 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE
+ &INTEGRAL')
+ 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ',
+ &'INVERSION)')
+ 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ',
+ &'INVERSION)')
+ 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4)
+ 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,
+ &' ',/,' ')
+ 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ',
+ &'LINE',' ',/,' ',/,' ')
+ 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ',
+ &'AND PHASE SHIFTS FILES >>>>>>>>>>')
+ 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ',
+ &'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>')
+ 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ',
+ &'FILE >>>>>>>>>>')
+ 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX
+ &ELEMENTS TAKEN INTO ACCOUNT <-----',///)
+ 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &AUGER DIFFRACTION CALCULATION #####', '#####',/////)
+ 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL
+ &APECS DIFFRACTION CALCULATION #####', '#####',/////)
+ 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &PHOTOELECTRON DIFFRACTION CALCULATION ','##########',/////)
+ 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &AUGER DIFFRACTION CALCULATION ', '##########',/////)
+ 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE
+ &APECS DIFFRACTION CALCULATION ', '##########',/////)
+ 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON
+ &DIFFRACTION CALCULATION #####','#####')
+ 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS
+ &DIFFRACTION CALCULATION #####', '#####',/////)
+ 252 FORMAT(/////,'########## BEGINNING ', 'OF THE MULTIPLE
+ &SCATTERING EIGENVALUE CALCULATION #####', '#####',/////)
+ 253 FORMAT(/////,'########## END ', 'OF THE MULTIPLE SCATTERING
+ &EIGENVALUE CALCULATION #####', '#####',/////)
+ 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +')
+ 335 FORMAT(24X,'+ STANDARD +')
+ 336 FORMAT(24X,'+ SPIN-POLARIZED +')
+ 337 FORMAT(24X,'+ WITH +')
+ 338 FORMAT(24X,'+ IN DICHROIC MODE +')
+ 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +')
+ 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','----
+ &--------------------')
+ 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','----
+ &--------------------')
+ 420 FORMAT(///,9X,'----------------------------------------------','-
+ &---------------------')
+ 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(
+ &',F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')')
+ 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.
+ &5,',',F8.5,')')
+ 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE
+ &DIMENSIONING >>>>>>>>>>')
+ 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ',
+ &'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,'
+ &>>>>>>>>>>')
+ 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ',
+ &'NAT IN THE DATA AND CLUSTER FILES >>>>>>>>>>')
+ 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ',
+ &'IBWD >>>>>>>>>>')
+ 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT','
+ &CONSISTENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE
+ &>>>>>>>>>>')
+ 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT
+ &WITH',' THE VALUE OF LI >>>>>>>>>>')
+ 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4)
+ 535 FORMAT(29X,F8.5,1X,F8.5)
+ 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 543 FORMAT(5X,F12.9,5X,F12.9)
+ 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,
+ &'SYM',/)
+ 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 555 FORMAT(4(7X,I2))
+ 556 FORMAT(28X,4(I2,5X))
+ 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,
+ &A2)
+ 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' :
+ & ',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,
+ &'ATOM',/)
+ 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,'
+ &No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/)
+ 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL
+ &ATOMS : ',//)
+ 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM
+ &: ',//)
+ 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',
+ &13X,'oooooooooooooooo',///)
+ 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/)
+ 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ',
+ &'CORRESPOND TO NAT >>>>>>>>>>')
+ 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD
+ &AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>')
+ 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT
+ &CONSISTENT WITH THE INPUT DATA FILE >>>>>>>>>>')
+ 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ',
+ &'>>>>>>>>>>',//)
+ 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE
+ &','.inc FILE >>>>>>>>>>',//)
+ 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ',
+ &'>>>>>>>>>>',//)
+ 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA
+ &','FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS
+ &FILE >>>>>>>>>>',//)
+ 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ',
+ &'>>>>>>>>>>',//)
+ 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ',
+ &'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',
+ &17X,'WITH THE INPUT DATA FILE ',16X,'>>>>>>>>>>',//)
+ 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ',
+ &'THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE
+ &IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH
+ &ELECTRONS IN CLUSTER ROTATION MODE',' >>>>>>>>>>',//)
+ 776 FORMAT(I2)
+ 777 FORMAT(A24)
+ 778 FORMAT(30X,I1)
+ 779 FORMAT(11X,A2,5X,I2,3F10.4,I5)
+ 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,'
+ &ATOMS')
+ 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M
+ &>>>>>>>>>>')
+ 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''',
+ &'UNITS >>>>>>>>>>')
+ 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE','
+ &ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,'
+ &ARE IDENTICAL >>>>>>>>>>')
+C
+ END
+C
+C=======================================================================
+C
diff --git a/src/msspec/spec/fortran/eig/pw/eigdif_mi.f b/src/msspec/spec/fortran/eig/pw/eigdif_mi.f
new file mode 100644
index 0000000..6142624
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/eigdif_mi.f
@@ -0,0 +1,115 @@
+C
+C=======================================================================
+C
+ SUBROUTINE EIGDIF_MI
+C
+C This subroutine computes the eigenvalues of the
+C multiple scattering matrix to obtain its spectral radius
+C
+C The eigenvalue calculation is performed using the LAPACK
+C eigenvalue routines for a general complex matrix (I_PWM = 0)
+C or using the power method (I_PWM > 0)
+C
+C Last modified : 26 Apr 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP
+ USE DEBWAL_MOD
+ USE EIGEN_MOD, NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE RESEAU_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE VALIN_MOD, E1 => E0
+C
+ COMPLEX IC,ONEC
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M)
+C
+ DATA CONV /0.512314/
+C
+ IC=(0.,1.)
+ ONEC=(1.,0.)
+C
+ OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN')
+C
+C Check file to monitor the convergence of the calculation
+C
+ OPEN(UNIT=36, FILE='div/radius_conv.lis', STATUS='unknown')
+C
+C Loop over the energies
+C
+ DO JE=1,NE
+ IF(NE.GT.1) THEN
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ELSEIF(NE.EQ.1) THEN
+ ECIN=E0
+ ENDIF
+ CALL LPM(ECIN,XLPM,*6)
+ XLPM1=XLPM/A
+ IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
+ IF(ITL.EQ.0) THEN
+ VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ GAMMA=1./(2.*XLPM1)
+ IF(IPOTC.EQ.0) THEN
+ VK(JE)=VK(JE)+IC*GAMMA
+ ENDIF
+ IF(I_MFP.EQ.0) THEN
+ VK(JE)=CMPLX(REAL(VK(JE)))
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ IF(I_VIB.EQ.1) THEN
+ IF(IDCM.GE.1) WRITE(IUO1,22)
+ DO JAT=1,N_PROT
+ IF(IDCM.EQ.0) THEN
+ XK2UJ2=VK2(JE)*UJ2(JAT)
+ ELSE
+ XK2UJ2=VK2(JE)*UJ_SQ(JAT)
+ WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
+ ENDIF
+ CALL DWSPH(JAT,JE,XK2UJ2,TLT,I_VIB)
+ DO LAT=0,LMAX(JAT,JE)
+ TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ IF(JE.EQ.1) WRITE(36,57)
+ WRITE(36,59)
+ WRITE(36,58) ECIN
+ WRITE(36,59)
+C
+C Eigenvalue calculation by power method
+C
+ CALL SPEC_RAD_POWER(JE,ECIN)
+C
+ WRITE(36,59)
+ WRITE(36,57)
+C
+C End of the loop on the energy
+C
+ ENDDO
+ CLOSE(36)
+ GOTO 7
+C
+ 6 WRITE(IUO1,55)
+C
+ 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,
+ &25X,' BY DEBYE UNCORRELATED MODEL:',/)
+ 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
+ 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
+ &'AVAILABLE >>>>>>>>>>')
+ 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
+ *'MEAN FREE PATH = ',F6.3,' * A',//)
+ 57 FORMAT('+++++++++++++++++++++++++++++++++++++++++++++++++++++++',
+ &'++++')
+ 58 FORMAT(18X,'E_KIN = ',F8.2,1X,'eV')
+ 59 FORMAT(20X)
+C
+ 7 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/interp_points.f b/src/msspec/spec/fortran/eig/pw/interp_points.f
new file mode 100644
index 0000000..cce9ee5
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/interp_points.f
@@ -0,0 +1,39 @@
+C
+C=======================================================================
+C
+ SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+C This subroutine computes the interpolation
+C points used in some algorithms
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 ALPHA,BETA
+C
+ DO N=0,N_APP
+C
+ IF(I_XN.EQ.1) THEN
+ XN(N)=(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.2) THEN
+ XN(N)=BETA+DFLOAT(N)
+ ELSEIF(I_XN.EQ.3) THEN
+ XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.4) THEN
+ XN(N)=(BETA+DFLOAT(N))**ALPHA
+ ELSEIF(I_XN.EQ.5) THEN
+ XN(N)=((2.D0**N)/BETA)**ALPHA
+ ENDIF
+C
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/levin.f b/src/msspec/spec/fortran/eig/pw/levin.f
new file mode 100644
index 0000000..852fadc
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/levin.f
@@ -0,0 +1,192 @@
+C
+C=======================================================================
+C
+ SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ &OMEGA)
+C
+C This subroutine computes Levin-type transforms of
+C a given sequence SN(N,1)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1:
+ &N_ORD_M)
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC
+ COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2
+C
+ CHARACTER*1 OMEGA
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Recovery of the original series elements
+C
+ DO N=N_INI,N_APP
+C
+ AN(N)=SN(N,0)-SN(N-1,0)
+C
+ ENDDO
+C
+C
+C Choice of the remainder estimate omega_n
+C
+C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000)
+C
+C
+ IF(OMEGA.EQ.'U') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*(DFLOAT(N)+BETA)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'V') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1))
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'T') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'D') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N+1)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'E') THEN
+C
+ MAX_N=N_APP-2
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+2)/AN(N+1)
+ ENDDO
+C
+ ENDIF
+C
+C Choice of the Levin-type transform
+C
+C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10)
+C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10)
+C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10)
+C I_WN = 4 ---> C-type (eq 3-16c p 11)
+C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70)
+C I_WN = 6 ---> R-type (eq 7.14-12 p 47)
+C
+C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004)
+C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989)
+C
+C
+C Check for the possibility of L extension (the standard case is L = 0)
+C
+ IF(L.GT.0) THEN
+ IF(I_WN.EQ.1) THEN
+ CALL COEFFICIENTS(MAX_N,COEL,BETA,2)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.2) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,3)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.3) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,4)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ENDIF
+ ENDIF
+C
+ DO N=N_INI,MAX_N
+C
+ X=BETA+DFLOAT(N)
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ XK=DFLOAT(K)
+ XXK=X+XK
+C
+ IF(I_WN.EQ.1) THEN
+ INC=XXK/(XXK+ONEC)
+ COEF(N,K)=X*(INC**K)/XXK
+ ELSEIF(I_WN.EQ.2) THEN
+ COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK))
+ ELSEIF(I_WN.EQ.3) THEN
+ COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC)
+ ELSEIF(I_WN.EQ.4) THEN
+ SUM_1=ZEROC
+ SUM_2=ZEROC
+ DO J=0,K
+ SUM_1=SUM_1+ALPHA*XXK
+ SUM_2=SUM_2+ALPHA*(XXK+ONEC)
+ ENDDO
+ COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2)
+ ELSEIF(I_WN.EQ.5) THEN
+ COEF(N,K)=ONEC
+ ELSEIF(I_WN.EQ.6) THEN
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computation of the recurrence relation for numerator
+C and denominator
+C
+ DO N=N_INI,MAX_N
+C
+C Starting values
+C
+ NUM(N,0)=SN(N,0)/WN(N)
+ DEN(N,0)=ONEC/WN(N)
+ SN(N,0)=NUM(N,0)/DEN(N,0)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,MAX_N-K-1
+C
+ IF(I_WN.NE.6) THEN
+ NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K)
+ DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K)
+ ELSE
+ NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N))
+ DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N))
+ ENDIF
+ SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/main.f b/src/msspec/spec/fortran/eig/pw/main.f
new file mode 100644
index 0000000..4bdf296
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/main.f
@@ -0,0 +1,20 @@
+ SUBROUTINE RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
+ & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
+ & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
+ & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
+
+ USE DIM_MOD
+ IMPLICIT INTEGER (A-Z)
+CF2PY INTEGER, INTENT(IN,COPY) :: NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_
+CF2PY INTEGER, INTENT(IN,COPY) :: NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_
+CF2PY INTEGER, INTENT(IN,COPY) :: NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_
+CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_
+
+ CALL ALLOCATION(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
+ & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
+ & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
+ & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
+
+ CALL DO_MAIN()
+
+ END SUBROUTINE RUN
diff --git a/src/msspec/spec/fortran/eig/pw/new.f.hidden b/src/msspec/spec/fortran/eig/pw/new.f.hidden
new file mode 100644
index 0000000..bdd94ee
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/new.f.hidden
@@ -0,0 +1,2079 @@
+C
+C=======================================================================
+C
+ SUBROUTINE EIGDIF_MI
+C
+C This subroutine computes the eigenvalues of the
+C multiple scattering matrix to obtain its spectral radius
+C
+C The eigenvalue calculation is performed using the LAPACK
+C eigenvalue routines for a general complex matrix (I_PWM = 0)
+C or using the power method (I_PWM > 0)
+C
+C Last modified : 26 Apr 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP
+ USE DEBWAL_MOD
+ USE EIGEN_MOD, NE => NE_EIG, E0 => E0_EIG, EFIN => EFIN_EIG
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE RESEAU_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE VALIN_MOD, E1 => E0
+C
+ COMPLEX IC,ONEC
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M)
+C
+ DATA CONV /0.512314/
+C
+ IC=(0.,1.)
+ ONEC=(1.,0.)
+C
+ OPEN(UNIT=IUO2, FILE=OUTFILE2, STATUS='UNKNOWN')
+C
+C Check file to monitor the convergence of the calculation
+C
+ OPEN(UNIT=36, FILE='div/radius_conv.lis', STATUS='unknown')
+C
+C Loop over the energies
+C
+ DO JE=1,NE
+ IF(NE.GT.1) THEN
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ELSEIF(NE.EQ.1) THEN
+ ECIN=E0
+ ENDIF
+ CALL LPM(ECIN,XLPM,*6)
+ XLPM1=XLPM/A
+ IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
+ IF(ITL.EQ.0) THEN
+ VK(JE)=SQRT(ECIN+VINT)*CONV*A*ONEC
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ GAMMA=1./(2.*XLPM1)
+ IF(IPOTC.EQ.0) THEN
+ VK(JE)=VK(JE)+IC*GAMMA
+ ENDIF
+ IF(I_MFP.EQ.0) THEN
+ VK(JE)=CMPLX(REAL(VK(JE)))
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ IF(I_VIB.EQ.1) THEN
+ IF(IDCM.GE.1) WRITE(IUO1,22)
+ DO JAT=1,N_PROT
+ IF(IDCM.EQ.0) THEN
+ XK2UJ2=VK2(JE)*UJ2(JAT)
+ ELSE
+ XK2UJ2=VK2(JE)*UJ_SQ(JAT)
+ WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
+ ENDIF
+ CALL DWSPH(JAT,JE,XK2UJ2,TLT,I_VIB)
+ DO LAT=0,LMAX(JAT,JE)
+ TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ IF(JE.EQ.1) WRITE(36,57)
+ WRITE(36,59)
+ WRITE(36,58) ECIN
+ WRITE(36,59)
+C
+C Eigenvalue calculation by power method
+C
+ CALL SPEC_RAD_POWER(JE,ECIN)
+C
+ WRITE(36,59)
+ WRITE(36,57)
+C
+C End of the loop on the energy
+C
+ ENDDO
+ CLOSE(36)
+ GOTO 7
+C
+ 6 WRITE(IUO1,55)
+C
+ 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,
+ &25X,' BY DEBYE UNCORRELATED MODEL:',/)
+ 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
+ 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
+ &'AVAILABLE >>>>>>>>>>')
+ 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
+ *'MEAN FREE PATH = ',F6.3,' * A',//)
+ 57 FORMAT('+++++++++++++++++++++++++++++++++++++++++++++++++++++++',
+ &'++++')
+ 58 FORMAT(18X,'E_KIN = ',F8.2,1X,'eV')
+ 59 FORMAT(20X)
+C
+ 7 RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE SPEC_RAD_POWER(JE,E_KIN)
+C
+C This subroutine computes the spectral radius of the G_o T kernel matrix
+C using the power method and the Rayleigh quotient. In addition,
+C a scalar convergence acceleration method can be used to refine the results.
+C
+C Power method approximation of the spectral radius :
+C
+C SR(A) = lim ||A^{n} x|| / ||A^{n-1} x||
+C n --> +infty
+C for any starting vector x
+C
+C Rayleigh quotient approximation of the spectral radius :
+C
+C SR(A) = lim ||(A^{n}x)^{+} A A^{n} x| / |(A^{n}x)^{+} A^{n} x||
+C n --> +infty
+C for any starting vector x
+C
+C Note: a shift (= SHIFT) can be introduced in the power method.
+C In this case, only the Rayleigh quotient is valid
+C
+C !!!!! This version does not store the G_o T matrix !!!!!
+C
+C Author : D. Sebilleau
+C
+C Last modified : 1 Mar 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE TRANS_MOD
+C
+C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD
+C
+ INTEGER NN(0:N_ORD_M)
+C
+ REAL R_SN(N_ORD_M),R_SN1(N_ORD_M)
+C
+ COMPLEX*16 TLK,SUM_L1,SUM_L2,EXPKJ,EXPJK,ONEC,MULT
+ COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO)
+ COMPLEX*16 X(LINMAX*NATCLU_M)
+ COMPLEX*16 AX(LINMAX*NATCLU_M),SUM_AX,XAX,XX
+ COMPLEX*16 HL1(0:NLTWO)
+ COMPLEX*16 ZEROC,IC,JC,JMULT,IFOURPI,CHIFT
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 COEF_GAUNT(LINMAX,LINMAX,0:N_GAUNT)
+C
+ REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
+ REAL*8 ATTJK,XJK,YJK,ZJK,RJK,ZDJK,KRJK,SMALL
+ REAL*8 NORMX2,NORMAX2,RLIN
+C
+ CHARACTER*10 METH
+ CHARACTER*24 OUTFILE,PATH
+C
+ DATA PI,SMALL /3.1415926535898D0,1.0D-6/
+C
+ ONEC=(1.D0,0.D0)
+ IC=(0.0D0,1.0D0)
+ ZEROC=(0.D0,0.D0)
+ IFOURPI=4.D0*PI*IC
+ IBESS=3
+ N_CALL=0
+ N_ACC=0
+ K_ACC=0
+ I_CONV=0
+C
+ CHIFT=DCMPLX(SHIFT)
+C
+ IF(N_MAX.GT.N_ORD_M) THEN
+ WRITE(IUO1,99) N_MAX
+ STOP
+ ENDIF
+C
+C Computing the size NLIN of the vectors A x
+C
+ LMAXJ=0
+ NLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ LMAXJ=MAX(LMAXJ,LMJ)
+ DO JNUM=1,NBTYPJ
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ NLIN=NLIN+1
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Storage of the modified Gaunt coefficients
+C
+ LIN1=0
+ DO L1=0,LMAXJ
+ DO M1=-L1,L1
+ LIN1=LIN1+1
+ LIN2=0
+ DO L2=0,LMAXJ
+ L_MIN=ABS(L2-L1)
+ L_MAX=L1+L2
+ DO M2=-L2,L2
+ LIN2=LIN2+1
+ CALL GAUNT2(L1,M1,L2,M2,GNT)
+ DO L=L_MIN,L_MAX,2
+ M=M1-M2
+ COEF_GAUNT(LIN1,LIN2,L)=IFOURPI*GNT(L)*(IC**
+ & L)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Starting vector for power method:
+C
+C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO
+C
+ JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0)
+ JMULT=JC**EXPO
+C
+ WRITE(IUO1,6)
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(36,76)
+ ELSE
+ WRITE(36,79)
+ ENDIF
+ WRITE(36,75)
+C
+C Initialization the vectors and their squared norm
+C
+ MULT=JMULT
+C
+ AX(1)=ONEC
+C
+ NORMAX2=1.D0
+C
+ DO JLIN=2,NLIN
+C
+ AX(JLIN)=AX(JLIN-1)*MULT
+ NORMAX2=NORMAX2+CDABS(AX(JLIN))*CDABS(AX(JLIN))
+C
+ ENDDO
+C
+C Computation of the vectors and their squared norm
+C
+C X ---> A*X
+C
+ 120 IF(N_CALL.EQ.0) THEN
+ J_INI=1
+ ELSE
+ J_INI=N_CALL*N_ITER+1
+ ENDIF
+ J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX)
+C
+ IF(J_INI.GT.J_FIN) GOTO 112
+C
+ DO JORD=J_INI,J_FIN
+C
+ NORMX2=NORMAX2
+C
+ XX=ZEROC
+ DO JLIN=1,NLIN
+C
+ X(JLIN)=AX(JLIN)
+ XX=XX+CONJG(X(JLIN))*X(JLIN)
+C
+ ENDDO
+C
+ NORMAX2=0.D0
+ XAX=ZEROC
+C
+C
+C Construction of the the multiple scattering kernel matrix G_o T
+C times the vector x
+C
+C Linear indices JLIN and KLIN represent (J,LJ) and (K,LK)
+C
+ JLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ XJ=SYM_AT(1,JATL)
+ YJ=SYM_AT(2,JATL)
+ ZJ=SYM_AT(3,JATL)
+C
+ LINJ=0
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ JLIN=JLIN+1
+ LINJ=LINJ+1
+C
+ SUM_AX=ZEROC
+C
+ KLIN=0
+ DO KTYP=1,N_PROT
+ NBTYPK=NATYP(KTYP)
+ LMK=LMAX(KTYP,JE)
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ XK=SYM_AT(1,KATL)
+ YK=SYM_AT(2,KATL)
+ ZK=SYM_AT(3,KATL)
+C
+ IF(KATL.NE.JATL) THEN
+C
+ XKJ=DBLE(XK-XJ)
+ YKJ=DBLE(YK-YJ)
+ ZKJ=DBLE(ZK-ZJ)
+ RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
+ KRKJ=DBLE(VK(JE))*RKJ
+ ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*
+ & RKJ)
+ EXPKJ=(XKJ+IC*YKJ)/RKJ
+ ZDKJ=ZKJ/RKJ
+ CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,
+ & LMJ+LMK)
+ CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,
+ & HL1)
+C
+ ENDIF
+C
+ LINK=0
+ DO LK=0,LMK
+ L_MIN=ABS(LK-LJ)
+ L_MAX=LK+LJ
+ TLK=ATTKJ*DCMPLX(TL(LK,1,KTYP,JE))
+ DO MK=-LK,LK
+ KLIN=KLIN+1
+ LINK=LINK+1
+ IF(KATL.NE.JATL) THEN
+C
+ SUM_L1=ZEROC
+ DO L=L_MIN,L_MAX,2
+ M=MJ-MK
+ IF(ABS(M).LE.L) THEN
+ SUM_L1=SUM_L1+HL1(L)*
+ & COEF_GAUNT(LINJ,LINK,L)*YLM(L,M)
+ ENDIF
+ ENDDO
+ SUM_AX=SUM_AX+TLK*SUM_L1*X(
+ & KLIN)
+C
+ ENDIF
+ IF(KLIN.EQ.JLIN) SUM_AX=SUM_AX-
+ & CHIFT*X(KLIN)
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ AX(JLIN)=SUM_AX
+ NORMAX2=NORMAX2+CDABS(SUM_AX)*CDABS(SUM_AX)
+ XAX=XAX+CONJG(X(JLIN))*SUM_AX
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+C R_SN : power method
+C R_SN1: Rayleigh quotient
+C
+ R_SN(JORD)=SQRT(REAL(NORMAX2/NORMX2))
+ R_SN1(JORD)=CDABS((XAX/XX)+SHIFT)
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(36,77) JORD,R_SN(JORD),R_SN1(JORD)
+ ELSE
+ WRITE(36,77) JORD,R_SN1(JORD)
+ ENDIF
+C
+C Check of convergence of power method series and
+C Rayleigh quotient method
+C
+C Note: only Rayleigh quotient valid if shift
+C
+ IF((I_PWM.EQ.2).AND.(ABS(SHIFT).LE.SMALL)) THEN
+ IF(JORD.GT.N_TABLE) THEN
+ CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN,*555)
+ ENDIF
+ ENDIF
+C
+ IF((ABS(SHIFT).GT.SMALL).AND.(I_PWM.GT.0)) I_PWM=-I_PWM
+ IF(I_PWM.EQ.-2) THEN
+ IF(JORD.GT.N_TABLE) THEN
+ CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN1,*555)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+C
+ 555 IF(J_INI.EQ.1) THEN
+ WRITE(IUO1,10)
+ WRITE(IUO1,11) SHIFT
+ WRITE(IUO1,46) NLIN
+ WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ ENDIF
+C
+ WRITE(IUO1,10)
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(IUO1,44) R_SN(JORD-1)
+ ENDIF
+ WRITE(IUO1,53) R_SN1(JORD-1)
+ WRITE(IUO1,47) JORD-1
+ WRITE(IUO1,10)
+ IF(J_FIN.EQ.N_MAX) THEN
+ IF((I_PWM.EQ.1).OR.(I_PWM.EQ.3)) THEN
+ WRITE(IUO1,213)
+ ELSE
+ WRITE(IUO1,60)
+ ENDIF
+ ENDIF
+C
+ IF(((I_ACC.EQ.1).OR.(I_ACC.EQ.2)).AND.(ABS(SHIFT).LE.SMALL)) THEN
+C
+C Convergence acceleration on the power method results whenever necessary
+C
+ CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ & R_SN,SN,METH)
+ IF(I_ACC.EQ.1) GOTO 111
+ IF((I_CONV.EQ.1).AND.(I_ACC.EQ.2)) GOTO 111
+ IF((I_CONV.EQ.0).AND.(I_ACC.EQ.2)) THEN
+ IF(J_FIN.EQ.N_MAX) THEN
+ GOTO 111
+ ELSE
+ GOTO 120
+ ENDIF
+ ENDIF
+C
+ 111 WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ WRITE(IUO1,10)
+ WRITE(IUO1,52) METH
+ WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC))
+ WRITE(IUO1,49) N_ACC
+ WRITE(IUO1,51) K_ACC
+C
+ IF(I_ACC.EQ.2) THEN
+ OPEN(UNIT=35, FILE='div/n_k_table_pm.lis', STATUS=
+ & 'unknown')
+ K_MAX=MIN(K_MAX,J_FIN)
+ DO L=0,K_MAX
+ NN(L)=L
+ ENDDO
+ WRITE(35,*) ' '
+ WRITE(35,78) E_KIN,METH
+ WRITE(35,*) ' '
+ WRITE(35,198) (NN(K),K=0,K_MAX)
+ WRITE(35,199)
+ WRITE(35,*) ' '
+ DO N=0,K_MAX
+ WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N)
+ WRITE(35,*) ' '
+ ENDDO
+ ENDIF
+C
+ WRITE(IUO1,10)
+ IF(I_ACC.GE.1) WRITE(IUO1,60)
+ IF(I_ACC.EQ.2) THEN
+ IF(I_CONV.EQ.0) WRITE(IUO1,212)
+ WRITE(IUO1,210)
+ ENDIF
+C
+ ENDIF
+C
+ IF((ABS(SHIFT).GT.SMALL).AND.(I_ACC.GT.0)) I_ACC=-I_ACC
+ IF((I_ACC.EQ.-1).OR.(I_ACC.EQ.-2))THEN
+C
+C Convergence acceleration on the Rayleigh quotient whenever necessary
+C
+ CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ & R_SN1,SN,METH)
+ IF(I_ACC.EQ.-1) GOTO 999
+ IF((I_CONV.EQ.1).AND.(I_ACC.EQ.-2)) GOTO 999
+ IF((I_CONV.EQ.0).AND.(I_ACC.EQ.-2)) THEN
+ IF(J_FIN.EQ.N_MAX) THEN
+ GOTO 999
+ ELSE
+ GOTO 120
+ ENDIF
+ ENDIF
+C
+ 999 WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ WRITE(IUO1,10)
+ WRITE(IUO1,52) METH
+ WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC))
+ WRITE(IUO1,49) N_ACC
+ WRITE(IUO1,51) K_ACC
+C
+ IF(I_ACC.EQ.-2) THEN
+ OPEN(UNIT=35, FILE='div/n_k_table_rq.lis', STATUS=
+ & 'unknown')
+ K_MAX=MIN(K_MAX,J_FIN)
+ DO L=0,K_MAX
+ NN(L)=L
+ ENDDO
+ WRITE(35,*) ' '
+ WRITE(35,78) E_KIN,METH
+ WRITE(35,*) ' '
+ WRITE(35,198) (NN(K),K=0,K_MAX)
+ WRITE(35,199)
+ WRITE(35,*) ' '
+ DO N=0,K_MAX
+ WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N)
+ WRITE(35,*) ' '
+ ENDDO
+ ENDIF
+C
+ WRITE(IUO1,10)
+ IF(ABS(I_ACC).GE.1) WRITE(IUO1,60)
+ IF(I_ACC.EQ.-2) THEN
+ IF(I_CONV.EQ.0) WRITE(IUO1,215)
+ WRITE(IUO1,214)
+ ENDIF
+C
+ ENDIF
+C
+C Writing the results:
+C
+ IF(ABS(I_ACC).LT.2) THEN
+C
+C No convergence acceleration: power method and Rayleigh quotient
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1)
+ ELSE
+ WRITE(IUO2,*) E_KIN,R_SN1(JORD-1)
+ ENDIF
+C
+ ELSE
+C
+ IF(I_CONV.EQ.1) THEN
+C
+C Convergence acceleration has succeeded:
+C
+ WRITE(IUO2,*) E_KIN,REAL(CDABS(SN(N_ACC,K_ACC)))
+C
+ ELSEIF(I_CONV.EQ.0) THEN
+C
+C Convergence acceleration has failed: power method and
+C Rayleigh quotient used instead
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1)
+ ELSE
+ WRITE(IUO2,*) E_KIN,R_SN1(JORD-1)
+ ENDIF
+C
+ ENDIF
+ ENDIF
+C
+ 112 WRITE(IUO1,211)
+C
+ RETURN
+C
+ 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','---------
+ &--------')
+ 6 FORMAT(/,11X,'----------- SHIFTED POWER METHOD ANALYSIS ',' ----
+ &--------')
+ 10 FORMAT(11X,'-',54X,'-')
+ 11 FORMAT(11X,'-',4X,'SHIFT ',20X,': ',F6.3,3X,'-')
+ 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-')
+ 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-')
+ 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-')
+ 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X,
+ &'-')
+ 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-')
+ 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-')
+ 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5,
+ &3X,'-')
+ 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5,
+ &3X,'-')
+ 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8,
+ &3X,'-')
+ 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8,
+ &3X,'-')
+ 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5,
+ &3X,'-')
+ 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8,
+ &3X,'-')
+ 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ',
+ &'CONVERGES ',4X,'-')
+ 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8,
+ &3X,'-')
+ 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10,
+ &1X,'-')
+ 53 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY RAYLEIGH QUOTIENT : ',F8.5,
+ &3X,'-')
+ 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/
+ &,11X,'-',18X,'SCATTERING SERIES',19X,'-')
+ 60 FORMAT(11X,'----------------------------------------','----------
+ &------',/)
+ 61 FORMAT(11X,'----------------------------------------','----------
+ &------')
+ 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,
+ &'-')
+ 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.
+ &3,')',8X,'-')
+ 75 FORMAT(' ')
+ 76 FORMAT(2X,'ITERATION: SPECTRAL RADIUS:',' RAYLEIGH
+ "IENT:')
+ 77 FORMAT(2X,I6,15X,F6.3,15X,F6.3)
+ 78 FORMAT(10X,' E_KIN = ',F6.2,' eV -- (N,K) TABLE OF ',A10,'
+ &METHOD')
+ 79 FORMAT(2X,'ITERATION: RAYLEIGH QUOTIENT:')
+ 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV')
+ 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3)
+ 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5)
+ 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,')
+ &')
+ 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE','
+ &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ',
+ &I5, 6X,' >>>>>>>>>>',///)
+ 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3)
+ 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :')
+ 110 FORMAT(2X,'-------------------------------')
+ 198 FORMAT(' K',50(I3,4X))
+ 199 FORMAT(' N')
+ 200 FORMAT(I3,50(2X,F5.3))
+ 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/
+ &n_k_table_pm.lis',//)
+ 211 FORMAT(//,' ---> THE EVOLUTION OF THE SPECTRAL RADIUS ','HAS
+ &BEEN WRITTEN IN /div/radius_conv.lis',//)
+ 212 FORMAT(//,10X,' !!!!! THE POWER METHOD HAS NOT CONVERGED YET
+ &','!!!!!')
+ 213 FORMAT(11X,'------------ NO CONVERGENCE CHECK WAS MADE ','------
+ &------')
+ 214 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/
+ &n_k_table_rq.lis',//)
+ 215 FORMAT(//,8X,' !!!!! THE RAYLEIGH QUOTIENT HAS NOT CONVERGED',
+ &' YET !!!!!')
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ &R_SN,SN,METH)
+C
+C Use of the various acceleration scheme on a scalar series
+C
+C AITK : Aitken, modified Aitken
+C RICH : Richardson
+C SALZ : Salzer
+C EPSI : epsilon
+C EPSG : generalized epsilon
+C RHOA : rho
+C THET : theta
+C LEGE : Legendre-Toeplitz
+C CHEB : Chebyshev-Toeplitz
+C OVER : Overholt
+C DURB : Durbin
+C DLEV : Levin d-transform !! differ by the
+C TLEV : Levin t-transform !! choice of w_n
+C ULEV : Levin u-transform !! the remainder
+C VLEV : Levin v-transform !! estimate given
+C ELEV : Levin e-transform !! by I_WN
+C EULE : generalized Euler transform
+C GBWT : Germain-Bronne-Wimp transform
+C VARI : various algorithms : Weniger, BDG, iterated rho
+C ITHE : iterated theta : Lubkin, iterated theta, modified Aitken 2
+C EALG : E-algorithm
+C
+C SN : series to be accelerated
+C XN : auxilliary series (chosen with I_XN) : interpolation points
+C GN : auxilliary series (chosen with I_GN) ---> E algorithm
+C
+C N_DIV : number of SN(N+M,L), M > 0 and L < K+1, necessary to compute S(N,K+1)
+C example: iterated Aitken method, we need SN(N,K), SN(N+1,K) and SN(N+2,K)
+C so N_DIV=2
+C Because of this only (N_TABLE/N_DIV,N_TABLE/N_DIV) (n,k) tables are
+C meaningful. Hence the K_MAX size
+C
+C COL_M : type of columns meaningful in the (n,k) table (example: even columns
+C for the epsilon algorithm)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 1 Mar 2013
+C
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVACC_MOD, L => LEVIN
+ USE CONVTYP_MOD
+C
+ PARAMETER (N_METH=24)
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ COMPLEX*16 ZEROC,ONEC
+C
+ REAL*8 R2_SN(N_ORD_M),RHO
+C
+ REAL R_SN(N_ORD_M)
+C
+ INTEGER N_DIV(N_METH)
+C
+ CHARACTER*3 COL_M(N_METH)
+ CHARACTER*4 SCHE(N_METH)
+ CHARACTER*10 NAME(N_METH),METH
+C
+ DATA SCHE /'AITK','RICH','EPSI','RHOA','THET','LEGE',
+ 1 'CHEB','OVER','DURB','DLEV','TLEV','ULEV',
+ 2 'VLEV','ELEV','EULE','GBWT','EALG','SALZ',
+ 3 'VARI','ITHE','EPSG','NONE','NONE','NONE'/
+ DATA NAME /' AITKEN ','RICHARDSON',' EPSILON ',
+ 1 ' RHO ',' THETA ',' LEGENDRE ',
+ 2 'CHEBYSHEV ',' OVERHOLT ',' DURBIN ',
+ 3 ' D LEVIN ',' T LEVIN ',' U LEVIN ',
+ 4 ' V LEVIN ',' E LEVIN ',' EULER ',
+ 5 ' GBW ',' E ',' SALZER ',
+ 6 ' VARIA ','ITER THETA',' EPSILON G',
+ 7 ' ',' ',' '/
+ DATA COL_M /'ALL','ALL','EVE','EVE','EVE','ALL',
+ 1 'ALL','ALL','ALL','ALL','ALL','ALL',
+ 2 'ALL','ALL','ALL','ALL','ALL','ALL',
+ 3 'ALL','ALL','EVE','ALL','ALL','ALL'/
+ DATA N_DIV /2,1,1,2,2,1,
+ 1 1,1,4,1,1,1,
+ 2 1,1,1,1,1,1,
+ 3 2,4,1,1,1,1/
+C
+ J_NAME=0
+ I_COL=0
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ DO J=J_INI,J_FIN
+ R2_SN(J)=DBLE(R_SN(J))
+ ENDDO
+C
+C Finding the name of the method
+C
+ DO JM=1,N_METH
+C
+ IF(METHOD.EQ.SCHE(JM)) THEN
+ J_NAME=JM
+ K_MAX=N_MAX/N_DIV(JM)
+ N_COEF=N_DIV(JM)
+ IF(COL_M(JM).EQ.'EVE') I_COL=2
+ ENDIF
+C
+ ENDDO
+C
+C Initialization of array SN
+C
+ DO N=J_INI,J_FIN
+C
+ DO K=-1,J_FIN
+C
+ SN(N,K)=ZEROC
+C
+ ENDDO
+C
+ ENDDO
+C
+C Initialisation of the schemes :
+C
+C -- SN(N,0) is the series to be accelerated --
+C
+ SN(0,-1)=ZEROC
+ SN(0,0)=ONEC
+C
+ DO N=J_INI,J_FIN
+C
+ SN(N,-1)=ZEROC
+ SN(N,0)=R2_SN(N)
+C
+ ENDDO
+C
+ CALL ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C Check for convergence : all results equal within ACC
+C in a N_TABLE x N_TABLE square
+C
+ IF(I_CONV.EQ.0) THEN
+ CALL CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,K_MAX,
+ & N_COEF,I_COL,ACC,RHO,SN)
+ ENDIF
+C
+ IF(METHOD(2:4).EQ.'LEV') THEN
+ METH=NAME(J_NAME)(1:9)//CHAR(48+I_WN)
+ ELSE
+ METH=NAME(J_NAME)
+ ENDIF
+C
+C Incrementation of the number of calls to this subroutine
+C if convergence has not been achieved
+C
+ IF((I_CONV.EQ.0).OR.(ABS(I_ACC).EQ.2)) THEN
+ N_CALL=N_CALL+1
+ ELSE
+ GOTO 10
+ ENDIF
+C
+C Printing the results in the check file
+C
+ 15 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',5X,'*')
+ 16 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',35X,'*')
+ 17 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',35X,'*')
+ 18 FORMAT(2X,'*',3X,I3,' --->','(',E12.6,',',E12.6,')',3X,'(',E12.6,
+ &',',E12.6,')',5X,'*')
+ 19 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',20X,'*')
+ 21 FORMAT(2X,'*',3X,I3,25X,'(',E12.6,',',E12.6,')',' <---
+ &convergence',2X,'*')
+ 25 FORMAT(2X,'*',3X,I3,5X,'(',E12.6,',',E12.6,')',3X,'(',E12.6,',',
+ &E12.6,')',3X,' * <--- convergence')
+ 35 FORMAT(2X,'***************************************','************
+ &************************')
+ 45 FORMAT(2X,'* ','
+ & *')
+ 65 FORMAT(2X,'* Exact result S = (',E12.6,',',E12.6,')
+ & *')
+ 75 FORMAT(2X,'* Order Taylor ',20X,A10,'
+ & *')
+ 105 FORMAT(2X,'* Convergence ',A4,26X,A4,14X,'*',/2X,'*
+ & order ',60X,'*')
+ 133 FORMAT(//,5X,'<<<<<<<<<< THIS METHOD IS NOT IMPLEMENTED ',
+ &'>>>>>>>>>>',//)
+C
+ 10 RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE ACC_SCAL(J_INI,J_FIN,METHOD,SN)
+C
+C This subroutine computes the scalar convergence acceleration
+C for various methods
+C
+C Note: let us consider that the (n,k) space pattern indicates
+C that we need S(n,k),...,S(n+p,k) in order to compute
+C S(n,k+1). We call N the maximum value of n for which
+C the S(n,0) are known. Then, to compute S(n,k+1), we
+C we need to know up to S(n+pk+p,0). This means that
+C the value of n is limited to N-pk-p.
+C
+C Author : D. Sebilleau
+C
+C Last modified : 14 Mar 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+ USE CONVACC_MOD, L => LEVIN
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 NK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SI(-1:N_ORD_M),TN(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 DELTA1,DELTA2,DELTA3,DELTA4,DELTA5
+ COMPLEX*16 NUM,DEN,FIR
+ COMPLEX*16 VAR,A,B,C,ZEROC,ONEC,XK
+C
+ REAL*8 EPS,EPSS,MUL
+C
+ CHARACTER*4 METHOD
+C
+ DATA EPS,EPSS /1.D-12,1.D-150/
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+ N_APP=J_FIN
+ N_INI=0
+C
+ IF(METHOD.EQ.'AITK') THEN
+C
+C The iterated Aitken and modified Aitken schemes
+C
+C H. H. H. Homeier, Num. Alg. 8, 47 (1994)
+C
+C I_VA = 1 : iterated Aitken (p 49 eq 5)
+C I_VA = 2 : modified iterated Aitken (p 49 eq 9)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ IF(I_VA.EQ.1) THEN
+ XK=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ XK=ONEC*DFLOAT(K+K+1)/DFLOAT(K+1)
+ ENDIF
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ IF(CDABS(DELTA2).LT.EPSS) THEN
+ DELTA3=ZEROC
+ ELSE
+ DELTA3=DELTA1*DELTA1/(DELTA2-DELTA1)
+ ENDIF
+ SN(N,K+1)=SN(N,K)-XK*DELTA3
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RICH') THEN
+C
+C The Richardson scheme
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=SN(N+1,0)-SN(N,0)
+ DELTA2=SN(N+K+2,0)-SN(N+K+1,0)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 10
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 10 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'SALZ') THEN
+C
+C The Salzer scheme
+C
+C A. Hautot, http://physinfo.org/Acc_Conv/Acc_Conv_Part4.pdf (p 12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=DFLOAT(N+K+2)
+ DELTA2=DFLOAT(N+1)
+ IF(CDABS(DELTA2-DELTA1).LT.EPSS) GOTO 11
+ SN(N,K+1)=(SN(N+1,K)*DELTA1-SN(N,K)*DELTA2)/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 11 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'GBWT') THEN
+C
+C The GBW scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C (eq 6.1-5 p33)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=XN(N)
+ DELTA2=XN(N+K+1)
+ IF(CDABS(DELTA1-DELTA2).LT.EPSS) GOTO 80
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 80 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSI') THEN
+C
+C The epsilon scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989) (p 21 eq 4-2-1)
+C A. Salam, J. Comput. Appl. Math 46, 455 (1993) (p 456)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ DELTA1=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 20
+ IF(I_VA.EQ.1) THEN
+ VAR=ONEC
+ ELSEIF(I_VA.EQ.2) THEN
+ VAR=XN(N+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ VAR=XN(N+K+1)-XN(N+K)
+ ENDIF
+ SN(N,K+1)=SN(N+1,K-1)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+C
+ 20 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EPSG') THEN
+C
+C The generalized epsilon scheme
+C
+C M. N. Barber and C. J. Hamer,
+C J. Austral. Math. Soc. (Series B) 23, 229 (1982)
+C
+C DELTA1 = 0 implies SN(N,K+1) = 0 (calculation not performed)
+C DELTA2 = 0 implies SN(N+1,K) = SN(N,K)
+C ---> convergence achieved for (N,K)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP,2
+C
+ IF(I_VA.EQ.1) THEN
+ SI(K)=ALPHA
+ SI(K+1)=ALPHA
+ ELSEIF(I_VA.EQ.2) THEN
+ SI(K)=ZEROC
+ SI(K+1)=-ONEC
+ ENDIF
+C
+ ENDDO
+C
+ VAR=ONEC
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ NK(N,-1)=ZEROC
+ DELTA2=(SN(N+1,K)-SN(N,K))
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 23
+ NK(N,K)=SI(K)*NK(N,K-1)+VAR/DELTA2
+ DELTA1=(NK(N,K)-NK(N-1,K))
+ IF(CDABS(DELTA1).LT.EPSS) GOTO 23
+ SN(N,K+1)=SN(N,K)+VAR/DELTA1
+ N_COUNT=N_COUNT+1
+ 23 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'RHOA') THEN
+C
+C The rho scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Osada's formulation (p 87 eq 11-2-1)
+C I_VA = 2 : Standard rho (p 34 eq 6.2-2)
+C I_VA = 3 : (p 37 eq 6.3-3) ???????
+C
+C ALPHA is the decay parameter. It is
+C generally advised to take it as
+C an integer to ensure convergence
+C
+ IF(DREAL(ALPHA).LT.0.0D0) THEN
+C
+C Drummond approximation to alpha :
+C
+C (non valid for the Taylor expansion
+C of 1/1+x as in this case the denominator
+C is always zero)
+C
+ DO N=N_INI,N_APP
+C
+ DELTA1=SN(N+3,1)-SN(N+2,1)
+ DELTA2=SN(N+2,1)-SN(N+1,1)
+ DELTA3=SN(N+1,1)-SN(N,1)
+C
+ NUM=(DELTA2-DELTA3)*(DELTA1-DELTA2)
+ DEN=(DELTA1-DELTA2)*DELTA2-(DELTA2-DELTA3)*DELTA1
+ ALPHA=NUM/DEN-ONEC
+C
+ ENDDO
+C
+ ENDIF
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ IF(I_VA.NE.3) THEN
+ DEN=(SN(N+1,K)-SN(N,K))
+ ELSE
+ DELTA2=(SN(N+2,K)-SN(N+1,K))
+ DELTA3=(SN(N+1,K)-SN(N,K))
+ DEN=(XN(N+2*K)-XN(N+1))*DELTA3-(XN(N+2*K-1)-
+ & XN(N))*DELTA2
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPS) GOTO 30
+ IF((I_VA.EQ.3).AND.(N.EQ.(N_APP-K-1))) GOTO 30
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=(DFLOAT(K+1)+ALPHA)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+K+1)-XN(N)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=(XN(N+2*K+1)-XN(N))*DELTA2*DELTA3
+ ENDIF
+C
+ SN(N,K+1)=SN(N+1,K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 30 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'THET') THEN
+C
+C The theta scheme
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C E. Calicetti et al, Phys. Rep. 446, 1 (2007)
+C
+C I_VA = 1 : standard formulation (eq 71 p 19)
+C I_VA = 2 : generalized formulation (eq 10.1-10 p 74)
+C
+ KMAX2=(N_APP-2)/2
+C
+ N_COUNT=0
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,KMAX2
+C
+ IF(I_VA.EQ.3) GOTO 51
+C
+ DO N=N_INI,N_APP-2*K-1
+C
+ DEN=SN(N+1,2*K)-SN(N,2*K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 40
+ IF(I_VA.EQ.1) THEN
+ NUM=1.D0
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=XN(N+2*K+1)-XN(N)
+ ENDIF
+ SN(N,2*K+1)=SN(N+1,2*K-1)+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 40 CONTINUE
+C
+ ENDDO
+C
+ DO N=N_INI,N_APP-4*K-2
+C
+ DELTA2=SN(N+2,2*K)-SN(N+1,2*K)
+ DELTA3=SN(N+1,2*K+1)-SN(N,2*K+1)
+ DELTA4=SN(N+2,2*K+1)-SN(N+1,2*K+1)
+C
+ IF(I_VA.EQ.1) THEN
+ NUM=DELTA2*DELTA4
+ DEN=DELTA4-DELTA3
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=(XN(N+2*K+2)-XN(N))*DELTA2*DELTA4
+ DEN=(XN(N+2*K+2)-XN(N+1))*DELTA3-(XN(N+2*K+1)-XN(
+ & N))*DELTA4
+ ENDIF
+ IF(CDABS(DEN).LT.EPSS) GOTO 50
+C
+ SN(N,2*K+2)=SN(N+1,2*K)+NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 50 CONTINUE
+C
+ ENDDO
+ GOTO 52
+C
+ 51 DO N=N_INI,N_APP-4*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ DELTA4=DELTA3-DELTA2
+ DELTA5=DELTA2-DELTA1
+ DEN=DELTA3*DELTA5-DELTA1*DELTA4
+ IF(CDABS(DEN).LT.EPSS) GOTO 53
+C
+ NUM=DELTA1*DELTA2*DELTA4
+ SN(N,K+1)=SN(N+1,K)-NUM/DEN
+C
+ N_COUNT=N_COUNT+1
+C
+ 53 CONTINUE
+C
+ ENDDO
+C
+ 52 CONTINUE
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'LEGE') THEN
+C
+C The Legendre-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.3), (4.4) p. 231
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DELTA1=DFLOAT(K+K+1)/DFLOAT(K+1)
+ DELTA2=DFLOAT(K)/DFLOAT(K+1)
+C
+ DO N=N_INI,N_APP-K-1
+ SN(N,K+1)=DELTA1*(2.D0*SN(N+1,K)-SN(N,K))-DELTA2*SN(
+ & N,K-1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'CHEB') THEN
+C
+C The Chebyshev-Toeplitz scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C eq. (4.4) - (4.9) p. 231
+C
+ SI(0)=ONEC
+ SI(1)=3.D0*ONEC
+C
+ DO N=N_INI,N_APP-1
+C
+ TN(N,0)=SN(N,0)
+ TN(N,1)=SN(N,0)+2.D0*TN(N+1,0)
+ SN(N,0)=TN(N,0)/SI(0)
+ SN(N,1)=TN(N,1)/SI(1)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=1,N_APP-1
+C
+ SI(K+1)=6.D0*SI(K)-SI(K-1)
+C
+ DO N=N_INI,N_APP-K-1
+C
+ TN(N,K+1)=2.D0*TN(N,K)+4.D0*TN(N+1,K)-TN(N,K-1)
+ SN(N,K+1)=TN(N,K+1)/SI(K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'OVER') THEN
+C
+C The Overholt scheme
+C
+C H. H. H. Homeier, J. Mol. Struc. (Theochem) 368, 81 (1996)
+C (eq 36 p 85)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-2
+C
+ DELTA1=ONEC
+ DELTA2=ONEC
+ MUL=1.D0
+C
+ DO I=1,K+1
+C
+ DELTA1=DELTA1*(SN(N+K+1,0)-SN(N+K,0))
+ DELTA2=DELTA2*(SN(N+K+2,0)-SN(N+K+1,0))
+ MUL=MUL*EPS
+C
+ ENDDO
+C
+ IF(CDABS(DELTA1-DELTA2).LT.MUL) GOTO 60
+C
+ SN(N,K+1)=(DELTA1*SN(N+1,K)-DELTA2*SN(N,K))/(DELTA1-
+ & DELTA2)
+ N_COUNT=N_COUNT+1
+C
+ 60 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'DURB') THEN
+C
+C The Durbin scheme
+C
+C C. Brezinski and M. Redivo Zaglia, Comput. Appl. Math. 26, 171 (2007)
+C (eq 25 p 185)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-4*K-4
+C
+ DELTA1=3.D0*SN(N+2,K)*SN(N+2,K)-4.D0*SN(N+1,K)*SN(N+
+ & 3,K)+SN(N,K)*SN(N+4,K)
+ DELTA2=6.D0*SN(N+2,K)-4.D0*(SN(N+1,K)+SN(N+3,K))+SN(
+ & N,K)+SN(N+4,K)
+ IF(CDABS(DELTA2).LT.EPSS) GOTO 70
+ SN(N,K+1)=DELTA1/DELTA2
+ N_COUNT=N_COUNT+1
+C
+ 70 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD(2:4).EQ.'LEV') THEN
+C
+C The Levin schemes
+C
+ CALL LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ & METHOD(1:1))
+C
+ ELSEIF(METHOD.EQ.'EULE') THEN
+C
+C The generalized Euler scheme
+C
+C D. A. Smith and W. F. Ford, SIAM J. Numer. Anal. 16, 223 (1979)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-K-1
+C
+ SN(N,K+1)=(SN(N+1,K)-BETA*SN(N,K))/(ONEC-BETA)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'VARI') THEN
+C
+C Various schemes
+C
+C I_VA = 1 : Weniger lambda scheme (p 87 eq 11-2-1)
+C I_VA = 2 : Weniger sigma scheme (p 87 eq 11-2-2)
+C I_VA = 3 : Weniger mu scheme (p 87 eq 11-2-3)
+C I_VA = 4 : iterated rho scheme
+C I_VA = 5 : Bjorstad, Dahlquist and Grosse scheme (p 77 eq 6-3-4)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-2*K-2
+C
+ IF(I_VA.EQ.1) THEN
+ A=BETA+DFLOAT(N)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.2) THEN
+ A=ALPHA+DFLOAT(N+K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.3) THEN
+ A=ALPHA+DFLOAT(N-K)
+ B=A+ONEC
+ C=A
+ ELSEIF(I_VA.EQ.4) THEN
+ A=XN(N+2*K+2)-XN(N)
+ B=XN(N+2*K+1)-XN(N)
+ C=XN(N+2*K+2)-XN(N+1)
+ ELSEIF(I_VA.EQ.5) THEN
+ A=(DFLOAT(2*K+1)+ALPHA)/(DFLOAT(2*K)+ALPHA)
+ B=ONEC
+ C=ONEC
+ ENDIF
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DEN=B*DELTA2-C*DELTA1
+ IF(CDABS(DEN).LT.EPSS) GOTO 81
+ SN(N,K+1)=SN(N+1,K)-A*DELTA1*DELTA2/DEN
+ N_COUNT=N_COUNT+1
+C
+ 81 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'ITHE') THEN
+C
+C Iterated theta schemes
+C
+C R. Thukral, Appl. Math. Comput. 187, 1502 (2007) <--- Lubkin
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C I_VA = 1 : Lubkin transform = iterated theta transform (p 79 eq 10-3-6)
+C I_VA = 2 : iterated theta transform (p 84 eq 11-1-5)
+C I_VA = 3 : 2nd modified iterated Aitken transform (p 85 eq 11-1-12)
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,N_APP-3*K-3
+C
+ DELTA1=SN(N+1,K)-SN(N,K)
+ DELTA2=SN(N+2,K)-SN(N+1,K)
+ DELTA3=SN(N+3,K)-SN(N+2,K)
+ IF(I_VA.EQ.1) THEN
+ NUM=-DELTA1*DELTA2*(DELTA3-DELTA2)
+ DEN=DELTA3*(DELTA2-DELTA1)-DELTA1*(DELTA3-DELTA2)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.2) THEN
+ NUM=DELTA1*DELTA1*DELTA1*(DELTA3-DELTA2)
+ DEN=DELTA1*DELTA1*(DELTA3-DELTA2)-DELTA2*DELTA2*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+1,K)
+ ELSEIF(I_VA.EQ.3) THEN
+ NUM=DELTA2*DELTA2*DELTA3*(DELTA3-DELTA2)
+ DEN=DELTA2*DELTA2*(DELTA3-DELTA2)-DELTA3*DELTA3*(
+ & DELTA2-DELTA1)
+ FIR=SN(N+2,K)
+ ENDIF
+C
+ IF(CDABS(DEN).LT.EPSS) GOTO 90
+ SN(N,K+1)=FIR+NUM/DEN
+ N_COUNT=N_COUNT+1
+C
+ 90 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(METHOD.EQ.'EALG') THEN
+C
+C E algorithm
+C
+ N_COUNT=0
+C
+ CALL INTERP_POINTS(I_XN,2*N_APP,ALPHA,BETA,SN,XN)
+ CALL REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C Computing the GN(N,K,I)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 91
+ DELTA1=GN(N,K-1,K)/DEN
+C
+ DO I=0,N_APP
+C
+ NUM=GN(N+1,K-1,I)-GN(N,K-1,I)
+ GN(N,K,I)=GN(N,K-1,I)-NUM*DELTA1
+C
+ ENDDO
+C
+ 91 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computing SN(N,K)
+C
+ DO K=1,N_APP
+C
+ DO N=N_INI,N_APP-K
+C
+ DEN=GN(N+1,K-1,K)-GN(N,K-1,K)
+ IF(CDABS(DEN).LT.EPSS) GOTO 92
+ DELTA1=GN(N,K-1,K)/DEN
+ SN(N,K)=SN(N,K-1)-(SN(N+1,K-1)-SN(N,K-1))*DELTA1
+C
+ 92 CONTINUE
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE COEFFICIENTS(N_APP,COEF,BETA,I_SWITCH)
+C
+C Binomial coefficients ---> ISWITCH = 1
+C Power coefficients ---> ISWITCH = 2
+C Pochhammer coefficients ---> ISWITCH = 3
+C Pochhammer coefficients ---> ISWITCH = 4 (negative argument)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Sep 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),BETA,ONEC
+C
+ ONEC=(1.D0,0.D0)
+C
+ COEF(0,0)=ONEC
+ COEF(1,0)=ONEC
+ COEF(1,1)=ONEC
+C
+ IF(I_SWITCH.EQ.1) THEN
+C
+ DO N=2,N_APP-1
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=DCMPLX(N)
+C
+ DO K=2,N
+C
+ COEF(N,K)=COEF(N-1,K-1)+COEF(N-1,K)
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.2) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+ COEF(N,1)=BETA+DFLOAT(N)
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.3) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(BETA+DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ELSEIF(I_SWITCH.EQ.4) THEN
+C
+ DO N=0,N_APP
+C
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ COEF(N,K)=COEF(N,K-1)*(-BETA-DFLOAT(N+K-1))
+C
+ ENDDO
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE LEVIN(ALPHA,BETA,SN,I_WN,I_XN,N_APP,N_INI,L,N_COUNT,
+ &OMEGA)
+C
+C This subroutine computes Levin-type transforms of
+C a given sequence SN(N,1)
+C
+C E. J. Weniger, Comp. Phys. Rep. 10, 189 (1989)
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),AN(-1:N_ORD_M),WN(-1:
+ &N_ORD_M)
+ COMPLEX*16 COEF(-1:3*N_ORD_M,-1:N_ORD_M),ZEROC,ONEC
+ COMPLEX*16 COEL(-1:3*N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 DEN(-1:N_ORD_M,-1:N_ORD_M),NUM(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 X,XK,XXK,ALPHA,BETA,INC,SUM_1,SUM_2
+C
+ CHARACTER*1 OMEGA
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Recovery of the original series elements
+C
+ DO N=N_INI,N_APP
+C
+ AN(N)=SN(N,0)-SN(N-1,0)
+C
+ ENDDO
+C
+C
+C Choice of the remainder estimate omega_n
+C
+C Reference : H. H. H. Homeier, J. Comput. App. Math. 122, 81 (2000)
+C
+C
+ IF(OMEGA.EQ.'U') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*(DFLOAT(N)+BETA)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'V') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+1)/(AN(N)-AN(N+1))
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'T') THEN
+C
+ MAX_N=N_APP
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'D') THEN
+C
+ MAX_N=N_APP-1
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N+1)
+ ENDDO
+C
+ ELSEIF(OMEGA.EQ.'E') THEN
+C
+ MAX_N=N_APP-2
+C
+ DO N=N_INI,MAX_N
+ WN(N)=AN(N)*AN(N+2)/AN(N+1)
+ ENDDO
+C
+ ENDIF
+C
+C Choice of the Levin-type transform
+C
+C I_WN = 1 ---> L-type (eq 7.2-8 p 41) (eq 3-13b p 10)
+C I_WN = 2 ---> S-type (eq 8.3-7 p 58) (eq 3-14b p 10)
+C I_WN = 3 ---> M-type !! BETA > K-1 (eq 9.3-7 p 66) (eq 3-15b p 10)
+C I_WN = 4 ---> C-type (eq 3-16c p 11)
+C I_WN = 5 ---> Drummond-type (eq 9.5-5 p 70)
+C I_WN = 6 ---> R-type (eq 7.14-12 p 47)
+C
+C References : E. J. Weniger, J. Math. Phys. 45 1209 (2004)
+C E. J. Weniger, Comp. Phys. Rep. 10 189 (1989)
+C
+C
+C Check for the possibility of L extension (the standard case is L = 0)
+C
+ IF(L.GT.0) THEN
+ IF(I_WN.EQ.1) THEN
+ CALL COEFFICIENTS(MAX_N,COEL,BETA,2)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.2) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,3)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ELSEIF(I_WN.EQ.3) THEN
+ CALL COEFFICIENTS(N_APP,COEL,BETA,4)
+ DO N=N_INI,MAX_N
+ WN(N)=WN(N)*COEL(N,L)
+ ENDDO
+ ENDIF
+ ENDIF
+C
+ DO N=N_INI,MAX_N
+C
+ X=BETA+DFLOAT(N)
+ COEF(N,0)=ONEC
+C
+ DO K=1,N_APP
+C
+ XK=DFLOAT(K)
+ XXK=X+XK
+C
+ IF(I_WN.EQ.1) THEN
+ INC=XXK/(XXK+ONEC)
+ COEF(N,K)=X*(INC**K)/XXK
+ ELSEIF(I_WN.EQ.2) THEN
+ COEF(N,K)=(XXK-ONEC)*XXK/((XXK+XK-ONEC)*(XXK+XK))
+ ELSEIF(I_WN.EQ.3) THEN
+ COEF(N,K)=(X-XK+ONEC)/(XXK+ONEC)
+ ELSEIF(I_WN.EQ.4) THEN
+ SUM_1=ZEROC
+ SUM_2=ZEROC
+ DO J=0,K
+ SUM_1=SUM_1+ALPHA*XXK
+ SUM_2=SUM_2+ALPHA*(XXK+ONEC)
+ ENDDO
+ COEF(N,K)=(ALPHA*X+XK-ONEC)*SUM_1/(ALPHA*XXK*SUM_2)
+ ELSEIF(I_WN.EQ.5) THEN
+ COEF(N,K)=ONEC
+ ELSEIF(I_WN.EQ.6) THEN
+ CALL INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+C Computation of the recurrence relation for numerator
+C and denominator
+C
+ DO N=N_INI,MAX_N
+C
+C Starting values
+C
+ NUM(N,0)=SN(N,0)/WN(N)
+ DEN(N,0)=ONEC/WN(N)
+ SN(N,0)=NUM(N,0)/DEN(N,0)
+C
+ ENDDO
+C
+ N_COUNT=0
+C
+ DO K=0,N_APP-1
+C
+ DO N=N_INI,MAX_N-K-1
+C
+ IF(I_WN.NE.6) THEN
+ NUM(N,K+1)=NUM(N+1,K)-COEF(N,K)*NUM(N,K)
+ DEN(N,K+1)=DEN(N+1,K)-COEF(N,K)*DEN(N,K)
+ ELSE
+ NUM(N,K+1)=(NUM(N+1,K)-NUM(N,K))/(XN(N+K+1)-XN(N))
+ DEN(N,K+1)=(DEN(N+1,K)-DEN(N,K))/(XN(N+K+1)-XN(N))
+ ENDIF
+ SN(N,K+1)=NUM(N,K+1)/DEN(N,K+1)
+ N_COUNT=N_COUNT+1
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE INTERP_POINTS(I_XN,N_APP,ALPHA,BETA,SN,XN)
+C
+C This subroutine computes the interpolation
+C points used in some algorithms
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 ALPHA,BETA
+C
+ DO N=0,N_APP
+C
+ IF(I_XN.EQ.1) THEN
+ XN(N)=(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.2) THEN
+ XN(N)=BETA+DFLOAT(N)
+ ELSEIF(I_XN.EQ.3) THEN
+ XN(N)=(BETA+DFLOAT(N))*(SN(N+1,0)-SN(N,0))
+ ELSEIF(I_XN.EQ.4) THEN
+ XN(N)=(BETA+DFLOAT(N))**ALPHA
+ ELSEIF(I_XN.EQ.5) THEN
+ XN(N)=((2.D0**N)/BETA)**ALPHA
+ ENDIF
+C
+ ENDDO
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C This subroutine computes the G_N series used to describe
+C the correction on the remainder estimate
+C
+C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n}
+C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation)
+C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.)
+C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n}
+C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n}
+C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne)
+C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Computing binomial coefficients
+C
+ IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1)
+C
+ DO N=0,N_APP
+C
+ GN(N,0,-1)=ZEROC
+ GN(N,0,0)=ONEC
+ MONE=-ONEC
+C
+ DO I=1,N_APP
+C
+ IF(I_GN.EQ.1) THEN
+ GN(N,0,I)=GN(N,0,I-1)*XN(N)
+ ELSEIF(I_GN.EQ.2) THEN
+ GN(N,0,I)=XN(N+I-1)
+ ELSEIF(I_GN.EQ.3) THEN
+ GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0)
+ ELSEIF(I_GN.EQ.4) THEN
+ GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N)
+ ELSEIF(I_GN.EQ.5) THEN
+ GN(N,0,I)=GN(N,0,I-1)/XN(N)
+ ELSEIF(I_GN.EQ.6) THEN
+ MONE=-MONE
+ SUM_J=ZEROC
+ ONE=-ONEC
+ DO J=0,I
+ ONE=-ONE
+ SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0)
+ ENDDO
+ GN(N,0,I)=MONE*SUM_J
+ ELSEIF(I_GN.EQ.7) THEN
+ IF(I.GT.1) THEN
+ GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0)
+ ELSE
+ GN(N,0,I)=SN(N,0)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE CHECK_CONV(J_INI,J_FIN,N_TABLE,I_CONV,N_ACC,K_ACC,
+ &K_MAX,N_COEF,I_COL,ACC,RHO,SN)
+C
+C This subroutine checks the convergence of the acceleration process.
+C For convergence, there must be a N_TABLE x N_TABLE square in the (n,k) table
+C of SN(n,k)that contains equal values (SMALL being the accepted error)
+C
+C This way, both the column convergence (k fixed and n increasing)
+C and the diagonal convergence (n=k increasing) are considered
+C
+C Important note: in some algorithms, such as the epsilon one, only
+C odd columns are meaningful. If I_COL = 0, all
+C columns are taken into account while for I_COL = 2
+C only even columns are considered
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2011
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+C
+ REAL*8 ACC,REF,COMP,RHO
+C
+C Step for the columns comparison and change of the size
+C of the square when only even columns should be considered
+C
+ IF(I_COL.EQ.0) THEN
+ I_STEP=1
+ N_SQUARE=N_TABLE
+ N_START=N_TABLE
+ ELSEIF(I_COL.EQ.2) THEN
+ I_STEP=2
+ N_SQUARE=N_TABLE+N_TABLE-1
+ IF(MOD(N_SQUARE,2).EQ.0) THEN
+ N_START=N_SQUARE
+ ELSE
+ N_START=N_SQUARE+1
+ ENDIF
+ ENDIF
+C
+C Positionning the bottom right corner of the square: (N,K),
+C starting from (N_START,N_START). If only even columns
+C should be considered, N_START must be even
+C
+ K_FIN=J_FIN/N_COEF
+ IF(K_FIN.LT.N_START) THEN
+ I_CONV=0
+ GOTO 10
+ ENDIF
+C
+ DO K=N_START,K_FIN+N_START-1,I_STEP
+ IF(K.GT.K_MAX) GOTO 20
+ DO N=N_START,K_FIN-K,I_STEP
+C
+C Checking the values (N1,K1) in the selected square
+C
+ REF=CDABS(SN(N,K))
+ I_CONV=1
+C
+ DO N1=0,N_START,I_STEP
+ NN=N-N1
+ DO K1=0,N_START,I_STEP
+C
+ KK=K-K1
+ COMP=CDABS(REF-SN(NN,KK))
+ IF(COMP.GT.ACC) THEN
+ I_CONV=0
+ ENDIF
+C
+ ENDDO
+ ENDDO
+C
+ IF(I_CONV.EQ.1) THEN
+C
+C All values in the square are equal (within ACC):
+C Spectral radius taken as the left top corner value
+C
+ N_ACC=N-N_START+I_STEP
+ K_ACC=K-N_START+I_STEP
+ RHO=REF
+ GOTO 10
+ ENDIF
+C
+ ENDDO
+ 20 CONTINUE
+ ENDDO
+C
+ 10 RETURN
+C
+ END
+C
+C=======================================================================
+C
+ SUBROUTINE CONV_SERIES(ACC,N_TABLE,JORD,R_SN,*)
+C
+C This subroutine checks the convergence of the power method or of
+C the Rayleigh quotient method at level JORD without convergence
+C acceleration. For convergence, there must be N_TABLE equal values
+C (ACC being the accepted error) of SN
+C
+C Author : D. Sebilleau
+C
+C Last modified : 27 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ REAL ACC,COMP,R_SN(N_ORD_M)
+C
+ NCONV=0
+ DO J=JORD,JORD-N_TABLE,-1
+ COMP=ABS(R_SN(J)-R_SN(J-1))
+ IF(COMP.LE.ACC) THEN
+ NCONV=NCONV+1
+ ENDIF
+ ENDDO
+C
+ IF(NCONV.EQ.N_TABLE-1) RETURN 1
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/remain_series.f b/src/msspec/spec/fortran/eig/pw/remain_series.f
new file mode 100644
index 0000000..7c9ae61
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/remain_series.f
@@ -0,0 +1,79 @@
+C
+C=======================================================================
+C
+ SUBROUTINE REMAIN_SERIES(I_GN,N_APP,SN,XN,GN)
+C
+C This subroutine computes the G_N series used to describe
+C the correction on the remainder estimate
+C
+C I_GN = 1 : G_{i}(n) = G_{i-1}(n)*x_{n}
+C I_GN = 2 : G_{i}(n) = x_{n+i-1} (G transformation)
+C I_GN = 3 : G_{i}(n) = DELTA S_{n+i-1} (epsilon alg.)
+C I_GN = 4 : G_{i}(n) = G_{i-1}(n)*S_{n}/x_{n}
+C I_GN = 5 : G_{i}(n) = G_{i-1}(n)/x_{n}
+C I_GN = 6 : G_{i}(n) = (DELTA S_{n})^i (Germain-Bonne)
+C I_GN = 7 : G_{i}(n) = x_{n+i-2} (p process)
+C
+C
+C Author : D. Sebilleau
+C
+C Last modified : 28 Feb 2013
+C
+C INCLUDE 'spec.inc'
+C
+ USE DIM_MOD
+C
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M),XN(-1:N_ORD_M)
+ COMPLEX*16 GN(-1:N_ORD_M,-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 CNK(-1:3*N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 SUM_J,MONE,ONE,ZEROC,ONEC
+C
+ ZEROC=(0.D0,0.D0)
+ ONEC=(1.D0,0.D0)
+C
+C Computing binomial coefficients
+C
+ IF(I_GN.EQ.6) CALL COEFFICIENTS(N_APP,CNK,ZEROC,1)
+C
+ DO N=0,N_APP
+C
+ GN(N,0,-1)=ZEROC
+ GN(N,0,0)=ONEC
+ MONE=-ONEC
+C
+ DO I=1,N_APP
+C
+ IF(I_GN.EQ.1) THEN
+ GN(N,0,I)=GN(N,0,I-1)*XN(N)
+ ELSEIF(I_GN.EQ.2) THEN
+ GN(N,0,I)=XN(N+I-1)
+ ELSEIF(I_GN.EQ.3) THEN
+ GN(N,0,I)=SN(N+I,0)-SN(N+I-1,0)
+ ELSEIF(I_GN.EQ.4) THEN
+ GN(N,0,I)=GN(N,0,I-1)*SN(N,0)/XN(N)
+ ELSEIF(I_GN.EQ.5) THEN
+ GN(N,0,I)=GN(N,0,I-1)/XN(N)
+ ELSEIF(I_GN.EQ.6) THEN
+ MONE=-MONE
+ SUM_J=ZEROC
+ ONE=-ONEC
+ DO J=0,I
+ ONE=-ONE
+ SUM_J=SUM_J+ONE*CNK(I,J)*SN(N+J,0)
+ ENDDO
+ GN(N,0,I)=MONE*SUM_J
+ ELSEIF(I_GN.EQ.7) THEN
+ IF(I.GT.1) THEN
+ GN(N,0,I)=SN(N+I-1,0)-SN(N+I-2,0)
+ ELSE
+ GN(N,0,I)=SN(N,0)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/eig/pw/spec_rad_power.f b/src/msspec/spec/fortran/eig/pw/spec_rad_power.f
new file mode 100644
index 0000000..b5746fb
--- /dev/null
+++ b/src/msspec/spec/fortran/eig/pw/spec_rad_power.f
@@ -0,0 +1,547 @@
+C
+C=======================================================================
+C
+ SUBROUTINE SPEC_RAD_POWER(JE,E_KIN)
+C
+C This subroutine computes the spectral radius of the G_o T kernel matrix
+C using the power method and the Rayleigh quotient. In addition,
+C a scalar convergence acceleration method can be used to refine the results.
+C
+C Power method approximation of the spectral radius :
+C
+C SR(A) = lim ||A^{n} x|| / ||A^{n-1} x||
+C n --> +infty
+C for any starting vector x
+C
+C Rayleigh quotient approximation of the spectral radius :
+C
+C SR(A) = lim ||(A^{n}x)^{+} A A^{n} x| / |(A^{n}x)^{+} A^{n} x||
+C n --> +infty
+C for any starting vector x
+C
+C Note: a shift (= SHIFT) can be introduced in the power method.
+C In this case, only the Rayleigh quotient is valid
+C
+C !!!!! This version does not store the G_o T matrix !!!!!
+C
+C Author : D. Sebilleau
+C
+C Last modified : 1 Mar 2013
+C
+C INCLUDE 'spec.inc'
+ USE DIM_MOD
+ USE CONVTYP_MOD
+ USE COOR_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE TRANS_MOD
+C
+C! PARAMETER(NLTWO=2*NL_M) !Moved to DIM_MOD
+C
+ INTEGER NN(0:N_ORD_M)
+C
+ REAL R_SN(N_ORD_M),R_SN1(N_ORD_M)
+C
+ COMPLEX*16 TLK,SUM_L1,SUM_L2,EXPKJ,EXPJK,ONEC,MULT
+ COMPLEX*16 YLM(0:NLTWO,-NLTWO:NLTWO)
+ COMPLEX*16 X(LINMAX*NATCLU_M)
+ COMPLEX*16 AX(LINMAX*NATCLU_M),SUM_AX,XAX,XX
+ COMPLEX*16 HL1(0:NLTWO)
+ COMPLEX*16 ZEROC,IC,JC,JMULT,IFOURPI,CHIFT
+ COMPLEX*16 SN(-1:N_ORD_M,-1:N_ORD_M)
+ COMPLEX*16 COEF_GAUNT(LINMAX,LINMAX,0:N_GAUNT)
+C
+ REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
+ REAL*8 ATTJK,XJK,YJK,ZJK,RJK,ZDJK,KRJK,SMALL
+ REAL*8 NORMX2,NORMAX2,RLIN
+C
+ CHARACTER*10 METH
+ CHARACTER*24 OUTFILE,PATH
+C
+ DATA PI,SMALL /3.1415926535898D0,1.0D-6/
+C
+ ONEC=(1.D0,0.D0)
+ IC=(0.0D0,1.0D0)
+ ZEROC=(0.D0,0.D0)
+ IFOURPI=4.D0*PI*IC
+ IBESS=3
+ N_CALL=0
+ N_ACC=0
+ K_ACC=0
+ I_CONV=0
+C
+ CHIFT=DCMPLX(SHIFT)
+C
+ IF(N_MAX.GT.N_ORD_M) THEN
+ WRITE(IUO1,99) N_MAX
+ STOP
+ ENDIF
+C
+C Computing the size NLIN of the vectors A x
+C
+ LMAXJ=0
+ NLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ LMAXJ=MAX(LMAXJ,LMJ)
+ DO JNUM=1,NBTYPJ
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ NLIN=NLIN+1
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Storage of the modified Gaunt coefficients
+C
+ LIN1=0
+ DO L1=0,LMAXJ
+ DO M1=-L1,L1
+ LIN1=LIN1+1
+ LIN2=0
+ DO L2=0,LMAXJ
+ L_MIN=ABS(L2-L1)
+ L_MAX=L1+L2
+ DO M2=-L2,L2
+ LIN2=LIN2+1
+ CALL GAUNT2(L1,M1,L2,M2,GNT)
+ DO L=L_MIN,L_MAX,2
+ M=M1-M2
+ COEF_GAUNT(LIN1,LIN2,L)=IFOURPI*GNT(L)*(IC**
+ & L)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Starting vector for power method:
+C
+C (JC^0,JC^1,JC^2,JC^3, ... ,JC^N)^EXPO
+C
+ JC=DCOS(PI/6.D0)+IC*DSIN(PI/6.D0)
+ JMULT=JC**EXPO
+C
+ WRITE(IUO1,6)
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(36,76)
+ ELSE
+ WRITE(36,79)
+ ENDIF
+ WRITE(36,75)
+C
+C Initialization the vectors and their squared norm
+C
+ MULT=JMULT
+C
+ AX(1)=ONEC
+C
+ NORMAX2=1.D0
+C
+ DO JLIN=2,NLIN
+C
+ AX(JLIN)=AX(JLIN-1)*MULT
+ NORMAX2=NORMAX2+CDABS(AX(JLIN))*CDABS(AX(JLIN))
+C
+ ENDDO
+C
+C Computation of the vectors and their squared norm
+C
+C X ---> A*X
+C
+ 120 IF(N_CALL.EQ.0) THEN
+ J_INI=1
+ ELSE
+ J_INI=N_CALL*N_ITER+1
+ ENDIF
+ J_FIN=MIN((N_CALL+1)*N_ITER,N_MAX)
+C
+ IF(J_INI.GT.J_FIN) GOTO 112
+C
+ DO JORD=J_INI,J_FIN
+C
+ NORMX2=NORMAX2
+C
+ XX=ZEROC
+ DO JLIN=1,NLIN
+C
+ X(JLIN)=AX(JLIN)
+ XX=XX+CONJG(X(JLIN))*X(JLIN)
+C
+ ENDDO
+C
+ NORMAX2=0.D0
+ XAX=ZEROC
+C
+C
+C Construction of the the multiple scattering kernel matrix G_o T
+C times the vector x
+C
+C Linear indices JLIN and KLIN represent (J,LJ) and (K,LK)
+C
+ JLIN=0
+ DO JTYP=1,N_PROT
+ NBTYPJ=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ XJ=SYM_AT(1,JATL)
+ YJ=SYM_AT(2,JATL)
+ ZJ=SYM_AT(3,JATL)
+C
+ LINJ=0
+ DO LJ=0,LMJ
+ DO MJ=-LJ,LJ
+ JLIN=JLIN+1
+ LINJ=LINJ+1
+C
+ SUM_AX=ZEROC
+C
+ KLIN=0
+ DO KTYP=1,N_PROT
+ NBTYPK=NATYP(KTYP)
+ LMK=LMAX(KTYP,JE)
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ XK=SYM_AT(1,KATL)
+ YK=SYM_AT(2,KATL)
+ ZK=SYM_AT(3,KATL)
+C
+ IF(KATL.NE.JATL) THEN
+C
+ XKJ=DBLE(XK-XJ)
+ YKJ=DBLE(YK-YJ)
+ ZKJ=DBLE(ZK-ZJ)
+ RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
+ KRKJ=DBLE(VK(JE))*RKJ
+ ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*
+ & RKJ)
+ EXPKJ=(XKJ+IC*YKJ)/RKJ
+ ZDKJ=ZKJ/RKJ
+ CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,
+ & LMJ+LMK)
+ CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,
+ & HL1)
+C
+ ENDIF
+C
+ LINK=0
+ DO LK=0,LMK
+ L_MIN=ABS(LK-LJ)
+ L_MAX=LK+LJ
+ TLK=ATTKJ*DCMPLX(TL(LK,1,KTYP,JE))
+ DO MK=-LK,LK
+ KLIN=KLIN+1
+ LINK=LINK+1
+ IF(KATL.NE.JATL) THEN
+C
+ SUM_L1=ZEROC
+ DO L=L_MIN,L_MAX,2
+ M=MJ-MK
+ IF(ABS(M).LE.L) THEN
+ SUM_L1=SUM_L1+HL1(L)*
+ & COEF_GAUNT(LINJ,LINK,L)*YLM(L,M)
+ ENDIF
+ ENDDO
+ SUM_AX=SUM_AX+TLK*SUM_L1*X(
+ & KLIN)
+C
+ ENDIF
+ IF(KLIN.EQ.JLIN) SUM_AX=SUM_AX-
+ & CHIFT*X(KLIN)
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+ AX(JLIN)=SUM_AX
+ NORMAX2=NORMAX2+CDABS(SUM_AX)*CDABS(SUM_AX)
+ XAX=XAX+CONJG(X(JLIN))*SUM_AX
+C
+ ENDDO
+ ENDDO
+C
+ ENDDO
+ ENDDO
+C
+C R_SN : power method
+C R_SN1: Rayleigh quotient
+C
+ R_SN(JORD)=SQRT(REAL(NORMAX2/NORMX2))
+ R_SN1(JORD)=CDABS((XAX/XX)+SHIFT)
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(36,77) JORD,R_SN(JORD),R_SN1(JORD)
+ ELSE
+ WRITE(36,77) JORD,R_SN1(JORD)
+ ENDIF
+C
+C Check of convergence of power method series and
+C Rayleigh quotient method
+C
+C Note: only Rayleigh quotient valid if shift
+C
+ IF((I_PWM.EQ.2).AND.(ABS(SHIFT).LE.SMALL)) THEN
+ IF(JORD.GT.N_TABLE) THEN
+ CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN,*555)
+ ENDIF
+ ENDIF
+C
+ IF((ABS(SHIFT).GT.SMALL).AND.(I_PWM.GT.0)) I_PWM=-I_PWM
+ IF(I_PWM.EQ.-2) THEN
+ IF(JORD.GT.N_TABLE) THEN
+ CALL CONV_SERIES(REAL(ACC),N_TABLE,JORD,R_SN1,*555)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+C
+ 555 IF(J_INI.EQ.1) THEN
+ WRITE(IUO1,10)
+ WRITE(IUO1,11) SHIFT
+ WRITE(IUO1,46) NLIN
+ WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ ENDIF
+C
+ WRITE(IUO1,10)
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(IUO1,44) R_SN(JORD-1)
+ ENDIF
+ WRITE(IUO1,53) R_SN1(JORD-1)
+ WRITE(IUO1,47) JORD-1
+ WRITE(IUO1,10)
+ IF(J_FIN.EQ.N_MAX) THEN
+ IF((I_PWM.EQ.1).OR.(I_PWM.EQ.3)) THEN
+ WRITE(IUO1,213)
+ ELSE
+ WRITE(IUO1,60)
+ ENDIF
+ ENDIF
+C
+ IF(((I_ACC.EQ.1).OR.(I_ACC.EQ.2)).AND.(ABS(SHIFT).LE.SMALL)) THEN
+C
+C Convergence acceleration on the power method results whenever necessary
+C
+ CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ & R_SN,SN,METH)
+ IF(I_ACC.EQ.1) GOTO 111
+ IF((I_CONV.EQ.1).AND.(I_ACC.EQ.2)) GOTO 111
+ IF((I_CONV.EQ.0).AND.(I_ACC.EQ.2)) THEN
+ IF(J_FIN.EQ.N_MAX) THEN
+ GOTO 111
+ ELSE
+ GOTO 120
+ ENDIF
+ ENDIF
+C
+ 111 WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ WRITE(IUO1,10)
+ WRITE(IUO1,52) METH
+ WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC))
+ WRITE(IUO1,49) N_ACC
+ WRITE(IUO1,51) K_ACC
+C
+ IF(I_ACC.EQ.2) THEN
+ OPEN(UNIT=35, FILE='div/n_k_table_pm.lis', STATUS=
+ & 'unknown')
+ K_MAX=MIN(K_MAX,J_FIN)
+ DO L=0,K_MAX
+ NN(L)=L
+ ENDDO
+ WRITE(35,*) ' '
+ WRITE(35,78) E_KIN,METH
+ WRITE(35,*) ' '
+ WRITE(35,198) (NN(K),K=0,K_MAX)
+ WRITE(35,199)
+ WRITE(35,*) ' '
+ DO N=0,K_MAX
+ WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N)
+ WRITE(35,*) ' '
+ ENDDO
+ ENDIF
+C
+ WRITE(IUO1,10)
+ IF(I_ACC.GE.1) WRITE(IUO1,60)
+ IF(I_ACC.EQ.2) THEN
+ IF(I_CONV.EQ.0) WRITE(IUO1,212)
+ WRITE(IUO1,210)
+ ENDIF
+C
+ ENDIF
+C
+ IF((ABS(SHIFT).GT.SMALL).AND.(I_ACC.GT.0)) I_ACC=-I_ACC
+ IF((I_ACC.EQ.-1).OR.(I_ACC.EQ.-2))THEN
+C
+C Convergence acceleration on the Rayleigh quotient whenever necessary
+C
+ CALL ACC_CONV(N_CALL,J_INI,J_FIN,N_ACC,K_ACC,K_MAX,I_CONV,
+ & R_SN1,SN,METH)
+ IF(I_ACC.EQ.-1) GOTO 999
+ IF((I_CONV.EQ.1).AND.(I_ACC.EQ.-2)) GOTO 999
+ IF((I_CONV.EQ.0).AND.(I_ACC.EQ.-2)) THEN
+ IF(J_FIN.EQ.N_MAX) THEN
+ GOTO 999
+ ELSE
+ GOTO 120
+ ENDIF
+ ENDIF
+C
+ 999 WRITE(IUO1,10)
+ WRITE(IUO1,61)
+ WRITE(IUO1,10)
+ WRITE(IUO1,52) METH
+ WRITE(IUO1,48) CDABS(SN(N_ACC,K_ACC))
+ WRITE(IUO1,49) N_ACC
+ WRITE(IUO1,51) K_ACC
+C
+ IF(I_ACC.EQ.-2) THEN
+ OPEN(UNIT=35, FILE='div/n_k_table_rq.lis', STATUS=
+ & 'unknown')
+ K_MAX=MIN(K_MAX,J_FIN)
+ DO L=0,K_MAX
+ NN(L)=L
+ ENDDO
+ WRITE(35,*) ' '
+ WRITE(35,78) E_KIN,METH
+ WRITE(35,*) ' '
+ WRITE(35,198) (NN(K),K=0,K_MAX)
+ WRITE(35,199)
+ WRITE(35,*) ' '
+ DO N=0,K_MAX
+ WRITE(35,200) N,(CDABS(SN(N,K)), K=0,K_MAX-N)
+ WRITE(35,*) ' '
+ ENDDO
+ ENDIF
+C
+ WRITE(IUO1,10)
+ IF(ABS(I_ACC).GE.1) WRITE(IUO1,60)
+ IF(I_ACC.EQ.-2) THEN
+ IF(I_CONV.EQ.0) WRITE(IUO1,215)
+ WRITE(IUO1,214)
+ ENDIF
+C
+ ENDIF
+C
+C Writing the results:
+C
+ IF(ABS(I_ACC).LT.2) THEN
+C
+C No convergence acceleration: power method and Rayleigh quotient
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1)
+ ELSE
+ WRITE(IUO2,*) E_KIN,R_SN1(JORD-1)
+ ENDIF
+C
+ ELSE
+C
+ IF(I_CONV.EQ.1) THEN
+C
+C Convergence acceleration has succeeded:
+C
+ WRITE(IUO2,*) E_KIN,REAL(CDABS(SN(N_ACC,K_ACC)))
+C
+ ELSEIF(I_CONV.EQ.0) THEN
+C
+C Convergence acceleration has failed: power method and
+C Rayleigh quotient used instead
+C
+ IF(ABS(SHIFT).LE.SMALL) THEN
+ WRITE(IUO2,*) E_KIN,R_SN(JORD-1),R_SN1(JORD-1)
+ ELSE
+ WRITE(IUO2,*) E_KIN,R_SN1(JORD-1)
+ ENDIF
+C
+ ENDIF
+ ENDIF
+C
+ 112 WRITE(IUO1,211)
+C
+ RETURN
+C
+ 5 FORMAT(/,11X,'----------------- EIGENVALUE ANALYSIS ','---------
+ &--------')
+ 6 FORMAT(/,11X,'----------- SHIFTED POWER METHOD ANALYSIS ',' ----
+ &--------')
+ 10 FORMAT(11X,'-',54X,'-')
+ 11 FORMAT(11X,'-',4X,'SHIFT ',20X,': ',F6.3,3X,'-')
+ 15 FORMAT(11X,'-',14X,'MAXIMUM MODULUS : ',F9.6,13X,'-')
+ 20 FORMAT(11X,'-',14X,'MINIMUM MODULUS : ',F9.6,13X,'-')
+ 25 FORMAT(11X,'-',6X,'1 EIGENVALUE IS > 1 ON A TOTAL OF ',I8,6X,'-')
+ 30 FORMAT(11X,'-',4X,I5,' EIGENVALUES ARE > 1 ON A TOTAL OF ',I8,2X,
+ &'-')
+ 35 FORMAT(11X,'-',11X,'THE ',I3,' LARGER EIGENVALUES ARE :',11X,'-')
+ 40 FORMAT(11X,'-',6X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,2X,F7.4,5X,'-')
+ 44 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY THE POWER METHOD : ',F8.5,
+ &3X,'-')
+ 45 FORMAT(11X,'-',4X,'SPECTRAL RADIUS OF THE KERNEL MATRIX : ',F8.5,
+ &3X,'-')
+ 46 FORMAT(11X,'-',4X,'MATRIX SIZE : ',I8,
+ &3X,'-')
+ 47 FORMAT(11X,'-',4X,'POWER METHOD TRUNCATION ORDER : ',I8,
+ &3X,'-')
+ 48 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY ACCELERATION : ',F8.5,
+ &3X,'-')
+ 49 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER N : ',I8,
+ &3X,'-')
+ 50 FORMAT(11X,'-',4X,'---> THE MULTIPLE SCATTERING SERIES ',
+ &'CONVERGES ',4X,'-')
+ 51 FORMAT(11X,'-',4X,'ACCELERATION TRUNCATION ORDER K : ',I8,
+ &3X,'-')
+ 52 FORMAT(11X,'-',4X,'ACCELERATION METHOD : ',A10,
+ &1X,'-')
+ 53 FORMAT(11X,'-',4X,'SPECTRAL RADIUS BY RAYLEIGH QUOTIENT : ',F8.5,
+ &3X,'-')
+ 55 FORMAT(11X,'-',10X,'---> NO CONVERGENCE OF THE MULTIPLE',9X,'-',/
+ &,11X,'-',18X,'SCATTERING SERIES',19X,'-')
+ 60 FORMAT(11X,'----------------------------------------','----------
+ &------',/)
+ 61 FORMAT(11X,'----------------------------------------','----------
+ &------')
+ 65 FORMAT(11X,'-',4X,' LABEL OF LARGEST EIGENVALUE : ',I5,8X,
+ &'-')
+ 70 FORMAT(11X,'-',4X,' LARGEST EIGENVALUE : ','(',F6.3,',',F6.
+ &3,')',8X,'-')
+ 75 FORMAT(' ')
+ 76 FORMAT(2X,'ITERATION: SPECTRAL RADIUS:',' RAYLEIGH
+ "IENT:')
+ 77 FORMAT(2X,I6,15X,F6.3,15X,F6.3)
+ 78 FORMAT(10X,' E_KIN = ',F6.2,' eV -- (N,K) TABLE OF ',A10,'
+ &METHOD')
+ 79 FORMAT(2X,'ITERATION: RAYLEIGH QUOTIENT:')
+ 80 FORMAT(' KINETIC ENERGY : ',F7.2,' eV')
+ 85 FORMAT(' LARGEST MODULUS OF EIGENVALUE : ',F6.3)
+ 90 FORMAT(' LABEL OF LARGEST EIGENVALUE : ',I5)
+ 95 FORMAT(' LARGEST EIGENVALUE : (',F6.3,',',F6.3,')
+ &')
+ 99 FORMAT(///,12X,' <<<<<<<<<< DIMENSION OF N_ORD_M IN INCLUDE','
+ &FILE >>>>>>>>>>',/,12X,' <<<<<<<<<< SHOULD BE AT LEAST ',
+ &I5, 6X,' >>>>>>>>>>',///)
+ 100 FORMAT(5X,F7.3,2X,F7.3,2X,F6.3)
+ 105 FORMAT(7X,'EIGENVALUES :',3X,'MODULUS :')
+ 110 FORMAT(2X,'-------------------------------')
+ 198 FORMAT(' K',50(I3,4X))
+ 199 FORMAT(' N')
+ 200 FORMAT(I3,50(2X,F5.3))
+ 210 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/
+ &n_k_table_pm.lis',//)
+ 211 FORMAT(//,' ---> THE EVOLUTION OF THE SPECTRAL RADIUS ','HAS
+ &BEEN WRITTEN IN /div/radius_conv.lis',//)
+ 212 FORMAT(//,10X,' !!!!! THE POWER METHOD HAS NOT CONVERGED YET
+ &','!!!!!')
+ 213 FORMAT(11X,'------------ NO CONVERGENCE CHECK WAS MADE ','------
+ &------')
+ 214 FORMAT(//,' ---> THE (N,K) TABLE HAS BEEN WRITTEN ','IN /div/
+ &n_k_table_rq.lis',//)
+ 215 FORMAT(//,8X,' !!!!! THE RAYLEIGH QUOTIENT HAS NOT CONVERGED',
+ &' YET !!!!!')
+C
+ END
diff --git a/src/msspec/spec/fortran/allocation.f b/src/msspec/spec/fortran/memalloc/allocation.f
similarity index 95%
rename from src/msspec/spec/fortran/allocation.f
rename to src/msspec/spec/fortran/memalloc/allocation.f
index 0237aa0..dd8a841 100644
--- a/src/msspec/spec/fortran/allocation.f
+++ b/src/msspec/spec/fortran/memalloc/allocation.f
@@ -10,7 +10,6 @@
USE BASES_MOD
USE CLUSLIM_MOD
USE COOR_MOD
- USE C_RENORM_MOD
USE DEBWAL_MOD
USE INDAT_MOD
USE INIT_A_MOD
@@ -28,7 +27,6 @@
USE PARCAL_A_MOD
USE RELADS_MOD
USE RELAX_MOD
- USE RENORM_MOD
USE RESEAU_MOD
USE SPIN_MOD
USE TESTS_MOD
@@ -76,7 +74,13 @@
USE DIRECT_MOD
USE DIRECT_A_MOD
USE PATH_MOD
+ USE RENORM_MOD
+ USE C_RENORM_MOD
USE ROT_MOD
+ USE ROT_CUB_MOD
+ USE SYMMOP_MOD
+ USE TAU_PROT_MOD
+ USE TAUSYMMOP_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TLDW_MOD
@@ -182,6 +186,10 @@
CALL ALLOC_DIRECT_A()
CALL ALLOC_PATH()
CALL ALLOC_ROT()
+ CALL ALLOC_ROT_CUB()
+ CALL ALLOC_SYMMOP()
+ CALL ALLOC_TAU_PROT()
+ CALL ALLOC_TAUSYMMOP()
CALL ALLOC_TESTPA()
CALL ALLOC_TESTPB()
CALL ALLOC_TLDW()
diff --git a/src/msspec/spec/fortran/dim_mod.f b/src/msspec/spec/fortran/memalloc/dim_mod.f
similarity index 96%
rename from src/msspec/spec/fortran/dim_mod.f
rename to src/msspec/spec/fortran/memalloc/dim_mod.f
index 97f43bf..b09db08 100644
--- a/src/msspec/spec/fortran/dim_mod.f
+++ b/src/msspec/spec/fortran/memalloc/dim_mod.f
@@ -30,6 +30,7 @@ C ===============================================================
INTEGER NT_M
INTEGER NCG_M
INTEGER N_BESS, N_GAUNT
+ INTEGER NLTWO
C ===============================================================
CONTAINS
SUBROUTINE INIT_DIM()
@@ -56,5 +57,7 @@ C ===============================================================
N_BESS=100*NL_M
N_GAUNT=5*NL_M
+
+ NLTWO=2*NL_M
END SUBROUTINE INIT_DIM
END MODULE DIM_MOD
diff --git a/src/msspec/spec/fortran/modules.f b/src/msspec/spec/fortran/memalloc/modules.f
similarity index 90%
rename from src/msspec/spec/fortran/modules.f
rename to src/msspec/spec/fortran/memalloc/modules.f
index a9a40cd..3362336 100644
--- a/src/msspec/spec/fortran/modules.f
+++ b/src/msspec/spec/fortran/memalloc/modules.f
@@ -1416,6 +1416,134 @@ C=======================================================================
ALLOCATE(JPON(NPATH_M,NDIF_M))
END SUBROUTINE ALLOC_PRINTP
END MODULE PRINTP_MOD
+C=======================================================================
+ MODULE ROT_CUB_MOD
+ IMPLICIT NONE
+ REAL*4, ALLOCATABLE, DIMENSION(:,:,:) :: R_PIS2
+ CONTAINS
+ SUBROUTINE ALLOC_ROT_CUB()
+ USE DIM_MOD
+ IF (ALLOCATED(R_PIS2)) THEN
+ DEALLOCATE(R_PIS2)
+ ENDIF
+ ALLOCATE(R_PIS2(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1))
+ END SUBROUTINE ALLOC_ROT_CUB
+ END MODULE ROT_CUB_MOD
+C=======================================================================
+ MODULE SYMMOP_MOD
+ IMPLICIT NONE
+ REAL*4, ALLOCATABLE, DIMENSION(:) :: ZL
+ COMPLEX, ALLOCATABLE, DIMENSION(:) :: ZM1
+ COMPLEX, ALLOCATABLE, DIMENSION(:) :: ZM2
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IZ
+ CONTAINS
+ SUBROUTINE ALLOC_SYMMOP()
+ USE DIM_MOD
+ IF (ALLOCATED(ZL)) THEN
+ DEALLOCATE(ZL)
+ ENDIF
+ ALLOCATE(ZL(64))
+ IF (ALLOCATED(ZM1)) THEN
+ DEALLOCATE(ZM1)
+ ENDIF
+ ALLOCATE(ZM1(64))
+ IF (ALLOCATED(ZM2)) THEN
+ DEALLOCATE(ZM2)
+ ENDIF
+ ALLOCATE(ZM2(64))
+ IF (ALLOCATED(IZ)) THEN
+ DEALLOCATE(IZ)
+ ENDIF
+ ALLOCATE(IZ(64))
+ END SUBROUTINE ALLOC_SYMMOP
+ END MODULE SYMMOP_MOD
+C=======================================================================
+ MODULE TAU_PROT_MOD
+ IMPLICIT NONE
+ REAL*4, ALLOCATABLE, DIMENSION(:) :: Z_L_P
+ COMPLEX, ALLOCATABLE, DIMENSION(:) :: Z_M_P
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: I_Z_P
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTEP_L
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: ISTEP_M
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: I_LM
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: I_REL_MP
+ CONTAINS
+ SUBROUTINE ALLOC_TAU_PROT()
+ USE DIM_MOD
+ IF (ALLOCATED(Z_L_P)) THEN
+ DEALLOCATE(Z_L_P)
+ ENDIF
+ ALLOCATE(Z_L_P(NATP_M))
+ IF (ALLOCATED(Z_M_P)) THEN
+ DEALLOCATE(Z_M_P)
+ ENDIF
+ ALLOCATE(Z_M_P(NATP_M))
+ IF (ALLOCATED(I_Z_P)) THEN
+ DEALLOCATE(I_Z_P)
+ ENDIF
+ ALLOCATE(I_Z_P(NATP_M))
+ IF (ALLOCATED(ISTEP_L)) THEN
+ DEALLOCATE(ISTEP_L)
+ ENDIF
+ ALLOCATE(ISTEP_L(NATP_M))
+ IF (ALLOCATED(ISTEP_M)) THEN
+ DEALLOCATE(ISTEP_M)
+ ENDIF
+ ALLOCATE(ISTEP_M(NATP_M))
+ IF (ALLOCATED(I_LM)) THEN
+ DEALLOCATE(I_LM)
+ ENDIF
+ ALLOCATE(I_LM(NATP_M))
+ IF (ALLOCATED(I_REL_MP)) THEN
+ DEALLOCATE(I_REL_MP)
+ ENDIF
+ ALLOCATE(I_REL_MP(NATP_M))
+ END SUBROUTINE ALLOC_TAU_PROT
+ END MODULE TAU_PROT_MOD
+C=======================================================================
+ MODULE TAUSYMMOP_MOD
+ IMPLICIT NONE
+ REAL*4, ALLOCATABLE, DIMENSION(:,:) :: Z_L
+ COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: Z_M1
+ COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: Z_M2
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: I_Z
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISYM
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NSYM_G
+ INTEGER :: NSIZE_GR
+ REAL, ALLOCATABLE, DIMENSION(:,:,:) :: S_INV
+ CONTAINS
+ SUBROUTINE ALLOC_TAUSYMMOP()
+ USE DIM_MOD
+ IF (ALLOCATED(Z_L)) THEN
+ DEALLOCATE(Z_L)
+ ENDIF
+ ALLOCATE(Z_L(NAT_EQ_M,NATP_M))
+ IF (ALLOCATED(Z_M1)) THEN
+ DEALLOCATE(Z_M1)
+ ENDIF
+ ALLOCATE(Z_M1(NAT_EQ_M,NATP_M))
+ IF (ALLOCATED(Z_M2)) THEN
+ DEALLOCATE(Z_M2)
+ ENDIF
+ ALLOCATE(Z_M2(NAT_EQ_M,NATP_M))
+ IF (ALLOCATED(I_Z)) THEN
+ DEALLOCATE(I_Z)
+ ENDIF
+ ALLOCATE(I_Z(NAT_EQ_M,NATP_M))
+ IF (ALLOCATED(ISYM)) THEN
+ DEALLOCATE(ISYM)
+ ENDIF
+ ALLOCATE(ISYM(NAT_EQ_M,NATP_M))
+ IF (ALLOCATED(NSYM_G)) THEN
+ DEALLOCATE(NSYM_G)
+ ENDIF
+ ALLOCATE(NSYM_G(48))
+ IF (ALLOCATED(S_INV)) THEN
+ DEALLOCATE(S_INV)
+ ENDIF
+ ALLOCATE(S_INV(64,3,3))
+ END SUBROUTINE ALLOC_TAUSYMMOP
+ END MODULE TAUSYMMOP_MOD
C=======================================================================
MODULE RENORM_MOD
IMPLICIT NONE
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f
new file mode 100644
index 0000000..bb376de
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/coumat.f
@@ -0,0 +1,121 @@
+C
+C=======================================================================
+C
+ SUBROUTINE COUMAT(ITL,MI,LF,MF,DELTA,RADIAL,MATRIX)
+C
+C This routine calculates the spin-independent PhD optical matrix
+C elements for dipolar excitations. It is stored in
+C MATRIX(JDIR,JPOL)
+C
+C Here, the conventions are :
+C
+C IPOL=1 : linearly polarized light
+C IPOL=2 : circularly polarized light
+C
+C JPOL=1 : +/x polarization for circular/linear light
+C JPOL=2 : -/y polarization for circular/linear light
+C
+C When IDICHR=0, JDIR = 1,2 and 3 correspond respectively to the x,y
+C and z directions for the linear polarization. But for IDICHR=1,
+C these basis directions are those of the position of the light.
+C
+C Last modified : 8 Dec 2008
+C
+ USE DIM_MOD
+C
+ USE INIT_L_MOD , L2 => NNL, L3 => LF1, L4 => LF2, L5 => ISTEP_LF
+ USE SPIN_MOD , I1 => ISPIN, N1 => NSPIN, N2 => NSPIN2, I2 => ISFLI
+ &P, I8 => IR_DIA, N3 => NSTEP
+ USE TYPCAL_MOD , I3 => IPHI, I4 => IE, I5 => ITHETA, I6 => IFTHET,
+ & I7 => IMOD, I9 => I_CP, I10 => I_EXT
+C
+ COMPLEX MATRIX(3,2),SUM_1,SUM_2,DELTA,YLM(3,-1:1),RADIAL
+ COMPLEX ONEC,IC,IL,COEF,PROD
+C
+ REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1),GNT(0:N_GAUNT)
+ REAL THETA(3),PHI(3)
+C
+ DATA PI4S3,C_LIN,SQR2 /4.188790,1.447202,1.414214/
+ DATA PIS2 /1.570796/
+C
+ ONEC=(1.,0.)
+ IC=(0.,1.)
+C
+ IF(INITL.EQ.0) GOTO 2
+C
+ M=MF-MI
+C
+ IF(MOD(LF,4).EQ.0) THEN
+ IL=ONEC
+ ELSEIF(MOD(LF,4).EQ.1) THEN
+ IL=IC
+ ELSEIF(MOD(LF,4).EQ.2) THEN
+ IL=-ONEC
+ ELSEIF(MOD(LF,4).EQ.3) THEN
+ IL=-IC
+ ENDIF
+C
+ CALL GAUNT(LI,MI,LF,MF,GNT)
+C
+ IF(ITL.EQ.0) THEN
+c COEF=CEXP(IC*DELTA)*CONJG(IL)
+ COEF=CEXP(IC*DELTA)*IL
+ ELSE
+ IF(IDICHR.EQ.0) THEN
+c COEF=PI4S3*CONJG(IL)
+ COEF=PI4S3*IL
+ ELSE
+c COEF=C_LIN*CONJG(IL)
+ COEF=C_LIN*IL
+ ENDIF
+ ENDIF
+C
+ PROD=COEF*RADIAL*GNT(1)
+C
+ IF(IDICHR.EQ.0) THEN
+ YLM(1,-1)=(0.345494,0.)
+ YLM(1,0)=(0.,0.)
+ YLM(1,1)=(-0.345494,0.)
+ YLM(2,-1)=(0.,-0.345494)
+ YLM(2,0)=(0.,0.)
+ YLM(2,1)=(0.,-0.345494)
+ YLM(3,-1)=(0.,0.)
+ YLM(3,0)=(0.488602,0.)
+ YLM(3,1)=(0.,0.)
+C
+ DO JDIR=1,3
+ MATRIX(JDIR,1)=PROD*CONJG(YLM(JDIR,M))
+ ENDDO
+C
+ ELSEIF(IDICHR.GE.1) THEN
+C
+ THETA(1)=PIS2
+ PHI(1)=0.
+ THETA(2)=PIS2
+ PHI(2)=PIS2
+ THETA(3)=0.
+ PHI(3)=0.
+C
+ DO JDIR=1,3
+ CALL DJMN(THETA(JDIR),RLM,1)
+ SUM_1=RLM(-1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
+ SUM_2=RLM(1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
+ IF(IPOL.EQ.2) THEN
+ MATRIX(JDIR,1)=SQR2*SUM_1
+ MATRIX(JDIR,2)=SQR2*SUM_2
+ ELSEIF(ABS(IPOL).EQ.1) THEN
+ MATRIX(JDIR,1)=(SUM_2-SUM_1)
+ MATRIX(JDIR,2)=(SUM_2+SUM_1)*IC
+ ENDIF
+ ENDDO
+ ENDIF
+ GOTO 1
+C
+ 2 DO JDIR=1,3
+ MATRIX(JDIR,1)=ONEC
+ MATRIX(JDIR,2)=ONEC
+ ENDDO
+C
+ 1 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f
new file mode 100644
index 0000000..e9dea7a
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/do_main.f
@@ -0,0 +1,1654 @@
+C
+C
+C ************************************************************
+C * ******************************************************** *
+C * * * *
+C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * *
+C * * PHOTOELECTRON DIFFRACTION CODE * *
+C * * BASED ON SERIES EXPANSION * *
+C * * * *
+C * ******************************************************** *
+C ************************************************************
+C
+C
+C
+C
+C Written by D. Sebilleau, Groupe Theorie,
+C Departement Materiaux-Nanosciences,
+C Institut de Physique de Rennes,
+C UMR CNRS-Universite 6251,
+C Universite de Rennes-1,
+C 35042 Rennes-Cedex,
+C France
+C
+C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada
+C
+C-----------------------------------------------------------------------
+C
+C As a general rule in this code, although there might be a few
+C exceptions (...), a variable whose name starts with a 'I' is a
+C switch, with a 'J' is a loop index and with a 'N' is a number.
+C
+C The main subroutines are :
+C
+C * PHDDIF : computes the photoelectron diffraction
+C formula
+C
+C * LEDDIF : computes the low-energy electron
+C diffraction formula
+C
+C * XASDIF : computes the EXAFS or XANES formula
+C depending on the energy
+C
+C * AEDDIF : computes the Auger electron diffraction
+C formula
+C
+C * FINDPATHS : generates the multiple scattering
+C paths the electron will follow
+C
+C * PATHOP : calculates the contribution of a given
+C path to the scattering path operator
+C
+C * MATDIF : computes the Rehr-Albers scattering
+C matrices
+C
+C A subroutine called NAME_A is the Auger equivalent of subroutine
+C NAME. The essentail difference between NAME and NAME_A is that
+C they do not contain the same arrays.
+C
+C Always remember, when changing the input data file, to keep the
+C format. The rule here is that the last digit of any integer or
+C character data must correspond to the tab (+) while for real data,
+C the tab precedes the point.
+C
+C Do not forget, before submitting a calculation, to check the
+C consistency of the input data with the corresponding maximal
+C values in the include file.
+C
+C-----------------------------------------------------------------------
+C
+C Please report any bug or problem to me at :
+C
+C didier.sebilleau@univ-rennes1.fr
+C
+C
+C
+C Last modified : 10 Jan 2016
+C
+C=======================================================================
+C
+ SUBROUTINE DO_MAIN()
+C
+C This routine reads the various input files and calls the subroutine
+C performing the requested calculation
+C
+ USE DIM_MOD
+ USE ADSORB_MOD
+ USE APPROX_MOD
+ USE ATOMS_MOD
+ USE AUGER_MOD
+ USE BASES_MOD
+ USE CLUSLIM_MOD
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INDAT_MOD
+ USE INIT_A_MOD
+ USE INIT_L_MOD
+ USE INIT_J_MOD
+ USE INIT_M_MOD
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE LIMAMA_MOD
+ USE LPMOY_MOD
+ USE MASSAT_MOD
+ USE MILLER_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD
+ USE PARCAL_A_MOD
+ USE RELADS_MOD
+ USE RELAX_MOD
+ USE RESEAU_MOD
+ USE SPIN_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE TL_AED_MOD
+ USE TYPCAL_MOD
+ USE TYPCAL_A_MOD
+ USE TYPEM_MOD
+ USE TYPEXP_MOD
+ USE VALIN_MOD
+ USE XMRHO_MOD
+C
+ DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3)
+ DIMENSION ROT(3,3),EMET(3)
+ DIMENSION VAL2(NATCLU_M)
+ DIMENSION IRE(NATCLU_M,2)
+ DIMENSION REL(NATCLU_M),RHOT(NATM)
+ DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M)
+ DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM)
+ DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M)
+ DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M)
+ DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM)
+C
+ COMPLEX TLSTAR
+ COMPLEX RHOR(NE_M,NATM,0:18,5,NSPIN2_M)
+ COMPLEX TLSTAR_A
+ COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E
+ COMPLEX RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHOR5STAR
+C
+ INTEGER INV(2)
+C
+ CHARACTER RIEN
+ CHARACTER*1 B
+ CHARACTER*2 R
+C
+C
+C
+C
+C
+C
+ CHARACTER*30 TUNIT,DUMMY
+C
+ DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/
+ DATA INV /0,0/
+C
+ LE_MAX=0
+C
+C! READ(*,776) NFICHLEC
+C! READ(*,776) ICOM
+C! DO JF=1,NFICHLEC
+C! READ(*,777) INDATA(JF)
+C! ENDDO
+C
+C.......... Loop on the data files ..........
+C
+ NFICHLEC=1
+ ICOM = 5
+ DO JFICH=1,NFICHLEC
+C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
+ OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD')
+ CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*5
+ &20,*540,*550,*570,*580,*590,*630)
+C
+C.......... Atomic case index ..........
+C
+ I_AT=0
+ IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1
+ IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1
+ IF(SPECTRO.EQ.'APC') THEN
+ IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1
+ ENDIF
+C
+ IF(IBAS.EQ.1) THEN
+ IF(ITEST.EQ.0) THEN
+ NEQ=(2*NIV+1)**3
+ ELSE
+ NEQ=(2*NIV+3)**3
+ ENDIF
+ IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518
+ ENDIF
+C
+ IF(SPECTRO.EQ.'APC') THEN
+ N_EL=2
+ ELSE
+ N_EL=1
+ ENDIF
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IF(I_MULT.EQ.0) THEN
+ LE_MIN=ABS(LI_C-ABS(LI_I-LI_A))
+ LE_MAX=LI_C+LI_A+LI_I
+ ELSE
+ LE_MIN=ABS(LI_C-L_MUL)
+ LE_MAX=LI_C+L_MUL
+ ENDIF
+ ENDIF
+C
+C.......... Test of the dimensions against the input values ..........
+C
+ IF(NO.GT.NO_ST_M) GOTO 600
+ IF(LE_MAX.GT.LI_M) GOTO 620
+C
+ OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD')
+ OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD')
+ IF(INTERACT.EQ.'DIPCOUL') THEN
+ OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD')
+ OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD')
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (dipolar excitation or no excitation case) ..........
+C
+ IF(INTERACT.NE.'COULOMB') THEN
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,418)
+ READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1
+ ENDIF
+ ENDIF
+ IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IUI2,530) E_MIN,E_MAX,DE
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN
+ NLG=INT(NAT1-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1
+ READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX. Waiting for a version of PHAGEN
+C with LMAX dependent on the energy
+C
+ DO JE=1,NE
+ DO JAT=1,NAT1
+ LMAX(JAT,JE)=LMAX(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1=1
+ DO JAT=1,NAT1
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL.EQ.0) READ(IUI3,101) NATR,NER
+ IF(ISPIN.EQ.1) THEN
+ READ(IUI3,106) L_IN,NATR,NER
+ IF(LI.NE.L_IN) GOTO 606
+ ENDIF
+ NAT2=NAT+NATA
+ IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180
+ IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL.EQ.0) THEN
+ DO JAT=1,NAT2
+ IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ ENDIF
+ DO JE=1,NE
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121
+ READ(IUI3,103) ENERGIE
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ READ(IUI3,102) RIEN
+ 121 CONTINUE
+ DO L=0,LMAX(JAT,JE)
+ READ(IUI2,7) VK(JE),TL(L,1,JAT,JE)
+ TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,1.)*TL(L,1,
+ &JAT,JE))
+ ENDDO
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5
+ DO LL=1,18
+ READ(IUI3,104) RH1,RH2,DEF1,DEF2
+ RHOR(JE,JAT,LL,1,1)=CMPLX(RH1)
+ RHOR(JE,JAT,LL,2,1)=CMPLX(RH2)
+ DLT(JE,JAT,LL,1)=CMPLX(DEF1)
+ DLT(JE,JAT,LL,2)=CMPLX(DEF2)
+ ENDDO
+ 5 CONTINUE
+ ENDDO
+ ENDDO
+ ELSE
+C
+C.......... TL and RHOR calculated by PHAGEN ..........
+C
+ DO JE=1,NE
+ NLG=INT(NAT2-0.0001)/4 +1
+ IF(NE.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2
+ READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ NL1=1
+ DO JAT=1,NAT2
+ NL1=MAX0(NL1,LMAX(JAT,1)+1)
+ ENDDO
+ IF(NL1.GT.NL_M) GOTO 184
+ DO JAT=1,NAT2
+ READ(IUI2,*) DUMMY
+ DO L=0,LMAX(JAT,JE)
+ IF(LMAX_MODE.EQ.0) THEN
+ READ(IUI2,9) VK(JE),TLSTAR
+ ELSE
+ READ(IUI2,9) VK(JE),TLSTAR
+ ENDIF
+ TL(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK(JE)=CONJG(VK(JE))
+ ENDDO
+ ENDDO
+C
+ IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333
+ IF(JE.EQ.1) THEN
+ DO JDUM=1,7
+ READ(IUI3,102) RIEN
+ ENDDO
+ ENDIF
+C
+C Reading or regular (RHOR) and irregular (RHOI) radial integrals
+C
+C 1-2 : dipole terms
+C 3-5 : quadrupole terms
+C
+ DO JEMET=1,NEMET
+C
+ JM=IEMET(JEMET)
+ READ(IUI3,105) RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHO
+ &R5STAR
+ RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR)
+ RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR)
+ RHOR(JE,JM,NNL,3,1)=CONJG(RHOR3STAR)
+ RHOR(JE,JM,NNL,4,1)=CONJG(RHOR4STAR)
+ RHOR(JE,JM,NNL,5,1)=CONJG(RHOR5STAR)
+C
+ ENDDO
+C
+ 333 VK(JE)=VK(JE)*A
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IUI2)
+ CLOSE(IUI3)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN
+ CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL)
+ ENDIF
+ ENDIF
+C
+C.......... Reading of the TL and radial matrix elements files ..........
+C.......... (Coulomb excitation case) ..........
+C
+ IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
+ IERR=0
+ IF(INTERACT.EQ.'COULOMB') THEN
+ IRD1=IUI2
+ IRD2=IUI3
+ ELSEIF(INTERACT.EQ.'DIPCOUL') THEN
+ IRD1=IUI7
+ IRD2=IUI8
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,419)
+ READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A
+ IF(ISPIN.EQ.0) THEN
+ IF(NAT1_A.EQ.1) THEN
+ WRITE(IUO1,561)
+ ELSE
+ WRITE(IUO1,560) NAT1_A
+ ENDIF
+ ENDIF
+ IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN
+ READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A
+ ENDIF
+ IF(ITL_A.EQ.1) THEN
+ READ(IRD2,107) LI_C2,LI_I2,LI_A2
+ READ(IRD2,117) LE_MIN1,N_CHANNEL
+ LE_MAX1=LE_MIN1+N_CHANNEL-1
+ IF(I_TEST_A.NE.1) THEN
+ IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO 610
+ ELSE
+ LI_C2=0
+ LI_I2=1
+ LI_A2=0
+ LE_MIN1=1
+ N_CHANNEL=1
+ ENDIF
+ ENDIF
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN
+ NLG=INT(NAT1_A-0.0001)/4 +1
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT1_A
+ READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL)
+ ENDDO
+C
+C Temporary storage of LMAX_A. Waiting for a version of PHAGEN
+C with LMAX_A dependent on the energy
+C
+ DO JE=1,NE1_A
+ DO JAT=1,NAT1_A
+ LMAX_A(JAT,JE)=LMAX_A(JAT,1)
+ ENDDO
+ ENDDO
+C
+ NL1_A=1
+ DO JAT=1,NAT1_A
+ NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1)
+ ENDDO
+ IF(NL1_A.GT.NL_M) GOTO 184
+ ENDIF
+ IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A
+ IF(ISPIN.EQ.1) THEN
+ READ(IRD2,106) L_IN_A,NATR_A,NER_A
+ IF(LI_C.NE.L_IN_A) GOTO 606
+ ENDIF
+ NAT2_A=NAT+NATA
+ NAT2=NAT2_A
+ IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180
+ IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) GOTO
+ &182
+C
+C.......... DL generated by MUFPOT and RHOR given ..........
+C.......... by S. M. Goldberg, C. S. Fadley ..........
+C.......... and S. Kono, J. Electron Spectr. ..........
+C.......... Relat. Phenom. 21, 285 (1981) ..........
+C
+ IF(ITL_A.EQ.0) THEN
+ CONTINUE
+ ELSE
+C
+C.......... TL_A and RHOR_A calculated by PHAGEN ..........
+C
+ DO JE=1,NE_A
+ NLG=INT(NAT2_A-0.0001)/4 +1
+ IF(NE_A.GT.1) WRITE(IUO1,563) JE
+ DO NN=1,NLG
+ NRL=4*NN
+ JD=4*(NN-1)+1
+ IF(NN.EQ.NLG) NRL=NAT2_A
+ READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL)
+ ENDDO
+ DO JAT=1,NAT2_A
+ READ(IRD1,*) DUMMY
+ DO L=0,LMAX_A(JAT,JE)
+ IF(LMAX_MODE_A.EQ.0) THEN
+ READ(IRD1,9) VK_A(JE),TLSTAR
+ ELSE
+ READ(IRD1,7) VK_A(JE),TLSTAR
+ ENDIF
+ TL_A(L,1,JAT,JE)=CONJG(TLSTAR)
+ VK_A(JE)=CONJG(VK_A(JE))
+ ENDDO
+ ENDDO
+C
+ IF(IFTHET_A.EQ.1) GOTO 331
+ DO LE=LE_MIN,LE_MAX
+ DO JEMET=1,NEMET
+ JM=IEMET(JEMET)
+ READ(IRD2,109) L_E,LB_MIN,LB_MAX
+ IF(I_TEST_A.EQ.1) THEN
+ L_E=1
+ LB_MIN=0
+ LB_MAX=1
+ ENDIF
+ IF(LE.NE.L_E) IERR=1
+ L_BOUNDS(L_E,1)=LB_MIN
+ L_BOUNDS(L_E,2)=LB_MAX
+ DO LB=LB_MIN,LB_MAX
+ READ(IRD2,108) L_A,RAD_D,RAD_E
+ RHOR_A(LE,JM,L_A,1,1)=RAD_D
+ RHOR_A(LE,JM,L_A,2,1)=RAD_E
+ IF(I_TEST_A.EQ.1) THEN
+ IF(LB.EQ.LB_MIN) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0)
+ ELSEIF(LB.EQ.LB_MAX) THEN
+ RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0)
+ RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ 331 VK_A(JE)=VK_A(JE)*A
+ VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE))
+ ENDDO
+ ENDIF
+C
+ CLOSE(IRD1)
+ CLOSE(IRD2)
+C
+C.......... Suppression of possible zeros in the TL array ..........
+C.......... (in case of the use of matrix inversion and ..........
+C.......... for energy variations) ..........
+C
+ IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN
+ CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL)
+ ENDIF
+ IF(SPECTRO.EQ.'APC') WRITE(IUO1,420)
+C
+ ENDIF
+C
+C.......... Check of the consistency of the two TL and radial ..........
+C.......... matrix elements for APECS ..........
+C
+ IF(SPECTRO.EQ.'APC') THEN
+C
+ I_TL_FILE=0
+ I_RD_FILE=0
+C
+ IF(NAT1.NE.NAT1_A) I_TL_FILE=1
+ IF(NE1.NE.NE1_A) I_TL_FILE=1
+ IF(ITL.NE.ITL_A) I_TL_FILE=1
+ IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1
+C
+ IF(LI_C.NE.LI_C2) I_RD_FILE=1
+ IF(LI_I.NE.LI_I2) I_RD_FILE=1
+ IF(LI_A.NE.LI_A2) I_RD_FILE=1
+C
+ IF(I_TL_FILE.EQ.1) GOTO 608
+ IF(I_RD_FILE.EQ.1) GOTO 610
+ IF(IERR.EQ.1) GOTO 610
+C
+ ENDIF
+C
+C.......... Calculation of the scattering factor (only) ..........
+C
+ IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8
+ IF(IFTHET.EQ.1) THEN
+ CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
+ ELSEIF(IFTHET_A.EQ.1) THEN
+c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A)
+ ENDIF
+ WRITE(IUO1,57)
+ STOP
+C
+ 8 IF(IBAS.EQ.0) THEN
+C
+C............... Reading of an external cluster ...............
+C
+C
+C Cluster originating from CLUSTER_NEW.F : IPHA=0
+C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems)
+C Other cluster : the first line must be text; then
+C free format : Atomic number,X,Y,Z,number
+C of the corresponding prototypical atom ;
+C All atoms corresponding to the same
+C prototypical atom must follow each other.
+C Moreover, the blocks of equivalent atoms
+C must be ordered by increasing number of
+C prototypical atom.
+C
+ VALZ_MIN=1000.0
+ VALZ_MAX=-1000.0
+C
+ OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD')
+ READ(IUI4,778,ERR=892) IPHA
+ GOTO 893
+ 892 IPHA=3
+ IF(UNIT.EQ.'ANG') THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ ELSEIF(UNIT.EQ.'LPU') THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(UNIT.EQ.'ATU') THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ ELSE
+ GOTO 890
+ ENDIF
+ 893 NATCLU=0
+ DO JAT=1,NAT2
+ NATYP(JAT)=0
+ ENDDO
+ IF(IPHA.EQ.0) THEN
+ CUNIT=1.
+ TUNIT='UNITS OF THE LATTICE PARAMETER'
+ ELSEIF(IPHA.EQ.1) THEN
+ CUNIT=BOHR/A
+ TUNIT='ATOMIC UNITS'
+ IEMET(1)=1
+ ELSEIF(IPHA.EQ.2) THEN
+ CUNIT=1./A
+ TUNIT='ANGSTROEMS'
+ IEMET(1)=1
+ ENDIF
+ IF(IPRINT.EQ.2) THEN
+ IF(I_AT.NE.1) THEN
+ WRITE(IUO1,558) IUI4,TUNIT
+ IF(IPHA.EQ.3) WRITE(IUO1,549)
+ ENDIF
+ ENDIF
+ JATM=0
+ DO JLINE=1,10000
+ IF(IPHA.EQ.0) THEN
+ READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.1) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.2) THEN
+ READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
+ ELSEIF(IPHA.EQ.3) THEN
+ READ(IUI4,*,END=780) NN,X,Y,Z,JAT
+ ENDIF
+ JATM=MAX0(JAT,JATM)
+ NATCLU=NATCLU+1
+ IF(IPHA.NE.3) THEN
+ CHEM(JAT)=R
+ ELSE
+ CHEM(JAT)='XX'
+ ENDIF
+ NZAT(JAT)=NN
+ NATYP(JAT)=NATYP(JAT)+1
+ COORD(1,NATCLU)=X*CUNIT
+ COORD(2,NATCLU)=Y*CUNIT
+ COORD(3,NATCLU)=Z*CUNIT
+ VALZ(NATCLU)=Z*CUNIT
+ IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN
+ WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,NATCLU),COORD
+ &(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT)
+ ENDIF
+ ENDDO
+ 780 NBZ=NATCLU
+ IF(JATM.NE.NAT) GOTO 514
+ CLOSE(IUI4)
+C
+ IF(NATCLU.GT.NATCLU_M) GOTO 510
+ DO JA1=1,NATCLU
+ DO JA2=1,NATCLU
+ DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(COORD(2
+ &,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**2)
+ IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO 895
+ ENDDO
+ ENDDO
+C
+ D_UP=VALZ_MAX-VALZ(1)
+ D_DO=VALZ(1)-VALZ_MIN
+ IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN
+ I_INV=1
+ ELSE
+ I_INV=0
+ ENDIF
+ ELSE
+C
+C............... Construction of an internal cluster ...............
+C
+ CALL BASE
+ CALL ROTBAS(ROT)
+ IF(IVG0.EQ.2) THEN
+ NMAX=NIV+1
+ ELSE
+ NMAX=(2*NIV+1)**3
+ ENDIF
+ IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN
+ WRITE(IUO1,37)
+ WRITE(IUO1,38) NIV
+ DO NUM=1,NMAX
+ CALL NUMAT(NUM,NIV,IA,IB,IC)
+ WRITE(IUO1,17) NUM,IA,IB,IC
+ ENDDO
+ WRITE(IUO1,39)
+ ENDIF
+ CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,NBZ,N
+ &AT2,NCOUCH,NMAX)
+ IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN
+ CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,NCOUCH)
+ &
+ IF(IREL.EQ.1) THEN
+ DO JP=1,NPLAN
+ VAL(JP)=VAL2(JP)
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C Storage of the extremal values of x and y for each plane. They define
+C the exterior of the cluster when a new cluster has to be build to
+C support a point-group
+C
+ IF(I_GR.GE.1) THEN
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ WRITE(IUO1,29) K,VAL(K)
+ X_MAX(K)=0.
+ X_MIN(K)=0.
+ Y_MAX(K)=0.
+ Y_MIN(K)=0.
+ ENDDO
+ ENDIF
+ DO JAT=1,NATCLU
+ X=COORD(1,JAT)
+ Y=COORD(2,JAT)
+ Z=COORD(3,JAT)
+ DO JPLAN=1,NPLAN
+ IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN
+ X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN))
+ X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN))
+ Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN))
+ Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN))
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Instead of the symmetrization of the cluster (this version only)
+C
+ N_PROT=NAT
+ NAT_ST=0
+ DO JTYP=1,JATM
+ NB_AT=NATYP(JTYP)
+ IF(NB_AT.GT.NAT_EQ_M) GOTO 614
+ DO JA=1,NB_AT
+ NAT_ST=NAT_ST+1
+ NCORR(JA,JTYP)=NAT_ST
+ ENDDO
+ ENDDO
+ DO JC=1,3
+ DO JA=1,NATCLU
+ SYM_AT(JC,JA)=COORD(JC,JA)
+ ENDDO
+ ENDDO
+C
+C Checking surface-like atoms for mean square displacements
+C calculations
+C
+ CALL CHECK_VIB(NAT2)
+C
+C.......... Set up of the variables used for an internal ..........
+C.......... calculation of the mean free path and/or of ..........
+C.......... the mean square displacements ..........
+C
+ IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN
+ DO JTYP=1,NAT2
+ XMT(JTYP)=XMAT(NZAT(JTYP))
+ RHOT(JTYP)=RHOAT(NZAT(JTYP))
+ ENDDO
+ XMTA=XMT(1)
+ RHOTA=RHOT(1)
+ NZA=NZAT(1)
+ ENDIF
+ IF(IDCM.GT.0) THEN
+ CALL CHNOT(3,VECBAS,VEC)
+ DO J=1,3
+ VB1(J)=VEC(J,1)
+ VB2(J)=VEC(J,2)
+ VB3(J)=VEC(J,3)
+ ENDDO
+ CPR=1.
+ CALL PRVECT(VB2,VB3,VBS,CPR)
+ VM=PRSCAL(VB1,VBS)
+ QD=(6.*PI*PI*NAT/VM)**(1./3.)
+ ENDIF
+C
+C.......... Writing of the contents of the cluster, ..........
+C.......... of the position of the different planes ..........
+C.......... and of their respective absorbers in ..........
+C.......... the control file IUO1 ..........
+C
+ IF(I_AT.EQ.1) GOTO 153
+ IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN
+ WRITE(IUO1,40)
+ NCA=0
+ DO J=1,NAT
+ DO I=1,NMAX
+ NCA=NCA+1
+ WRITE(IUO1,20) J,I
+ WRITE(IUO1,21) (ATOME(L,NCA),L=1,3)
+ K=IRE(NCA,1)
+ IF(K.EQ.0) THEN
+ WRITE(IUO1,22)
+ ELSE
+ WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2)
+ ENDIF
+ ENDDO
+ ENDDO
+ WRITE(IUO1,41)
+ ENDIF
+ IF(IBAS.EQ.1) THEN
+ WRITE(IUO1,24)
+ NATCLU=0
+ DO I=1,NAT
+ NN=NATYP(I)
+ NATCLU=NATCLU+NATYP(I)
+ WRITE(IUO1,26) NN,I
+ ENDDO
+ IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3
+ WRITE(IUO1,782) NATCLU
+ IF(NATCLU.GT.NATCLU_M) GOTO 516
+ IF(IPRINT.EQ.3) WRITE(IUO1,559)
+ IF(IPRINT.EQ.3) THEN
+ NBTA=0
+ DO JT=1,NAT2
+ NBJT=NATYP(JT)
+ DO JN=1,NBJT
+ NBTA=NBTA+1
+ WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),COORD(3,N
+ &BTA),JT,JN,CHEM(JT)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+ 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN
+ CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56)
+ ENDIF
+ IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
+ CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
+ IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN
+ DO K=1,NPLAN
+ IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K)
+ ENDDO
+ ENDIF
+C
+ IF(I_AT.EQ.0) WRITE(IUO1,30)
+ IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN
+ WRITE(IUO1,31) (IEMET(J),J=1,NEMET)
+ ENDIF
+ ZEM=1.E+20
+ DO L=1,NPLAN
+ Z=VAL(L)
+ DO JEMED=1,NEMET
+ CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93)
+ IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET(3)
+ IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3)
+ GO TO 33
+ 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM
+ 33 CONTINUE
+ ENDDO
+ ENDDO
+C
+C.......... Loop on the electrons involved in the ..........
+C.......... spectroscopy : N_EL = 1 for PHD, XAS ..........
+C.......... LEED or AED and N_EL = 2 for APC ..........
+C
+ DO J_EL=1,N_EL
+C
+C.......... Writing the information on the spectroscopies ..........
+C.......... in the control file IUO1 ..........
+C
+ IF(SPECTRO.EQ.'XAS') GOTO 566
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,236)
+ ELSE
+ WRITE(IUO1,248)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,245)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+C
+C---------- Photoelectron diffraction case (PHD) ----------
+C
+ IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,35)
+ ELSE
+ WRITE(IUO1,246)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,44)
+ IF(IE.EQ.1) WRITE(IUO1,58)
+ IF(INITL.EQ.0) WRITE(IUO1,118)
+ IF(I_TEST.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
+ WRITE(IUO1,418)
+ WRITE(IUO1,18)
+ ENDIF
+ IF(J_EL.EQ.2) GOTO 222
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(INITL.NE.0) THEN
+ WRITE(IUO1,337)
+ WRITE(IUO1,91)
+ IF(IPOL.EQ.0) THEN
+ WRITE(IUO1,88)
+ ELSEIF(ABS(IPOL).EQ.1) THEN
+ WRITE(IUO1,87)
+ ELSEIF(IPOL.EQ.2) THEN
+ WRITE(IUO1,89)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IDICHR.GT.0) THEN
+ WRITE(IUO1,338)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,90)
+ WRITE(IUO1,43) THLUM,PHILUM
+ IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN
+ WRITE(IUO1,45)
+ ENDIF
+ ENDIF
+C
+ IF(INITL.EQ.2) THEN
+ WRITE(IUO1,79) LI,LI-1,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,1,1),RHOR(JE,JTE
+ &,NNL,2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1),DLT(JE,JTE,N
+ &NL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.-1) THEN
+ WRITE(IUO1,82) LI,LI-1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,1,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,1)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF(INITL.EQ.1) THEN
+ WRITE(IUO1,82) LI,LI+1
+ IF(I_SO.EQ.1) THEN
+ WRITE(IUO1,80) S_O
+ ENDIF
+ DO JE=1,NE
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,2,1)
+ IF(ITL.EQ.0) THEN
+ WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV(J_EL).EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ 222 CONTINUE
+ ENDIF
+C
+C---------- LEED case (LED) ----------
+C
+ IF(SPECTRO.EQ.'LED') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,252)
+ ELSE
+ WRITE(IUO1,258)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,254)
+ IF(IE.EQ.1) WRITE(IUO1,256)
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,260)
+ WRITE(IUO1,261) THLUM,PHILUM
+ IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN
+ WRITE(IUO1,45)
+ ENDIF
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV(J_EL).EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ ENDIF
+C
+C---------- Auger diffraction case (AED) ----------
+C
+ IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
+ IF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,235)
+ ELSE
+ WRITE(IUO1,247)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,244)
+ IF(I_TEST_A.EQ.1) WRITE(IUO1,234)
+ ENDIF
+ IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN
+ WRITE(IUO1,419)
+ WRITE(IUO1,18)
+ ENDIF
+ IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,92)
+ WRITE(IUO1,91)
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,335)
+ ELSE
+ WRITE(IUO1,336)
+ ENDIF
+ WRITE(IUO1,91)
+ IF(IPOTC_A.EQ.0) THEN
+ WRITE(IUO1,339)
+ ELSE
+ WRITE(IUO1,334)
+ ENDIF
+ WRITE(IUO1,91)
+ WRITE(IUO1,92)
+ WRITE(IUO1,95) AUGER
+ CALL AUGER_MULT
+ IF(I_MULT.EQ.0) THEN
+ WRITE(IUO1,154)
+ ELSE
+ WRITE(IUO1,155) MULTIPLET
+ ENDIF
+C
+ DO JEM=1,NEMET
+ JTE=IEMET(JEM)
+ WRITE(IUO1,112) JTE
+ DO LE=LE_MIN,LE_MAX
+ WRITE(IUO1,119) LE
+ LA_MIN=L_BOUNDS(LE,1)
+ LA_MAX=L_BOUNDS(LE,2)
+ DO LA=LA_MIN,LA_MAX
+ IF(ISPIN.EQ.0) THEN
+ WRITE(IUO1,115) LA,RHOR_A(LE,JTE,LA,1,1),RHOR_A(LE
+ &,JTE,LA,2,1)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ IF(I_AT.EQ.0) THEN
+ IF(INV(J_EL).EQ.0) THEN
+ IF(NDIF.EQ.1) THEN
+ IF(ISPHER.EQ.1) THEN
+ WRITE(IUO1,83)
+ ELSEIF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,84)
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,97) NDIF
+ ELSE
+ WRITE(IUO1,98) NDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,122)
+ ELSE
+ WRITE(IUO1,120)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISPHER.EQ.0) THEN
+ WRITE(IUO1,85)
+ ELSE
+ WRITE(IUO1,86)
+ ENDIF
+ ENDIF
+C
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C.......... Check of the dimensioning of the treatment routine ..........
+C
+ CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,NPH
+ &I_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
+C
+C.......... Call of the subroutine performing either ..........
+C.......... the PhD, LEED, AED, EXAFS or APECS calculation ..........
+C
+ 566 IF(ISPIN.EQ.0) THEN
+ IF(SPECTRO.EQ.'PHD') THEN
+ CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,NATC
+ &LU,NFICHLEC,JFICH,NP)
+ ELSEIF(SPECTRO.EQ.'LED') THEN
+c CALL LEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+c IF(J_EL.EQ.1) THEN
+c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(J_EL.EQ.2) THEN
+c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
+c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
+c ENDIF
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF(SPECTRO.EQ.'PHD') THEN
+c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
+c 1 NATCLU,NFICHLEC,JFICH,NP)
+c ELSEIF(SPECTRO.EQ.'AED') THEN
+c CALL AEDDIF_SP
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL XASDIF_SP
+c ENDIF
+ continue
+ ENDIF
+C
+C.......... End of the MS calculation : ..........
+C.......... direct exit or treatment of the results ..........
+C
+C
+C.......... End of the loop on the electrons ..........
+C
+ ENDDO
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,52)
+ ELSE
+ WRITE(IUO1,249)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,49)
+ IF(IE.EQ.1) WRITE(IUO1,59)
+ ELSEIF(SPECTRO.EQ.'LED') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,253)
+ ELSE
+ WRITE(IUO1,259)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,255)
+ IF(IE.EQ.1) WRITE(IUO1,257)
+ ELSEIF(SPECTRO.EQ.'XAS') THEN
+ WRITE(IUO1,51)
+ ELSEIF(SPECTRO.EQ.'AED') THEN
+ IF(IPHI_A.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,237)
+ ELSE
+ WRITE(IUO1,250)
+ ENDIF
+ ENDIF
+ IF(ITHETA_A.EQ.1) WRITE(IUO1,238)
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ IF(IPHI.EQ.1) THEN
+ IF(STEREO.EQ.' NO') THEN
+ WRITE(IUO1,239)
+ ELSE
+ WRITE(IUO1,251)
+ ENDIF
+ ENDIF
+ IF(ITHETA.EQ.1) WRITE(IUO1,240)
+ ENDIF
+C
+ CLOSE(ICOM)
+ IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
+ WRITE(IUO1,562)
+ ENDIF
+ IF(ISOM.EQ.0) CLOSE(IUO2)
+C! IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
+C
+C.......... End of the loop on the data files ..........
+C
+ ENDDO
+C
+ IF(ISOM.NE.0) THEN
+ JFF=1
+ IF(ISPIN.EQ.0) THEN
+ IF(SPECTRO.NE.'XAS') THEN
+ CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP)
+ ELSE
+c CALL TREAT_XAS(ISOM,NFICHLEC,NP)
+ ENDIF
+ ELSEIF(ISPIN.EQ.1) THEN
+c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
+c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP)
+c ELSEIF(SPECTRO.EQ.'XAS') THEN
+c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP)
+c ENDIF
+ continue
+ ENDIF
+ ENDIF
+C
+C! IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
+ IF(ISOM.NE.0) CLOSE(IUO2)
+C STOP
+ GOTO 999
+C
+ 1 WRITE(IUO1,60)
+ STOP
+ 2 WRITE(IUO1,61)
+ STOP
+ 55 WRITE(IUO1,65)
+ STOP
+ 56 WRITE(IUO1,64)
+ STOP
+ 74 WRITE(IUO1,75)
+ STOP
+ 99 WRITE(IUO1,100)
+ STOP
+ 180 WRITE(IUO1,181)
+ STOP
+ 182 WRITE(IUO1,183)
+ STOP
+ 184 WRITE(IUO1,185)
+ STOP
+ 504 WRITE(IUO1,505)
+ STOP
+ 510 WRITE(IUO1,511) IUI4
+ STOP
+ 514 WRITE(IUO1,515)
+ STOP
+ 516 WRITE(IUO1,517)
+ STOP
+ 518 WRITE(IUO1,519)
+ WRITE(IUO1,889)
+ STOP
+ 520 WRITE(IUO1,521)
+ STOP
+ 540 WRITE(IUO1,541)
+ STOP
+ 550 WRITE(IUO1,551)
+ STOP
+ 570 WRITE(IUO1,571)
+ STOP
+ 580 WRITE(IUO1,581)
+ STOP
+ 590 WRITE(IUO1,591)
+ STOP
+ 600 WRITE(IUO1,601)
+ STOP
+ 602 WRITE(IUO1,603)
+ STOP
+ 604 WRITE(IUO1,605)
+ STOP
+ 606 WRITE(IUO1,607)
+ STOP
+ 608 WRITE(IUO1,609)
+ STOP
+ 610 WRITE(IUO1,611)
+ STOP
+ 614 WRITE(IUO1,615) NB_AT
+ STOP
+ 620 WRITE(IUO1,621) LE_MAX
+ STOP
+ 630 WRITE(IUO1,631)
+ STOP
+ 890 WRITE(IUO1,891)
+ STOP
+ 895 WRITE(IUO1,896) JA1,JA2
+C
+ 3 FORMAT(5(5X,I4))
+ 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9)
+ 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6)
+ 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',':
+ &(',I3,',',I3,',',I3,')')
+ 18 FORMAT(' ',/)
+ 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5)
+ 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,',
+ &',F7.3,')')
+ 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER')
+ 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,'
+ &,',F7.3,')',5X,'NEW NUMBER : ',I4)
+ 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/)
+ 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2)
+ 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3)
+ 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/)
+ 31 FORMAT(38X,10(I2,3X),//)
+ 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS P
+ &OSITIONED AT (',F7.3,',',F7.3,',',F7.3,')')
+ 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL PHOTO
+ &ELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
+ 36 FORMAT(/////,'########## BEGINNING ', 'OF THE EX
+ &AFS CALCULATION ##########',/////)
+ 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE A
+ &TOMS GENERATED +++++++++++++++++++')
+ 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///)
+ 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++',
+ &'++++++++++++++++++++++++++++++++',/////)
+ 40 FORMAT(/////,'======================', ' CONTENTS OF THE RE
+ &DUCED CLUSTER ======================',///)
+ 41 FORMAT(///,'====================================================',
+ &'============================',/////)
+ 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,'
+ &DEGREES')
+ 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR PHOTOELECTR
+ &ON DIFFRACTION CALCULATION #####', '#####',/////)
+ 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE SURF
+ &ACE)')
+ 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON DIFFRA
+ &CTION CALCULATION ##########')
+ 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :')
+ 51 FORMAT(/////,'########## END OF THE ', 'EXAFS CALCU
+ &LATION ##########')
+ 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON DI
+ &FFRACTION CALCULATION #####','#####')
+ 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE')
+ 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE STRUCTURE
+ & OSCILLATIONS CALCULATION #####', '#####',/////)
+ 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE OSCILLATI
+ &ONS CALCULATION #####','#####')
+ 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M)
+ &- CHECK THE DIMENSIONING >>>>>>>>>>')
+ 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', '
+ & >>>>>>>>>>')
+ 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ','CLUST
+ &ER HAS NOT CONVERGED YET >>>>>>>>>>')
+ 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ',
+ &'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>')
+ 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ',
+ & 'IN MAIN ET READ_DATA >>>>>>>>>>')
+ 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ',
+ & I1,',',I1,/)
+ 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',A3
+ &,')',//)
+ 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)')
+ 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1)
+ 83 FORMAT(//,32X,'(SPHERICAL WAVES)')
+ 84 FORMAT(//,34X,'(PLANE WAVES)')
+ 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)')
+ 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)')
+ 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +')
+ 88 FORMAT(24X,'+ NON POLARIZED LIGHT +')
+ 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +')
+ 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/)
+ 91 FORMAT(24X,'+',35X,'+')
+ 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++')
+ 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS PR
+ &ESENT IN THIS PLANE')
+ 95 FORMAT(////,31X,'AUGER LINE :',A6,//)
+ 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')')
+ &
+ 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',I1,
+ &')')
+ 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE',' >>
+ &>>>>>>>>')
+ 101 FORMAT(24X,I3,24X,I3)
+ 102 FORMAT(A1)
+ 103 FORMAT(31X,F7.2)
+ 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5)
+ 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,E1
+ &2.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9)
+ 106 FORMAT(12X,I3,12X,I3,12X,I3)
+ 107 FORMAT(5X,I2,5X,I2,5X,I2)
+ 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5)
+ 109 FORMAT(5X,I2,12X,I2,11X,I2)
+ 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
+ & :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//)
+ 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
+ &: (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')')
+ 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
+ &: ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)',/,
+ &8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//)
+ 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ',
+ * 'TYPE ',I2,' : (',F8.5,',',F8.5,')')
+ 114 FORMAT(/)
+ 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.5
+ &,')')
+ 117 FORMAT(12X,I2,5X,I2)
+ 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/)
+ 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE INTEGRAL'
+ &)
+ 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ','I
+ &NVERSION)')
+ 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ','INVER
+ &SION)')
+ 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4)
+ 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,'
+ &',/,' ')
+ 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ','LINE'
+ &,' ',/,' ',/,' ')
+ 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A
+ &ND PHASE SHIFTS FILES >>>>>>>>>>')
+ 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A
+ &ND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>')
+ 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ','FILE
+ & >>>>>>>>>>')
+ 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX ELEME
+ &NTS TAKEN INTO ACCOUNT <-----',///)
+ 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL AUGER
+ & DIFFRACTION CALCULATION #####', '#####',/////)
+ 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL APECS
+ & DIFFRACTION CALCULATION #####', '#####',/////)
+ 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER DIFFR
+ &ACTION CALCULATION #####', '#####',/////)
+ 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER DIFFRACT
+ &ION CALCULATION #####', '#####',/////)
+ 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS DIFFR
+ &ACTION CALCULATION #####', '#####',/////)
+ 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS DIFFRACT
+ &ION CALCULATION #####', '#####',/////)
+ 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER DI
+ &FFRACTION CALCULATION #####', '#####',/////)
+ 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS DI
+ &FFRACTION CALCULATION #####', '#####',/////)
+ 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE PHOT
+ &OELECTRON DIFFRACTION CALCULATION ','##########',/////)
+ 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE AUGE
+ &R DIFFRACTION CALCULATION ', '##########',/////)
+ 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE APEC
+ &S DIFFRACTION CALCULATION ', '##########',/////)
+ 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON D
+ &IFFRACTION CALCULATION #####','#####')
+ 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER DIFF
+ &RACTION CALCULATION #####', '#####',/////)
+ 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS DIFF
+ &RACTION CALCULATION #####', '#####',/////)
+ 252 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL LEED
+ &CALCULATION #####', '#####',/////)
+ 253 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL LEED CALCUL
+ &ATION #####', '#####',/////)
+ 254 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR LEED CAL
+ &CULATION #####', '#####',/////)
+ 255 FORMAT(/////,6X,'########## END ', 'OF THE POLAR LEED CALCULATI
+ &ON #####', '#####',/////)
+ 256 FORMAT(/////,5X,'########## BEGINNING ', 'OF THE ENERGY LEED CA
+ &LCULATION #####', '#####',/////)
+ 257 FORMAT(/////,5X,'########## END ', 'OF THE ENERGY LEED CALCULAT
+ &ION #####', '#####',/////)
+ 258 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE LEED
+ & CALCULATION ', '##########',/////)
+ 259 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE LEED CALCULATIO
+ &N #####','#####')
+ 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/)
+ 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ',F6.2,' DE
+ &GREES')
+ 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +')
+ 335 FORMAT(24X,'+ STANDARD +')
+ 336 FORMAT(24X,'+ SPIN-POLARIZED +')
+ 337 FORMAT(24X,'+ WITH +')
+ 338 FORMAT(24X,'+ IN DICHROIC MODE +')
+ 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +')
+ 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','-----
+ &-------------------')
+ 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','-----
+ &-------------------')
+ 420 FORMAT(///,9X,'----------------------------------------------','--
+ &--------------------')
+ 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(',
+ &F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')')
+ 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.5
+ &,',',F8.5,')')
+ 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE DIME
+ &NSIONING >>>>>>>>>>')
+ 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ','CONSIS
+ &TENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' >>>>>>>>>>')
+ 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ','N
+ &AT IN THE DATA AND CLUSTER FILES >>>>>>>>>>')
+ 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ','
+ &IBWD >>>>>>>>>>')
+ 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT',' CONSIS
+ &TENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE >>>>>>>>>>
+ &')
+ 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH',
+ &' THE VALUE OF LI >>>>>>>>>>')
+ 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4)
+ 535 FORMAT(29X,F8.5,1X,F8.5)
+ 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ','CORR
+ &ESPOND TO NAT >>>>>>>>>>')
+ 543 FORMAT(5X,F12.9,5X,F12.9)
+ 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM'
+ &,/)
+ 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ','CORRES
+ &POND TO NAT >>>>>>>>>>')
+ 555 FORMAT(4(7X,I2))
+ 556 FORMAT(28X,4(I2,5X))
+ 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,A2)
+ &
+ 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' :
+ &',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,'A
+ &TOM',/)
+ 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' N
+ &o ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/)
+ 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL A
+ &TOMS : ',//)
+ 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM :
+ & ',//)
+ 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',13X
+ &,'oooooooooooooooo',///)
+ 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/)
+ 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ','CORR
+ &ESPOND TO NAT >>>>>>>>>>')
+ 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD A
+ &ND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>')
+ 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT CON
+ &SISTENT WITH THE INPUT DATA FILE >>>>>>>>>>')
+ 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ','>
+ &>>>>>>>>>',//)
+ 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ',
+ &'.inc FILE >>>>>>>>>>',//)
+ 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ','>>>>
+ &>>>>>>',//)
+ 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ',
+ &'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS FILE
+ & >>>>>>>>>>',//)
+ 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ','>>>
+ &>>>>>>>',//)
+ 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ','ELECTR
+ &ON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',17X,'WITH T
+ &HE INPUT DATA FILE ',16X,'>>>>>>>>>>',//)
+ 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ','TH
+ &E DIMENSIONNING FILE >>>>>>>>>>',//)
+ 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ','
+ &THE DIMENSIONNING FILE >>>>>>>>>>',//)
+ 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ','THE
+ &DIMENSIONNING FILE >>>>>>>>>>',//)
+ 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE IDE
+ &NTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH ELECTRONS IN
+ & CLUSTER ROTATION MODE',' >>>>>>>>>>',//)
+ 776 FORMAT(I2)
+ 777 FORMAT(A24)
+ 778 FORMAT(30X,I1)
+ 779 FORMAT(11X,A2,5X,I2,3F10.4,I5)
+ 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,' ATOMS
+ &')
+ 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M >>
+ &>>>>>>>>')
+ 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''','UNIT
+ &S >>>>>>>>>>')
+ 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' AT
+ &OMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' ARE
+ & IDENTICAL >>>>>>>>>>')
+C
+ 999 END
+C
+C=======================================================================
+C
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f
new file mode 100644
index 0000000..6d48a79
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/dwsph.f
@@ -0,0 +1,85 @@
+C
+C=======================================================================
+C
+ SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
+C
+C This routine recomputes the T-matrix elements taking into account the
+C mean square displacements.
+C
+C When the argument X is tiny, no vibrations are taken into account
+C
+C Last modified : 25 Apr 2013
+C
+ USE DIM_MOD
+C
+ USE TRANS_MOD
+C
+ DIMENSION GNT(0:N_GAUNT)
+C
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC
+C
+ COMPLEX*16 FFL(0:2*NL_M)
+C
+ DATA PI4,EPS /12.566371,1.0E-10/
+C
+ ZEROC=(0.,0.)
+C
+ IF(X.GT.EPS) THEN
+C
+C Standard case: vibrations
+C
+ IF(ISPEED.LT.0) THEN
+ NSUM_LB=ABS(ISPEED)
+ ENDIF
+C
+ COEF=PI4*EXP(-X)
+ NL2=2*LMAX(JTYP,JE)+2
+ IBESP=5
+ MG1=0
+ MG2=0
+C
+ CALL BESPHE(NL2,IBESP,X,FFL)
+C
+ DO L=0,LMAX(JTYP,JE)
+ XL=FLOAT(L+L+1)
+ SL1=ZEROC
+C
+ DO L1=0,LMAX(JTYP,JE)
+ XL1=FLOAT(L1+L1+1)
+ CALL GAUNT(L,MG1,L1,MG2,GNT)
+ L2MIN=ABS(L1-L)
+ IF(ISPEED.GE.0) THEN
+ L2MAX=L1+L
+ ELSEIF(ISPEED.LT.0) THEN
+ L2MAX=L2MIN+2*(NSUM_LB-1)
+ ENDIF
+ SL2=0.
+C
+ DO L2=L2MIN,L2MAX,2
+ XL2=FLOAT(L2+L2+1)
+ C=SQRT(XL1*XL2/(PI4*XL))
+ SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2)))
+ ENDDO
+C
+ SL1=SL1+SL2*TL(L1,1,JTYP,JE)
+ ENDDO
+C
+ TLT(L,1,JTYP,JE)=COEF*SL1
+C
+ ENDDO
+C
+ ELSE
+C
+C Argument X tiny: no vibrations
+C
+ DO L=0,LMAX(JTYP,JE)
+C
+ TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE)
+C
+ ENDDO
+C
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f
new file mode 100644
index 0000000..2ac7683
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif.f
@@ -0,0 +1,26 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FACDIF(COSTH,JAT,JE,FTHETA)
+C
+C This routine computes the plane wave scattering factor
+C
+ USE DIM_MOD
+C
+ USE TRANS_MOD
+C
+ DIMENSION PL(0:100)
+C
+ COMPLEX FTHETA
+C
+ FTHETA=(0.,0.)
+ NL=LMAX(JAT,JE)+1
+ CALL POLLEG(NL,COSTH,PL)
+ DO 20 L=0,NL-1
+ FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L)
+ 20 CONTINUE
+ FTHETA=FTHETA/VK(JE)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f
new file mode 100644
index 0000000..62ac3f8
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/facdif1.f
@@ -0,0 +1,113 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J
+ &E,*)
+C
+C This routine computes a spherical wave scattering factor
+C
+C Last modified : 03/04/2006
+C
+ USE DIM_MOD
+ USE APPROX_MOD
+ USE EXPFAC_MOD
+ USE TRANS_MOD
+ USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I
+ &6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
+C
+ DIMENSION PLMM(0:100,0:100)
+ DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
+C
+ COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
+ COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
+ COMPLEX RHOJK
+C
+C
+ DATA PI/3.141593/
+C
+ A=1.
+ INTER=0
+ IF(ITL.EQ.1) VKE=VK(JE)
+ RHOJ=VKE*RJ
+ RHOJK=VKE*RJK
+ HLM1=(1.,0.)
+ HLM2=(1.,0.)
+ HLM3=(1.,0.)
+ HLM4=(1.,0.)
+ IEM=1
+ CSTH=COS(BETA)
+ IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN
+ INTER=1
+ BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI))
+ ENDIF
+ CALL PLM(CSTH,PLMM,LMAX(JAT,JE))
+ IF(ISPHER.EQ.0) NO1=0
+ IF(ISPHER.EQ.1) THEN
+ IF(NO.EQ.8) THEN
+ NO1=LMAX(JAT,JE)+1
+ ELSE
+ NO1=NO
+ ENDIF
+ CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM)
+ IF(IEM.EQ.0) THEN
+ HLM4=HLM(0,L)
+ ENDIF
+ IF(RJK.GT.0.0001) THEN
+ NDUM=0
+ CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN)
+ ENDIF
+ CALL DJMN(THRJ,D,L)
+ A1=ABS(D(0,M,L))
+ IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1
+ &
+ ENDIF
+ MUMAX=MIN0(L,NO1)
+ SMU=(0.,0.)
+ DO 10 MU=0,MUMAX
+ IF(MOD(MU,2).EQ.0) THEN
+ B=1.
+ ELSE
+ B=-1.
+ IF(SIN(BETA).LT.0.) THEN
+ A=-1.
+ ENDIF
+ ENDIF
+ IF(ISPHER.LE.1) THEN
+ ALMU=(1.,0.)
+ C=1.
+ ENDIF
+ IF(ISPHER.EQ.0) GOTO 40
+ IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L))
+ IF(MU.GT.0) THEN
+ C=B*FLOAT(L+L+1)/EXPF(MU,L)
+ ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B*
+ * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU
+ ELSE
+ C=1.
+ ALMU=CMPLX(D(M,0,L))/BLMU
+ ENDIF
+ 40 SNU=(0.,0.)
+ NU1=INT(0.5*(NO1-MU)+0.0001)
+ NUMAX=MIN0(NU1,L-MU)
+ DO 20 NU=0,NUMAX
+ SLP=(0.,0.)
+ LPMIN=MAX0(MU,NU)
+ DO 30 LP=LPMIN,LMAX(JAT,JE)
+ IF(ISPHER.EQ.1) THEN
+ HLM1=HLM(NU,LP)
+ IF(RJK.GT.0.0001) HLM3=HLN(0,LP)
+ ENDIF
+ SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3
+ 30 CONTINUE
+ IF(ISPHER.EQ.1) THEN
+ HLM2=HLM(MU+NU,L)
+ ENDIF
+ SNU=SNU+SLP*HLM2
+ 20 CONTINUE
+ SMU=SMU+SNU*C*ALMU*A*B
+ 10 CONTINUE
+ FSPH=SMU/(VKE*HLM4)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f
new file mode 100644
index 0000000..51c2687
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths1.f
@@ -0,0 +1,366 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FINDPATHS(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIMI
+ &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+C
+C This routine generates all the paths and filters them according to the
+C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
+C It corresponds to the spin-independent case from a non spin-orbit
+C resolved initial core state LI
+C
+C Last modified : 16 May 2007
+C
+ USE DIM_MOD
+C
+ USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INIT_L_MOD
+ USE PATH_MOD
+ USE ROT_MOD
+ USE TESTPA_MOD
+ USE TESTPB_MOD
+ USE TRANS_MOD
+ USE TLDW_MOD
+ USE VARIA_MOD
+C
+ DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
+ DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
+C
+C
+C
+ COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
+ COMPLEX IC,COMPL1,PW(0:NDIF_M)
+ COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
+ COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
+ COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
+C
+ DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
+C
+ IC=(0.,1.)
+ IEULER=1
+C
+ IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
+ IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
+C
+C I_CP = 0 : all open paths generated
+C I_CP = 1 : only closed paths generated
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO JTYP=1,N_TYP
+ IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
+ IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
+ ND=ND+1
+C
+C I_ABS = 0 : the atom before the scatterer is not the absorber
+C I_ABS = 1 : the atom before the scatterer is the absorber
+C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
+C
+ IF(ND.EQ.1) THEN
+ I_ABS=1
+ ELSE
+ I_ABS=0
+ ENDIF
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPJ=NATYP(JTYP)
+ ELSE
+ NBTYPJ=1
+ ENDIF
+C
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ IF(JATL.EQ.IATL) GOTO 12
+ XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
+ YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
+ ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ JPOS(ND,1)=JTYP
+ JPOS(ND,2)=JNUM
+ JPOS(ND,3)=JATL
+ NPATH(ND)=NPATH(ND)+1.
+ IF(ND.GT.1) THEN
+ COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
+ &R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(ITYP).EQ.0) THEN
+ IF(COSTHMIJ.LT.COSFWDI) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(ITYP).EQ.1) THEN
+ IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ RHOIJ=VK(JE)*R(ND)
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1.) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THIJ=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
+ IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
+ ZSURFI=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(ITYP)=SIG2(R(ND-1),ITYP)
+ ENDIF
+ IF(ABS(ZSURFI).LE.SMALL) THEN
+ IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
+ CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
+ &STHMIJ)
+ ELSE
+ CSKZ2I=1.
+ ENDIF
+ UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
+ ELSE
+ UII=UJ2(ITYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UI2=VK2(JE)*UII
+ CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
+ ENDIF
+ 40 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
+ ENDIF
+ ENDIF
+ IF(ND.EQ.1) THEN
+ RHO01=RHOIJ
+ TH01=THIJ
+ PHI01=PHIIJ
+ CALL DJMN2(TH01,RLM01,LF2,2)
+ GOTO 30
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ LMJ=LMAX(ITYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
+ CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
+ CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
+ &BMIJ,CMIJ,RHOMI,RHOIJ)
+ 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
+ &REF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 42
+ I_ABS=0
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO KTYP=1,N_TYP
+ ND=ND+1
+ IF(ND.GT.NDIF) GOTO 20
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPK=NATYP(KTYP)
+ ELSE
+ NBTYPK=1
+ ENDIF
+C
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.EQ.JATL) GOTO 22
+ JPOS(ND,1)=KTYP
+ JPOS(ND,2)=KNUM
+ JPOS(ND,3)=KATL
+ XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
+ YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
+ ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF(IT(ND-1).EQ.1) GOTO 32
+ RHOJK=R(ND)*VK(JE)
+ NPATH(ND)=NPATH(ND)+1.
+ COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
+ &/(R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(JTYP).EQ.0) THEN
+ IF(COSTHIJK.LT.COSFWDJ) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(JTYP).EQ.1) THEN
+ IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
+ &EN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IT(ND-1).EQ.1) GOTO 32
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THJK=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ IF(ND-1.LT.NDIF) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
+ ZSURFJ=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(JTYP)=SIG2(R(ND-1),JTYP)
+ ENDIF
+ IF(ABS(ZSURFJ).LE.SMALL) THEN
+ IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
+ CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
+ &.*COSTHIJK)
+ ELSE
+ CSKZ2J=1.
+ ENDIF
+ UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
+ ELSE
+ UJJ=UJ2(JTYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UJ2=VK2(JE)*UJJ
+ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
+ ENDIF
+ 50 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
+ ENDIF
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ LMJ=LMAX(JTYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
+ & IT(ND)=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
+ IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ ENDIF
+ CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
+ &IJK,BIJK,CIJK,RHOIJ,RHOJK)
+ CEX(ND)=CEXP(IC*RHOJK)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
+ &JK,FREF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 32
+ CALL FINDPATHS2(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
+ &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+ 32 DIJ=DIJ-R(ND)
+ 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDDO
+ 20 CONTINUE
+ ND=ND-1
+ ENDDO
+ 42 DIJ=DIJ-R(ND)
+ 12 IF(ND.GT.1) THEN
+ IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDIF
+ ENDDO
+ ND=ND-1
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f
new file mode 100644
index 0000000..79aa914
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths2.f
@@ -0,0 +1,367 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FINDPATHS2(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
+ &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+C
+C This routine generates all the paths and filters them according to the
+C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
+C It corresponds to the spin-independent case from a non spin-orbit
+C resolved initial core state LI
+C
+C Last modified : 16 May 2007
+C
+ USE DIM_MOD
+C
+ USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INIT_L_MOD
+ USE PATH_MOD
+ USE ROT_MOD
+ USE TESTPA_MOD
+ USE TESTPB_MOD
+ USE TRANS_MOD
+ USE TLDW_MOD
+ USE VARIA_MOD
+C
+ COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
+ COMPLEX IC,COMPL1,PW(0:NDIF_M)
+ COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
+ COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
+ COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
+C
+ DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
+ DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
+C
+C
+C
+ DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
+C
+ IC=(0.,1.)
+ IEULER=1
+C
+ IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
+ IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
+C
+C I_CP = 0 : all open paths generated
+C I_CP = 1 : only closed paths generated
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO JTYP=1,N_TYP
+ IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
+ IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
+ ND=ND+1
+C
+C I_ABS = 0 : the atom before the scatterer is not the absorber
+C I_ABS = 1 : the atom before the scatterer is the absorber
+C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
+C
+ IF(ND.EQ.1) THEN
+ I_ABS=1
+ ELSE
+ I_ABS=0
+ ENDIF
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPJ=NATYP(JTYP)
+ ELSE
+ NBTYPJ=1
+ ENDIF
+C
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ IF(JATL.EQ.IATL) GOTO 12
+ XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
+ YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
+ ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ JPOS(ND,1)=JTYP
+ JPOS(ND,2)=JNUM
+ JPOS(ND,3)=JATL
+ NPATH(ND)=NPATH(ND)+1.
+ IF(ND.GT.1) THEN
+ COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
+ &R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(ITYP).EQ.0) THEN
+ IF(COSTHMIJ.LT.COSFWDI) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(ITYP).EQ.1) THEN
+ IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ RHOIJ=VK(JE)*R(ND)
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1.) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THIJ=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
+ IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
+ ZSURFI=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(ITYP)=SIG2(R(ND-1),ITYP)
+ ENDIF
+ IF(ABS(ZSURFI).LE.SMALL) THEN
+ IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
+ CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
+ &STHMIJ)
+ ELSE
+ CSKZ2I=1.
+ ENDIF
+ UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
+ ELSE
+ UII=UJ2(ITYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UI2=VK2(JE)*UII
+ CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
+ ENDIF
+ 40 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
+ ENDIF
+ ENDIF
+ IF(ND.EQ.1) THEN
+ RHO01=RHOIJ
+ TH01=THIJ
+ PHI01=PHIIJ
+ CALL DJMN2(TH01,RLM01,LF2,2)
+ GOTO 30
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ LMJ=LMAX(ITYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
+ CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
+ &BMIJ,CMIJ,RHOMI,RHOIJ)
+ 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
+ &REF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 42
+ I_ABS=0
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO KTYP=1,N_TYP
+ ND=ND+1
+ IF(ND.GT.NDIF) GOTO 20
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPK=NATYP(KTYP)
+ ELSE
+ NBTYPK=1
+ ENDIF
+C
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.EQ.JATL) GOTO 22
+ JPOS(ND,1)=KTYP
+ JPOS(ND,2)=KNUM
+ JPOS(ND,3)=KATL
+ XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
+ YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
+ ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF(IT(ND-1).EQ.1) GOTO 32
+ RHOJK=R(ND)*VK(JE)
+ NPATH(ND)=NPATH(ND)+1.
+ COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
+ &/(R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(JTYP).EQ.0) THEN
+ IF(COSTHIJK.LT.COSFWDJ) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(JTYP).EQ.1) THEN
+ IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
+ &EN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IT(ND-1).EQ.1) GOTO 32
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THJK=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ IF(ND-1.LT.NDIF) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
+ ZSURFJ=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(JTYP)=SIG2(R(ND-1),JTYP)
+ ENDIF
+ IF(ABS(ZSURFJ).LE.SMALL) THEN
+ IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
+ CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
+ &.*COSTHIJK)
+ ELSE
+ CSKZ2J=1.
+ ENDIF
+ UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
+ ELSE
+ UJJ=UJ2(JTYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UJ2=VK2(JE)*UJJ
+ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
+ ENDIF
+ 50 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
+ ENDIF
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ LMJ=LMAX(JTYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
+ &=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
+ IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ ENDIF
+ CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
+ &IJK,BIJK,CIJK,RHOIJ,RHOJK)
+ CEX(ND)=CEXP(IC*RHOJK)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
+ &JK,FREF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 32
+ CALL FINDPATHS3(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
+ &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+ 32 DIJ=DIJ-R(ND)
+ 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDDO
+ 20 CONTINUE
+ ND=ND-1
+ ENDDO
+ 42 DIJ=DIJ-R(ND)
+ 12 IF(ND.GT.1) THEN
+ IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDIF
+ ENDDO
+ ND=ND-1
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f
new file mode 100644
index 0000000..e6c82e0
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths3.f
@@ -0,0 +1,367 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FINDPATHS3(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
+ &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+C
+C This routine generates all the paths and filters them according to the
+C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
+C It corresponds to the spin-independent case from a non spin-orbit
+C resolved initial core state LI
+C
+C Last modified : 16 May 2007
+C
+ USE DIM_MOD
+C
+ USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INIT_L_MOD
+ USE PATH_MOD
+ USE ROT_MOD
+ USE TESTPA_MOD
+ USE TESTPB_MOD
+ USE TRANS_MOD
+ USE TLDW_MOD
+ USE VARIA_MOD
+C
+ DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
+ DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
+C
+C
+C
+ COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
+ COMPLEX IC,COMPL1,PW(0:NDIF_M)
+ COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
+ COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
+ COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
+C
+ DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
+C
+ IC=(0.,1.)
+ IEULER=1
+C
+ IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
+ IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
+C
+C I_CP = 0 : all open paths generated
+C I_CP = 1 : only closed paths generated
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO JTYP=1,N_TYP
+ IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
+ IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
+ ND=ND+1
+C
+C I_ABS = 0 : the atom before the scatterer is not the absorber
+C I_ABS = 1 : the atom before the scatterer is the absorber
+C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
+C
+ IF(ND.EQ.1) THEN
+ I_ABS=1
+ ELSE
+ I_ABS=0
+ ENDIF
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPJ=NATYP(JTYP)
+ ELSE
+ NBTYPJ=1
+ ENDIF
+C
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ IF(JATL.EQ.IATL) GOTO 12
+ XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
+ YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
+ ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ JPOS(ND,1)=JTYP
+ JPOS(ND,2)=JNUM
+ JPOS(ND,3)=JATL
+ NPATH(ND)=NPATH(ND)+1.
+ IF(ND.GT.1) THEN
+ COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
+ &R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(ITYP).EQ.0) THEN
+ IF(COSTHMIJ.LT.COSFWDI) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(ITYP).EQ.1) THEN
+ IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ RHOIJ=VK(JE)*R(ND)
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1.) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THIJ=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
+ IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
+ ZSURFI=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(ITYP)=SIG2(R(ND-1),ITYP)
+ ENDIF
+ IF(ABS(ZSURFI).LE.SMALL) THEN
+ IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
+ CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
+ &STHMIJ)
+ ELSE
+ CSKZ2I=1.
+ ENDIF
+ UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
+ ELSE
+ UII=UJ2(ITYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UI2=VK2(JE)*UII
+ CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
+ ENDIF
+ 40 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
+ ENDIF
+ ENDIF
+ IF(ND.EQ.1) THEN
+ RHO01=RHOIJ
+ TH01=THIJ
+ PHI01=PHIIJ
+ CALL DJMN2(TH01,RLM01,LF2,2)
+ GOTO 30
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ LMJ=LMAX(ITYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
+ CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
+ &BMIJ,CMIJ,RHOMI,RHOIJ)
+ 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
+ &REF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 42
+ I_ABS=0
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO KTYP=1,N_TYP
+ ND=ND+1
+ IF(ND.GT.NDIF) GOTO 20
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPK=NATYP(KTYP)
+ ELSE
+ NBTYPK=1
+ ENDIF
+C
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.EQ.JATL) GOTO 22
+ JPOS(ND,1)=KTYP
+ JPOS(ND,2)=KNUM
+ JPOS(ND,3)=KATL
+ XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
+ YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
+ ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF(IT(ND-1).EQ.1) GOTO 32
+ RHOJK=R(ND)*VK(JE)
+ NPATH(ND)=NPATH(ND)+1.
+ COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
+ &/(R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(JTYP).EQ.0) THEN
+ IF(COSTHIJK.LT.COSFWDJ) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(JTYP).EQ.1) THEN
+ IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
+ &EN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IT(ND-1).EQ.1) GOTO 32
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THJK=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ IF(ND-1.LT.NDIF) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
+ ZSURFJ=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(JTYP)=SIG2(R(ND-1),JTYP)
+ ENDIF
+ IF(ABS(ZSURFJ).LE.SMALL) THEN
+ IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
+ CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
+ &.*COSTHIJK)
+ ELSE
+ CSKZ2J=1.
+ ENDIF
+ UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
+ ELSE
+ UJJ=UJ2(JTYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UJ2=VK2(JE)*UJJ
+ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
+ ENDIF
+ 50 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
+ ENDIF
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ LMJ=LMAX(JTYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
+ &=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
+ IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ ENDIF
+ CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
+ &IJK,BIJK,CIJK,RHOIJ,RHOJK)
+ CEX(ND)=CEXP(IC*RHOJK)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
+ &JK,FREF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 32
+ CALL FINDPATHS4(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
+ &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+ 32 DIJ=DIJ-R(ND)
+ 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDDO
+ 20 CONTINUE
+ ND=ND-1
+ ENDDO
+ 42 DIJ=DIJ-R(ND)
+ 12 IF(ND.GT.1) THEN
+ IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDIF
+ ENDDO
+ ND=ND-1
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths4.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths4.f
new file mode 100644
index 0000000..7e0f563
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths4.f
@@ -0,0 +1,367 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FINDPATHS4(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
+ &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+C
+C This routine generates all the paths and filters them according to the
+C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
+C It corresponds to the spin-independent case from a non spin-orbit
+C resolved initial core state LI
+C
+C Last modified : 16 May 2007
+C
+ USE DIM_MOD
+C
+ USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INIT_L_MOD
+ USE PATH_MOD
+ USE ROT_MOD
+ USE TESTPA_MOD
+ USE TESTPB_MOD
+ USE TRANS_MOD
+ USE TLDW_MOD
+ USE VARIA_MOD
+C
+ DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
+ DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
+C
+C
+C
+ COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
+ COMPLEX IC,COMPL1,PW(0:NDIF_M)
+ COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
+ COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
+ COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
+C
+ DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
+C
+ IC=(0.,1.)
+ IEULER=1
+C
+ IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
+ IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
+C
+C I_CP = 0 : all open paths generated
+C I_CP = 1 : only closed paths generated
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO JTYP=1,N_TYP
+ IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
+ IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
+ ND=ND+1
+C
+C I_ABS = 0 : the atom before the scatterer is not the absorber
+C I_ABS = 1 : the atom before the scatterer is the absorber
+C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
+C
+ IF(ND.EQ.1) THEN
+ I_ABS=1
+ ELSE
+ I_ABS=0
+ ENDIF
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPJ=NATYP(JTYP)
+ ELSE
+ NBTYPJ=1
+ ENDIF
+C
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ IF(JATL.EQ.IATL) GOTO 12
+ XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
+ YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
+ ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ JPOS(ND,1)=JTYP
+ JPOS(ND,2)=JNUM
+ JPOS(ND,3)=JATL
+ NPATH(ND)=NPATH(ND)+1.
+ IF(ND.GT.1) THEN
+ COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
+ &R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(ITYP).EQ.0) THEN
+ IF(COSTHMIJ.LT.COSFWDI) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(ITYP).EQ.1) THEN
+ IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ RHOIJ=VK(JE)*R(ND)
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1.) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THIJ=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
+ IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
+ ZSURFI=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(ITYP)=SIG2(R(ND-1),ITYP)
+ ENDIF
+ IF(ABS(ZSURFI).LE.SMALL) THEN
+ IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
+ CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
+ &STHMIJ)
+ ELSE
+ CSKZ2I=1.
+ ENDIF
+ UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
+ ELSE
+ UII=UJ2(ITYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UI2=VK2(JE)*UII
+ CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
+ ENDIF
+ 40 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
+ ENDIF
+ ENDIF
+ IF(ND.EQ.1) THEN
+ RHO01=RHOIJ
+ TH01=THIJ
+ PHI01=PHIIJ
+ CALL DJMN2(TH01,RLM01,LF2,2)
+ GOTO 30
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ LMJ=LMAX(ITYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
+ CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
+ &BMIJ,CMIJ,RHOMI,RHOIJ)
+ 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
+ &REF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 42
+ I_ABS=0
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO KTYP=1,N_TYP
+ ND=ND+1
+ IF(ND.GT.NDIF) GOTO 20
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPK=NATYP(KTYP)
+ ELSE
+ NBTYPK=1
+ ENDIF
+C
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.EQ.JATL) GOTO 22
+ JPOS(ND,1)=KTYP
+ JPOS(ND,2)=KNUM
+ JPOS(ND,3)=KATL
+ XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
+ YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
+ ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF(IT(ND-1).EQ.1) GOTO 32
+ RHOJK=R(ND)*VK(JE)
+ NPATH(ND)=NPATH(ND)+1.
+ COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
+ &/(R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(JTYP).EQ.0) THEN
+ IF(COSTHIJK.LT.COSFWDJ) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(JTYP).EQ.1) THEN
+ IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
+ &EN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IT(ND-1).EQ.1) GOTO 32
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THJK=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ IF(ND-1.LT.NDIF) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
+ ZSURFJ=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(JTYP)=SIG2(R(ND-1),JTYP)
+ ENDIF
+ IF(ABS(ZSURFJ).LE.SMALL) THEN
+ IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
+ CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
+ &.*COSTHIJK)
+ ELSE
+ CSKZ2J=1.
+ ENDIF
+ UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
+ ELSE
+ UJJ=UJ2(JTYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UJ2=VK2(JE)*UJJ
+ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
+ ENDIF
+ 50 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
+ ENDIF
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ LMJ=LMAX(JTYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
+ &=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
+ IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ ENDIF
+ CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
+ &IJK,BIJK,CIJK,RHOIJ,RHOJK)
+ CEX(ND)=CEXP(IC*RHOJK)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
+ &JK,FREF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 32
+ CALL FINDPATHS5(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
+ &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+ 32 DIJ=DIJ-R(ND)
+ 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDDO
+ 20 CONTINUE
+ ND=ND-1
+ ENDDO
+ 42 DIJ=DIJ-R(ND)
+ 12 IF(ND.GT.1) THEN
+ IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDIF
+ ENDDO
+ ND=ND-1
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths5.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths5.f
new file mode 100644
index 0000000..b379ca1
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/findpaths5.f
@@ -0,0 +1,367 @@
+C
+C=======================================================================
+C
+ SUBROUTINE FINDPATHS5(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
+ &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+C
+C This routine generates all the paths and filters them according to the
+C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
+C It corresponds to the spin-independent case from a non spin-orbit
+C resolved initial core state LI
+C
+C Last modified : 16 May 2007
+C
+ USE DIM_MOD
+C
+ USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
+ USE COOR_MOD
+ USE DEBWAL_MOD
+ USE INIT_L_MOD
+ USE PATH_MOD
+ USE ROT_MOD
+ USE TESTPA_MOD
+ USE TESTPB_MOD
+ USE TRANS_MOD
+ USE TLDW_MOD
+ USE VARIA_MOD
+C
+ DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
+ DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
+C
+C
+C
+ COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
+ COMPLEX IC,COMPL1,PW(0:NDIF_M)
+ COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
+ COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
+ COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
+C
+ DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
+C
+ IC=(0.,1.)
+ IEULER=1
+C
+ IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
+ IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
+C
+C I_CP = 0 : all open paths generated
+C I_CP = 1 : only closed paths generated
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO JTYP=1,N_TYP
+ IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
+ IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
+ ND=ND+1
+C
+C I_ABS = 0 : the atom before the scatterer is not the absorber
+C I_ABS = 1 : the atom before the scatterer is the absorber
+C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
+C
+ IF(ND.EQ.1) THEN
+ I_ABS=1
+ ELSE
+ I_ABS=0
+ ENDIF
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPJ=NATYP(JTYP)
+ ELSE
+ NBTYPJ=1
+ ENDIF
+C
+ DO JNUM=1,NBTYPJ
+ JATL=NCORR(JNUM,JTYP)
+ IF(JATL.EQ.IATL) GOTO 12
+ XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
+ YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
+ ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ JPOS(ND,1)=JTYP
+ JPOS(ND,2)=JNUM
+ JPOS(ND,3)=JATL
+ NPATH(ND)=NPATH(ND)+1.
+ IF(ND.GT.1) THEN
+ COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
+ &R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(ITYP).EQ.0) THEN
+ IF(COSTHMIJ.LT.COSFWDI) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(ITYP).EQ.1) THEN
+ IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
+ RHOIJ=VK(JE)*R(ND)
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1.) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THIJ=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
+ IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
+ ZSURFI=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(ITYP)=SIG2(R(ND-1),ITYP)
+ ENDIF
+ IF(ABS(ZSURFI).LE.SMALL) THEN
+ IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
+ CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
+ &STHMIJ)
+ ELSE
+ CSKZ2I=1.
+ ENDIF
+ UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
+ ELSE
+ UII=UJ2(ITYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UI2=VK2(JE)*UII
+ CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
+ ENDIF
+ 40 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
+ ENDIF
+ ENDIF
+ IF(ND.EQ.1) THEN
+ RHO01=RHOIJ
+ TH01=THIJ
+ PHI01=PHIIJ
+ CALL DJMN2(TH01,RLM01,LF2,2)
+ GOTO 30
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ LMJ=LMAX(ITYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
+ CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
+ &BMIJ,CMIJ,RHOMI,RHOIJ)
+ 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
+ &REF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 42
+ I_ABS=0
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
+ N_TYP=N_PROT
+ ELSE
+ N_TYP=1
+ ENDIF
+C
+ DO KTYP=1,N_TYP
+ ND=ND+1
+ IF(ND.GT.NDIF) GOTO 20
+C
+ IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
+ NBTYPK=NATYP(KTYP)
+ ELSE
+ NBTYPK=1
+ ENDIF
+C
+ DO KNUM=1,NBTYPK
+ KATL=NCORR(KNUM,KTYP)
+ IF(KATL.EQ.JATL) GOTO 22
+ JPOS(ND,1)=KTYP
+ JPOS(ND,2)=KNUM
+ JPOS(ND,3)=KATL
+ XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
+ YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
+ ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
+ R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
+ DIJ=DIJ+R(ND)
+ IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
+ IF(IT(ND-1).EQ.1) GOTO 32
+ RHOJK=R(ND)*VK(JE)
+ NPATH(ND)=NPATH(ND)+1.
+ COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
+ &/(R(ND)*R(ND-1))
+ IF(IFWD.EQ.1) THEN
+ IF(IBWD(JTYP).EQ.0) THEN
+ IF(COSTHIJK.LT.COSFWDJ) THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ELSEIF(IBWD(JTYP).EQ.1) THEN
+ IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
+ &EN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
+ NTHOF=NTHOF+1
+ IN(ND-1)=1
+ IF(NTHOF.GT.NTHOUT) THEN
+ IT(ND-1)=1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(IT(ND-1).EQ.1) GOTO 32
+ CTROIS1=ZR(ND)/R(ND)
+ IF(CTROIS1.GT.1) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ THJK=ACOS(CTROIS1)
+ COMPL1= XR(ND)+IC*YR(ND)
+ IF(ND-1.LT.NDIF) THEN
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
+ ZSURFJ=ZSURF-ZR(ND-1)
+ IF(IDCM.EQ.1) THEN
+ UJ2(JTYP)=SIG2(R(ND-1),JTYP)
+ ENDIF
+ IF(ABS(ZSURFJ).LE.SMALL) THEN
+ IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
+ CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
+ &.*COSTHIJK)
+ ELSE
+ CSKZ2J=1.
+ ENDIF
+ UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
+ ELSE
+ UJJ=UJ2(JTYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UJ2=VK2(JE)*UJJ
+ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
+ ENDIF
+ 50 IF(IDWSPH.EQ.1) THEN
+ DW(ND-1)=1.
+ ELSE
+ DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
+ ENDIF
+ ENDIF
+ IF(IPW.EQ.1) THEN
+ CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
+ PWI=FTHETA*DW(ND-1)/R(ND)
+ PW(ND)=PW(ND-1)*PWI
+ CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ LMJ=LMAX(JTYP,JE)
+ IF(ND.GT.NCUT) THEN
+ IT(ND)=1
+ ELSE
+ IT(ND)=0
+ ENDIF
+ CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
+ CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
+ XMAXT=0.
+ DO LJ=0,LMJ
+ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
+ DO LF=LF1,LF2,ISTEP_LF
+ PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
+ XMAXT=AMAX1(XMAXT,CABS(PW1))
+ ENDDO
+ ENDDO
+ IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
+ &=0
+ ENDIF
+ IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
+ IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
+ CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
+ ENDIF
+ CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
+ IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
+ CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
+ &IJK,BIJK,CIJK,RHOIJ,RHOJK)
+ CEX(ND)=CEXP(IC*RHOJK)/R(ND)
+ CEXDW(ND)=CEX(ND)*DW(ND-1)
+ IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
+ IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
+ CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
+ &JK,FREF,IJ,DIJ,TAU)
+ NPATH2(ND)=NPATH2(ND)+1.
+ ENDIF
+ ENDIF
+ IF(ND.EQ.NDIF) GOTO 32
+c CALL FINDPATHS(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
+c 1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+ 32 DIJ=DIJ-R(ND)
+ 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDDO
+ 20 CONTINUE
+ ND=ND-1
+ ENDDO
+ 42 DIJ=DIJ-R(ND)
+ 12 IF(ND.GT.1) THEN
+ IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
+ IT(ND-1)=0
+ IN(ND-1)=0
+ ENDIF
+ ENDDO
+ ND=ND-1
+ ENDDO
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/main.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/main.f
new file mode 100644
index 0000000..4bdf296
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/main.f
@@ -0,0 +1,20 @@
+ SUBROUTINE RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
+ & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
+ & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
+ & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
+
+ USE DIM_MOD
+ IMPLICIT INTEGER (A-Z)
+CF2PY INTEGER, INTENT(IN,COPY) :: NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_
+CF2PY INTEGER, INTENT(IN,COPY) :: NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_
+CF2PY INTEGER, INTENT(IN,COPY) :: NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_
+CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_
+
+ CALL ALLOCATION(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
+ & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
+ & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
+ & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
+
+ CALL DO_MAIN()
+
+ END SUBROUTINE RUN
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/matdif.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/matdif.f
new file mode 100644
index 0000000..e78ac1f
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/matdif.f
@@ -0,0 +1,344 @@
+C
+C=======================================================================
+C
+ SUBROUTINE MATDIF(NO,ND,LF,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A21,B2
+ &1,C21,RHO1,RHO2)
+C
+C This routine calculates the Rehr-Albers scattering matrix
+C F_{LAMBDA1,LAMBDA2}. The result is stored in the COMMON block
+C /SCATMAT/ as F21(NSPIN2_M,NLAMBDA_M,NLAMBDA_M,NDIF_M).
+C
+C Last modified : 3 Aug 2007
+C
+ USE DIM_MOD
+C
+ USE EXPFAC_MOD
+ USE LBD_MOD
+ USE LINLBD_MOD
+ USE RA_MOD
+ USE SCATMAT_MOD
+ USE TRANS_MOD
+ USE TLDW_MOD
+C
+ REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
+C
+ COMPLEX HLM1(0:NO_ST_M,0:NL_M-1),HLM2(0:NO_ST_M,0:NL_M-1)
+ COMPLEX SL,RHO1,RHO2,IC,ZEROC,ONEC,ONEOVK
+ COMPLEX SL_2_1,SL_2_2
+ COMPLEX EXP1,EXP2,PROD1,PROD2
+C
+ DATA PI,SMALL /3.141593,0.0001/
+C
+ IC=(0.,1.)
+ ZEROC=(0.,0.)
+ ONEC=(1.,0.)
+ ONEOVK=1./VK(JE)
+ IB=0
+ LMJ=LMAX(JTYP,JE)
+ IF(ABS(ABS(B21)-PI).LT.SMALL) IB=-1
+ IF(ABS(B21).LT.SMALL) IB=1
+ IF(NO.EQ.8) THEN
+ NN2=LMAX(JTYP,JE)+1
+ ELSE
+ NN2=NO
+ ENDIF
+C
+C NO is atom-dependent and is decreased with the rank of the scatterer
+C in the path when I_NO > 0. Here LAMBDA1 depends on the scatterer JTYP
+C while LAMBDA2 depends on the next atom (KTYP) in the path
+C
+ IF(I_NO.EQ.0) THEN
+ NO1=N_RA(JTYP)
+ NO2=N_RA(KTYP)
+ ELSE
+ NO1=MAX(N_RA(JTYP)-(ND-1)/I_NO,0)
+ NO2=MAX(N_RA(KTYP)-ND/I_NO,0)
+ ENDIF
+ IF(I_ABS.EQ.0) THEN
+ NUMAX1=NO1/2
+ NUMAX2=NO2/2
+ ELSEIF(I_ABS.EQ.1) THEN
+ NUMAX1=MIN0(LF,NO1/2)
+ NUMAX2=NO2/2
+ ELSEIF(I_ABS.EQ.2) THEN
+ NUMAX1=NO1/2
+ NUMAX2=MIN0(LF,NO2/2)
+ ENDIF
+ LBDM(1,ND)=(NO1+1)*(NO1+2)/2
+ LBDM(2,ND)=(NO2+1)*(NO2+2)/2
+C
+ EXP2=-EXP(-IC*A21)
+ EXP1=EXP(-IC*C21)
+C
+ DO LAMBDA1=1,LBDMAX
+ DO LAMBDA2=1,LBDMAX
+ F21(1,LAMBDA2,LAMBDA1,ND)=ZEROC
+ ENDDO
+ ENDDO
+C
+ IF(ABS(RHO1-RHO2).GT.SMALL) THEN
+ CALL POLHAN(ISPHER,NUMAX1,LMJ,RHO1,HLM1)
+ CALL POLHAN(ISPHER,NN2,LMJ,RHO2,HLM2)
+ NEQUAL=0
+ ELSE
+ CALL POLHAN(ISPHER,NN2,LMJ,RHO1,HLM1)
+ NEQUAL=1
+ ENDIF
+C
+C Calculation of the scattering matrix when the scattering angle
+C is different from 0 and pi
+C
+ IF(IB.EQ.0) THEN
+ CALL DJMN(B21,RLM,LMJ)
+ DO NU1=0,NUMAX1
+ MUMAX1=NO1-2*NU1
+ IF(I_ABS.EQ.1) MUMAX1=MIN(LF-NU1,MUMAX1)
+ DO NU2=0,NUMAX2
+ MUMAX2=NO2-2*NU2
+C
+C Case MU1 = 0
+C
+ LAMBDA1=LBD(0,NU1)
+C
+C Case MU2 = 0
+C
+ LAMBDA2=LBD(0,NU2)
+ LMIN=MAX(NU1,NU2)
+ SL=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(NU2,L)=HLM1(NU2,L)
+ ENDIF
+ IF(ISPEED.EQ.1) THEN
+ SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TL(L,1,JTYP,JE)*HLM1(NU1,L
+ &)*HLM2(NU2,L)
+ ELSE
+ SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TLT(L,1,JTYP,JE)*HLM1(NU1,
+ &L)*HLM2(NU2,L)
+ ENDIF
+ ENDDO
+ F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
+C
+C Case MU2 > 0
+C
+ PROD2=ONEC
+ SIG2=1.
+ DO MU2=1,MUMAX2
+ LAMBDA2_1=LBD(MU2,NU2)
+ LAMBDA2_2=LBD(-MU2,NU2)
+ PROD2=PROD2*EXP2
+ SIG2=-SIG2
+ LMIN=MAX(NU1,MU2+NU2)
+ SL=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
+ ENDIF
+ C1=EXPF(0,L)/EXPF(MU2,L)
+ IF(ISPEED.EQ.1) THEN
+ SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TL(L,1,JTYP,JE)*HLM
+ &1(NU1,L)*HLM2(MU2+NU2,L)
+ ELSE
+ SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TLT(L,1,JTYP,JE)*HL
+ &M1(NU1,L)*HLM2(MU2+NU2,L)
+ ENDIF
+ ENDDO
+ F21(1,LAMBDA2_1,LAMBDA1,ND)=SL*PROD2*ONEOVK*SIG2
+ F21(1,LAMBDA2_2,LAMBDA1,ND)=SL*ONEOVK/PROD2
+ ENDDO
+C
+C Case MU1 > 0
+C
+ PROD1=ONEC
+ SIG1=1.
+ DO MU1=1,MUMAX1
+ LAMBDA1_1=LBD(MU1,NU1)
+ LAMBDA1_2=LBD(-MU1,NU1)
+ PROD1=PROD1*EXP1
+ SIG1=-SIG1
+C
+C Case MU2 = 0
+C
+ LAMBDA2=LBD(0,NU2)
+ LMIN=MAX(MU1,NU1,NU2)
+ SL=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(NU2,L)=HLM1(NU2,L)
+ ENDIF
+ C1=EXPF(MU1,L)/EXPF(0,L)
+ IF(ISPEED.EQ.1) THEN
+ SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TL(L,1,JTYP,JE)*HLM
+ &1(NU1,L)*HLM2(NU2,L)
+ ELSE
+ SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TLT(L,1,JTYP,JE)*HL
+ &M1(NU1,L)*HLM2(NU2,L)
+ ENDIF
+ ENDDO
+ F21(1,LAMBDA2,LAMBDA1_1,ND)=SL*PROD1*ONEOVK*SIG1
+ F21(1,LAMBDA2,LAMBDA1_2,ND)=SL*ONEOVK/PROD1
+C
+C Case MU2 > 0
+C
+ PROD2=ONEC
+ SIG2=SIG1
+ DO MU2=1,MUMAX2
+ LAMBDA2_1=LBD(MU2,NU2)
+ LAMBDA2_2=LBD(-MU2,NU2)
+ PROD2=PROD2*EXP2
+ SIG2=-SIG2
+ LMIN=MAX(MU1,NU1,MU2+NU2)
+ SL_2_1=ZEROC
+ SL_2_2=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
+ ENDIF
+ C1=EXPF(MU1,L)/EXPF(MU2,L)
+ IF(ISPEED.EQ.1) THEN
+ SL=FLOAT(L+L+1)*C1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(
+ &MU2+NU2,L)
+ ELSE
+ SL=FLOAT(L+L+1)*C1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2
+ &(MU2+NU2,L)
+ ENDIF
+ SL_2_1=SL_2_1+SL*RLM(MU2,-MU1,L)
+ SL_2_2=SL_2_2+SL*RLM(MU2,MU1,L)
+ ENDDO
+ F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL_2_2*PROD1*PROD2*ONEOVK*
+ &SIG2
+ F21(1,LAMBDA2_2,LAMBDA1_1,ND)=SL_2_1*PROD1*ONEOVK/PROD2
+ F21(1,LAMBDA2_1,LAMBDA1_2,ND)=SL_2_1*ONEOVK*PROD2*SIG2/P
+ &ROD1
+ F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL_2_2*ONEOVK/(PROD1*PROD2
+ &)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Calculation of the scattering matrix when the scattering angle
+C is equal to 0 (forward scattering) or pi (backscattering)
+C
+ ELSEIF(IB.EQ.1) THEN
+ DO NU1=0,NUMAX1
+ DO NU2=0,NUMAX2
+ MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
+ IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
+C
+C Case MU = 0
+C
+ LAMBDA1=LBD(0,NU1)
+ LAMBDA2=LBD(0,NU2)
+ LMIN=MAX(NU1,NU2)
+ SL=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(NU2,L)=HLM1(NU2,L)
+ ENDIF
+ IF(ISPEED.EQ.1) THEN
+ SL=SL+FLOAT(L+L+1)*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,
+ &L)
+ ELSE
+ SL=SL+FLOAT(L+L+1)*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2
+ &,L)
+ ENDIF
+ ENDDO
+ F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
+C
+C Case MU > 0
+C
+ CST1=1.
+ DO MU=1,MUMAX1
+ LAMBDA1=LBD(MU,NU2)
+ LAMBDA2=LBD(-MU,NU2)
+ CST1=-CST1
+ LMIN=MAX(NU1,MU+NU2)
+ SL=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
+ ENDIF
+ IF(ISPEED.EQ.1) THEN
+ SL=SL+FLOAT(L+L+1)*CST1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL
+ &M2(MU+NU2,L)
+ ELSE
+ SL=SL+FLOAT(L+L+1)*CST1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H
+ &LM2(MU+NU2,L)
+ ENDIF
+ ENDDO
+ F21(1,LAMBDA1,LAMBDA1,ND)=SL*ONEOVK
+ F21(1,LAMBDA2,LAMBDA2,ND)=SL*ONEOVK
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSEIF(IB.EQ.-1) THEN
+ DO NU1=0,NUMAX1
+ DO NU2=0,NUMAX2
+ MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
+ IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
+C
+C Case MU = 0
+C
+ LAMBDA1=LBD(0,NU1)
+ LAMBDA2=LBD(0,NU2)
+ LMIN=MAX(NU1,NU2)
+ SL=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(NU2,L)=HLM1(NU2,L)
+ ENDIF
+ IF(MOD(L,2).EQ.0) THEN
+ CST2=1.0
+ ELSE
+ CST2=-1.0
+ ENDIF
+ IF(ISPEED.EQ.1) THEN
+ SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2
+ &(NU2,L)
+ ELSE
+ SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM
+ &2(NU2,L)
+ ENDIF
+ ENDDO
+ F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
+C
+C Case MU > 0
+C
+ CST1=1.
+ DO MU=1,MUMAX1
+ MUP=-MU
+ LAMBDA1_1=LBD(MUP,NU1)
+ LAMBDA1_2=LBD(-MUP,NU1)
+ LAMBDA2_1=LBD(MU,NU2)
+ LAMBDA2_2=LBD(-MU,NU2)
+ CST1=-CST1
+ LMIN=MAX(NU1,MU+NU2)
+ SL=ZEROC
+ DO L=LMIN,LMJ
+ IF(NEQUAL.EQ.1) THEN
+ HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
+ ENDIF
+ IF(MOD(L,2).EQ.0) THEN
+ CST2=CST1
+ ELSE
+ CST2=-CST1
+ ENDIF
+ IF(ISPEED.EQ.1) THEN
+ SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL
+ &M2(MU+NU2,L)
+ ELSE
+ SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H
+ &LM2(MU+NU2,L)
+ ENDIF
+ ENDDO
+ F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL*ONEOVK
+ F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL*ONEOVK
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f
new file mode 100644
index 0000000..e07d33d
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/pathop.f
@@ -0,0 +1,550 @@
+C
+C=======================================================================
+C
+ SUBROUTINE PATHOP(JPOS,JORDP,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,
+ &FREF,IJ,D,TAU)
+C
+C This subroutine calculates the contribution of a given path to
+C the scattering path operator TAU.
+C
+C Last modified : 3 Aug 2007
+C
+ USE DIM_MOD
+C
+ USE APPROX_MOD
+ USE C_RENORM_MOD
+ USE EXPFAC_MOD
+ USE EXTREM_MOD
+ USE INIT_L_MOD
+ USE INIT_J_MOD
+ USE LBD_MOD
+ USE LINLBD_MOD
+ USE OUTUNITS_MOD
+ USE PATH_MOD
+ USE PRINTP_MOD
+ USE RA_MOD
+ USE RENORM_MOD
+ USE ROT_MOD
+ USE SCATMAT_MOD , F => F21
+ USE TESTS_MOD
+ USE TLDW_MOD
+ USE TRANS_MOD
+ USE VARIA_MOD
+C
+ INTEGER JPOS(NDIF_M,3),AMU1
+C
+C
+ REAL RLMIJ(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
+C
+ COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
+ COMPLEX H(NLAMBDA_M,NLAMBDA_M)
+ COMPLEX G(NLAMBDA_M,NLAMBDA_M)
+ COMPLEX HLM01(0:NO_ST_M,0:NL_M-1),HLMIJ(0:NO_ST_M,0:NL_M-1)
+ COMPLEX SUM_NUJ_0,SUM_MUJ_0,SUM_NU1_0
+ COMPLEX SUM_NUJ_1,SUM_MUJ_1,SUM_NU1_1
+ COMPLEX SUM_NU1_2,SUM_NU1_3
+ COMPLEX RHO01,RHOIJ
+ COMPLEX RLMF_0,RLMF_1
+ COMPLEX CF,CJ,OVK
+ COMPLEX EXP_J,EXP_F,SUM_1
+ COMPLEX TL_J
+ COMPLEX COEF,ONEC,ZEROC
+C
+C
+C
+ DATA PI,XCOMP /3.141593,1.E-10/
+C
+ ZEROC=(0.,0.)
+ ONEC=(1.,0.)
+C
+ OVK=(1.,0.)/VK(JE)
+ IF(NPATHP.GT.0) THEN
+ FM1=FMIN(JORDP)
+ XMAX=0.
+ ENDIF
+ EXP_J=CEXP((0.,-1.)*(PHIIJ-PI))
+ EXP_F=CEXP((0.,1.)*PHI01)
+ JTYP=JPOS(JORDP,1)
+ ITYP=JPOS(1,1)
+ JATL=JPOS(JORDP,3)
+ IF(I_CP.EQ.0) THEN
+ LMJ=LMAX(JTYP,JE)
+ ELSE
+ LMJ=LF2
+ ENDIF
+ IF(NO.EQ.8) THEN
+ NN2=LMJ+1
+ ELSE
+ NN2=NO
+ ENDIF
+ IF(NO.GT.LF2) THEN
+ NN=LF2
+ ELSE
+ NN=NO
+ ENDIF
+C
+C NO is atom-dependent and is decreased with the rank of the scatterer
+C in the path when I_NO > 0 (except for the first scatterer ITYP for
+C which there is no such decrease)
+C
+ NO1=N_RA(ITYP)
+ IF(I_NO.EQ.0) THEN
+ IF(IJ.EQ.1) THEN
+ NOJ=N_RA(JTYP)
+ ELSE
+ NOJ=0
+ ENDIF
+ ELSE
+ IF(IJ.EQ.1) THEN
+ NOJ= MAX(N_RA(JTYP)-(JORDP-1)/I_NO,0)
+ ELSE
+ NOJ=0
+ ENDIF
+ ENDIF
+ NUMX=NO1/2
+ NUMAXJ=NOJ/2
+C
+C Calculation of the attenuation coefficients along the path
+C
+ COEF=CEX(1)*OVK
+ DO JSC=2,JORDP
+ COEF=COEF*CEXDW(JSC)
+ ENDDO
+C
+C Renormalization of the path
+C
+ IF(I_REN.GE.1) THEN
+ COEF=COEF*C_REN(JORDP)
+ write(354,*) JORDP,C_REN(JORDP)
+ ENDIF
+C
+C Call of the subroutines used for the R-A termination matrix
+C This termination matrix is now merged into PATHOP
+C
+ CALL DJMN2(-THIJ,RLMIJ,LMJ,1)
+ CALL POLHAN(ISPHER,NN,LF2,RHO01,HLM01)
+ CALL POLHAN(ISPHER,NN2,LMJ,RHOIJ,HLMIJ)
+C
+ LBD1M1=LBDM(1,1)
+ LBD1M2=LBDM(2,1)
+C
+C Calculation of the L-independent part of TAU, called H
+C
+ IF(JORDP.GE.3) THEN
+ DO JPAT=2,JORDP-1
+ LBD2M=LBDM(1,JPAT)
+ LBD3M=LBDM(2,JPAT)
+ DO LAMBDA1=1,LBD1M1
+ DO LAMBDA3=1,LBD3M
+ SUM_1=ZEROC
+ DO LAMBDA2=1,LBD2M
+ IF(JPAT.GT.2) THEN
+ SUM_1=SUM_1+H(LAMBDA2,LAMBDA1)*F(1,LAMBDA3,LAMBDA2,JPA
+ &T)
+ ELSE
+ SUM_1=SUM_1+F(1,LAMBDA2,LAMBDA1,1)*F(1,LAMBDA3,LAMBDA2
+ &,2)
+ ENDIF
+ ENDDO
+ G(LAMBDA3,LAMBDA1)=SUM_1
+ ENDDO
+ ENDDO
+ DO LAMBDA1=1,LBD1M1
+ DO LAMBDA2=1,LBD3M
+ H(LAMBDA2,LAMBDA1)=G(LAMBDA2,LAMBDA1)
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSEIF(JORDP.EQ.2) THEN
+ DO LAMBDA1=1,LBD1M1
+ DO LAMBDA2=1,LBD1M2
+ H(LAMBDA2,LAMBDA1)=F(1,LAMBDA2,LAMBDA1,1)
+ ENDDO
+ ENDDO
+ ELSEIF(JORDP.EQ.1) THEN
+ DO LAMBDA1=1,LBD1M1
+ DO LAMBDA2=1,LBD1M1
+ H(LAMBDA2,LAMBDA1)=ONEC
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Calculation of the path operator TAU
+C
+ DO LF=LF1,LF2,ISTEP_LF
+ ILF=LF*LF+LF+1
+C
+ NU1MAX1=MIN(LF,NUMX)
+C
+C Case MF = 0
+C
+ DO LJ=0,LMJ
+ ILJ=LJ*LJ+LJ+1
+ NUJMAX=MIN(LJ,NUMAXJ)
+ IF(JORDP.EQ.1) THEN
+ NU1MAX=MIN(NU1MAX1,LJ)
+ ELSE
+ NU1MAX=NU1MAX1
+ ENDIF
+C
+ IF(ISPEED.EQ.1) THEN
+ TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
+ ELSE
+ TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
+ ENDIF
+C
+C Case MJ = 0
+C
+ SUM_NU1_0=ZEROC
+C
+ DO NU1=0,NU1MAX
+ IF(JORDP.GT.1) THEN
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
+ ELSE
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
+ ENDIF
+C
+ DO MU1=-MU1MAX,MU1MAX
+ LAMBDA1=LBD(MU1,NU1)
+ AMU1=ABS(MU1)
+C
+ RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
+C
+ SUM_NUJ_0=ZEROC
+C
+ IF(JORDP.GT.1) THEN
+ DO NUJ=0,NUJMAX
+ MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
+C
+ SUM_MUJ_0=ZEROC
+C
+ DO MUJ=-MUJMAX,MUJMAX
+C
+ LAMBDAJ=LBD(MUJ,NUJ)
+C
+ SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0,L
+ &J)
+ ENDDO
+ SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
+C
+ ENDDO
+ ELSE
+ SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
+ ENDIF
+C
+ SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
+C
+ ENDDO
+C
+ ENDDO
+C
+ TAU(ILJ,ILF,JATL)=TAU(ILJ,ILF,JATL)+TL_J*SUM_NU1_0
+C
+ IF(NPATHP.EQ.0) GOTO 35
+C
+ FM2=FMAX(JORDP)
+ XINT=CABS(TL_J*SUM_NU1_0)
+ XMAX=AMAX1(XINT,XMAX)
+ FMAX(JORDP)=AMAX1(FM2,XINT)
+ IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
+ IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
+ FREF=FMAX(JORDP)
+ ENDIF
+ 35 CONTINUE
+C
+C Case MJ > 0
+C
+ CJ=ONEC
+ DO MJ=1,LJ
+ INDJ=ILJ+MJ
+ INDJP=ILJ-MJ
+ CJ=CJ*EXP_J
+C
+ SUM_NU1_0=ZEROC
+ SUM_NU1_1=ZEROC
+C
+ DO NU1=0,NU1MAX
+ IF(JORDP.GT.1) THEN
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
+ ELSE
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
+ ENDIF
+C
+ DO MU1=-MU1MAX,MU1MAX
+ LAMBDA1=LBD(MU1,NU1)
+ AMU1=ABS(MU1)
+C
+ RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
+C
+ SUM_NUJ_0=ZEROC
+ SUM_NUJ_1=ZEROC
+C
+ IF(JORDP.GT.1) THEN
+ DO NUJ=0,NUJMAX
+ MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
+C
+ SUM_MUJ_0=ZEROC
+ SUM_MUJ_1=ZEROC
+C
+ DO MUJ=-MUJMAX,MUJMAX
+C
+ LAMBDAJ=LBD(MUJ,NUJ)
+C
+ SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,-
+ &MJ,LJ)
+ SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,M
+ &J,LJ)
+C
+ ENDDO
+C
+ SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
+ SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
+C
+ ENDDO
+ ELSE
+ SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
+ SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
+ ENDIF
+C
+ SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
+ SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
+C
+ ENDDO
+C
+ ENDDO
+C
+ TAU(INDJP,ILF,JATL)=TAU(INDJP,ILF,JATL)+CONJG(CJ)*TL_J*SUM_N
+ &U1_1
+ TAU(INDJ,ILF,JATL)=TAU(INDJ,ILF,JATL)+CJ*TL_J*SUM_NU1_0
+C
+ IF(NPATHP.EQ.0) GOTO 45
+C
+ FM2=FMAX(JORDP)
+ XINT1=CABS(CJ*TL_J*SUM_NU1_0)
+ XINT2=CABS(CONJG(CJ)*TL_J*SUM_NU1_1)
+ XMAX=AMAX1(XINT1,XINT2,XMAX)
+ FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
+ IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
+ IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
+ FREF=FMAX(JORDP)
+ ENDIF
+ 45 CONTINUE
+ ENDDO
+ ENDDO
+C
+C Case MF > 0
+C
+ CF=ONEC
+ DO MF=1,LF
+ INDF=ILF+MF
+ INDFP=ILF-MF
+ CF=CF*EXP_F
+C
+ DO LJ=0,LMJ
+ ILJ=LJ*LJ+LJ+1
+ NUJMAX=MIN(LJ,NUMAXJ)
+ IF(JORDP.EQ.1) THEN
+ NU1MAX=MIN(NU1MAX1,LJ)
+ ELSE
+ NU1MAX=NU1MAX1
+ ENDIF
+C
+ IF(ISPEED.EQ.1) THEN
+ TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
+ ELSE
+ TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
+ ENDIF
+C
+C Case MJ = 0
+C
+ SUM_NU1_0=ZEROC
+ SUM_NU1_1=ZEROC
+C
+ DO NU1=0,NU1MAX
+ IF(JORDP.GT.1) THEN
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
+ ELSE
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
+ ENDIF
+C
+ DO MU1=-MU1MAX,MU1MAX
+ LAMBDA1=LBD(MU1,NU1)
+ AMU1=ABS(MU1)
+C
+ RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
+ RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
+C
+ SUM_NUJ_0=ZEROC
+C
+ IF(JORDP.GT.1) THEN
+ DO NUJ=0,NUJMAX
+ MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
+C
+ SUM_MUJ_0=ZEROC
+C
+ DO MUJ=-MUJMAX,MUJMAX
+C
+ LAMBDAJ=LBD(MUJ,NUJ)
+C
+ SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0
+ &,LJ)
+C
+ ENDDO
+C
+ SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
+C
+ ENDDO
+ ELSE
+ SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
+ ENDIF
+C
+ SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
+ SUM_NU1_1=SUM_NU1_1+RLMF_1*SUM_NUJ_0
+C
+ ENDDO
+C
+ ENDDO
+C
+ TAU(ILJ,INDF,JATL)=TAU(ILJ,INDF,JATL)+CF*TL_J*SUM_NU1_0
+ TAU(ILJ,INDFP,JATL)=TAU(ILJ,INDFP,JATL)+CONJG(CF)*TL_J*SUM_N
+ &U1_1
+C
+ IF(NPATHP.EQ.0) GOTO 25
+C
+ FM2=FMAX(JORDP)
+ XINT1=CABS(CF*TL_J*SUM_NU1_0)
+ XINT2=CABS(CONJG(CF)*TL_J*SUM_NU1_1)
+ XMAX=AMAX1(XINT1,XINT2,XMAX)
+ FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
+ IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
+ IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
+ FREF=FMAX(JORDP)
+ ENDIF
+ 25 CONTINUE
+C
+C Case MJ > 0
+C
+ CJ=ONEC
+ DO MJ=1,LJ
+ INDJ=ILJ+MJ
+ INDJP=ILJ-MJ
+ CJ=CJ*EXP_J
+C
+ SUM_NU1_0=ZEROC
+ SUM_NU1_1=ZEROC
+ SUM_NU1_2=ZEROC
+ SUM_NU1_3=ZEROC
+C
+ DO NU1=0,NU1MAX
+ IF(JORDP.GT.1) THEN
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
+ ELSE
+ MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
+ ENDIF
+C
+ DO MU1=-MU1MAX,MU1MAX
+ LAMBDA1=LBD(MU1,NU1)
+ AMU1=ABS(MU1)
+C
+ RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
+ RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
+C
+ SUM_NUJ_0=ZEROC
+ SUM_NUJ_1=ZEROC
+C
+ IF(JORDP.GT.1) THEN
+ DO NUJ=0,NUJMAX
+ MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
+C
+ SUM_MUJ_0=ZEROC
+ SUM_MUJ_1=ZEROC
+C
+ DO MUJ=-MUJMAX,MUJMAX
+C
+ LAMBDAJ=LBD(MUJ,NUJ)
+C
+ SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ
+ &,-MJ,LJ)
+ SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ
+ &,MJ,LJ)
+C
+ ENDDO
+C
+ SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
+ SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
+C
+ ENDDO
+ ELSE
+ SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
+ SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
+ ENDIF
+C
+ SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
+ SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
+ SUM_NU1_2=SUM_NU1_2+RLMF_1*SUM_NUJ_0
+ SUM_NU1_3=SUM_NU1_3+RLMF_1*SUM_NUJ_1
+C
+ ENDDO
+C
+ ENDDO
+C
+ TAU(INDJP,INDF,JATL)=TAU(INDJP,INDF,JATL)+CF*CONJG(CJ)*TL_
+ &J*SUM_NU1_1
+ TAU(INDJP,INDFP,JATL)=TAU(INDJP,INDFP,JATL)+CONJG(CF*CJ)*T
+ &L_J*SUM_NU1_3
+ TAU(INDJ,INDF,JATL)=TAU(INDJ,INDF,JATL)+CF*CJ*TL_J*SUM_NU1
+ &_0
+ TAU(INDJ,INDFP,JATL)=TAU(INDJ,INDFP,JATL)+CONJG(CF)*CJ*TL_
+ &J*SUM_NU1_2
+C
+ IF(NPATHP.EQ.0) GOTO 15
+C
+ FM2=FMAX(JORDP)
+ XINT1=CABS(CF*CJ*TL_J*SUM_NU1_0)
+ XINT2=CABS(CF*CONJG(CJ)*TL_J*SUM_NU1_1)
+ XINT3=CABS(CONJG(CF)*CJ*TL_J*SUM_NU1_2)
+ XINT4=CABS(CONJG(CF*CJ)*TL_J*SUM_NU1_3)
+ XMAX=AMAX1(XINT1,XINT2,XINT3,XINT4,XMAX)
+ FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2,XINT3,XINT4)
+ IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
+ IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
+ FREF=FMAX(JORDP)
+ ENDIF
+ 15 CONTINUE
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ IF(NPATHP.EQ.0) GOTO 16
+ FMIN(JORDP)=AMIN1(FM1,XMAX)
+ IF(XMAX.GT.FMN(NPATHP)) THEN
+ CALL LOCATE(FMN,NPATHP,XMAX,JMX)
+ DO KF=NPATHP,JMX+2,-1
+ FMN(KF)=FMN(KF-1)
+ JON(KF)=JON(KF-1)
+ PATH(KF)=PATH(KF-1)
+ DMN(KF)=DMN(KF-1)
+ DO KD=1,10
+ JPON(KF,KD)=JPON(KF-1,KD)
+ ENDDO
+ ENDDO
+ FMN(JMX+1)=XMAX
+ JON(JMX+1)=JORDP
+ PATH(JMX+1)=NPATH(JORDP)
+ DMN(JMX+1)=D
+ DO KD=1,JORDP
+ JPON(JMX+1,KD)=JPOS(KD,3)
+ ENDDO
+ ENDIF
+ IF((FMIN(JORDP)-FM1).LT.-XCOMP) NPMI(JORDP)=NPATH(JORDP)
+ IF((IPRINT.EQ.3).AND.(IJ.EQ.1)) THEN
+ WRITE(IUSCR,1) JORDP,NPATH(JORDP),XMAX,D,(JPOS(KD,3),KD=1,JORDP)
+ &
+ ENDIF
+C
+ 16 RETURN
+C
+ 1 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/phddif_se.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/phddif_se.f
new file mode 100644
index 0000000..5433418
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/phddif_se.f
@@ -0,0 +1,1306 @@
+C
+C=======================================================================
+C
+ SUBROUTINE PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,NATC
+ &LU,NFICHLEC,JFICH,NP)
+C
+C This subroutine computes the PhD formula in the spin-independent case
+C from a non spin-orbit resolved initial core state LI.
+C
+C Alternatively, it can compute the PhD amplitude for the APECS process.
+C
+C The calculation is performed using a series expansion for the
+C expression of the scattering path operator
+C
+C Last modified : 10 Jan 2016
+C
+ USE DIM_MOD
+C
+ USE ALGORITHM_MOD
+ USE AMPLI_MOD
+ USE APPROX_MOD
+ USE COOR_MOD , NTCLU => NATCLU, NTP => NATYP
+ USE C_RENORM_MOD
+ USE DEBWAL_MOD
+ USE DIRECT_MOD , RTHETA => RTHEXT
+ USE EXTREM_MOD
+ USE FIXSCAN_MOD
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE INIT_L_MOD
+ USE INIT_J_MOD
+ USE LIMAMA_MOD
+ USE LINLBD_MOD
+ USE MOYEN_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD
+ USE PATH_MOD
+ USE PRINTP_MOD
+ USE RENORM_MOD
+ USE RESEAU_MOD
+ USE SPIN_MOD
+ USE TESTPA_MOD
+ USE TESTPB_MOD
+ USE TESTS_MOD
+ USE TRANS_MOD
+ USE TYPCAL_MOD
+ USE TYPEM_MOD
+ USE TYPEXP_MOD
+ USE VALIN_MOD , PHLUM => PHILUM
+ USE VALIN_AV_MOD
+ USE VALFIN_MOD
+C
+ REAL NPATH1(0:NDIF_M),NOPA
+ REAL LUM(3),AXE(3),EPS(3),DIRLUM(3),E_PH(NE_M)
+C
+ COMPLEX IC,ONEC,ZEROC,COEF,PW(0:NDIF_M),DELTA
+ COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI
+ COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
+ COMPLEX YLMR(0:NL_M,-NL_M:NL_M),MATRIX(3,2)
+ COMPLEX YLME(0:NL_M,-NL_M:NL_M)
+ COMPLEX R2,MLFLI(2,-LI_M:LI_M,3,2,3)
+ COMPLEX SJDIR_1,SJDIR_2,SJDIF_1,SJDIF_2
+ COMPLEX RHOK(NE_M,NATM,0:18,5,NSPIN2_M),RD
+ COMPLEX SLJDIF,ATT_M,MLIL0(2,-LI_M:LI_M,6),SLF_1,SLF_2
+ COMPLEX SL0DIF,SMJDIF
+C
+ DIMENSION VAL(NATCLU_M),NATYP(NATM),DIRPOL(3,2)
+ DIMENSION EMET(3),R_L(9),COORD(3,NATCLU_M)
+ DIMENSION R(NDIF_M),XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
+ DIMENSION JPOS(NDIF_M,3),JPA(NDIF_M)
+C
+C
+C
+ CHARACTER*7 STAT
+ CHARACTER*13 OUTDATA1,OUTDATA2
+C
+C
+ CHARACTER*24 OUTFILE
+ CHARACTER*24 AMPFILE
+C
+ DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/
+ DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/
+C
+ ALGO1='SE'
+ ALGO2=' '
+ ALGO3=' '
+ ALGO4=' '
+C
+ I_DIR=0
+ NSET=1
+ JEL=1
+ OUTDATA1='CROSS-SECTION'
+ IF(I_AMP.EQ.1) THEN
+ I_MI=1
+ OUTDATA2='MS AMPLITUDES'
+ ELSE
+ I_MI=0
+ ENDIF
+C
+ IF(SPECTRO.EQ.'PHD') THEN
+ IOUT=IUO2
+ OUTFILE=OUTFILE2
+ STAT='UNKNOWN'
+ IF(I_MI.EQ.1) THEN
+ IOUT2=IUSCR2+1
+ N_DOT=1
+ DO J_CHAR=1,24
+ IF(OUTFILE(J_CHAR:J_CHAR).EQ.'.') GOTO 888
+ N_DOT=N_DOT+1
+ ENDDO
+ 888 CONTINUE
+ AMPFILE=OUTFILE(1:N_DOT)//'amp'
+ OPEN(UNIT=IOUT2, FILE=AMPFILE, STATUS=STAT)
+ ENDIF
+ ELSEIF(SPECTRO.EQ.'APC') THEN
+ IOUT=IUSCR2+1
+ OUTFILE='res/phot.amp'
+ STAT='UNKNOWN'
+ ENDIF
+C
+C Position of the light when the analyzer is along the z axis :
+C (X_LUM_Z,Y_LUM_Z,Z_LUM_Z)
+C
+ RTHLUM=THLUM*PIS180
+ RPHLUM=PHLUM*PIS180
+ X_LUM_Z=SIN(RTHLUM)*COS(RPHLUM)
+ Y_LUM_Z=SIN(RTHLUM)*SIN(RPHLUM)
+ Z_LUM_Z=COS(RTHLUM)
+C
+ IF(IMOD.EQ.0) THEN
+C
+C The analyzer is rotated
+C
+ DIRLUM(1)=X_LUM_Z
+ DIRLUM(2)=Y_LUM_Z
+ DIRLUM(3)=Z_LUM_Z
+ ELSE
+C
+C The sample is rotated ---> light and analyzer rotated
+C
+ IF(I_EXT.EQ.0) THEN
+ RTH0=THETA0*PIS180
+ RPH0=PHI0*PIS180
+ RTH=RTH0
+ RPH=RPH0
+C
+C R_L is the rotation matrix from 0z to (THETA0,PHI0) expressed as
+C a function of the Euler angles ALPHA=PHI0, BETA=THETA0, GAMMA=-PHI0
+C It is stored as (1 2 3)
+C (4 5 6)
+C (7 8 9)
+C
+ R_L(1)=COS(RTH0)*COS(RPH0)*COS(RPH0)+SIN(RPH0)*SIN(RPH0)
+ R_L(2)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
+ R_L(3)=SIN(RTH0)*COS(RPH0)
+ R_L(4)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
+ R_L(5)=COS(RTH0)*SIN(RPH0)*SIN(RPH0)+COS(RPH0)*COS(RPH0)
+ R_L(6)=SIN(RTH0)*SIN(RPH0)
+ R_L(7)=-SIN(RTH0)*COS(RPH0)
+ R_L(8)=-SIN(RTH0)*SIN(RPH0)
+ R_L(9)=COS(RTH0)
+C
+C Position of the light when the analyzer is along (THETA0,PHI0) : LUM(3)
+C
+ LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
+ LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
+ LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
+C
+ ENDIF
+ ENDIF
+C
+ IC=(0.,1.)
+ ONEC=(1.,0.)
+ ZEROC=(0.,0.)
+ NSCAT=NATCLU-1
+ ATTSE=1.
+ ATTSJ=1.
+ NPATH2(0)=1.
+ NPATH(0)=1.
+ NPMA(0)=1.
+ NPMI(0)=1.
+ ZSURF=VAL(1)
+C
+ IF((ISOM.EQ.0).OR.(JFICH.EQ.1)) THEN
+ OPEN(UNIT=IOUT, FILE=OUTFILE, STATUS=STAT)
+ ENDIF
+C
+C Writing the headers in the output file
+C
+ CALL HEADERS(IOUT)
+C
+ IF((ISOM.EQ.0).OR.((ISOM.GT.0).AND.(JFICH.EQ.1))) THEN
+ WRITE(IOUT,12) SPECTRO,OUTDATA1
+ WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IP
+ &H_1,I_EXT
+ IF(I_MI.EQ.1) THEN
+ WRITE(IOUT2,12) SPECTRO,OUTDATA2
+ WRITE(IOUT2,12) STEREO
+ WRITE(IOUT2,19) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,I
+ &E,IPH_1,I_EXT
+ WRITE(IOUT2,20) PHI0,THETA0,PHI1,THETA1,NONVOL(1)
+ ENDIF
+ ENDIF
+C
+ IF(ISOM.EQ.0) THEN
+ WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE
+ IF(I_MI.EQ.1) THEN
+ WRITE(IOUT2,79) NPLAN,NEMET,NTHETA,NPHI,NE
+ ENDIF
+ ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN
+ WRITE(IOUT,11) NTHETA,NPHI,NE
+ IF(I_MI.EQ.1) THEN
+ WRITE(IOUT2,11) NTHETA,NPHI,NE
+ ENDIF
+ ENDIF
+C
+C Construction of the linear index LAMBDA=(MU,NU)
+C
+ LAMBDA0=0
+ DO N_O=0,NO
+ NMX=N_O/2
+ DO NU=0,NMX
+ DO MU=-N_O,N_O
+ NMU=2*NU+ABS(MU)
+ IF(NMU.EQ.N_O) THEN
+ LAMBDA0=LAMBDA0+1
+ LBD(MU,NU)=LAMBDA0
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ LBDMAX=LAMBDA0
+ IJK=0
+C
+C Loop over the planes
+C
+ DO JPLAN=1,NPLAN
+ Z=VAL(JPLAN)
+ IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN
+ DZZEM=ABS(Z-ZEM)
+ IF(DZZEM.LT.SMALL) GOTO 10
+ GOTO 1
+ ENDIF
+ 10 CONTINUE
+C
+C Loop over the different absorbers in a given plane
+C
+ DO JEMET=1,NEMET
+ CALL EMETT(JEMET,IEMET,Z,SYM_AT,NATYP,EMET,NTYPEM,JNEM,*4)
+ GO TO 2
+ 4 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN
+ IF(I_TEST.NE.2) WRITE(IUO1,51) JPLAN,NTYPEM
+ ENDIF
+ GO TO 3
+ 2 IF((ABS(EMET(3)).GT.COUPUR).AND.(IBAS.EQ.1)) GOTO 5
+ IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN
+ IF(I_TEST.NE.2) THEN
+ WRITE(IUO1,52) JPLAN,EMET(1),EMET(2),EMET(3),NTYPEM
+ ENDIF
+ ENDIF
+ IF(ISOM.EQ.1) NP=JPLAN
+ ZSURFE=VAL(1)-EMET(3)
+C
+C Loop over the energies
+C
+ DO JE=1,NE
+ FMIN(0)=1.
+ FMAX(0)=1.
+ IF(NE.GT.1) THEN
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ E_PH(JE)=ELUM+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ELSEIF(NE.EQ.1) THEN
+ ECIN=E0
+ E_PH(JE)=ELUM
+ ENDIF
+ IF(I_TEST.NE.1) THEN
+ CFM=8.*PI*E_PH(JE)*FINSTRUC
+ ELSE
+ CFM=1.
+ ENDIF
+ CALL LPM(ECIN,XLPM,*6)
+ XLPM1=XLPM/A
+ IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
+ IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN
+ IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR
+ ENDIF
+ IF(ITL.EQ.0) THEN
+ VK(JE)=SQRT(ECIN+VINT)*CONV*A*(1.,0.)
+ VK2(JE)=CABS(VK(JE)*VK(JE))
+ ENDIF
+ GAMMA=1./(2.*XLPM1)
+ IF(IPOTC.EQ.0) THEN
+ VK(JE)=VK(JE)+IC*GAMMA
+ ENDIF
+ IF(I_TEST.NE.1) THEN
+ VKR=REAL(VK(JE))
+ ELSE
+ VKR=1.
+ ENDIF
+ IF(I_MI.EQ.1) THEN
+ WRITE(IOUT2,21) ECIN,VKR*CFM
+ ENDIF
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN
+ IF(IDCM.GE.1) WRITE(IUO1,22)
+ DO JAT=1,N_PROT
+ IF(IDCM.EQ.0) THEN
+ XK2UJ2=VK2(JE)*UJ2(JAT)
+ ELSE
+ XK2UJ2=VK2(JE)*UJ_SQ(JAT)
+ WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
+ ENDIF
+ CALL DWSPH(JAT,JE,XK2UJ2,TLT,ISPEED)
+ DO LAT=0,LMAX(JAT,JE)
+ TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
+ ENDDO
+ ENDDO
+ ENDIF
+ IF(ABS(I_EXT).GE.1) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,13) I_DIR,NSET,N_DUM1
+ READ(IUI6,14) I_DUM1,N_DUM2,N_DUM3
+ ENDIF
+C
+C Initialization of TAU(INDJ,LINFMAX,JTYP)
+C
+ JATL=0
+ DO JTYP=1,N_PROT
+ NBTYP=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYP
+ JATL=JATL+1
+ DO LF=LF1,LF2,ISTEP_LF
+ ILF=LF*LF+LF+1
+ DO MF=-LF,LF
+ INDF=ILF+MF
+ DO LJ=0,LMJ
+ ILJ=LJ*LJ+LJ+1
+ DO MJ=-LJ,LJ
+ INDJ=ILJ+MJ
+ TAU(INDJ,INDF,JATL)=ZEROC
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Storage of the coupling matrix elements MLFLI along the basis
+C directions X,Y ET Z
+C
+C These basis directions refer to the polarization if IDICHR = 0
+C but to the light when IDICHR = 1
+C
+C JBASE = 1 : X
+C JBASE = 2 : Y
+C JBASE = 3 : Z
+C
+ DO MI=-LI,LI
+ DO LF=LF1,LF2,ISTEP_LF
+ LR=1+(1+LF-LI)/2
+ DELTA=DLT(JE,NTYPEM,NNL,LR)
+ RD=RHOK(JE,NTYPEM,NNL,LR,1)
+ DO MF=-LF,LF
+ IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 333
+ IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 333
+ MR=2+MF-MI
+ CALL COUMAT(ITL,MI,LF,MF,DELTA,RD,MATRIX)
+ DO JBASE=1,3
+ MLFLI(1,MI,MR,LR,JBASE)=MATRIX(JBASE,1)
+ IF(IDICHR.GE.1) THEN
+ MLFLI(2,MI,MR,LR,JBASE)=MATRIX(JBASE,2)
+ ENDIF
+ ENDDO
+ 333 CONTINUE
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Calculation of the scattering path operator TAU
+C
+ IF(I_TEST.EQ.2) GOTO 666
+ PW(0)=ONEC
+ PW(1)=ONEC
+ ND=0
+ TH01=0.
+ PHI01=0.
+ RHO01=ZEROC
+ THMI=0.
+ PHMI=0.
+ RHOMI=ZEROC
+ JATLEM=JNEM
+ IF(NTYPEM.GT.1) THEN
+ DO JAEM=NTYPEM-1,1,-1
+ JATLEM=JATLEM+NATYP(JAEM)
+ ENDDO
+ ENDIF
+ DO JD=1,NDIF
+ NPATH2(JD)=0.
+ NPATH(JD)=0.
+ IT(JD)=0
+ IN(JD)=0
+ FMIN(JD)=1.E+20
+ FMAX(JD)=0.
+ ENDDO
+ NTHOF=0
+C
+C Calculation of the maximal intensity for the paths of order NCUT
+C (plane waves). This will be taken as a reference for the IPW filter.
+C
+ IF(IPW.EQ.1) THEN
+ NDIFOLD=NDIF
+ NOOLD=NO
+ ISPHEROLD=ISPHER
+ NDIF=NCUT
+ NO=0
+ ISPHER=0
+ IREF=1
+ IPW=0
+ IJ=0
+ DIJ=0.
+ FREF=0.
+ CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PH
+ &MI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+ NDIF=NDIFOLD
+ NO=NOOLD
+ ISPHER=ISPHEROLD
+ PW(0)=ONEC
+ PW(1)=ONEC
+ IPW=1
+ ND=0
+ TH01=0.
+ PHI01=0.
+ RHO01=ZEROC
+ THMI=0.
+ PHMI=0.
+ RHOMI=ZEROC
+ JATLEM=JNEM
+ IF(NTYPEM.GT.1) THEN
+ DO JAEM=NTYPEM-1,1,-1
+ JATLEM=JATLEM+NATYP(JAEM)
+ ENDDO
+ ENDIF
+ DO JD=1,NDIF
+ NPATH2(JD)=0.
+ NPATH(JD)=0.
+ IT(JD)=0
+ IN(JD)=0
+ FMIN(JD)=1.E+20
+ FMAX(JD)=0.
+ ENDDO
+ NTHOF=0
+C
+C New initialization of TAU(INDJ,INDF,JATL) after the PW calculation
+C
+ JATL=0
+ DO JTYP=1,N_PROT
+ NBTYP=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYP
+ JATL=JATL+1
+ DO LF=LF1,LF2,ISTEP_LF
+ ILF=LF*LF+LF+1
+ DO MF=-LF,LF
+ INDF=ILF+MF
+ DO LJ=0,LMJ
+ ILJ=LJ*LJ+LJ+1
+ DO MJ=-LJ,LJ
+ INDJ=ILJ+MJ
+ TAU(INDJ,INDF,JATL)=ZEROC
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C Generation and print-out of the paths
+C
+ IF (NPATHP.GT.0) THEN
+ DO JP=1,NPATHP-1
+ FMN(JP)=0.
+ PATH(JP)=0.
+ JON(JP)=0
+ ENDDO
+ FMN(NPATHP)=-1.
+ PATH(NPATHP)=0.
+ JON(NPATHP)=0
+ ENDIF
+ IREF=0
+ IJ=1
+ IF(IPRINT.EQ.3) THEN
+ OPEN(UNIT=IUSCR, STATUS='SCRATCH')
+ ENDIF
+ DIJ=0.
+ CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHMI
+ &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
+ IF(NPATHP.EQ.0) GOTO 15
+ IF(NSCAT.GT.1) THEN
+ XPATOT=REAL((DFLOAT(NSCAT)**DFLOAT(NDIF+1) -1.D0)/DFLOAT(NSCA
+ &T-1))
+ ELSE
+ XPATOT=FLOAT(NDIF+1)
+ ENDIF
+ IF(XPATOT.LT.2.14748E+09) THEN
+ NPATOT=INT(XPATOT)
+ IF(NPATOT.LT.NPATHP) NPATHP=NPATOT-1
+ ENDIF
+ WRITE(IUO1,84) NPATHP
+ WRITE(IUO1,81)
+ DO JPT=1,NPATHP
+ IF(PATH(NPATHP).GT.2.14E+09) THEN
+ WRITE(IUO1,82) JPT,JON(JPT),PATH(JPT),FMN(JPT),DMN(JPT),JNE
+ &M,(JPON(JPT,KD),KD=1,JON(JPT))
+ ELSE
+ WRITE(IUO1,83) JPT,JON(JPT),INT(PATH(JPT)),FMN(JPT),DMN(JPT
+ &),JNEM,(JPON(JPT,KD),KD=1,JON(JPT))
+ ENDIF
+ ENDDO
+ IF(IPRINT.EQ.3) THEN
+ IF(XPATOT.GT.2.14748E+09) GOTO 172
+ WRITE(IUO1,85)
+ WRITE(IUO1,71)
+ NPATOT=INT(XPATOT)
+ DO JOP=0,NDIF
+ IF(JOP.EQ.0) THEN
+ XINT0=FMAX(0)
+ DIST0=0.
+ WRITE(IUO1,70) JOP,JOP+1,XINT0,DIST0,JNEM
+ GOTO 75
+ ENDIF
+ WRITE(IUO1,77)
+ DO JLINE=1,NPATOT-1
+ READ(IUSCR,69,ERR=75,END=75) JOPA,NOPA,XMAX,DIST0,(JPA(KD
+ &),KD=1,JOPA)
+ IF(JOPA.EQ.JOP) THEN
+ IF(NOPA.GT.2.14E+09) THEN
+ WRITE(IUO1,76) JOPA,NOPA,XMAX,DIST0,JNEM,(JPA(KD),KD=1
+ &,JOPA)
+ ELSE
+ WRITE(IUO1,70) JOPA,INT(NOPA),XMAX,DIST0,JNEM,(JPA(KD)
+ &,KD=1,JOPA)
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(JOP.EQ.NDIF) WRITE(IUO1,80)
+ 75 REWIND IUSCR
+ ENDDO
+ GOTO 73
+ 172 WRITE(IUO1,74)
+ CLOSE(IUSCR,STATUS='DELETE')
+ 73 ENDIF
+ DO JD=0,NDIF
+ NPATH1(JD)=REAL(DFLOAT(NSCAT)**DFLOAT(JD))
+ IF(NPATH1(JD).GT.2.14E+09) THEN
+ IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
+ WRITE(IUO1,53) JD,NPATH1(JD),NPATH2(JD),FMIN(JD),NPMI(JD),F
+ &MAX(JD),NPMA(JD)
+ IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
+ ELSE
+ IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
+ WRITE(IUO1,58) JD,INT(NPATH1(JD)+0.1),INT(NPATH2(JD)+0.1),F
+ &MIN(JD),INT(NPMI(JD)+0.1),FMAX(JD),INT(NPMA(JD)+0.1)
+ IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
+ ENDIF
+ ENDDO
+ 666 CONTINUE
+C
+C Calculation of the Photoelectron Diffraction formula
+C
+C
+C Loop over the 'fixed' angle
+C
+ 15 DO J_FIXED=1,N_FIXED
+ IF(N_FIXED.GT.1) THEN
+ IF(I_EXT.EQ.0) THEN
+ FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
+ XINCRF=FLOAT(J_FIXED-1)*FIX_STEP
+ ELSE
+ XINCRF=0.
+ ENDIF
+ ELSEIF(N_FIXED.EQ.1) THEN
+ XINCRF=0.
+ ENDIF
+ IF(ABS(I_EXT).GE.1) THEN
+ READ(IUI6,86) JSET,JLINE,THD,PHD
+ IF(I_EXT.EQ.-1) BACKSPACE IUI6
+ THETA0=THD
+ PHI0=PHD
+ ENDIF
+ IF(IPH_1.EQ.1) THEN
+ IF(I_EXT.EQ.0) THEN
+ DPHI=PHI0+XINCRF
+ ELSE
+ DPHI=PHD
+ ENDIF
+ RPHI=DPHI*PIS180
+ IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
+ ELSE
+ ISAUT=0
+ IF(I_EXT.EQ.0) THEN
+ DTHETA=THETA0+XINCRF
+ ELSE
+ DTHETA=THD
+ ENDIF
+ RTHETA=DTHETA*PIS180
+ IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
+ IF(I_EXT.GE.1) ISAUT=0
+ IF(I_TEST.EQ.2) ISAUT=0
+ IF(ISAUT.GT.0) GOTO 8
+ IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
+ IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
+ IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
+C
+C THETA-dependent number of PHI points for stereographic
+C representation (to obtain a uniform sampling density).
+C (Courtesy of J. Osterwalder - University of Zurich)
+C
+ IF(STEREO.EQ.'YES') THEN
+ N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+SMALL)+1
+ ENDIF
+C
+ ENDIF
+ IF((N_FIXED.GT.1).AND.(IMOD.EQ.1)) THEN
+C
+C When there are several sets of scans (N_FIXED > 1),
+C the initial position LUM of the light is recalculated
+C for each initial position (RTH,RPH) of the analyzer
+C
+ IF(IPH_1.EQ.1) THEN
+ RTH=THETA0*PIS180
+ RPH=RPHI
+ ELSE
+ RTH=RTHETA
+ RPH=PHI0*PIS180
+ ENDIF
+C
+ R_L(1)=COS(RTH)*COS(RPH)
+ R_L(2)=-SIN(RPH)
+ R_L(3)=SIN(RTH)*COS(RPH)
+ R_L(4)=COS(RTH)*SIN(RPH)
+ R_L(5)=COS(RPH)
+ R_L(6)=SIN(RTH)*SIN(RPH)
+ R_L(7)=-SIN(RTH)
+ R_L(8)=0.
+ R_L(9)=COS(RTH)
+C
+ LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
+ LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
+ LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
+ ENDIF
+C
+C Loop over the scanned angle
+C
+ DO J_SCAN=1,N_SCAN
+ IF(N_SCAN.GT.1) THEN
+ XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1)
+ ELSEIF(N_SCAN.EQ.1) THEN
+ XINCRS=0.
+ ENDIF
+ IF(I_EXT.EQ.-1) THEN
+ READ(IUI6,86) JSET,JLINE,THD,PHD
+ BACKSPACE IUI6
+ ENDIF
+ IF(IPH_1.EQ.1) THEN
+ ISAUT=0
+ IF(I_EXT.EQ.0) THEN
+ DTHETA=THETA0+XINCRS
+ ELSE
+ DTHETA=THD
+ ENDIF
+ RTHETA=DTHETA*PIS180
+ IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
+ IF(I_EXT.GE.1) ISAUT=0
+ IF(I_TEST.EQ.2) ISAUT=0
+ IF(ISAUT.GT.0) GOTO 8
+ IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
+ IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
+ IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
+ ELSE
+ IF(I_EXT.EQ.0) THEN
+ DPHI=PHI0+XINCRS
+ ELSE
+ DPHI=PHD
+ ENDIF
+ RPHI=DPHI*PIS180
+ IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
+ ENDIF
+C
+C Loop over the sets of directions to average over (for gaussian average)
+C
+C
+ SSETDIR_1=0.
+ SSETDIF_1=0.
+ SSETDIR_2=0.
+ SSETDIF_2=0.
+C
+ SSET2DIR_1=0.
+ SSET2DIF_1=0.
+ SSET2DIR_2=0.
+ SSET2DIF_2=0.
+C
+ IF(I_EXT.EQ.-1) THEN
+ JREF=INT(NSET)/2+1
+ ELSE
+ JREF=1
+ ENDIF
+C
+ DO J_SET=1,NSET
+ IF(I_EXT.EQ.-1) THEN
+ READ(IUI6,86) JSET,JLINE,THD,PHD,W
+ DTHETA=THD
+ DPHI=PHD
+ RTHETA=DTHETA*PIS180
+ RPHI=DPHI*PIS180
+C
+C Here, there are several sets of scans (NSET > 1), so
+C the initial position LUM of the light must be
+C recalculated for each initial position of the analyzer
+C
+ RTH=TH_0(J_SET)*PIS180
+ RPH=PH_0(J_SET)*PIS180
+C
+ IF(IMOD.EQ.1) THEN
+ R_L(1)=COS(RTH)*COS(RPH)
+ R_L(2)=-SIN(RPH)
+ R_L(3)=SIN(RTH)*COS(RPH)
+ R_L(4)=COS(RTH)*SIN(RPH)
+ R_L(5)=COS(RPH)
+ R_L(6)=SIN(RTH)*SIN(RPH)
+ R_L(7)=-SIN(RTH)
+ R_L(8)=0.
+ R_L(9)=COS(RTH)
+C
+ LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
+ LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
+ LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
+C
+ ENDIF
+ ELSE
+ W=1.
+ ENDIF
+C
+ IF(I_EXT.EQ.-1) PRINT 89
+C
+ CALL DIRAN(VINT,ECIN,JEL)
+C
+ IF(J_SET.EQ.JREF) THEN
+ DTHETAP=DTHETA
+ DPHIP=DPHI
+ ENDIF
+C
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO1,88) DTHETA,DPHI
+ ENDIF
+C
+C .......... Case IMOD=1 only ..........
+C
+C Calculation of the position of the light when the analyzer is at
+C (THETA,PHI). DIRLUM is the direction of the light and its initial
+C value (at (THETA0,PHI0)) is LUM. AXE is the direction of the theta
+C rotation axis and EPS is defined so that (AXE,DIRLUM,EPS) is a
+C direct orthonormal basis. The transform of a vector R by a rotation
+C of OMEGA about AXE is then given by
+C
+C R' = R COS(OMEGA) + (AXE.R)(1-COS(OMEGA)) AXE + (AXE^R) SIN(OMEGA)
+C
+C Here, DIRANA is the internal direction of the analyzer and ANADIR
+C its external position
+C
+C Note that when the initial position of the analyzer is (RTH,RPH)
+C which coincides with (RTH0,RPH0) only for the first fixed angle
+C
+ IF(IMOD.EQ.1) THEN
+ IF(ITHETA.EQ.1) THEN
+ AXE(1)=-SIN(RPH)
+ AXE(2)=COS(RPH)
+ AXE(3)=0.
+ RANGLE=RTHETA-RTH
+ ELSEIF(IPHI.EQ.1) THEN
+ AXE(1)=0.
+ AXE(2)=0.
+ AXE(3)=1.
+ RANGLE=RPHI-RPH
+ ENDIF
+ CALL PRVECT(AXE,LUM,EPS,CVECT)
+ PRS=PRSCAL(AXE,LUM)
+ IF(J_SCAN.EQ.1) THEN
+ DIRLUM(1)=LUM(1)
+ DIRLUM(2)=LUM(2)
+ DIRLUM(3)=LUM(3)
+ ELSE
+ DIRLUM(1)=LUM(1)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(1)+
+ &SIN(RANGLE)*EPS(1)
+ DIRLUM(2)=LUM(2)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(2)+
+ &SIN(RANGLE)*EPS(2)
+ DIRLUM(3)=LUM(3)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(3)+
+ &SIN(RANGLE)*EPS(3)
+ ENDIF
+ ENDIF
+ IF(DIRLUM(3).GT.1.) DIRLUM(3)=1.
+ IF(DIRLUM(3).LT.-1.) DIRLUM(3)=-1.
+ THETALUM=ACOS(DIRLUM(3))
+ IF(I_TEST.EQ.2) THETALUM=-THETALUM
+ COEF=DIRLUM(1)+IC*DIRLUM(2)
+ CALL ARCSIN(COEF,DIRLUM(3),PHILUM)
+ ANALUM=ANADIR(1,1)*DIRLUM(1) + ANADIR(2,1)*DIRLUM(2) +ANADIR(
+ &3,1)*DIRLUM(3)
+C
+ SEPSDIR_1=0.
+ SEPSDIF_1=0.
+ SEPSDIR_2=0.
+ SEPSDIF_2=0.
+C
+C Loop over the directions of polarization
+C
+ DO JEPS=1,NEPS
+ IF((JEPS.EQ.1).AND.(IPOL.GE.0)) THEN
+ DIRPOL(1,JEPS)=COS(THETALUM)*COS(PHILUM)
+ DIRPOL(2,JEPS)=COS(THETALUM)*SIN(PHILUM)
+ DIRPOL(3,JEPS)=-SIN(THETALUM)
+ ELSE
+ DIRPOL(1,JEPS)=-SIN(PHILUM)
+ DIRPOL(2,JEPS)=COS(PHILUM)
+ DIRPOL(3,JEPS)=0.
+ ENDIF
+ IF(ABS(IPOL).EQ.1) THEN
+ IF(IPRINT.GT.0) THEN
+ WRITE(IUO1,61) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),
+ & (DIRPOL(K,1),K=1,3),ANALUM
+ ENDIF
+ ELSE
+ IF((JEPS.EQ.1).AND.(IPRINT.GT.0)) THEN
+ WRITE(IUO1,63) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),ANA
+ &LUM
+ ENDIF
+ ENDIF
+ IF((JEPS.EQ.1).AND.(I_EXT.EQ.-1)) PRINT 89
+C
+C Calculation of the coupling matrix MLIL0
+C
+ DO MI=-LI,LI
+ DO LF=LF1,LF2,ISTEP_LF
+ LR=1+(1+LF-LI)/2
+ LRR=3*(LR-1)
+ DO MF=-LF,LF
+ MR=2+MF-MI
+ IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 777
+ IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 777
+ LMR=LRR+MR
+ IF(IDICHR.EQ.0) THEN
+ IF(I_TEST.NE.1) THEN
+ MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRPOL(1,JEPS)
+ & +MLFLI(1,MI,MR,LR,2)*DIRPOL(2,JEPS) +MLFLI(1,MI,MR,LR,3)*DIRPOL(3
+ &,JEPS)
+ ELSE
+ MLIL0(1,MI,LMR)=ONEC
+ ENDIF
+ ELSEIF(IDICHR.GE.1) THEN
+ IF(I_TEST.NE.1) THEN
+ MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRLUM(1) +MLF
+ &LI(1,MI,MR,LR,2)*DIRLUM(2) +MLFLI(1,MI,MR,LR,3)*DIRLUM(3)
+ MLIL0(2,MI,LMR)=MLFLI(2,MI,MR,LR,1)*DIRLUM(1) +MLF
+ &LI(2,MI,MR,LR,2)*DIRLUM(2) +MLFLI(2,MI,MR,LR,3)*DIRLUM(3)
+ ELSE
+ MLIL0(1,MI,LMR)=ONEC
+ ENDIF
+ ENDIF
+ 777 CONTINUE
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ SRDIF_1=0.
+ SRDIR_1=0.
+ SRDIF_2=0.
+ SRDIR_2=0.
+C
+C Loop over the different directions of the analyzer contained in a cone
+C
+ DO JDIR=1,NDIR
+ IF(IATTS.EQ.1) THEN
+ ATTSE=EXP(-ZSURFE*GAMMA/DIRANA(3,JDIR))
+ ENDIF
+C
+ SMIDIR_1=0.
+ SMIDIF_1=0.
+ SMIDIR_2=0.
+ SMIDIF_2=0.
+C
+C Loop over the equiprobable azimuthal quantum numbers MI corresponding
+C to the initial state LI
+C
+ LME=LMAX(1,JE)
+ CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME)
+ DO MI=-LI,LI
+ SJDIR_1=ZEROC
+ SJDIF_1=ZEROC
+ SJDIR_2=ZEROC
+ SJDIF_2=ZEROC
+C
+C Calculation of the direct emission (used a a reference for the
+C output), which is not contained in the calculation of TAU
+C
+ DO LF=LF1,LF2,ISTEP_LF
+ LR=1+(1+LF-LI)/2
+ LRR=3*(LR-1)
+ ILF=LF*LF+LF+1
+ IF(ISPEED.EQ.1) THEN
+ R2=TL(LF,1,1,JE)
+ ELSE
+ R2=TLT(LF,1,1,JE)
+ ENDIF
+ IF(I_REN.GE.1) R2=R2*C_REN(0)
+ DO MF=-LF,LF
+ MR=2+MF-MI
+ LMR=LRR+MR
+ INDF=ILF+MF
+ IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 444
+ IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 444
+ SJDIR_1=SJDIR_1+YLME(LF,MF)*ATTSE*MLIL0(1,MI,LMR)*R2
+ IF(IDICHR.GE.1) THEN
+ SJDIR_2=SJDIR_2+YLME(LF,MF)*ATTSE*MLIL0(2,MI,LMR)*R2
+ &
+ ENDIF
+C
+C Contribution of the absorber to TAU (initialization of SJDIF)
+C
+ IF(I_TEST.EQ.2) GOTO 444
+ SL0DIF=ZEROC
+ DO L0=0,LME
+ IL0=L0*L0+L0+1
+ SL0DIF=SL0DIF+YLME(L0,0)*TAU(IL0,INDF,1)
+ DO M0=1,L0
+ IND01=IL0+M0
+ IND02=IL0-M0
+ SL0DIF=SL0DIF+(YLME(L0,M0)*TAU(IND01,INDF,1)+YLME(L
+ &0,-M0)*TAU(IND02,INDF,1))
+ ENDDO
+ ENDDO
+ SJDIF_1=SJDIF_1+SL0DIF*MLIL0(1,MI,LMR)
+ IF(IDICHR.GE.1) THEN
+ SJDIF_2=SJDIF_2+SL0DIF*MLIL0(2,MI,LMR)
+ ENDIF
+ 444 CONTINUE
+ ENDDO
+ ENDDO
+ SJDIF_1=SJDIF_1*ATTSE
+ IF(IDICHR.GE.1) THEN
+ SJDIF_2=SJDIF_2*ATTSE
+ ENDIF
+C
+C Loop over the last atom J encountered by the photoelectron
+C before escaping the solid
+C
+ IF(I_TEST.EQ.2) GOTO 111
+ DO JTYP=2,N_PROT
+ NBTYP=NATYP(JTYP)
+ LMJ=LMAX(JTYP,JE)
+ DO JNUM=1,NBTYP
+ JATL=NCORR(JNUM,JTYP)
+ XOJ=SYM_AT(1,JATL)-EMET(1)
+ YOJ=SYM_AT(2,JATL)-EMET(2)
+ ZOJ=SYM_AT(3,JATL)-EMET(3)
+ ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ)
+ ZSURFJ=VAL(1)-SYM_AT(3,JATL)
+ CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLMR,LMJ)
+ IF(IATTS.EQ.1) THEN
+ ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR))
+ ENDIF
+ CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+ZOJ*DIRANA
+ &(3,JDIR))/ROJ
+ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78
+ CTROIS1=ZOJ/ROJ
+ IF(CTROIS1.GT.1.) THEN
+ CTROIS1=1.
+ ELSEIF(CTROIS1.LT.-1.) THEN
+ CTROIS1=-1.
+ ENDIF
+ IF(IDCM.GE.1) THEN
+ UJ2(JTYP)=UJ_SQ(JTYP)
+ ENDIF
+ IF(ABS(ZSURFJ).LE.SMALL) THEN
+ IF(ABS(CSTHJR-1.).GT.SMALL) THEN
+ CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)*(DIRANA(3,JDIR)-CTRO
+ &IS1)/(2.-2.*CSTHJR)
+ ELSE
+ CSKZ2J=1.
+ ENDIF
+ UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
+ ELSE
+ UJJ=UJ2(JTYP)
+ ENDIF
+ IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
+ XK2UJ2=VK2(JE)*UJJ
+ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
+ ENDIF
+ 78 IF(IDWSPH.EQ.1) THEN
+ DWTER=1.
+ ELSE
+ DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR))
+ ENDIF
+ IF(JATL.EQ.JATLEM) THEN
+ ATT_M=ATTSE*DWTER
+ ELSE
+ ATT_M=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*CSTHJR)
+ ENDIF
+C
+ SLF_1=ZEROC
+ SLF_2=ZEROC
+ DO LF=LF1,LF2,ISTEP_LF
+ LR=1+(1+LF-LI)/2
+ LRR=3*(LR-1)
+ ILF=LF*LF+LF+1
+ DO MF=-LF,LF
+ MR=2+MF-MI
+ INDF=ILF+MF
+ IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 555
+ IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 555
+ LMR=LRR+MR
+ SLJDIF=ZEROC
+ DO LJ=0,LMJ
+ ILJ=LJ*LJ+LJ+1
+ SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDF,JATL)
+ IF(LJ.GT.0) THEN
+ DO MJ=1,LJ
+ INDJ1=ILJ+MJ
+ INDJ2=ILJ-MJ
+ SMJDIF=SMJDIF+(YLMR(LJ,MJ)*TAU(INDJ1,INDF,JATL)+YL
+ &MR(LJ,-MJ)*TAU(INDJ2,INDF,JATL))
+ ENDDO
+ ENDIF
+ SLJDIF=SLJDIF+SMJDIF
+ ENDDO
+ SLF_1=SLF_1+SLJDIF*MLIL0(1,MI,LMR)
+ IF(IDICHR.GE.1) THEN
+ SLF_2=SLF_2+SLJDIF*MLIL0(2,MI,LMR)
+ ENDIF
+ 555 CONTINUE
+ ENDDO
+ ENDDO
+ SJDIF_1=SJDIF_1+SLF_1*ATT_M
+ IF(IDICHR.GE.1) THEN
+ SJDIF_2=SJDIF_2+SLF_2*ATT_M
+ ENDIF
+C
+C End of the loops over the last atom J
+C
+ ENDDO
+ ENDDO
+C
+C Writing the amplitudes in file IOUT for APECS, or
+C in file IOUT2 for PhD (orientated orbitals' case)
+C
+ 111 IF(SPECTRO.EQ.'APC') THEN
+ WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEPS,
+ &JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1
+ IF(IDICHR.GE.1) THEN
+ WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEP
+ &S,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2
+ ENDIF
+ ELSE
+ IF(I_MI.EQ.1) THEN
+ WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JE
+ &PS,JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1
+ IF(IDICHR.GE.1) THEN
+ WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,
+ &JEPS,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2
+ ENDIF
+ ENDIF
+C
+C Computing the square modulus
+C
+ SMIDIF_1=SMIDIF_1+CABS(SJDIR_1+SJDIF_1)*CABS(SJDIR_1+SJD
+ &IF_1)
+ SMIDIR_1=SMIDIR_1+CABS(SJDIR_1)*CABS(SJDIR_1)
+ IF(IDICHR.GE.1) THEN
+ SMIDIF_2=SMIDIF_2+CABS(SJDIR_2+SJDIF_2)*CABS(SJDIR_2+S
+ &JDIF_2)
+ SMIDIR_2=SMIDIR_2+CABS(SJDIR_2)*CABS(SJDIR_2)
+ ENDIF
+ ENDIF
+C
+C End of the loop over MI
+C
+ ENDDO
+C
+ IF(SPECTRO.EQ.'APC') GOTO 220
+ SRDIR_1=SRDIR_1+SMIDIR_1
+ SRDIF_1=SRDIF_1+SMIDIF_1
+ IF(IDICHR.GE.1) THEN
+ SRDIR_2=SRDIR_2+SMIDIR_2
+ SRDIF_2=SRDIF_2+SMIDIF_2
+ ENDIF
+ 220 CONTINUE
+C
+C End of the loop on the directions of the analyzer
+C
+ ENDDO
+C
+ IF(SPECTRO.EQ.'APC') GOTO 221
+ SEPSDIF_1=SEPSDIF_1+SRDIF_1*VKR*CFM/NDIR
+ SEPSDIR_1=SEPSDIR_1+SRDIR_1*VKR*CFM/NDIR
+ IF(IDICHR.GE.1) THEN
+ SEPSDIF_2=SEPSDIF_2+SRDIF_2*VKR*CFM/NDIR
+ SEPSDIR_2=SEPSDIR_2+SRDIR_2*VKR*CFM/NDIR
+ ENDIF
+ 221 CONTINUE
+C
+C End of the loop on the polarization
+C
+ ENDDO
+C
+ SSETDIR_1=SSETDIR_1+SEPSDIR_1*W
+ SSETDIF_1=SSETDIF_1+SEPSDIF_1*W
+ IF(ICHKDIR.EQ.2) THEN
+ IF(JSET.EQ.JREF) THEN
+ SSET2DIR_1=SEPSDIR_1
+ SSET2DIF_1=SEPSDIF_1
+ ENDIF
+ ENDIF
+ IF(IDICHR.GE.1) THEN
+ SSETDIR_2=SSETDIR_2+SEPSDIR_2*W
+ SSETDIF_2=SSETDIF_2+SEPSDIF_2*W
+ IF(ICHKDIR.EQ.2) THEN
+ IF(JSET.EQ.JREF) THEN
+ SSET2DIR_2=SEPSDIR_2
+ SSET2DIF_2=SEPSDIF_2
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C End of the loop on the set averaging
+C
+ ENDDO
+C
+ IF(SPECTRO.EQ.'APC') GOTO 222
+ IF(IDICHR.EQ.0) THEN
+ IF(ISOM.EQ.2) THEN
+ WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
+ &ETDIF_1
+ IF(ICHKDIR.EQ.2) THEN
+ WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
+ &SSET2DIF_1
+ ENDIF
+ ELSE
+ WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
+ &ETDIF_1
+ IF(ICHKDIR.EQ.2) THEN
+ WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
+ &SSET2DIF_1
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ISOM.EQ.2) THEN
+ WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
+ &ETDIF_1,SSETDIR_2,SSETDIF_2
+ IF(ICHKDIR.EQ.2) THEN
+ WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
+ &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2
+ ENDIF
+ ELSE
+ WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
+ &ETDIF_1,SSETDIR_2,SSETDIF_2
+ IF(ICHKDIR.EQ.2) THEN
+ WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
+ &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2
+ ENDIF
+ ENDIF
+ ENDIF
+ 222 CONTINUE
+C
+C End of the loop on the scanned angle
+C
+ ENDDO
+C
+ 8 CONTINUE
+C
+C End of the loop on the fixed angle
+C
+ ENDDO
+C
+C End of the loop on the energy
+C
+ CLOSE(IUI6)
+ ENDDO
+C
+ 3 CONTINUE
+C
+C End of the loop on the emitters
+C
+ ENDDO
+C
+ GO TO 1
+ 5 IPLAN=JPLAN-1
+ IJK=IJK+1
+ IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN
+ IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN
+ ENDIF
+ 1 CONTINUE
+C
+C End of the loop on the planes
+C
+ ENDDO
+C
+ IF(ABS(I_EXT).GE.1) CLOSE(IUI6)
+ IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*)
+ IF(SPECTRO.EQ.'APC') CLOSE(IOUT)
+ IF(SPECTRO.EQ.'APC') GOTO 7
+c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN
+ IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN
+ NP=0
+ CALL TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
+ ENDIF
+ IF(I_EXT.EQ.2) THEN
+ CALL WEIGHT_SUM(ISOM,I_EXT,0,1)
+ ENDIF
+ GOTO 7
+ 6 WRITE(IUO1,55)
+C
+ 9 FORMAT(9(2X,I1),2X,I2)
+ 11 FORMAT(I4,2X,I4,2X,I4)
+ 12 FORMAT(2X,A3,11X,A13)
+ 13 FORMAT(6X,I1,1X,I3,2X,I4)
+ 14 FORMAT(6X,I1,1X,I3,3X,I3)
+ 19 FORMAT(2(2X,I1),1X,I2,6(2X,I1),2X,I2)
+ 20 FORMAT(2(5X,F6.2,2X,F6.2),2X,I1)
+ 21 FORMAT(10X,E12.6,3X,E12.6)
+ 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,2
+ &5X,' BY DEBYE UNCORRELATED MODEL:',/)
+ 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
+ 51 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' DOES NOT CONTAIN ',
+ *'ANY ABSORBER OF TYPE ',I2,' *******')
+ 52 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' POSITION OF ','THE AB
+ &SORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X,'******* ',19X
+ &,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******')
+ 53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1,/,
+ &10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1,/,10X,' MINIMAL INTENS
+ &ITY : ',E12.6,2X,'No OF THE PATH : ',F15.1,
+ & /,10X,' MAXIMAL INTENSITY : ',E12.6,2X,'No OF T
+ &HE PATH : ',F15.1)
+ 54 FORMAT(//,7X,'DUE TO THE SIZE OF THE CLUSTER, THE SUMMATION',
+ *' HAS BEEN TRUNCATED TO THE ',I2,' TH PLANE')
+ 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
+ *'AVAILABLE >>>>>>>>>>')
+ 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
+ *'MEAN FREE PATH = ',F6.3,' * A',//)
+ 57 FORMAT(25X,'CLUSTER RADIUS = ',F6.3,' *A')
+ 58 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',I10,/,10
+ &X,' EFFECTIVE NUMBER OF PATHS : ',I10, /,10X,' MI
+ &NIMAL INTENSITY : ',E12.6,2X,'No OF THE PATH : ',I10,
+ & /,10X,' MAXIMAL INTENSITY : ',E12.6,
+ & 2X,'No OF THE PATH : ',I10)
+ 59 FORMAT(//,15X,'THE SCATTERING DIRECTION IS GIVEN INSIDE ',
+ *'THE CRYSTAL')
+ 60 FORMAT(7X,'THE POSITIONS OF THE ATOMS ARE GIVEN WITH RESPECT ',
+ *'TO THE ABSORBER')
+ 61 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6.
+ &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI
+ &GHT ', ' : (',F6.3,',',F6.3,',',F6.3,
+ & ')',/,16X,'DIRECTION OF THE POLARIZATION : (
+ &', F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZER.LIGHT ','
+ & : ',F7.4)
+ 63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6.
+ &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI
+ &GHT ', ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZE
+ &R.LIGHT : ',F7.4)
+ 65 FORMAT(////,3X,'++++++++++++++++++',9X,
+ *'THETA = ',F6.2,' DEGREES',9X,'++++++++',
+ *'++++++++++',///)
+ 66 FORMAT(////,3X,'++++++++++++++++++',9X,
+ *'PHI = ',F6.2,' DEGREES',9X,'++++++++++',
+ *'++++++++++',///)
+ 67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
+ 68 FORMAT(10X,' CUT-OFF INTENSITY : ',E12.6)
+ 69 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
+ 70 FORMAT(2X,I2,2X,I10,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
+ 71 FORMAT(//,1X,'JDIF',4X,'No OF THE PATH',2X,'INTENSITY',3X,'LENGTH'
+ &,4X,'ABSORBER',2X,'ORDER OF THE SCATTERERS',/)
+ 72 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1
+ &2.6,2X,E12.6)
+ 74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ','=====
+ &>')
+ 76 FORMAT(2X,I2,2X,E12.6,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
+ 77 FORMAT(' ')
+ 79 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
+ 80 FORMAT(///)
+ 81 FORMAT(//,1X,'RANK',1X,'ORDER',4X,'No PATH',3X,'INTENSITY',3X,'LEN
+ >H',4X,'ABS',3X,'ORDER OF THE SCATTERERS',/)
+ 82 FORMAT(I3,4X,I2,1X,E12.6,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X))
+ 83 FORMAT(I3,4X,I2,1X,I10,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X))
+ 84 FORMAT(/////,18X,'THE ',I3,' MORE INTENSE PATHS BY DECREASING',' O
+ &RDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ','OF A)')
+ 85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ',/,24X,'(THE L
+ &ENGTH IS GIVEN IN UNITS OF A)')
+ 86 FORMAT(2X,I3,1X,I4,5X,F8.3,3X,F8.3,3X,E12.6)
+ 87 FORMAT(2X,I2,2X,I3,2X,I2,2X,I3,2X,I3,2X,I3,2X,I1,2X,I2,2X,I2,2X,E1
+ &2.6,2X,E12.6,2X,E12.6,2X,E12.6)
+ 88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =', F6.2)
+ 89 FORMAT(/,4X,'..........................................','........
+ &.............................')
+C
+ 7 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/plotfd.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/plotfd.f
new file mode 100644
index 0000000..bc73cf4
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/plotfd.f
@@ -0,0 +1,106 @@
+C
+C=======================================================================
+C
+ SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
+C
+C This routine prepares the output for a plot of the scattering factor
+C
+ USE DIM_MOD
+C
+ USE APPROX_MOD
+ USE FDIF_MOD
+ USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 =>
+ & LF2, I10 => ISTEP_LF
+ USE INIT_J_MOD
+ USE OUTFILES_MOD
+ USE OUTUNITS_MOD
+ USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
+ USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP
+ &, I13 => I_EXT, I14 => I_TEST
+ USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO
+ &L
+ USE VALFIN_MOD
+C
+C
+C
+ DIMENSION LMX(NATM,NE_M)
+C
+ COMPLEX FSPH,VKE
+C
+C
+C
+ DATA PI,CONV/3.141593,0.512314/
+C
+ OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
+ IF(ISPHER.EQ.0) THEN
+ L=0
+ LMAX=0
+ ELSE
+ LMAX=L
+ ENDIF
+ PHITOT=360.
+ THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
+ NPHI=(NFTHET+1)*IPHI+(1-IPHI)
+ NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
+ * (1-ITHETA)
+ NE=NFTHET*IE + (1-IE)
+ WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
+ DO 10 JT=1,NTHT
+ DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
+ RTHETA=DTHETA*PI/180.
+ TEST=SIN(RTHETA)
+ IF(TEST.GE.0.) THEN
+ POZ=PI
+ EPS=1.
+ ELSE
+ POZ=0.
+ EPS=-1.
+ ENDIF
+ BETA=RTHETA*EPS
+ IF(ABS(TEST).LT.0.0001) THEN
+ NPHIM=1
+ ELSE
+ NPHIM=NPHI
+ ENDIF
+ DO 20 JP=1,NPHIM
+ DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
+ RPHI=DPHI*PI/180.
+ GAMMA=POZ-RPHI
+ DO 30 JE=1,NE
+ IF(NE.EQ.1) THEN
+ ECIN=E0
+ ELSE
+ ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
+ ENDIF
+ IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
+ DO 40 JAT=1,NAT
+ IF(L.GT.LMX(JAT,JE)) GOTO 90
+ DO 50 M=-LMAX,LMAX
+ CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J
+ &AT,JE,*60)
+ GOTO 70
+ 60 WRITE(IUO1,80)
+ STOP
+ 70 REFTH=REAL(FSPH)
+ XIMFTH=AIMAG(FSPH)
+ WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN
+ 50 CONTINUE
+ GOTO 40
+ 90 WRITE(IUO1,100) JAT
+ STOP
+ 40 CONTINUE
+ 30 CONTINUE
+ 20 CONTINUE
+ 10 CONTINUE
+ CLOSE(IUO3)
+ 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
+ 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X,
+ &F8.2)
+ 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z
+ &ERO >>>>>')
+ 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : '
+ &,I2,' >>>>>')
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/treat_phd.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/treat_phd.f
new file mode 100644
index 0000000..a76a31e
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/treat_phd.f
@@ -0,0 +1,769 @@
+C
+C=======================================================================
+C
+ SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
+C
+C This routine sums up the calculations corresponding to different
+C absorbers or different planes when this has to be done
+C (parameter ISOM in the input data file).
+C
+C Last modified : 24 Jan 2013
+C
+ USE DIM_MOD
+ USE OUTUNITS_MOD
+ USE TYPEXP_MOD , DUMMY => SPECTRO
+ USE VALIN_MOD
+ USE VALFIN_MOD
+C
+ PARAMETER(N_HEAD=5000,N_FILES=1000)
+C
+ CHARACTER*3 SPECTRO
+C
+ CHARACTER*13 OUTDATA
+ CHARACTER*72 HEAD(N_HEAD,N_FILES)
+C
+ REAL TAB(NDIM_M,4)
+ REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M)
+C
+C
+ DATA JVOL,JTOT/0,-1/
+C
+ REWIND IUO2
+C
+C Reading and storing the headers:
+C
+ NHEAD=0
+ DO JLINE=1,N_HEAD
+ READ(IUO2,888) HEAD(JLINE,JFICH)
+ NHEAD=NHEAD+1
+ IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333
+ ENDDO
+C
+ 333 CONTINUE
+C
+ READ(IUO2,15) SPECTRO,OUTDATA
+ READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IPH_1
+ &,I_EXT
+C
+ IF(I_EXT.EQ.2) THEN
+ IPH_1=0
+ ENDIF
+C
+ IF(ISOM.EQ.0) THEN
+C
+C........ ISOM = 0 : case of independent input files .................
+C
+ READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE
+C
+ IF(IPH_1.EQ.1) THEN
+ N_FIXED=NPHI
+ FIX0=PHI0
+ FIX1=PHI1
+ N_SCAN=NTHETA
+ ELSE
+ N_FIXED=NTHETA
+ FIX0=THETA0
+ FIX1=THETA1
+ IF(STEREO.EQ.'YES') THEN
+ NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
+ &+1
+ IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
+ ENDIF
+ N_SCAN=NPHI
+ ENDIF
+C
+ IF(I_EXT.EQ.-1) THEN
+ N_SCAN=2*N_SCAN
+ ENDIF
+C
+ IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
+ NDP=NEMET*NTHETA*NPHI*NE
+ ELSEIF(I_EXT.EQ.-1) THEN
+ NDP=NEMET*NTHETA*NPHI*NE*2
+ ELSEIF(I_EXT.EQ.2) THEN
+ NDP=NEMET*NTHETA*NE
+ N_FIXED=NTHETA
+ N_SCAN=NPHI
+ IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
+ ENDIF
+C
+ NTT=NPLAN*NDP
+ IF(NTT.GT.NDIM_M) GOTO 5
+C
+ DO JPLAN=1,NPLAN
+ DO JEMET=1,NEMET
+ DO JE=1,NE
+C
+ DO J_FIXED=1,N_FIXED
+ IF(N_FIXED.GT.1) THEN
+ XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
+ ELSEIF(N_FIXED.EQ.1) THEN
+ XINCRF=0.
+ ENDIF
+ IF(IPH_1.EQ.1) THEN
+ JPHI=J_FIXED
+ ELSE
+ THETA=THETA0+XINCRF
+ JTHETA=J_FIXED
+ IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11
+ ENDIF
+ IF(STEREO.EQ.' NO') THEN
+ N_SCAN_R=N_SCAN
+ ELSE
+ RTHETA=THETA*0.017453
+ FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
+ N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
+ ENDIF
+C
+ DO J_SCAN=1,N_SCAN_R
+ IF(IPH_1.EQ.1) THEN
+ JTHETA=J_SCAN
+ ELSE
+ JPHI=J_SCAN
+ ENDIF
+C
+ JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN + (JE-1)*N
+ &_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI
+C
+ IF(I_EXT.LE.0) THEN
+ IF(STEREO.EQ.' NO') THEN
+ JPHI2=JPHI
+ ELSE
+ JPHI2=(JTHETA-1)*NPHI+JPHI
+ ENDIF
+ ELSE
+ JPHI2=JTHETA
+ ENDIF
+C
+ READ(IUO2,2) JPL
+ IF(JPLAN.EQ.JPL) THEN
+ BACKSPACE IUO2
+ IF(IDICHR.EQ.0) THEN
+ READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
+ &),TAB(JLIN,1),TAB(JLIN,2)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
+ ENDIF
+ ELSE
+ READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
+ &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
+ &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
+ ENDIF
+ ENDIF
+ ELSE
+ BACKSPACE IUO2
+ DO JL=JLIN,JPLAN*NDP
+ TAB(JL,1)=0.0
+ TAB(JL,2)=0.0
+ TAB(JL,3)=0.0
+ TAB(JL,4)=0.0
+ ENDDO
+ GOTO 10
+ ENDIF
+ ENDDO
+ ENDDO
+ 11 CONTINUE
+ ENDDO
+ ENDDO
+ 10 CONTINUE
+ ENDDO
+C
+ REWIND IUO2
+C
+C Skipping the NHEAD lines of headers before rewriting:
+C
+ DO JLINE=1,NHEAD
+ READ(IUO2,888) HEAD(JLINE,JFICH)
+ ENDDO
+C
+ WRITE(IUO2,15) SPECTRO,OUTDATA
+ WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
+ WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
+C
+ DO JE=1,NE
+ DO JTHETA=1,NTHETA
+ IF(STEREO.EQ.' NO') THEN
+ NPHI_R=NPHI
+ ELSE
+ RTHETA=DTHETA(JTHETA)*0.017453
+ FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
+ NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
+ NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
+ ENDIF
+ DO JPHI=1,NPHI_R
+ TOTDIF_1=0.
+ TOTDIR_1=0.
+ VOLDIF_1=0.
+ VOLDIR_1=0.
+ TOTDIF_2=0.
+ TOTDIR_2=0.
+ VOLDIF_2=0.
+ VOLDIR_2=0.
+ IF(I_EXT.EQ.-1) THEN
+ TOTDIF2_1=0.
+ TOTDIR2_1=0.
+ VOLDIF2_1=0.
+ VOLDIR2_1=0.
+ TOTDIF2_2=0.
+ TOTDIR2_2=0.
+ VOLDIF2_2=0.
+ VOLDIR2_2=0.
+ ENDIF
+C
+ DO JPLAN=1,NPLAN
+C
+ SF_1=0.
+ SR_1=0.
+ SF_2=0.
+ SR_2=0.
+ IF(I_EXT.EQ.-1) THEN
+ SF2_1=0.
+ SR2_1=0.
+ SF2_2=0.
+ SR2_2=0.
+ ENDIF
+C
+ DO JEMET=1,NEMET
+ JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (JE-1)*NTHE
+ &TA*NPHI +(JTHETA-1)*NPHI + JPHI
+ SF_1=SF_1+TAB(JLIN,2)
+ SR_1=SR_1+TAB(JLIN,1)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ SF2_1=SF2_1+TAB(JLIN2,2)
+ SR2_1=SR2_1+TAB(JLIN2,1)
+ ENDIF
+ IF(IDICHR.GE.1) THEN
+ SF_2=SF_2+TAB(JLIN,4)
+ SR_2=SR_2+TAB(JLIN,3)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ SF2_2=SF2_2+TAB(JLIN2,4)
+ SR2_2=SR2_2+TAB(JLIN2,3)
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(I_EXT.LE.0) THEN
+ IF(STEREO.EQ.' NO') THEN
+ JPHI2=JPHI
+ ELSE
+ JPHI2=(JTHETA-1)*NPHI+JPHI
+ ENDIF
+ ELSE
+ JPHI2=JTHETA
+ ENDIF
+ IF(IDICHR.EQ.0) THEN
+ WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
+ &_1,SF_1
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
+ &SR2_1,SF2_1
+ ENDIF
+ ELSE
+ WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S
+ &R_1,SF_1,SR_2,SF_2
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
+ &,SR2_1,SF2_1,SR2_2,SF2_2
+ ENDIF
+ ENDIF
+ IF(JPLAN.GT.NONVOL(JFICH)) THEN
+ VOLDIF_1=VOLDIF_1+SF_1
+ VOLDIR_1=VOLDIR_1+SR_1
+ IF(I_EXT.EQ.-1) THEN
+ VOLDIF2_1=VOLDIF2_1+SF2_1
+ VOLDIR2_1=VOLDIR2_1+SR2_1
+ ENDIF
+ IF(IDICHR.GE.1) THEN
+ VOLDIF_2=VOLDIF_2+SF_2
+ VOLDIR_2=VOLDIR_1+SR_2
+ IF(I_EXT.EQ.-1) THEN
+ VOLDIF2_2=VOLDIF2_2+SF2_2
+ VOLDIR2_2=VOLDIR2_1+SR2_2
+ ENDIF
+ ENDIF
+ ENDIF
+ TOTDIF_1=TOTDIF_1+SF_1
+ TOTDIR_1=TOTDIR_1+SR_1
+ IF(I_EXT.EQ.-1) THEN
+ TOTDIF2_1=TOTDIF2_1+SF2_1
+ TOTDIR2_1=TOTDIR2_1+SR2_1
+ ENDIF
+ IF(IDICHR.GE.1) THEN
+ TOTDIF_2=TOTDIF_2+SF_2
+ TOTDIR_2=TOTDIR_2+SR_2
+ IF(I_EXT.EQ.-1) THEN
+ TOTDIF2_2=TOTDIF2_2+SF2_2
+ TOTDIR2_2=TOTDIR2_2+SR2_2
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(IDICHR.EQ.0) THEN
+ WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOLD
+ &IR_1,VOLDIF_1
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO
+ &LDIR2_1,VOLDIF2_1
+ ENDIF
+ WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOTD
+ &IR_1,TOTDIF_1
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO
+ &TDIR2_1,TOTDIF2_1
+ ENDIF
+ ELSE
+ WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOL
+ &DIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V
+ &OLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
+ ENDIF
+ WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOT
+ &DIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T
+ &OTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ ELSE
+C
+C........ ISOM not= 0 : multiple input files to be summed up ..........
+C
+ READ(IUO2,7) NTHETA,NPHI,NE
+C
+ IF(IPH_1.EQ.1) THEN
+ N_FIXED=NPHI
+ FIX0=PHI0
+ FIX1=PHI1
+ N_SCAN=NTHETA
+ ELSE
+ N_FIXED=NTHETA
+ FIX0=THETA0
+ FIX1=THETA1
+ IF(STEREO.EQ.'YES') THEN
+ NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
+ &+1
+ IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
+ ENDIF
+ N_SCAN=NPHI
+ ENDIF
+C
+ IF(I_EXT.EQ.-1) THEN
+ N_SCAN=2*N_SCAN
+ ENDIF
+C
+ IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
+ NDP=NTHETA*NPHI*NE
+ ELSEIF(I_EXT.EQ.-1) THEN
+ NDP=NTHETA*NPHI*NE*2
+ ELSEIF(I_EXT.EQ.2) THEN
+ NDP=NTHETA*NE
+ N_FIXED=NTHETA
+ N_SCAN=NPHI
+ IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
+ ENDIF
+C
+ NTT=NFICHLEC*NDP
+ IF(NTT.GT.NDIM_M) GOTO 5
+C
+ IF(ISOM.EQ.1) THEN
+ NPLAN=NP
+ NF=NP
+ ELSEIF(ISOM.EQ.2) THEN
+ NEMET=NFICHLEC
+ NF=NFICHLEC
+ NPLAN=1
+ ENDIF
+C
+ DO JF=1,NF
+C
+C Reading the headers for each file:
+C
+ IF(JF.GT.1) THEN
+ DO JLINE=1,NHEAD
+ READ(IUO2,888) HEAD(JLINE,JF)
+ ENDDO
+ ENDIF
+C
+ DO JE=1,NE
+C
+ DO J_FIXED=1,N_FIXED
+ IF(N_FIXED.GT.1) THEN
+ XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
+ ELSEIF(N_FIXED.EQ.1) THEN
+ XINCRF=0.
+ ENDIF
+ IF(IPH_1.EQ.1) THEN
+ JPHI=J_FIXED
+ ELSE
+ THETA=THETA0+XINCRF
+ JTHETA=J_FIXED
+ IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12
+ ENDIF
+ IF(STEREO.EQ.' NO') THEN
+ N_SCAN_R=N_SCAN
+ ELSE
+ RTHETA=THETA*0.017453
+ FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
+ N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
+ ENDIF
+C
+ DO J_SCAN=1,N_SCAN_R
+ IF(IPH_1.EQ.1) THEN
+ JTHETA=J_SCAN
+ ELSE
+ JPHI=J_SCAN
+ ENDIF
+C
+ JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI +
+ &JPHI
+ IF(I_EXT.LE.0) THEN
+ IF(STEREO.EQ.' NO') THEN
+ JPHI2=JPHI
+ ELSE
+ JPHI2=(JTHETA-1)*NPHI+JPHI
+ ENDIF
+ ELSE
+ JPHI2=JTHETA
+ ENDIF
+C
+ IF(ISOM.EQ.1) THEN
+ READ(IUO2,2) JPL
+ IF(JF.EQ.JPL) THEN
+ BACKSPACE IUO2
+ IF(IDICHR.EQ.0) THEN
+ READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(
+ &JE),TAB(JLIN,1),TAB(JLIN,2)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
+ ENDIF
+ ELSE
+ READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
+ &(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),EC
+ &IN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
+ ENDIF
+ ENDIF
+ ELSE
+ BACKSPACE IUO2
+ DO JLINE=1,NHEAD
+ BACKSPACE IUO2
+ ENDDO
+ DO JL=JLIN,JF*NDP
+ TAB(JL,1)=0.0
+ TAB(JL,2)=0.0
+ TAB(JL,3)=0.0
+ TAB(JL,4)=0.0
+ ENDDO
+ GOTO 13
+ ENDIF
+ ELSEIF(ISOM.EQ.2) THEN
+ IF(IDICHR.EQ.0) THEN
+ READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
+ &),TAB(JLIN,1),TAB(JLIN,2)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
+ ENDIF
+ ELSE
+ READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
+ &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
+ &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ 12 CONTINUE
+ ENDDO
+ ENDDO
+ 13 CONTINUE
+ ENDDO
+C
+ REWIND IUO2
+C
+C Writing the headers:
+C
+ DO JLINE=1,2
+ WRITE(IUO2,888) HEAD(JLINE,1)
+ ENDDO
+ DO JF=1,NFICHLEC
+ DO JLINE=3,6
+ WRITE(IUO2,888) HEAD(JLINE,JF)
+ ENDDO
+ WRITE(IUO2,888) HEAD(2,JF)
+ ENDDO
+ DO JLINE=7,NHEAD
+ WRITE(IUO2,888) HEAD(JLINE,1)
+ ENDDO
+C
+ WRITE(IUO2,15) SPECTRO,OUTDATA
+ WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
+ WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
+C
+ IF(ISOM.EQ.1) THEN
+C
+ DO JE=1,NE
+C
+ DO JTHETA=1,NTHETA
+ IF(STEREO.EQ.' NO') THEN
+ NPHI_R=NPHI
+ ELSE
+ RTHETA=DTHETA(JTHETA)*0.017453
+ FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
+ NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
+ NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
+ ENDIF
+ DO JPHI=1,NPHI_R
+C
+ TOTDIF_1=0.
+ TOTDIR_1=0.
+ VOLDIF_1=0.
+ VOLDIR_1=0.
+ TOTDIF_2=0.
+ TOTDIR_2=0.
+ VOLDIF_2=0.
+ VOLDIR_2=0.
+ IF(I_EXT.EQ.-1) THEN
+ TOTDIF2_1=0.
+ TOTDIR2_1=0.
+ VOLDIF2_1=0.
+ VOLDIR2_1=0.
+ TOTDIF2_2=0.
+ TOTDIR2_2=0.
+ VOLDIF2_2=0.
+ VOLDIR2_2=0.
+ ENDIF
+C
+ DO JPLAN=1,NPLAN
+ JF=JPLAN
+C
+ JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JP
+ &HI
+C
+ SR_1=TAB(JLIN,1)
+ SF_1=TAB(JLIN,2)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ SF2_1=TAB(JLIN2,2)
+ SR2_1=TAB(JLIN2,1)
+ ENDIF
+ IF(I_EXT.LE.0) THEN
+ IF(STEREO.EQ.' NO') THEN
+ JPHI2=JPHI
+ ELSE
+ JPHI2=(JTHETA-1)*NPHI+JPHI
+ ENDIF
+ ELSE
+ JPHI2=JTHETA
+ ENDIF
+ IF(IDICHR.EQ.0) THEN
+ WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
+ &SR_1,SF_1
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
+ &),SR2_1,SF2_1
+ ENDIF
+ ELSE
+ SR_2=TAB(JLIN,3)
+ SF_2=TAB(JLIN,4)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ SF2_2=TAB(JLIN2,4)
+ SR2_2=TAB(JLIN2,3)
+ ENDIF
+ WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
+ &,SR_1,SF_1,SR_2,SF_2
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
+ &E),SR2_1,SF2_1,SR2_2,SF2_2
+ ENDIF
+ ENDIF
+ IF(NONVOL(JPLAN).EQ.0) THEN
+ VOLDIF_1=VOLDIF_1+SF_1
+ VOLDIR_1=VOLDIR_1+SR_1
+ IF(I_EXT.EQ.-1) THEN
+ VOLDIF2_1=VOLDIF2_1+SF2_1
+ VOLDIR2_1=VOLDIR2_1+SR2_1
+ ENDIF
+ IF(IDICHR.GE.1) THEN
+ VOLDIF_2=VOLDIF_2+SF_2
+ VOLDIR_2=VOLDIR_2+SR_2
+ IF(I_EXT.EQ.-1) THEN
+ VOLDIF2_2=VOLDIF2_2+SF2_2
+ VOLDIR2_2=VOLDIR2_1+SR2_2
+ ENDIF
+ ENDIF
+ ENDIF
+ TOTDIF_1=TOTDIF_1+SF_1
+ TOTDIR_1=TOTDIR_1+SR_1
+ IF(I_EXT.EQ.-1) THEN
+ TOTDIF2_1=TOTDIF2_1+SF2_1
+ TOTDIR2_1=TOTDIR2_1+SR2_1
+ ENDIF
+ IF(IDICHR.GE.1) THEN
+ TOTDIF_2=TOTDIF_2+SF_2
+ TOTDIR_2=TOTDIR_2+SR_2
+ IF(I_EXT.EQ.-1) THEN
+ TOTDIF2_2=TOTDIF2_2+SF2_2
+ TOTDIR2_2=TOTDIR2_2+SR2_2
+ ENDIF
+ ENDIF
+ ENDDO
+C
+ IF(IDICHR.EQ.0) THEN
+ WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO
+ &LDIR_1,VOLDIF_1
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
+ &VOLDIR2_1,VOLDIF2_1
+ ENDIF
+ WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO
+ &TDIR_1,TOTDIF_1
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
+ &TOTDIR2_1,TOTDIF2_1
+ ENDIF
+ ELSE
+ WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V
+ &OLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
+ &,VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
+ ENDIF
+ WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T
+ &OTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
+ &,TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
+ ENDIF
+ ENDIF
+C
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSEIF(ISOM.EQ.2) THEN
+ DO JE=1,NE
+C
+ DO JTHETA=1,NTHETA
+ IF(STEREO.EQ.' NO') THEN
+ NPHI_R=NPHI
+ ELSE
+ RTHETA=DTHETA(JTHETA)*0.017453
+ FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
+ NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
+ NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
+ ENDIF
+ DO JPHI=1,NPHI_R
+C
+ SF_1=0.
+ SR_1=0.
+ SF_2=0.
+ SR_2=0.
+ IF(I_EXT.EQ.-1) THEN
+ SF2_1=0.
+ SR2_1=0.
+ SF2_2=0.
+ SR2_2=0.
+ ENDIF
+C
+ DO JEMET=1,NEMET
+ JF=JEMET
+C
+ JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + J
+ &PHI
+C
+ SF_1=SF_1+TAB(JLIN,2)
+ SR_1=SR_1+TAB(JLIN,1)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ SF2_1=SF2_1+TAB(JLIN2,2)
+ SR2_1=SR2_1+TAB(JLIN2,1)
+ ENDIF
+ IF(IDICHR.GE.1) THEN
+ SF_2=SF_2+TAB(JLIN,4)
+ SR_2=SR_2+TAB(JLIN,3)
+ IF(I_EXT.EQ.-1) THEN
+ JLIN2=NTT+JLIN
+ SF2_2=SF2_2+TAB(JLIN2,4)
+ SR2_2=SR2_2+TAB(JLIN2,3)
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(I_EXT.LE.0) THEN
+ IF(STEREO.EQ.' NO') THEN
+ JPHI2=JPHI
+ ELSE
+ JPHI2=(JTHETA-1)*NPHI+JPHI
+ ENDIF
+ ELSE
+ JPHI2=JTHETA
+ ENDIF
+ IF(IDICHR.EQ.0) THEN
+ WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
+ &_1,SF_1
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
+ &),SR2_1,SF2_1
+ ENDIF
+ ELSE
+ WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S
+ &R_1,SF_1,SR_2,SF_2
+ IF(I_EXT.EQ.-1) THEN
+ WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
+ &E),SR2_1,SF2_1,SR2_2,SF2_2
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+C
+ GOTO 6
+C
+ 5 WRITE(IUO1,4)
+ STOP
+ 35 WRITE(IUO1,36) N_FIXED
+ STOP
+ 37 WRITE(IUO1,38) NTHETA*NPHI
+ STOP
+C
+ 1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
+ 2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
+ 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
+ 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
+ &THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>')
+ 7 FORMAT(I4,2X,I4,2X,I4)
+ 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
+ 9 FORMAT(9(2X,I1),2X,I2)
+ 15 FORMAT(2X,A3,11X,A13)
+ 22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1
+ &2.6,2X,E12.6)
+ 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
+ &,E12.6)
+ 25 FORMAT(37X,E12.6,2X,E12.6)
+ 36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL ',
+ &'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<<
+ &SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
+ 38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE I
+ &NCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE AT
+ &LEAST ',I6,' >>>>>>>>>>')
+ 888 FORMAT(A72)
+C
+ 6 RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/weight_sum.f b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/weight_sum.f
new file mode 100644
index 0000000..0db9ffc
--- /dev/null
+++ b/src/msspec/spec/fortran/phd_se_noso_nosp_nosym/weight_sum.f
@@ -0,0 +1,335 @@
+C
+C=======================================================================
+C
+ SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL)
+C
+C This subroutine performs a weighted sum of the results
+C corresponding to different directions of the detector.
+C The directions and weights are read from an external input file
+C
+C JEL is the electron undetected (i.e. for which the outgoing
+C directions are integrated over the unit sphere). It is always
+C 1 for one electron spectroscopies (PHD). For APECS, It can be
+C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron
+C detected)
+C
+C Last modified : 31 Jan 2007
+C
+ USE DIM_MOD
+ USE INFILES_MOD
+ USE INUNITS_MOD
+ USE OUTUNITS_MOD
+C
+C
+ PARAMETER(N_MAX=5810,NPM=20)
+C
+ REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M)
+ REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX)
+ REAL*4 SR_1,SF_1,SR_2,SF_2
+ REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX)
+ REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX)
+C
+ CHARACTER*3 SPECTRO,SPECTRO2
+ CHARACTER*5 LIKE
+ CHARACTER*13 OUTDATA
+C
+C
+C
+C
+ DATA JVOL,JTOT/0,-1/
+ DATA LIKE /'-like'/
+C
+ REWIND IUO2
+C
+ READ(IUO2,15) SPECTRO,OUTDATA
+ IF(SPECTRO.NE.'APC') THEN
+ READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
+ READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
+ SPECTRO2='XAS'
+ ELSE
+ READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
+ READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I
+ &THETA_A,IE_A
+ READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
+ READ(IUO2,8) NPHI_A,NTHETA_A
+ IF(JEL.EQ.1) THEN
+ SPECTRO2='AED'
+ ELSEIF(JEL.EQ.2) THEN
+ SPECTRO2='PHD'
+ ELSEIF(JEL.EQ.0) THEN
+ SPECTRO2='XAS'
+ ENDIF
+ ENDIF
+C
+ IF(NPLAN.GT.NPM) THEN
+ WRITE(IUO1,4) NPLAN+2
+ STOP
+ ENDIF
+C
+C Reading the number of angular points
+C
+ IF(SPECTRO.NE.'APC') THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,1) N_POINTS
+ READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
+ N_POINTS_A=1
+ ELSE
+ IF(JEL.EQ.1) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,1) N_POINTS
+ READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
+ IF(I_EXT_A.EQ.0) THEN
+ N_POINTS_A=NTHETA_A*NPHI_A
+ ELSE
+ OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
+ READ(IUI9,1) N_POINTS_A
+ READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
+ ENDIF
+ NTHETA0=NTHETA_A
+ NPHI0=NPHI_A
+ ELSEIF(JEL.EQ.2) THEN
+ OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
+ READ(IUI9,1) N_POINTS_A
+ READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
+ IF(I_EXT.EQ.0) THEN
+ N_POINTS=NTHETA*NPHI
+ ELSE
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ READ(IUI6,1) N_POINTS
+ READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
+ ENDIF
+ NTHETA0=NTHETA
+ NPHI0=NPHI
+ ELSEIF(JEL.EQ.0) THEN
+ OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
+ OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
+ READ(IUI6,1) N_POINTS
+ READ(IUI9,1) N_POINTS_A
+ READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
+ READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
+ ENDIF
+ ENDIF
+C
+ IF(SPECTRO.NE.'APC') THEN
+ NANGLE=1
+ ELSE
+ IF(JEL.EQ.1) THEN
+ NANGLE=N_POINTS_A
+ ELSEIF(JEL.EQ.2) THEN
+ NANGLE=N_POINTS
+ ELSEIF(JEL.EQ.0) THEN
+ NANGLE=1
+ ENDIF
+ ENDIF
+C
+C Initialization of the arrays
+C
+ DO JE=1,NE
+ DO JANGLE=1,NANGLE
+ DO JPLAN=1,NPLAN+2
+ SUMR_1(JPLAN,JE,JANGLE)=0.
+ SUMF_1(JPLAN,JE,JANGLE)=0.
+ IF(IDICHR.GT.0) THEN
+ SUMR_2(JPLAN,JE,JANGLE)=0.
+ SUMF_2(JPLAN,JE,JANGLE)=0.
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C Reading of the data to be angle integrated
+C
+ DO JE=1,NE
+C
+ DO JANGLE=1,N_POINTS
+ IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE)
+ DO JANGLE_A=1,N_POINTS_A
+ IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN
+ READ(IUI9,2) THA,PHA,W_A(JANGLE_A)
+ ENDIF
+C
+ DO JPLAN=1,NPLAN+2
+C
+ IF(IDICHR.EQ.0) THEN
+ IF(SPECTRO.NE.'APC') THEN
+ READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE)
+ &,SR_1,SF_1
+ ELSE
+ READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
+ &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1
+ ENDIF
+ ELSE
+ IF(SPECTRO.NE.'APC') THEN
+ READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
+ &),SR_1,SF_1,SR_2,SF_2
+ ELSE
+ READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
+ &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2
+ ENDIF
+ ENDIF
+C
+ IF(JEL.EQ.1) THEN
+ SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1
+ &*W(JANGLE)
+ SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1
+ &*W(JANGLE)
+ ELSEIF(JEL.EQ.2) THEN
+ SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A
+ &(JANGLE_A)
+ SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A
+ &(JANGLE_A)
+ ELSEIF(JEL.EQ.0) THEN
+ SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A
+ &(JANGLE_A)
+ SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A
+ &(JANGLE_A)
+ ENDIF
+ IF(IDICHR.GT.0) THEN
+ IF(JEL.EQ.1) THEN
+ SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR
+ &_2*W(JANGLE)
+ SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF
+ &_2*W(JANGLE)
+ ELSEIF(JEL.EQ.2) THEN
+ SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W
+ &_A(JANGLE_A)
+ SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W
+ &_A(JANGLE_A)
+ ELSEIF(JEL.EQ.0) THEN
+ SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W
+ &_A(JANGLE_A)
+ SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W
+ &_A(JANGLE_A)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+C
+ ENDDO
+ IF(I_EXT_A.NE.0) THEN
+ REWIND IUI9
+ READ(IUI9,1) NDUM
+ READ(IUI9,1) NDUM
+ ENDIF
+ ENDDO
+C
+ IF(I_EXT.NE.0) THEN
+ REWIND IUI6
+ READ(IUI6,1) NDUM
+ READ(IUI6,1) NDUM
+ ENDIF
+ ENDDO
+C
+ CLOSE(IUI6)
+ CLOSE(IUI9)
+ REWIND IUO2
+C
+ WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA
+ IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
+ WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP
+ WRITE(IUO2,18) NE,NPLAN,ISOM
+ ELSEIF(JEL.EQ.1) THEN
+ WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A
+ &,ITHETA_A,IE_A
+ WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
+ ELSEIF(JEL.EQ.2) THEN
+ WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
+ WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
+ ENDIF
+C
+ DO JE=1,NE
+ DO JANGLE=1,NANGLE
+ IF(SPECTRO.EQ.'APC') THEN
+ IF(JEL.EQ.1) THEN
+ THETA=DTHETAA(JANGLE)
+ PHI=DPHIA(JANGLE)
+ ELSEIF(JEL.EQ.2) THEN
+ THETA=DTHETA(JANGLE)
+ PHI=DPHI(JANGLE)
+ ENDIF
+ ENDIF
+C
+ DO JPLAN=1,NPLAN
+ IF(IDICHR.EQ.0) THEN
+ IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
+ WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
+ &MF_1(JPLAN,JE,JANGLE)
+ ELSE
+ WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
+ &JANGLE),SUMF_1(JPLAN,JE,JANGLE)
+ ENDIF
+ ELSE
+ IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
+ WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
+ &MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG
+ &LE)
+ ELSE
+ WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
+ &JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL
+ &AN,JE,JANGLE)
+ ENDIF
+ ENDIF
+ ENDDO
+C
+ IF(IDICHR.EQ.0) THEN
+ IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
+ WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
+ &F_1(NPLAN+1,JE,JANGLE)
+ WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
+ &F_1(NPLAN+2,JE,JANGLE)
+ ELSE
+ WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
+ &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE)
+ WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
+ &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE)
+ ENDIF
+ ELSE
+ IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
+ WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
+ &F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE
+ &,JANGLE)
+ WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
+ &F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE
+ &,JANGLE)
+ ELSE
+ WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
+ &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(
+ &NPLAN+1,JE,JANGLE)
+ WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
+ &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(
+ &NPLAN+2,JE,JANGLE)
+ ENDIF
+ ENDIF
+C
+ ENDDO
+ ENDDO
+C
+ 1 FORMAT(13X,I4)
+ 2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6)
+ 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
+ 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
+ &THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>')
+ 5 FORMAT(6X,I1,1X,I3,3X,I3)
+ 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
+ 9 FORMAT(9(2X,I1),2X,I2)
+ 13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
+ &12.6)
+ 15 FORMAT(2X,A3,11X,A13)
+ 16 FORMAT(2X,A3,A5,1X,A3,2X,A13)
+ 18 FORMAT(I4,2X,I3,2X,I1)
+ 19 FORMAT(4(2X,I1))
+ 20 FORMAT(8(2X,I1))
+ 21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
+ 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
+ &,E12.6)
+ 24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
+ &12.6,2X,E12.6,2X,E12.6)
+ 33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6)
+ 34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
+ 43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
+ 44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
+ &,E12.6)
+C
+ RETURN
+C
+ END
diff --git a/src/msspec/spec/fortran/prog.f b/src/msspec/spec/fortran/prog.f
deleted file mode 100644
index 0a2de49..0000000
--- a/src/msspec/spec/fortran/prog.f
+++ /dev/null
@@ -1,13 +0,0 @@
- PROGRAM MAIN
- IMPLICIT INTEGER (A-Z)
-
- READ *, NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
- & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
- & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
- & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_
-
- CALL RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
- & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
- & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
- & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
- END PROGRAM MAIN
diff --git a/src/msspec/spec/fortran/renormalization.f b/src/msspec/spec/fortran/renormalization/renormalization.f
similarity index 100%
rename from src/msspec/spec/fortran/renormalization.f
rename to src/msspec/spec/fortran/renormalization/renormalization.f
diff --git a/src/msspec/spec/fortran/spec.f b/src/msspec/spec/fortran/spec.f
deleted file mode 100644
index 681b1d5..0000000
--- a/src/msspec/spec/fortran/spec.f
+++ /dev/null
@@ -1,13322 +0,0 @@
-C
-C
-C ************************************************************
-C * ******************************************************** *
-C * * * *
-C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * *
-C * * PHOTOELECTRON DIFFRACTION CODE * *
-C * * BASED ON SERIES EXPANSION * *
-C * * * *
-C * ******************************************************** *
-C ************************************************************
-C
-C
-C
-C
-C Written by D. Sebilleau, Groupe Theorie,
-C Departement Materiaux-Nanosciences,
-C Institut de Physique de Rennes,
-C UMR CNRS-Universite 6251,
-C Universite de Rennes-1,
-C 35042 Rennes-Cedex,
-C France
-C
-C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada
-C
-C-----------------------------------------------------------------------
-C
-C As a general rule in this code, although there might be a few
-C exceptions (...), a variable whose name starts with a 'I' is a
-C switch, with a 'J' is a loop index and with a 'N' is a number.
-C
-C The main subroutines are :
-C
-C * PHDDIF : computes the photoelectron diffraction
-C formula
-C
-C * LEDDIF : computes the low-energy electron
-C diffraction formula
-C
-C * XASDIF : computes the EXAFS or XANES formula
-C depending on the energy
-C
-C * AEDDIF : computes the Auger electron diffraction
-C formula
-C
-C * FINDPATHS : generates the multiple scattering
-C paths the electron will follow
-C
-C * PATHOP : calculates the contribution of a given
-C path to the scattering path operator
-C
-C * MATDIF : computes the Rehr-Albers scattering
-C matrices
-C
-C A subroutine called NAME_A is the Auger equivalent of subroutine
-C NAME. The essentail difference between NAME and NAME_A is that
-C they do not contain the same arrays.
-C
-C Always remember, when changing the input data file, to keep the
-C format. The rule here is that the last digit of any integer or
-C character data must correspond to the tab (+) while for real data,
-C the tab precedes the point.
-C
-C Do not forget, before submitting a calculation, to check the
-C consistency of the input data with the corresponding maximal
-C values in the include file.
-C
-C-----------------------------------------------------------------------
-C
-C Please report any bug or problem to me at :
-C
-C didier.sebilleau@univ-rennes1.fr
-C
-C
-C
-C Last modified : 10 Jan 2016
-C
-C=======================================================================
-C
- SUBROUTINE DO_MAIN()
-C
-C This routine reads the various input files and calls the subroutine
-C performing the requested calculation
-C
- USE DIM_MOD
-C
- USE ADSORB_MOD
- USE APPROX_MOD
- USE ATOMS_MOD
- USE AUGER_MOD
- USE BASES_MOD
- USE CLUSLIM_MOD
- USE COOR_MOD
- USE DEBWAL_MOD
- USE INDAT_MOD
- USE INIT_A_MOD
- USE INIT_L_MOD
- USE INIT_J_MOD
- USE INIT_M_MOD
- USE INFILES_MOD
- USE INUNITS_MOD
- USE LIMAMA_MOD
- USE LPMOY_MOD
- USE MASSAT_MOD
- USE MILLER_MOD
- USE OUTUNITS_MOD
- USE PARCAL_MOD
- USE PARCAL_A_MOD
- USE RELADS_MOD
- USE RELAX_MOD
- USE RESEAU_MOD
- USE SPIN_MOD
- USE TESTS_MOD
- USE TRANS_MOD
- USE TL_AED_MOD
- USE TYPCAL_MOD
- USE TYPCAL_A_MOD
- USE TYPEM_MOD
- USE TYPEXP_MOD
- USE VALIN_MOD
- USE XMRHO_MOD
-C
- DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3)
- DIMENSION ROT(3,3),EMET(3)
- DIMENSION VAL2(NATCLU_M)
- DIMENSION IRE(NATCLU_M,2)
- DIMENSION REL(NATCLU_M),RHOT(NATM)
- DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M)
- DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM)
- DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M)
- DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M)
- DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM)
-C
- COMPLEX TLSTAR
- COMPLEX RHOR(NE_M,NATM,0:18,5,NSPIN2_M)
- COMPLEX TLSTAR_A
- COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E
- COMPLEX RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHOR5STAR
-C
- INTEGER INV(2)
-C
- CHARACTER RIEN
- CHARACTER*1 B
- CHARACTER*2 R
-C
-C
-C
-C
-C
-C
- CHARACTER*30 TUNIT,DUMMY
-C
- DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/
- DATA INV /0,0/
-C
- LE_MAX=0
-C
-C! READ(*,776) NFICHLEC
-C! READ(*,776) ICOM
-C! DO JF=1,NFICHLEC
-C! READ(*,777) INDATA(JF)
-C! ENDDO
-C
-C.......... Loop on the data files ..........
-C
- NFICHLEC=1
- ICOM = 5
- DO JFICH=1,NFICHLEC
-C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
- OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD')
- CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*5
- &20,*540,*550,*570,*580,*590,*630)
-C
-C.......... Atomic case index ..........
-C
- I_AT=0
- IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1
- IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1
- IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1
- IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1
- IF(SPECTRO.EQ.'APC') THEN
- IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1
- ENDIF
-C
- IF(IBAS.EQ.1) THEN
- IF(ITEST.EQ.0) THEN
- NEQ=(2*NIV+1)**3
- ELSE
- NEQ=(2*NIV+3)**3
- ENDIF
- IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518
- ENDIF
-C
- IF(SPECTRO.EQ.'APC') THEN
- N_EL=2
- ELSE
- N_EL=1
- ENDIF
- IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
- IF(I_MULT.EQ.0) THEN
- LE_MIN=ABS(LI_C-ABS(LI_I-LI_A))
- LE_MAX=LI_C+LI_A+LI_I
- ELSE
- LE_MIN=ABS(LI_C-L_MUL)
- LE_MAX=LI_C+L_MUL
- ENDIF
- ENDIF
-C
-C.......... Test of the dimensions against the input values ..........
-C
- IF(NO.GT.NO_ST_M) GOTO 600
- IF(LE_MAX.GT.LI_M) GOTO 620
-C
- OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD')
- OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD')
- IF(INTERACT.EQ.'DIPCOUL') THEN
- OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD')
- OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD')
- ENDIF
-C
-C.......... Reading of the TL and radial matrix elements files ..........
-C.......... (dipolar excitation or no excitation case) ..........
-C
- IF(INTERACT.NE.'COULOMB') THEN
- IF(SPECTRO.EQ.'APC') WRITE(IUO1,418)
- READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE
- IF(ISPIN.EQ.0) THEN
- IF(NAT1.EQ.1) THEN
- WRITE(IUO1,561)
- ELSE
- WRITE(IUO1,560) NAT1
- ENDIF
- ENDIF
- IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN
- READ(IUI2,530) E_MIN,E_MAX,DE
- ENDIF
- IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN
- NLG=INT(NAT1-0.0001)/4 +1
- DO NN=1,NLG
- NRL=4*NN
- JD=4*(NN-1)+1
- IF(NN.EQ.NLG) NRL=NAT1
- READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL)
- WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL)
- ENDDO
-C
-C Temporary storage of LMAX. Waiting for a version of PHAGEN
-C with LMAX dependent on the energy
-C
- DO JE=1,NE
- DO JAT=1,NAT1
- LMAX(JAT,JE)=LMAX(JAT,1)
- ENDDO
- ENDDO
-C
- NL1=1
- DO JAT=1,NAT1
- NL1=MAX0(NL1,LMAX(JAT,1)+1)
- ENDDO
- IF(NL1.GT.NL_M) GOTO 184
- ENDIF
- IF(ITL.EQ.0) READ(IUI3,101) NATR,NER
- IF(ISPIN.EQ.1) THEN
- READ(IUI3,106) L_IN,NATR,NER
- IF(LI.NE.L_IN) GOTO 606
- ENDIF
- NAT2=NAT+NATA
- IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180
- IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182
-C
-C.......... DL generated by MUFPOT and RHOR given ..........
-C.......... by S. M. Goldberg, C. S. Fadley ..........
-C.......... and S. Kono, J. Electron Spectr. ..........
-C.......... Relat. Phenom. 21, 285 (1981) ..........
-C
- IF(ITL.EQ.0) THEN
- DO JAT=1,NAT2
- IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN
- READ(IUI3,102) RIEN
- READ(IUI3,102) RIEN
- READ(IUI3,102) RIEN
- ENDIF
- DO JE=1,NE
- IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121
- READ(IUI3,103) ENERGIE
- READ(IUI3,102) RIEN
- READ(IUI3,102) RIEN
- READ(IUI3,102) RIEN
- 121 CONTINUE
- DO L=0,LMAX(JAT,JE)
- READ(IUI2,7) VK(JE),TL(L,1,JAT,JE)
- TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,1.)*TL(L,1,
- &JAT,JE))
- ENDDO
- IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5
- DO LL=1,18
- READ(IUI3,104) RH1,RH2,DEF1,DEF2
- RHOR(JE,JAT,LL,1,1)=CMPLX(RH1)
- RHOR(JE,JAT,LL,2,1)=CMPLX(RH2)
- DLT(JE,JAT,LL,1)=CMPLX(DEF1)
- DLT(JE,JAT,LL,2)=CMPLX(DEF2)
- ENDDO
- 5 CONTINUE
- ENDDO
- ENDDO
- ELSE
-C
-C.......... TL and RHOR calculated by PHAGEN ..........
-C
- DO JE=1,NE
- NLG=INT(NAT2-0.0001)/4 +1
- IF(NE.GT.1) WRITE(IUO1,563) JE
- DO NN=1,NLG
- NRL=4*NN
- JD=4*(NN-1)+1
- IF(NN.EQ.NLG) NRL=NAT2
- READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL)
- WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL)
- ENDDO
- NL1=1
- DO JAT=1,NAT2
- NL1=MAX0(NL1,LMAX(JAT,1)+1)
- ENDDO
- IF(NL1.GT.NL_M) GOTO 184
- DO JAT=1,NAT2
- READ(IUI2,*) DUMMY
- DO L=0,LMAX(JAT,JE)
- IF(LMAX_MODE.EQ.0) THEN
- READ(IUI2,9) VK(JE),TLSTAR
- ELSE
- READ(IUI2,9) VK(JE),TLSTAR
- ENDIF
- TL(L,1,JAT,JE)=CONJG(TLSTAR)
- VK(JE)=CONJG(VK(JE))
- ENDDO
- ENDDO
-C
- IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333
- IF(JE.EQ.1) THEN
- DO JDUM=1,7
- READ(IUI3,102) RIEN
- ENDDO
- ENDIF
-C
-C Reading or regular (RHOR) and irregular (RHOI) radial integrals
-C
-C 1-2 : dipole terms
-C 3-5 : quadrupole terms
-C
- DO JEMET=1,NEMET
-C
- JM=IEMET(JEMET)
- READ(IUI3,105) RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHO
- &R5STAR
- RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR)
- RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR)
- RHOR(JE,JM,NNL,3,1)=CONJG(RHOR3STAR)
- RHOR(JE,JM,NNL,4,1)=CONJG(RHOR4STAR)
- RHOR(JE,JM,NNL,5,1)=CONJG(RHOR5STAR)
-C
- ENDDO
-C
- 333 VK(JE)=VK(JE)*A
- VK2(JE)=CABS(VK(JE)*VK(JE))
- ENDDO
- ENDIF
-C
- CLOSE(IUI2)
- CLOSE(IUI3)
-C
-C.......... Suppression of possible zeros in the TL array ..........
-C.......... (in case of the use of matrix inversion and ..........
-C.......... for energy variations) ..........
-C
- IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN
- CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL)
- ENDIF
- ENDIF
-C
-C.......... Reading of the TL and radial matrix elements files ..........
-C.......... (Coulomb excitation case) ..........
-C
- IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
- IERR=0
- IF(INTERACT.EQ.'COULOMB') THEN
- IRD1=IUI2
- IRD2=IUI3
- ELSEIF(INTERACT.EQ.'DIPCOUL') THEN
- IRD1=IUI7
- IRD2=IUI8
- ENDIF
- IF(SPECTRO.EQ.'APC') WRITE(IUO1,419)
- READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A
- IF(ISPIN.EQ.0) THEN
- IF(NAT1_A.EQ.1) THEN
- WRITE(IUO1,561)
- ELSE
- WRITE(IUO1,560) NAT1_A
- ENDIF
- ENDIF
- IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN
- READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A
- ENDIF
- IF(ITL_A.EQ.1) THEN
- READ(IRD2,107) LI_C2,LI_I2,LI_A2
- READ(IRD2,117) LE_MIN1,N_CHANNEL
- LE_MAX1=LE_MIN1+N_CHANNEL-1
- IF(I_TEST_A.NE.1) THEN
- IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO 610
- ELSE
- LI_C2=0
- LI_I2=1
- LI_A2=0
- LE_MIN1=1
- N_CHANNEL=1
- ENDIF
- ENDIF
- IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN
- NLG=INT(NAT1_A-0.0001)/4 +1
- DO NN=1,NLG
- NRL=4*NN
- JD=4*(NN-1)+1
- IF(NN.EQ.NLG) NRL=NAT1_A
- READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL)
- WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL)
- ENDDO
-C
-C Temporary storage of LMAX_A. Waiting for a version of PHAGEN
-C with LMAX_A dependent on the energy
-C
- DO JE=1,NE1_A
- DO JAT=1,NAT1_A
- LMAX_A(JAT,JE)=LMAX_A(JAT,1)
- ENDDO
- ENDDO
-C
- NL1_A=1
- DO JAT=1,NAT1_A
- NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1)
- ENDDO
- IF(NL1_A.GT.NL_M) GOTO 184
- ENDIF
- IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A
- IF(ISPIN.EQ.1) THEN
- READ(IRD2,106) L_IN_A,NATR_A,NER_A
- IF(LI_C.NE.L_IN_A) GOTO 606
- ENDIF
- NAT2_A=NAT+NATA
- NAT2=NAT2_A
- IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180
- IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) GOTO
- &182
-C
-C.......... DL generated by MUFPOT and RHOR given ..........
-C.......... by S. M. Goldberg, C. S. Fadley ..........
-C.......... and S. Kono, J. Electron Spectr. ..........
-C.......... Relat. Phenom. 21, 285 (1981) ..........
-C
- IF(ITL_A.EQ.0) THEN
- CONTINUE
- ELSE
-C
-C.......... TL_A and RHOR_A calculated by PHAGEN ..........
-C
- DO JE=1,NE_A
- NLG=INT(NAT2_A-0.0001)/4 +1
- IF(NE_A.GT.1) WRITE(IUO1,563) JE
- DO NN=1,NLG
- NRL=4*NN
- JD=4*(NN-1)+1
- IF(NN.EQ.NLG) NRL=NAT2_A
- READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL)
- WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL)
- ENDDO
- DO JAT=1,NAT2_A
- READ(IRD1,*) DUMMY
- DO L=0,LMAX_A(JAT,JE)
- IF(LMAX_MODE_A.EQ.0) THEN
- READ(IRD1,9) VK_A(JE),TLSTAR
- ELSE
- READ(IRD1,7) VK_A(JE),TLSTAR
- ENDIF
- TL_A(L,1,JAT,JE)=CONJG(TLSTAR)
- VK_A(JE)=CONJG(VK_A(JE))
- ENDDO
- ENDDO
-C
- IF(IFTHET_A.EQ.1) GOTO 331
- DO LE=LE_MIN,LE_MAX
- DO JEMET=1,NEMET
- JM=IEMET(JEMET)
- READ(IRD2,109) L_E,LB_MIN,LB_MAX
- IF(I_TEST_A.EQ.1) THEN
- L_E=1
- LB_MIN=0
- LB_MAX=1
- ENDIF
- IF(LE.NE.L_E) IERR=1
- L_BOUNDS(L_E,1)=LB_MIN
- L_BOUNDS(L_E,2)=LB_MAX
- DO LB=LB_MIN,LB_MAX
- READ(IRD2,108) L_A,RAD_D,RAD_E
- RHOR_A(LE,JM,L_A,1,1)=RAD_D
- RHOR_A(LE,JM,L_A,2,1)=RAD_E
- IF(I_TEST_A.EQ.1) THEN
- IF(LB.EQ.LB_MIN) THEN
- RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0)
- RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0)
- ELSEIF(LB.EQ.LB_MAX) THEN
- RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0)
- RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0)
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- 331 VK_A(JE)=VK_A(JE)*A
- VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE))
- ENDDO
- ENDIF
-C
- CLOSE(IRD1)
- CLOSE(IRD2)
-C
-C.......... Suppression of possible zeros in the TL array ..........
-C.......... (in case of the use of matrix inversion and ..........
-C.......... for energy variations) ..........
-C
- IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN
- CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL)
- ENDIF
- IF(SPECTRO.EQ.'APC') WRITE(IUO1,420)
-C
- ENDIF
-C
-C.......... Check of the consistency of the two TL and radial ..........
-C.......... matrix elements for APECS ..........
-C
- IF(SPECTRO.EQ.'APC') THEN
-C
- I_TL_FILE=0
- I_RD_FILE=0
-C
- IF(NAT1.NE.NAT1_A) I_TL_FILE=1
- IF(NE1.NE.NE1_A) I_TL_FILE=1
- IF(ITL.NE.ITL_A) I_TL_FILE=1
- IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1
-C
- IF(LI_C.NE.LI_C2) I_RD_FILE=1
- IF(LI_I.NE.LI_I2) I_RD_FILE=1
- IF(LI_A.NE.LI_A2) I_RD_FILE=1
-C
- IF(I_TL_FILE.EQ.1) GOTO 608
- IF(I_RD_FILE.EQ.1) GOTO 610
- IF(IERR.EQ.1) GOTO 610
-C
- ENDIF
-C
-C.......... Calculation of the scattering factor (only) ..........
-C
- IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8
- IF(IFTHET.EQ.1) THEN
- CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
- ELSEIF(IFTHET_A.EQ.1) THEN
-c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A)
- ENDIF
- WRITE(IUO1,57)
- STOP
-C
- 8 IF(IBAS.EQ.0) THEN
-C
-C............... Reading of an external cluster ...............
-C
-C
-C Cluster originating from CLUSTER_NEW.F : IPHA=0
-C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems)
-C Other cluster : the first line must be text; then
-C free format : Atomic number,X,Y,Z,number
-C of the corresponding prototypical atom ;
-C All atoms corresponding to the same
-C prototypical atom must follow each other.
-C Moreover, the blocks of equivalent atoms
-C must be ordered by increasing number of
-C prototypical atom.
-C
- VALZ_MIN=1000.0
- VALZ_MAX=-1000.0
-C
- OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD')
- READ(IUI4,778,ERR=892) IPHA
- GOTO 893
- 892 IPHA=3
- IF(UNIT.EQ.'ANG') THEN
- CUNIT=1./A
- TUNIT='ANGSTROEMS'
- ELSEIF(UNIT.EQ.'LPU') THEN
- CUNIT=1.
- TUNIT='UNITS OF THE LATTICE PARAMETER'
- ELSEIF(UNIT.EQ.'ATU') THEN
- CUNIT=BOHR/A
- TUNIT='ATOMIC UNITS'
- ELSE
- GOTO 890
- ENDIF
- 893 NATCLU=0
- DO JAT=1,NAT2
- NATYP(JAT)=0
- ENDDO
- IF(IPHA.EQ.0) THEN
- CUNIT=1.
- TUNIT='UNITS OF THE LATTICE PARAMETER'
- ELSEIF(IPHA.EQ.1) THEN
- CUNIT=BOHR/A
- TUNIT='ATOMIC UNITS'
- IEMET(1)=1
- ELSEIF(IPHA.EQ.2) THEN
- CUNIT=1./A
- TUNIT='ANGSTROEMS'
- IEMET(1)=1
- ENDIF
- IF(IPRINT.EQ.2) THEN
- IF(I_AT.NE.1) THEN
- WRITE(IUO1,558) IUI4,TUNIT
- IF(IPHA.EQ.3) WRITE(IUO1,549)
- ENDIF
- ENDIF
- JATM=0
- DO JLINE=1,10000
- IF(IPHA.EQ.0) THEN
- READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT
- ELSEIF(IPHA.EQ.1) THEN
- READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
- ELSEIF(IPHA.EQ.2) THEN
- READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
- ELSEIF(IPHA.EQ.3) THEN
- READ(IUI4,*,END=780) NN,X,Y,Z,JAT
- ENDIF
- JATM=MAX0(JAT,JATM)
- NATCLU=NATCLU+1
- IF(IPHA.NE.3) THEN
- CHEM(JAT)=R
- ELSE
- CHEM(JAT)='XX'
- ENDIF
- NZAT(JAT)=NN
- NATYP(JAT)=NATYP(JAT)+1
- COORD(1,NATCLU)=X*CUNIT
- COORD(2,NATCLU)=Y*CUNIT
- COORD(3,NATCLU)=Z*CUNIT
- VALZ(NATCLU)=Z*CUNIT
- IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN
- WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,NATCLU),COORD
- &(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT)
- ENDIF
- ENDDO
- 780 NBZ=NATCLU
- IF(JATM.NE.NAT) GOTO 514
- CLOSE(IUI4)
-C
- IF(NATCLU.GT.NATCLU_M) GOTO 510
- DO JA1=1,NATCLU
- DO JA2=1,NATCLU
- DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(COORD(2
- &,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**2)
- IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO 895
- ENDDO
- ENDDO
-C
- D_UP=VALZ_MAX-VALZ(1)
- D_DO=VALZ(1)-VALZ_MIN
- IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN
- I_INV=1
- ELSE
- I_INV=0
- ENDIF
- ELSE
-C
-C............... Construction of an internal cluster ...............
-C
- CALL BASE
- CALL ROTBAS(ROT)
- IF(IVG0.EQ.2) THEN
- NMAX=NIV+1
- ELSE
- NMAX=(2*NIV+1)**3
- ENDIF
- IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN
- WRITE(IUO1,37)
- WRITE(IUO1,38) NIV
- DO NUM=1,NMAX
- CALL NUMAT(NUM,NIV,IA,IB,IC)
- WRITE(IUO1,17) NUM,IA,IB,IC
- ENDDO
- WRITE(IUO1,39)
- ENDIF
- CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,NBZ,N
- &AT2,NCOUCH,NMAX)
- IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN
- CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,NCOUCH)
- &
- IF(IREL.EQ.1) THEN
- DO JP=1,NPLAN
- VAL(JP)=VAL2(JP)
- ENDDO
- ENDIF
- ENDIF
- ENDIF
-C
-C Storage of the extremal values of x and y for each plane. They define
-C the exterior of the cluster when a new cluster has to be build to
-C support a point-group
-C
- IF(I_GR.GE.1) THEN
- IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
- CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
- WRITE(IUO1,50) NPLAN
- DO K=1,NPLAN
- WRITE(IUO1,29) K,VAL(K)
- X_MAX(K)=0.
- X_MIN(K)=0.
- Y_MAX(K)=0.
- Y_MIN(K)=0.
- ENDDO
- ENDIF
- DO JAT=1,NATCLU
- X=COORD(1,JAT)
- Y=COORD(2,JAT)
- Z=COORD(3,JAT)
- DO JPLAN=1,NPLAN
- IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN
- X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN))
- X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN))
- Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN))
- Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN))
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-C
-C Instead of the symmetrization of the cluster (this version only)
-C
- N_PROT=NAT
- NAT_ST=0
- DO JTYP=1,JATM
- NB_AT=NATYP(JTYP)
- IF(NB_AT.GT.NAT_EQ_M) GOTO 614
- DO JA=1,NB_AT
- NAT_ST=NAT_ST+1
- NCORR(JA,JTYP)=NAT_ST
- ENDDO
- ENDDO
- DO JC=1,3
- DO JA=1,NATCLU
- SYM_AT(JC,JA)=COORD(JC,JA)
- ENDDO
- ENDDO
-C
-C Checking surface-like atoms for mean square displacements
-C calculations
-C
- CALL CHECK_VIB(NAT2)
-C
-C.......... Set up of the variables used for an internal ..........
-C.......... calculation of the mean free path and/or of ..........
-C.......... the mean square displacements ..........
-C
- IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN
- DO JTYP=1,NAT2
- XMT(JTYP)=XMAT(NZAT(JTYP))
- RHOT(JTYP)=RHOAT(NZAT(JTYP))
- ENDDO
- XMTA=XMT(1)
- RHOTA=RHOT(1)
- NZA=NZAT(1)
- ENDIF
- IF(IDCM.GT.0) THEN
- CALL CHNOT(3,VECBAS,VEC)
- DO J=1,3
- VB1(J)=VEC(J,1)
- VB2(J)=VEC(J,2)
- VB3(J)=VEC(J,3)
- ENDDO
- CPR=1.
- CALL PRVECT(VB2,VB3,VBS,CPR)
- VM=PRSCAL(VB1,VBS)
- QD=(6.*PI*PI*NAT/VM)**(1./3.)
- ENDIF
-C
-C.......... Writing of the contents of the cluster, ..........
-C.......... of the position of the different planes ..........
-C.......... and of their respective absorbers in ..........
-C.......... the control file IUO1 ..........
-C
- IF(I_AT.EQ.1) GOTO 153
- IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN
- WRITE(IUO1,40)
- NCA=0
- DO J=1,NAT
- DO I=1,NMAX
- NCA=NCA+1
- WRITE(IUO1,20) J,I
- WRITE(IUO1,21) (ATOME(L,NCA),L=1,3)
- K=IRE(NCA,1)
- IF(K.EQ.0) THEN
- WRITE(IUO1,22)
- ELSE
- WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2)
- ENDIF
- ENDDO
- ENDDO
- WRITE(IUO1,41)
- ENDIF
- IF(IBAS.EQ.1) THEN
- WRITE(IUO1,24)
- NATCLU=0
- DO I=1,NAT
- NN=NATYP(I)
- NATCLU=NATCLU+NATYP(I)
- WRITE(IUO1,26) NN,I
- ENDDO
- IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3
- WRITE(IUO1,782) NATCLU
- IF(NATCLU.GT.NATCLU_M) GOTO 516
- IF(IPRINT.EQ.3) WRITE(IUO1,559)
- IF(IPRINT.EQ.3) THEN
- NBTA=0
- DO JT=1,NAT2
- NBJT=NATYP(JT)
- DO JN=1,NBJT
- NBTA=NBTA+1
- WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),COORD(3,N
- &BTA),JT,JN,CHEM(JT)
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN
- CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56)
- ENDIF
- IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
- CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
- IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN
- DO K=1,NPLAN
- IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K)
- ENDDO
- ENDIF
-C
- IF(I_AT.EQ.0) WRITE(IUO1,30)
- IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN
- WRITE(IUO1,31) (IEMET(J),J=1,NEMET)
- ENDIF
- ZEM=1.E+20
- DO L=1,NPLAN
- Z=VAL(L)
- DO JEMED=1,NEMET
- CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93)
- IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET(3)
- IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3)
- GO TO 33
- 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM
- 33 CONTINUE
- ENDDO
- ENDDO
-C
-C.......... Loop on the electrons involved in the ..........
-C.......... spectroscopy : N_EL = 1 for PHD, XAS ..........
-C.......... LEED or AED and N_EL = 2 for APC ..........
-C
- DO J_EL=1,N_EL
-C
-C.......... Writing the information on the spectroscopies ..........
-C.......... in the control file IUO1 ..........
-C
- IF(SPECTRO.EQ.'XAS') GOTO 566
- IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,236)
- ELSE
- WRITE(IUO1,248)
- ENDIF
- ENDIF
- IF(ITHETA.EQ.1) WRITE(IUO1,245)
- IF(I_TEST.EQ.1) WRITE(IUO1,234)
- ENDIF
-C
-C---------- Photoelectron diffraction case (PHD) ----------
-C
- IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
- IF(SPECTRO.EQ.'PHD') THEN
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,35)
- ELSE
- WRITE(IUO1,246)
- ENDIF
- ENDIF
- IF(ITHETA.EQ.1) WRITE(IUO1,44)
- IF(IE.EQ.1) WRITE(IUO1,58)
- IF(INITL.EQ.0) WRITE(IUO1,118)
- IF(I_TEST.EQ.1) WRITE(IUO1,234)
- ENDIF
- IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
- WRITE(IUO1,418)
- WRITE(IUO1,18)
- ENDIF
- IF(J_EL.EQ.2) GOTO 222
- IF(IPRINT.GT.0) THEN
- WRITE(IUO1,92)
- WRITE(IUO1,91)
- IF(ISPIN.EQ.0) THEN
- WRITE(IUO1,335)
- ELSE
- WRITE(IUO1,336)
- ENDIF
- WRITE(IUO1,91)
- IF(IPOTC.EQ.0) THEN
- WRITE(IUO1,339)
- ELSE
- WRITE(IUO1,334)
- ENDIF
- WRITE(IUO1,91)
- IF(INITL.NE.0) THEN
- WRITE(IUO1,337)
- WRITE(IUO1,91)
- IF(IPOL.EQ.0) THEN
- WRITE(IUO1,88)
- ELSEIF(ABS(IPOL).EQ.1) THEN
- WRITE(IUO1,87)
- ELSEIF(IPOL.EQ.2) THEN
- WRITE(IUO1,89)
- ENDIF
- WRITE(IUO1,91)
- IF(IDICHR.GT.0) THEN
- WRITE(IUO1,338)
- ENDIF
- WRITE(IUO1,91)
- WRITE(IUO1,92)
- WRITE(IUO1,90)
- WRITE(IUO1,43) THLUM,PHILUM
- IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN
- WRITE(IUO1,45)
- ENDIF
- ENDIF
-C
- IF(INITL.EQ.2) THEN
- WRITE(IUO1,79) LI,LI-1,LI+1
- IF(I_SO.EQ.1) THEN
- WRITE(IUO1,80) S_O
- ENDIF
- DO JE=1,NE
- DO JEM=1,NEMET
- JTE=IEMET(JEM)
- IF(ISPIN.EQ.0) THEN
- WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,1,1),RHOR(JE,JTE
- &,NNL,2,1)
- IF(ITL.EQ.0) THEN
- WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1),DLT(JE,JTE,N
- &NL,2)
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ELSEIF(INITL.EQ.-1) THEN
- WRITE(IUO1,82) LI,LI-1
- IF(I_SO.EQ.1) THEN
- WRITE(IUO1,80) S_O
- ENDIF
- DO JE=1,NE
- DO JEM=1,NEMET
- JTE=IEMET(JEM)
- IF(ISPIN.EQ.0) THEN
- WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,1,1)
- IF(ITL.EQ.0) THEN
- WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,1)
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ELSEIF(INITL.EQ.1) THEN
- WRITE(IUO1,82) LI,LI+1
- IF(I_SO.EQ.1) THEN
- WRITE(IUO1,80) S_O
- ENDIF
- DO JE=1,NE
- DO JEM=1,NEMET
- JTE=IEMET(JEM)
- IF(ISPIN.EQ.0) THEN
- WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,2,1)
- IF(ITL.EQ.0) THEN
- WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,2)
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-C
- IF(I_AT.EQ.0) THEN
- IF(INV(J_EL).EQ.0) THEN
- IF(NDIF.EQ.1) THEN
- IF(ISPHER.EQ.1) THEN
- WRITE(IUO1,83)
- ELSEIF(ISPHER.EQ.0) THEN
- WRITE(IUO1,84)
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,97) NDIF
- ELSE
- WRITE(IUO1,98) NDIF
- ENDIF
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,122)
- ELSE
- WRITE(IUO1,120)
- ENDIF
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,85)
- ELSE
- WRITE(IUO1,86)
- ENDIF
- ENDIF
-C
- ENDIF
- 222 CONTINUE
- ENDIF
-C
-C---------- LEED case (LED) ----------
-C
- IF(SPECTRO.EQ.'LED') THEN
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,252)
- ELSE
- WRITE(IUO1,258)
- ENDIF
- ENDIF
- IF(ITHETA.EQ.1) WRITE(IUO1,254)
- IF(IE.EQ.1) WRITE(IUO1,256)
- IF(IPRINT.GT.0) THEN
- WRITE(IUO1,92)
- WRITE(IUO1,91)
- IF(ISPIN.EQ.0) THEN
- WRITE(IUO1,335)
- ELSE
- WRITE(IUO1,336)
- ENDIF
- WRITE(IUO1,91)
- IF(IPOTC.EQ.0) THEN
- WRITE(IUO1,339)
- ELSE
- WRITE(IUO1,334)
- ENDIF
- WRITE(IUO1,91)
- WRITE(IUO1,92)
- WRITE(IUO1,260)
- WRITE(IUO1,261) THLUM,PHILUM
- IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN
- WRITE(IUO1,45)
- ENDIF
-C
- IF(I_AT.EQ.0) THEN
- IF(INV(J_EL).EQ.0) THEN
- IF(NDIF.EQ.1) THEN
- IF(ISPHER.EQ.1) THEN
- WRITE(IUO1,83)
- ELSEIF(ISPHER.EQ.0) THEN
- WRITE(IUO1,84)
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,97) NDIF
- ELSE
- WRITE(IUO1,98) NDIF
- ENDIF
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,122)
- ELSE
- WRITE(IUO1,120)
- ENDIF
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,85)
- ELSE
- WRITE(IUO1,86)
- ENDIF
- ENDIF
-C
- ENDIF
- ENDIF
-C
-C---------- Auger diffraction case (AED) ----------
-C
- IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
- IF(SPECTRO.EQ.'AED') THEN
- IF(IPHI_A.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,235)
- ELSE
- WRITE(IUO1,247)
- ENDIF
- ENDIF
- IF(ITHETA_A.EQ.1) WRITE(IUO1,244)
- IF(I_TEST_A.EQ.1) WRITE(IUO1,234)
- ENDIF
- IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN
- WRITE(IUO1,419)
- WRITE(IUO1,18)
- ENDIF
- IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN
- IF(IPRINT.GT.0) THEN
- WRITE(IUO1,92)
- WRITE(IUO1,91)
- IF(ISPIN.EQ.0) THEN
- WRITE(IUO1,335)
- ELSE
- WRITE(IUO1,336)
- ENDIF
- WRITE(IUO1,91)
- IF(IPOTC_A.EQ.0) THEN
- WRITE(IUO1,339)
- ELSE
- WRITE(IUO1,334)
- ENDIF
- WRITE(IUO1,91)
- WRITE(IUO1,92)
- WRITE(IUO1,95) AUGER
- CALL AUGER_MULT
- IF(I_MULT.EQ.0) THEN
- WRITE(IUO1,154)
- ELSE
- WRITE(IUO1,155) MULTIPLET
- ENDIF
-C
- DO JEM=1,NEMET
- JTE=IEMET(JEM)
- WRITE(IUO1,112) JTE
- DO LE=LE_MIN,LE_MAX
- WRITE(IUO1,119) LE
- LA_MIN=L_BOUNDS(LE,1)
- LA_MAX=L_BOUNDS(LE,2)
- DO LA=LA_MIN,LA_MAX
- IF(ISPIN.EQ.0) THEN
- WRITE(IUO1,115) LA,RHOR_A(LE,JTE,LA,1,1),RHOR_A(LE
- &,JTE,LA,2,1)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-C
- IF(I_AT.EQ.0) THEN
- IF(INV(J_EL).EQ.0) THEN
- IF(NDIF.EQ.1) THEN
- IF(ISPHER.EQ.1) THEN
- WRITE(IUO1,83)
- ELSEIF(ISPHER.EQ.0) THEN
- WRITE(IUO1,84)
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,97) NDIF
- ELSE
- WRITE(IUO1,98) NDIF
- ENDIF
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,122)
- ELSE
- WRITE(IUO1,120)
- ENDIF
- ENDIF
- ELSE
- IF(ISPHER.EQ.0) THEN
- WRITE(IUO1,85)
- ELSE
- WRITE(IUO1,86)
- ENDIF
- ENDIF
-C
- ENDIF
- ENDIF
- ENDIF
-C
-C.......... Check of the dimensioning of the treatment routine ..........
-C
- CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,NPH
- &I_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
-C
-C.......... Call of the subroutine performing either ..........
-C.......... the PhD, LEED, AED, EXAFS or APECS calculation ..........
-C
- 566 IF(ISPIN.EQ.0) THEN
- IF(SPECTRO.EQ.'PHD') THEN
- CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,NATC
- &LU,NFICHLEC,JFICH,NP)
- ELSEIF(SPECTRO.EQ.'LED') THEN
-c CALL LEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
-c 1 NATCLU,NFICHLEC,JFICH,NP)
- ELSEIF(SPECTRO.EQ.'AED') THEN
-c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
-c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
- ELSEIF(SPECTRO.EQ.'XAS') THEN
-c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
- ELSEIF(SPECTRO.EQ.'APC') THEN
-c IF(J_EL.EQ.1) THEN
-c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
-c 1 NATCLU,NFICHLEC,JFICH,NP)
-c ELSEIF(J_EL.EQ.2) THEN
-c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
-c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
-c ENDIF
- ENDIF
- ELSEIF(ISPIN.EQ.1) THEN
-c IF(SPECTRO.EQ.'PHD') THEN
-c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
-c 1 NATCLU,NFICHLEC,JFICH,NP)
-c ELSEIF(SPECTRO.EQ.'AED') THEN
-c CALL AEDDIF_SP
-c ELSEIF(SPECTRO.EQ.'XAS') THEN
-c CALL XASDIF_SP
-c ENDIF
- continue
- ENDIF
-C
-C.......... End of the MS calculation : ..........
-C.......... direct exit or treatment of the results ..........
-C
-C
-C.......... End of the loop on the electrons ..........
-C
- ENDDO
-C
- IF(SPECTRO.EQ.'PHD') THEN
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,52)
- ELSE
- WRITE(IUO1,249)
- ENDIF
- ENDIF
- IF(ITHETA.EQ.1) WRITE(IUO1,49)
- IF(IE.EQ.1) WRITE(IUO1,59)
- ELSEIF(SPECTRO.EQ.'LED') THEN
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,253)
- ELSE
- WRITE(IUO1,259)
- ENDIF
- ENDIF
- IF(ITHETA.EQ.1) WRITE(IUO1,255)
- IF(IE.EQ.1) WRITE(IUO1,257)
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- WRITE(IUO1,51)
- ELSEIF(SPECTRO.EQ.'AED') THEN
- IF(IPHI_A.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,237)
- ELSE
- WRITE(IUO1,250)
- ENDIF
- ENDIF
- IF(ITHETA_A.EQ.1) WRITE(IUO1,238)
- ELSEIF(SPECTRO.EQ.'APC') THEN
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,239)
- ELSE
- WRITE(IUO1,251)
- ENDIF
- ENDIF
- IF(ITHETA.EQ.1) WRITE(IUO1,240)
- ENDIF
-C
- CLOSE(ICOM)
- IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
- WRITE(IUO1,562)
- ENDIF
- IF(ISOM.EQ.0) CLOSE(IUO2)
-C! IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
-C
-C.......... End of the loop on the data files ..........
-C
- ENDDO
-C
- IF(ISOM.NE.0) THEN
- JFF=1
- IF(ISPIN.EQ.0) THEN
- IF(SPECTRO.NE.'XAS') THEN
- CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP)
- ELSE
-c CALL TREAT_XAS(ISOM,NFICHLEC,NP)
- ENDIF
- ELSEIF(ISPIN.EQ.1) THEN
-c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
-c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP)
-c ELSEIF(SPECTRO.EQ.'XAS') THEN
-c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP)
-c ENDIF
- continue
- ENDIF
- ENDIF
-C
-C! IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
- IF(ISOM.NE.0) CLOSE(IUO2)
-C STOP
- GOTO 999
-C
- 1 WRITE(IUO1,60)
- STOP
- 2 WRITE(IUO1,61)
- STOP
- 55 WRITE(IUO1,65)
- STOP
- 56 WRITE(IUO1,64)
- STOP
- 74 WRITE(IUO1,75)
- STOP
- 99 WRITE(IUO1,100)
- STOP
- 180 WRITE(IUO1,181)
- STOP
- 182 WRITE(IUO1,183)
- STOP
- 184 WRITE(IUO1,185)
- STOP
- 504 WRITE(IUO1,505)
- STOP
- 510 WRITE(IUO1,511) IUI4
- STOP
- 514 WRITE(IUO1,515)
- STOP
- 516 WRITE(IUO1,517)
- STOP
- 518 WRITE(IUO1,519)
- WRITE(IUO1,889)
- STOP
- 520 WRITE(IUO1,521)
- STOP
- 540 WRITE(IUO1,541)
- STOP
- 550 WRITE(IUO1,551)
- STOP
- 570 WRITE(IUO1,571)
- STOP
- 580 WRITE(IUO1,581)
- STOP
- 590 WRITE(IUO1,591)
- STOP
- 600 WRITE(IUO1,601)
- STOP
- 602 WRITE(IUO1,603)
- STOP
- 604 WRITE(IUO1,605)
- STOP
- 606 WRITE(IUO1,607)
- STOP
- 608 WRITE(IUO1,609)
- STOP
- 610 WRITE(IUO1,611)
- STOP
- 614 WRITE(IUO1,615) NB_AT
- STOP
- 620 WRITE(IUO1,621) LE_MAX
- STOP
- 630 WRITE(IUO1,631)
- STOP
- 890 WRITE(IUO1,891)
- STOP
- 895 WRITE(IUO1,896) JA1,JA2
-C
- 3 FORMAT(5(5X,I4))
- 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9)
- 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6)
- 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',':
- &(',I3,',',I3,',',I3,')')
- 18 FORMAT(' ',/)
- 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5)
- 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,',
- &',F7.3,')')
- 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER')
- 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,'
- &,',F7.3,')',5X,'NEW NUMBER : ',I4)
- 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/)
- 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2)
- 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3)
- 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/)
- 31 FORMAT(38X,10(I2,3X),//)
- 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS P
- &OSITIONED AT (',F7.3,',',F7.3,',',F7.3,')')
- 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL PHOTO
- &ELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
- 36 FORMAT(/////,'########## BEGINNING ', 'OF THE EX
- &AFS CALCULATION ##########',/////)
- 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE A
- &TOMS GENERATED +++++++++++++++++++')
- 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///)
- 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++',
- &'++++++++++++++++++++++++++++++++',/////)
- 40 FORMAT(/////,'======================', ' CONTENTS OF THE RE
- &DUCED CLUSTER ======================',///)
- 41 FORMAT(///,'====================================================',
- &'============================',/////)
- 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,'
- &DEGREES')
- 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR PHOTOELECTR
- &ON DIFFRACTION CALCULATION #####', '#####',/////)
- 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE SURF
- &ACE)')
- 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON DIFFRA
- &CTION CALCULATION ##########')
- 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :')
- 51 FORMAT(/////,'########## END OF THE ', 'EXAFS CALCU
- &LATION ##########')
- 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON DI
- &FFRACTION CALCULATION #####','#####')
- 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE')
- 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE STRUCTURE
- & OSCILLATIONS CALCULATION #####', '#####',/////)
- 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE OSCILLATI
- &ONS CALCULATION #####','#####')
- 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M)
- &- CHECK THE DIMENSIONING >>>>>>>>>>')
- 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', '
- & >>>>>>>>>>')
- 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ','CLUST
- &ER HAS NOT CONVERGED YET >>>>>>>>>>')
- 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ',
- &'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>')
- 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ',
- & 'IN MAIN ET READ_DATA >>>>>>>>>>')
- 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ',
- & I1,',',I1,/)
- 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',A3
- &,')',//)
- 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)')
- 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1)
- 83 FORMAT(//,32X,'(SPHERICAL WAVES)')
- 84 FORMAT(//,34X,'(PLANE WAVES)')
- 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)')
- 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)')
- 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +')
- 88 FORMAT(24X,'+ NON POLARIZED LIGHT +')
- 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +')
- 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/)
- 91 FORMAT(24X,'+',35X,'+')
- 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++')
- 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS PR
- &ESENT IN THIS PLANE')
- 95 FORMAT(////,31X,'AUGER LINE :',A6,//)
- 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')')
- &
- 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',I1,
- &')')
- 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE',' >>
- &>>>>>>>>')
- 101 FORMAT(24X,I3,24X,I3)
- 102 FORMAT(A1)
- 103 FORMAT(31X,F7.2)
- 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5)
- 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,E1
- &2.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9)
- 106 FORMAT(12X,I3,12X,I3,12X,I3)
- 107 FORMAT(5X,I2,5X,I2,5X,I2)
- 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5)
- 109 FORMAT(5X,I2,12X,I2,11X,I2)
- 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
- & :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//)
- 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
- &: (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')')
- 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
- &: ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)',/,
- &8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//)
- 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ',
- * 'TYPE ',I2,' : (',F8.5,',',F8.5,')')
- 114 FORMAT(/)
- 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.5
- &,')')
- 117 FORMAT(12X,I2,5X,I2)
- 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/)
- 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE INTEGRAL'
- &)
- 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ','I
- &NVERSION)')
- 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ','INVER
- &SION)')
- 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4)
- 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,'
- &',/,' ')
- 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ','LINE'
- &,' ',/,' ',/,' ')
- 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A
- &ND PHASE SHIFTS FILES >>>>>>>>>>')
- 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A
- &ND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>')
- 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ','FILE
- & >>>>>>>>>>')
- 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX ELEME
- &NTS TAKEN INTO ACCOUNT <-----',///)
- 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL AUGER
- & DIFFRACTION CALCULATION #####', '#####',/////)
- 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL APECS
- & DIFFRACTION CALCULATION #####', '#####',/////)
- 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER DIFFR
- &ACTION CALCULATION #####', '#####',/////)
- 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER DIFFRACT
- &ION CALCULATION #####', '#####',/////)
- 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS DIFFR
- &ACTION CALCULATION #####', '#####',/////)
- 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS DIFFRACT
- &ION CALCULATION #####', '#####',/////)
- 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER DI
- &FFRACTION CALCULATION #####', '#####',/////)
- 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS DI
- &FFRACTION CALCULATION #####', '#####',/////)
- 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE PHOT
- &OELECTRON DIFFRACTION CALCULATION ','##########',/////)
- 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE AUGE
- &R DIFFRACTION CALCULATION ', '##########',/////)
- 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE APEC
- &S DIFFRACTION CALCULATION ', '##########',/////)
- 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON D
- &IFFRACTION CALCULATION #####','#####')
- 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER DIFF
- &RACTION CALCULATION #####', '#####',/////)
- 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS DIFF
- &RACTION CALCULATION #####', '#####',/////)
- 252 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL LEED
- &CALCULATION #####', '#####',/////)
- 253 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL LEED CALCUL
- &ATION #####', '#####',/////)
- 254 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR LEED CAL
- &CULATION #####', '#####',/////)
- 255 FORMAT(/////,6X,'########## END ', 'OF THE POLAR LEED CALCULATI
- &ON #####', '#####',/////)
- 256 FORMAT(/////,5X,'########## BEGINNING ', 'OF THE ENERGY LEED CA
- &LCULATION #####', '#####',/////)
- 257 FORMAT(/////,5X,'########## END ', 'OF THE ENERGY LEED CALCULAT
- &ION #####', '#####',/////)
- 258 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE LEED
- & CALCULATION ', '##########',/////)
- 259 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE LEED CALCULATIO
- &N #####','#####')
- 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/)
- 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ',F6.2,' DE
- &GREES')
- 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +')
- 335 FORMAT(24X,'+ STANDARD +')
- 336 FORMAT(24X,'+ SPIN-POLARIZED +')
- 337 FORMAT(24X,'+ WITH +')
- 338 FORMAT(24X,'+ IN DICHROIC MODE +')
- 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +')
- 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','-----
- &-------------------')
- 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','-----
- &-------------------')
- 420 FORMAT(///,9X,'----------------------------------------------','--
- &--------------------')
- 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(',
- &F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')')
- 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.5
- &,',',F8.5,')')
- 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE DIME
- &NSIONING >>>>>>>>>>')
- 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ','CONSIS
- &TENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' >>>>>>>>>>')
- 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ','N
- &AT IN THE DATA AND CLUSTER FILES >>>>>>>>>>')
- 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ','
- &IBWD >>>>>>>>>>')
- 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT',' CONSIS
- &TENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE >>>>>>>>>>
- &')
- 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH',
- &' THE VALUE OF LI >>>>>>>>>>')
- 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4)
- 535 FORMAT(29X,F8.5,1X,F8.5)
- 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ','CORR
- &ESPOND TO NAT >>>>>>>>>>')
- 543 FORMAT(5X,F12.9,5X,F12.9)
- 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM'
- &,/)
- 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ','CORRES
- &POND TO NAT >>>>>>>>>>')
- 555 FORMAT(4(7X,I2))
- 556 FORMAT(28X,4(I2,5X))
- 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,A2)
- &
- 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' :
- &',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,'A
- &TOM',/)
- 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' N
- &o ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/)
- 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL A
- &TOMS : ',//)
- 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM :
- & ',//)
- 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',13X
- &,'oooooooooooooooo',///)
- 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/)
- 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ','CORR
- &ESPOND TO NAT >>>>>>>>>>')
- 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD A
- &ND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>')
- 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT CON
- &SISTENT WITH THE INPUT DATA FILE >>>>>>>>>>')
- 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ','>
- &>>>>>>>>>',//)
- 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ',
- &'.inc FILE >>>>>>>>>>',//)
- 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ','>>>>
- &>>>>>>',//)
- 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ',
- &'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS FILE
- & >>>>>>>>>>',//)
- 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ','>>>
- &>>>>>>>',//)
- 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ','ELECTR
- &ON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',17X,'WITH T
- &HE INPUT DATA FILE ',16X,'>>>>>>>>>>',//)
- 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ','TH
- &E DIMENSIONNING FILE >>>>>>>>>>',//)
- 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ','
- &THE DIMENSIONNING FILE >>>>>>>>>>',//)
- 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ','THE
- &DIMENSIONNING FILE >>>>>>>>>>',//)
- 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE IDE
- &NTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH ELECTRONS IN
- & CLUSTER ROTATION MODE',' >>>>>>>>>>',//)
- 776 FORMAT(I2)
- 777 FORMAT(A24)
- 778 FORMAT(30X,I1)
- 779 FORMAT(11X,A2,5X,I2,3F10.4,I5)
- 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,' ATOMS
- &')
- 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M >>
- &>>>>>>>>')
- 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''','UNIT
- &S >>>>>>>>>>')
- 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' AT
- &OMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' ARE
- & IDENTICAL >>>>>>>>>>')
-C
- 999 END
-C
-C=======================================================================
-C
- SUBROUTINE AMAS(NIV,ATOME,COORD,VALZ,ISURF,COUPUR,ROT,IRE,NATYP,NB
- &Z,NAT2,NCOUCH,NMAX)
-C
-C This routine generates a cluster from the knowledge of its
-C lattice vectors
-C
- USE DIM_MOD
-C
- USE ADSORB_MOD , NCOUCH1 => NCOUCH
- USE BASES_MOD
- USE MILLER_MOD , IM1 => IH, IM2 => IK, IM3 => II, IM4 => IL
- USE OUTUNITS_MOD
- USE RESEAU_MOD
-C
- DIMENSION VALZ(NATCLU_M)
- DIMENSION ROT(3,3),IRE(NATCLU_M,2),NATYP(NATM),ITA(NATCLU_M)
- DIMENSION ATOME(3,NATCLU_M),ATRSU(3,NATCLU_M),COORD(3,NATCLU_M)
- DIMENSION ROTINV(3,3),XINIT(3,1),XFIN(3,1)
-C
-C
-C
- NCOUCH=0
- WRITE(IUO1,10) ISURF
- 10 FORMAT(//,18X,'ATOM (0,0,0) ON THE SURFACE PLANE IS OF TYPE ',I2)
- NBZ=0
- CALL INVMAT(ROT,ROTINV)
- IF(IVG0.EQ.0) THEN
- CALL CHBASE(NATP_M,ATBAS)
- ENDIF
- NB1=0
- NB2=0
- DO NTYP=1,NAT
- NBAT=0
- DO NUM=1,NMAX
- NB1=NB1+1
- IRE(NB1,1)=0
- IRE(NB1,2)=0
- IF(IVG0.LE.1) THEN
- CALL NUMAT(NUM,NIV,IA,IB,IC)
- ELSE
- BSURA=1.
- CSURA=1.
- ENDIF
- IF(IVG0.LE.1) THEN
- XA=FLOAT(IA)
- XB=FLOAT(IB)
- XC=FLOAT(IC)
- ELSEIF(IVG0.EQ.2) THEN
- XA=FLOAT(NUM-1)
- XB=FLOAT(NUM-1)
- XC=FLOAT(NUM-1)
- ENDIF
- IF(IVG0.EQ.1) THEN
- IF(IVN(1).EQ.0) THEN
- ITA(NUM)=IA
- ELSEIF(IVN(2).EQ.0) THEN
- ITA(NUM)=IB
- ELSEIF(IVN(3).EQ.0) THEN
- ITA(NUM)=IC
- ENDIF
- IF((ITA(NUM).EQ.ITA(NUM-1)).AND.(NUM.GT.1)) GOTO 30
- ENDIF
- DO J=1,3
- K=J+3*(NTYP-1)
- O=ATBAS(K)
- ATOME(J,NB1)=O+XA*VECBAS(J)+XB*VECBAS(J+3)+XC*VECBAS(J+6)
- ENDDO
- DO I=1,3
- M=I+3*(ISURF-1)
- XINIT(I,1)=ATOME(I,NB1)-ATBAS(M)
- ENDDO
- CALL MULMAT(ROTINV,3,3,XINIT,3,1,XFIN)
- DO I=1,3
- ATRSU(I,NB1)=XFIN(I,1)
- ENDDO
- CALL TEST1(COUPUR,NB1,NB2,ATRSU,COORD,VALZ,NBAT,IRE,NBZ)
- 30 CONTINUE
- ENDDO
- NATYP(NTYP)=NBAT
- ENDDO
- IF(IADS.GE.1) THEN
- N0=NBZ
- DO JADS=1,NADS1
- NB1=NB1+1
- DO I=1,3
- COORD(I,NB1)=ADS(I,JADS)
- ENDDO
- N1=0
- DO N=1,N0
- D=ABS(COORD(3,NB1)-VALZ(N))
- IF(D.LT.0.0001) N1=N1+1
- ENDDO
- IF(N1.EQ.0) THEN
- N0=N0+1
- VALZ(N0)=COORD(3,NB1)
- ENDIF
- ENDDO
- NANEW1=NADS1+NADS2
- NATYP(NAT+1)=NADS1
- IF(NANEW1.EQ.NADS1) GOTO 99
- DO JADS=NADS1+1,NANEW1
- NB1=NB1+1
- DO I=1,3
- COORD(I,NB1)=ADS(I,JADS)
- ENDDO
- N1=0
- DO N=1,N0
- D=ABS(COORD(3,NB1)-VALZ(N))
- IF(D.LT.0.0001) N1=N1+1
- ENDDO
- IF(N1.EQ.0) THEN
- N0=N0+1
- VALZ(N0)=COORD(3,NB1)
- ENDIF
- ENDDO
- NATYP(NAT+2)=NADS2
- NANEW2=NANEW1+NADS3
- IF(NANEW2.EQ.NANEW1) GOTO 99
- DO JADS=NANEW1+1,NANEW2
- NB1=NB1+1
- DO I=1,3
- COORD(I,NB1)=ADS(I,JADS)
- ENDDO
- N1=0
- DO N=1,N0
- D=ABS(COORD(3,NB1)-VALZ(N))
- IF(D.LT.0.0001) N1=N1+1
- ENDDO
- IF(N1.EQ.0) THEN
- N0=N0+1
- VALZ(N0)=COORD(3,NB1)
- ENDIF
- ENDDO
- NATYP(NAT+3)=NADS3
- 99 CONTINUE
- NCOUCH=N0-NBZ
- NBZ=N0
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE BASE
-C
-C This routine generates the lattice basis vectors for a given Bravais
-C lattice NCRIST centered according to NCENTR
-C
- USE DIM_MOD
- USE BASES_MOD
- USE CRANGL_MOD
- USE OUTUNITS_MOD
- USE RESEAU_MOD
- USE VECSYS_MOD
-C
- CHARACTER*15 BRAV(8),CENT(7)
- CHARACTER*31 RESEAU
-C
-C
- DIMENSION CUB(9),MNC(9),TCN(9),TRG(9),HEX(9)
-C
-C
-C
- DATA CUB /1.,0.,0., 0.,1.,0., 0.,0.,1./
- DATA MNC /1.,0.,1., 0.,1.,0., 0.,0.,1./
- DATA TCN /1.,0.,1., 1.,1.,1., 0.,0.,1./
- DATA TRG /0.,1.,1., -0.866025,-0.5,1., 0.866025,-0.5,1./
- DATA HEX /1.,0.,0., -0.5,0.866025,0., 0.,0.,1./
- DATA PIS180 /0.017453/
- DATA BRAV /' CUBIQUE',' TETRAGONAL',' ORTHORHOMBIQUE','
- & MONOCLINIQUE',' TRICLINIQUE',' TRIGONAL',' HEXAGO
- &NAL',' EXTERNE'/
- DATA CENT /' ','CENTRE',' FACES CENTREES','(RHOMBOEDRIQUE)',' FACE
- & A CENTREE',' FACE B CENTREE',' FACE C CENTREE'/
-C
- ALPHAR=ALPHAD*PIS180
- BETAR=BETAD*PIS180
- GAMMAR=GAMMAD*PIS180
- NAT3=NAT*3
- GO TO (1,1,1,2,3,4,5,6) NCRIST
-C
- 1 DO I=1,9
- VECBAS(I)=CUB(I)
- ENDDO
- IF(NCRIST.NE.1) THEN
- VECBAS(9)=CSURA
- IF(NCRIST.EQ.3) THEN
- VECBAS(5)=BSURA
- ENDIF
- ENDIF
- GO TO 6
-C
- 2 DO I=1,9
- VECBAS(I)=MNC(I)
- ENDDO
- VECBAS(1)=SIN(BETAR)
- VECBAS(3)=COS(BETAR)
- VECBAS(5)=BSURA
- VECBAS(9)=CSURA
- GO TO 6
-C
- 3 DO I=1,9
- VECBAS(I)=TCN(I)
- ENDDO
- VECBAS(1)=SIN(BETAR)
- VECBAS(3)=COS(BETAR)
- A2Y=(COS(GAMMAR)-COS(ALPHAR)*COS(BETAR))/SIN(BETAR)
- VECBAS(4)=BSURA*A2Y
- VECBAS(5)=BSURA*SQRT(SIN(ALPHAR)*SIN(ALPHAR)-A2Y*A2Y)
- VECBAS(6)=BSURA*COS(ALPHAR)
- VECBAS(9)=CSURA
- GO TO 6
-C
- 4 IF(((NCENTR.EQ.4).AND.(CSURA.NE.1.)).OR.(NCENTR.EQ.1)) GO TO 5
- ETA=-2.*SIN(ALPHAR/2.)/SQRT(3.)
- DZETA=SQRT(1.-ETA*ETA)
- DO I=1,3
- J=I+2*(I-1)
- J1=J+1
- J2=J+2
- VECBAS(J)=TRG(J)*ETA
- VECBAS(J1)=TRG(J1)*ETA
- VECBAS(J2)=TRG(J2)*DZETA
- ENDDO
- GO TO 6
-C
- 5 DO I=1,9
- VECBAS(I)=HEX(I)
- ENDDO
- VECBAS(9)=CSURA
-C
- 6 DO I=1,3
- ASYS(I)=VECBAS(I)
- BSYS(I)=VECBAS(I+3)
- CSYS(I)=VECBAS(I+6)
- ENDDO
- DCA=ABS(CSURA-1.)
- IF((NCRIST.EQ.6).AND.(DCA.LT.0.0001)) GO TO 8
- IF(NCRIST.EQ.8) GO TO 8
- IF(NCENTR.GT.1) THEN
- CALL CENTRE(VECBAS)
- IF(NCENTR.EQ.4) THEN
- DO I=1,9
- VECBAS(I)=VECBAS(I)*SQRT((1.-CSURA*CSURA)*3.)
- ENDDO
- DO I=1,3
- ASYS(I)=VECBAS(I)
- BSYS(I)=VECBAS(I+3)
- CSYS(I)=VECBAS(I+6)
- ENDDO
- ENDIF
- ENDIF
-C
- 8 RESEAU=BRAV(NCRIST)//' '//CENT(NCENTR)
- WRITE(IUO1,80) RESEAU,NAT
- WRITE(IUO1,81) (VECBAS(I),I=1,9)
- WRITE(IUO1,82)
- WRITE(IUO1,83) (ATBAS(I),I=1,NAT3)
-C
- 80 FORMAT(////,10X,'RESEAU CRISTALLIN DE TYPE : ',A29,/,16X,
- * 'CONTENANT',I3,' ATOMES DANS LA MAILLE ELEMENTAIRE',//)
- 81 FORMAT(28X,'VECTEURS GENERATEURS :',//,26X,'A1 = (',F6.3,',',
- *F6.3,',',F6.3,')',/,26X,'A2 = (',F6.3,',',F6.3,',',F6.3,')',/,
- *26X,'A3 = (',F6.3,',',F6.3,',',F6.3,')')
- 82 FORMAT(/,21X,'POSITIONS DES ATOMES DANS LA MAILLE :',/)
- 83 FORMAT(29X,'(',F6.3,',',F6.3,',',F6.3,')')
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE CENTRE(VECBAS)
-C
-C This routine modifies the Bravais lattice basis vectors according to
-C the way the lattice is centered
-C
- USE RESEAU_MOD
-C
- DIMENSION VECBAS(9),V1(9)
-C
-C
-C
- DO I=1,9
- V1(I)=VECBAS(I)
- ENDDO
- N1=NCENTR-1
- GO TO (2,3,4,5,6,7) N1
-C
- 2 DO I=1,3
- VECBAS(I)=-0.5*V1(I)+0.5*V1(I+3)+0.5*V1(I+6)
- VECBAS(I+3)=0.5*V1(I)-0.5*V1(I+3)+0.5*V1(I+6)
- VECBAS(I+6)=0.5*V1(I)+0.5*V1(I+3)-0.5*V1(I+6)
- ENDDO
- GO TO 8
-C
- 3 DO I=1,3
- VECBAS(I)=0.5*(V1(I+3)+V1(I+6))
- VECBAS(I+3)=0.5*(V1(I)+V1(I+6))
- VECBAS(I+6)=0.5*(V1(I)+V1(I+3))
- ENDDO
- GO TO 8
-C
- 4 DO I=1,3
- VECBAS(I)=(2./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6)
- VECBAS(I+3)=(-1./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6)
- VECBAS(I+6)=(-1./3.)*V1(I)-(2./3.)*V1(I+3)+(1./3.)*V1(I+6)
- ENDDO
- DO I=1,3
- VECBAS(3*I)=VECBAS(3*I)*SQRT(3./(1.-CSURA*CSURA))
- ENDDO
- GO TO 8
-C
- 5 DO I=1,3
- VECBAS(I+6)=0.5*(V1(I+3)+V1(I+6))
- ENDDO
- GO TO 8
-C
- 6 DO I=1,3
- VECBAS(I+6)=0.5*(V1(I)+V1(I+6))
- ENDDO
- GO TO 8
-C
- 7 DO I=1,3
- VECBAS(I+3)=0.5*(V1(I)+V1(I+3))
- ENDDO
-C
- 8 RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE CHBASE(NAT,ATBAS)
-C
- USE VECSYS_MOD
-C
- DIMENSION ATBAS(3*NAT),BASVEC(3,3),BAS1(1,3),BAS2(1,3)
-C
- DO J=1,3
- BASVEC(1,J)=ASYS(J)
- BASVEC(2,J)=BSYS(J)
- BASVEC(3,J)=CSYS(J)
- ENDDO
-C
- DO JAT=1,NAT
- DO J=1,3
- K=J+3*(JAT-1)
- BAS1(1,J)=ATBAS(K)
- ENDDO
- CALL MULMAT(BAS1,1,3,BASVEC,3,3,BAS2)
- DO J=1,3
- K=J+3*(JAT-1)
- ATBAS(K)=BAS2(1,J)
- ENDDO
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE CHNOT(NVEC,VEC1,VEC2)
-C
-C This routine linearizes the storage of a two index array
-C
- DIMENSION VEC1(3*NVEC),VEC2(3,NVEC)
-C
- DO J=1,NVEC
- DO I=1,3
- VEC2(I,J)=VEC1(I+3*(J-1))
- ENDDO
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE INVMAT(B,BINV)
-C
- USE OUTUNITS_MOD
- DIMENSION B(3,3),BINV(3,3)
-C
-C
- A1=B(1,1)*B(2,2)*B(3,3)
- A2=B(2,1)*B(3,2)*B(1,3)
- A3=B(3,1)*B(1,2)*B(2,3)
- A4=B(1,1)*B(3,2)*B(2,3)
- A5=B(2,1)*B(1,2)*B(3,3)
- A6=B(3,1)*B(2,2)*B(1,3)
- DET=A1+A2+A3-A4-A5-A6
-C
- IF(ABS(DET).LT.0.0001) GO TO 10
-C
- DO I=1,3
- DO J=1,3
- DO K=1,3
- L=(I-J)*(I-K)*(J-K)
- IF(L.NE.0) THEN
- XNUM1=B(J,J)*B(K,K)-B(J,K)*B(K,J)
- XNUM2=B(I,K)*B(K,J)-B(K,K)*B(I,J)
- BINV(I,I)=XNUM1/DET
- BINV(I,J)=XNUM2/DET
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- GO TO 50
-C
- 10 WRITE(IUO1,60)
-C
- 60 FORMAT(5X,'NON INVERTIBLE MATRIX')
-C
- 50 CONTINUE
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE MULMAT(A1,IL1,IC1,A2,IL2,IC2,A3)
-C
-C This routine performs the matrix multiplication of A1(IL1,IC1) by
-C A2(IL2,IC2) with the result stored in A3(IL1,IC2)
-C
- USE OUTUNITS_MOD
- DIMENSION A1(IL1,IC1),A2(IL2,IC2),A3(IL1,IC2)
-C
-C
- IF(IC1.NE.IL2) THEN
- WRITE(IUO1,10)
- ELSE
- DO I=1,IL1
- DO J=1,IC2
- A3(I,J)=0.
- DO K=1,IC1
- A3(I,J)=A3(I,J)+A1(I,K)*A2(K,J)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-C
- 10 FORMAT(5X,'THESE MATRICES CANNOT BE MULTIPLIED')
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE NUMAT(NUM,NIVA,IL,IM,IN)
-C
- USE OUTUNITS_MOD
- DIMENSION I(100)
-C
-C
- L=2*NIVA+1
- IF(L.GT.100) THEN
- WRITE(IUO1,5)
- STOP
- ENDIF
- L1=NIVA+1
-C
- DO K=1,L
- IF(K.LE.L1) THEN
- I(K)=K-1
- ELSE
- I(K)=L1-K
- ENDIF
- ENDDO
-C
- Q1=FLOAT(NUM)/FLOAT(L*L)
- JR1=NUM-L*L*INT(Q1+0.0001)
- JS1=INT(Q1+0.9999)
- Q2=FLOAT(JR1)/FLOAT(L)
- JS2=INT(Q2+0.9999)
- IF(JR1.EQ.0) JS2=L
- Q3=FLOAT(NUM)/FLOAT(L)
- JR3=INT(Q3+0.0001)
- JS3=NUM-L*JR3
- IF(JS3.EQ.0) JS3=L
- IL=I(JS1)
- IM=I(JS2)
- IN=I(JS3)
-C
- 5 FORMAT(///,'<<<<<<<<<< INCREASE THE SIZE OF I IN',' THE NUMAT SU
- &BROUTINE >>>>>>>>>>')
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE RELA(NINI,NFIN,NAT,VALINI,VALFIN,VALFIN2,COORD,NTYP,REL
- &,L)
-C
- USE DIM_MOD
-C
- USE ADSORB_MOD , I1 => IADS, N1 => NADS1, N2 => NADS2, N3 => NADS3
- &
- USE OUTUNITS_MOD
- USE RELADS_MOD
- USE RELAX_MOD
-C
- DIMENSION VALINI(NATCLU_M),VALFIN(NATCLU_M),REL(NATCLU_M)
- DIMENSION NTYP(NATM),COORD(3,NATCLU_M),LSP(2),DZA(2),DZB(2)
- DIMENSION DYA(2),DYB(2),VALFIN2(NATCLU_M),KZ(1000)
-C
- DATA SMALL /0.0001/
-C
- IF((IREL.EQ.1).OR.((IREL.EQ.0).AND.(NRELA.GT.0))) THEN
-C
- CALL ORDRE(NINI,VALINI,NFIN,VALFIN)
- WRITE(IUO1,70) NFIN
- DO JPLAN=1,NFIN
- IF(JPLAN.LE.NRELA) THEN
- X1=1.
- X2=0.
- PCADS=PCRELA(JPLAN)
- ELSEIF((JPLAN.GT.NRELA).AND.(JPLAN.LE.L)) THEN
- X1=0.
- X2=0.
- ELSE
- X1=0.
- X2=1.
- PCSUBS=PCREL(JPLAN-L)
- ENDIF
- REL(JPLAN)=0.
- IF(JPLAN.GT.NREL+L) GO TO 20
- IF(JPLAN.EQ.NFIN) GO TO 20
- DPLAN=VALFIN(JPLAN)-VALFIN(JPLAN+1)
- REL(JPLAN)=DPLAN*(X1*PCADS+X2*PCSUBS)/100.
- 20 DREL=VALFIN(JPLAN)+REL(JPLAN)
- WRITE(IUO1,30) JPLAN,VALFIN(JPLAN),DREL
- ENDDO
-C
- NBR=0
- DO JTYP=1,NAT
- NBAT=NTYP(JTYP)
- DO NUM=1,NBAT
- NBR=NBR+1
- DO JPLAN=1,NFIN
- DIF=ABS(COORD(3,NBR)-VALFIN(JPLAN))
- IF(DIF.LT.SMALL) THEN
- COORD(3,NBR)=COORD(3,NBR)+REL(JPLAN)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-C
- DO JPLAN=1,NFIN
- VALFIN(JPLAN)=VALFIN(JPLAN)+REL(JPLAN)
- ENDDO
-C
- ELSEIF(IREL.GE.2) THEN
-C
- IP=0
- LSP(2)=0
- OMEGA=OMEGA1
- 97 XN1=1.
- XN2=0.
- IP=IP+1
- CALL ORDRE(NINI,VALINI,NFIN,VALFIN)
- ZP=VALFIN(IP)
- CALL RZB110(OMEGA,DY1,DY2,DZ1,DZ2)
- DZA(IP)=DZ1
- DZB(IP)=DZ2
- DYA(IP)=DY1
- DYB(IP)=DY2
- IF(ABS(OMEGA).LT.SMALL) THEN
- LSP(IP)=1
- ELSE
- LSP(IP)=2
- ENDIF
- IF(LSP(IP).EQ.1) GOTO 95
- NBR=0
-C
- DO JTYP=1,NAT-NATA
- NBAT=NTYP(JTYP)
- XN1=XN1+1.-FLOAT(JTYP)
- XN2=XN2-1.+FLOAT(JTYP)
- DO JNUM=1,NBAT
- NBR=NBR+1
- ZAT=COORD(3,NBR)-ZP
- IF(ABS(ZAT).LT.SMALL) THEN
- YAT=COORD(2,NBR)
- COORD(2,NBR)=YAT-XN1*DYA(IP)-XN2*DYB(IP)
- COORD(3,NBR)=ZAT+ZP+XN1*DZA(IP)+XN2*DZB(IP)
- ENDIF
- ENDDO
- ENDDO
-C
- 95 OMEGA=OMEGA2
- IF((IREL.EQ.3).AND.(IP.EQ.1)) GOTO 97
- LS=0
- DO I=1,IP
- LS=LS+LSP(I)
- ENDDO
- NBZ1=NFIN+LS-IP
- DO K=1,IP
- IF(LSP(K).EQ.2) THEN
- IF((K.EQ.2).AND.(LS.EQ.3)) THEN
- KN=K-1
- ELSE
- KN=K
- ENDIF
- VALINI(NBZ1-KN+1)=VALFIN(L+K)+DZB(K)
- REL(NBZ1-KN+1)=DZB(K)
- ELSE
- VALINI(NBZ1-K+1)=VALFIN(L+K)
- REL(NBZ1-K+1)=0.
- ENDIF
- ENDDO
-C
- IL=0
- IR=0
- DO J=1,NFIN
- IS=0
- IF(J.LE.NRELA) THEN
- X1=1.
- X2=0.
- X3=0.
- PCADS=PCRELA(J)
- IS=1
- ELSEIF((J.GT.NRELA).AND.(J.LE.L)) THEN
- X1=0.
- X2=0.
- X3=0.
- ELSEIF((J.GT.L).AND.(J.LE.(L+IP))) THEN
- IR=IR+1
- IF(LSP(IR).EQ.1) THEN
- IF((IR.EQ.1).AND.(LSP(2).EQ.2)) GOTO 31
- X1=0.
- X2=1.
- X3=0.
- LT=MAX0(LSP(1),LSP(2))-1
- PCSUBS=PCREL(J-L-LT)
- IL=1
- IS=1
- 31 CONTINUE
- ELSE
- X1=0.
- X2=0.
- X3=1.
- ENDIF
- ELSEIF((J.GT.(L+IP)).AND.(J.LE.(L+IP+NREL))) THEN
- X1=0.
- X2=1.
- X3=0.
- LT=MAX0(LSP(1),LSP(2))+IP-1
- PCSUBS=PCREL(J-L-LT+IL+1)
- IS=1
- ELSE
- X1=0.
- X2=0.
- X3=0.
- ENDIF
- DPLAN=VALFIN(J)-VALFIN(J+1)
- REL(J)=X3*DZA(IR)+DPLAN*(X1*PCADS+X2*PCSUBS)/100.
- VALINI(J)=VALFIN(J)+REL(J)
- IF(IS.EQ.1) THEN
- NBR=0
- DO JTYP=1,NAT
- NBAT=NTYP(JTYP)
- DO NUM=1,NBAT
- NBR=NBR+1
- DIF=ABS(COORD(3,NBR)-VALFIN(J))
- IF(DIF.LT.SMALL) THEN
- COORD(3,NBR)=VALINI(J)
- ENDIF
- ENDDO
- ENDDO
- ENDIF
- ENDDO
-C
- CALL ORDRE(NBZ1,VALINI,NFIN,VALFIN2)
- WRITE(IUO1,65) NFIN
- KZ(1)=0
- KZ(2)=LSP(1)
- KZ(3)=MAX0(LSP(1),LSP(2))
- DO KK=4,NFIN
- KZ(KK)=LS
- ENDDO
- DO JPLAN=1,NFIN
- IF(JPLAN.LE.L) THEN
- WRITE(IUO1,55) JPLAN,VALFIN(JPLAN),VALFIN2(JPLAN)
- VALINI(JPLAN)=VALFIN(JPLAN)
- ELSEIF((JPLAN.GT.L).AND.(JPLAN.LE.(L+LS))) THEN
- K=KZ(JPLAN-L) - INT((JPLAN-L)/2)
- IPLAN=JPLAN-K
- WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN)
- VALINI(JPLAN)=VALFIN(IPLAN)
- ELSEIF(JPLAN.GT.(L+LS)) THEN
- IPLAN=JPLAN-LS+IP
- WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN)
- VALINI(JPLAN)=VALFIN(IPLAN)
- ENDIF
- ENDDO
- ENDIF
-C
- 30 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3,
- * ' BEFORE RELAXATION AND : ',F6.3,' AFTER')
- 55 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3,
- * ' BEFORE RELAXATION AND : ',F6.3,' AFTER')
- 65 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ')
- 70 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ')
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE ROTBAS(ROT)
-C
-C This routine calculates the basis vectors related to a surface
-C characterized by its Miller indices (IH,IK,II,IL)
-C
- USE MILLER_MOD
- USE OUTUNITS_MOD
- USE RESEAU_MOD
- USE VECSYS_MOD , A1 => ASYS, A2 => BSYS, A3 => CSYS
-C
- DIMENSION ROT(3,3),VECT(3,3),A1STAR(3),A2STAR(3),A3STAR(3),B1(3)
- DIMENSION VECT1(3),XNORM(3),CHBASE(3,3),VECT2(3,3)
-C
-C
-C
- DATA PI /3.141593/
-C
- IF((NCRIST.EQ.8).AND.(IVG0.GE.1)) GOTO 7
- XH=FLOAT(IH)
- XK=FLOAT(IK)
- XI=FLOAT(II)
- XL=FLOAT(IL)
- XI1=-XH-XK
- II1=INT(XI1)
- IF((NCRIST.EQ.7).AND.(XI.NE.XI1)) WRITE(IUO1,5) IH,IK,II1,IL
- 5 FORMAT(5X,'THE SURFACE INDICES ARE NOT CORRECT,',/,5X, 'FOR THE RE
- &ST OF THE CALCULATION, THEY ARE TAKEN AS ','(',I2,1X,I2,1X,I2,1X,I
- &2,')')
- CPR=1.
- CALL PRVECT(A2,A3,B1,CPR)
- OMEGA=PRSCAL(A1,B1)/(2.*PI)
- CALL PRVECT(A2,A3,A1STAR,OMEGA)
- CALL PRVECT(A3,A1,A2STAR,OMEGA)
- CALL PRVECT(A1,A2,A3STAR,OMEGA)
- DO 10 I=1,3
- VECT1(I)=XH*A1STAR(I)+XK*A2STAR(I)+XL*A3STAR(I)
- 10 CONTINUE
- DO 15 I=1,3
- ROT(I,3)=VECT1(I)/SQRT(PRSCAL(VECT1,VECT1))
- 15 CONTINUE
- DO 20 I=1,3
- CHBASE(I,1)=A1(I)
- CHBASE(I,2)=A2(I)
- CHBASE(I,3)=A3(I)
- DO 25 J=1,3
- VECT(I,J)=0.
- 25 CONTINUE
- 20 CONTINUE
- XHKL=XH*XK*XL
- XHK=XH*XK
- XHL=XH*XL
- XKL=XK*XL
- IF(XHKL.NE.0.) THEN
- VECT(1,1)=-1./XH
- VECT(2,1)=1./XK
- VECT(1,2)=-1./XH
- VECT(3,2)=1./XL
- VECT(2,3)=-1./XK
- VECT(3,3)=1./XL
- ELSEIF(XHK.NE.0.) THEN
- VECT(1,1)=-1./XH
- VECT(2,1)=1./XK
- ELSEIF(XHL.NE.0.) THEN
- VECT(1,2)=-1./XH
- VECT(3,2)=1./XL
- ELSEIF(XKL.NE.0.) THEN
- VECT(2,3)=-1./XK
- VECT(3,3)=1./XL
- ELSEIF(XH.NE.0.) THEN
- VECT(2,2)=1./XH
- ELSEIF(XK.NE.0.) THEN
- VECT(3,3)=1./XK
- ELSEIF(XL.NE.0.) THEN
- VECT(1,1)=1./XL
- ENDIF
- CALL MULMAT(CHBASE,3,3,VECT,3,3,VECT2)
- DO 35 I=1,3
- XNORM(I)=SQRT(VECT2(1,I)**2+VECT2(2,I)**2+VECT2(3,I)**2)
- 35 CONTINUE
- XMIN=AMIN1(XNORM(1),XNORM(2),XNORM(3))
- XMAX=AMAX1(XNORM(1),XNORM(2),XNORM(3))
- DO 40 I=1,3
- IF(XHKL.NE.0.) THEN
- IF(ABS(XMIN-XNORM(I)).LT.0.0001) THEN
- DO 45 J=1,3
- ROT(J,1)=VECT2(J,I)/XNORM(I)
- 45 CONTINUE
- ENDIF
- ELSE
- IF(ABS(XMAX-XNORM(I)).LT.0.0001) THEN
- DO 50 J=1,3
- ROT(J,1)=VECT2(J,I)/XNORM(I)
- 50 CONTINUE
- ENDIF
- ENDIF
- 40 CONTINUE
- ROT(1,2)=ROT(2,3)*ROT(3,1)-ROT(3,3)*ROT(2,1)
- ROT(2,2)=ROT(3,3)*ROT(1,1)-ROT(3,1)*ROT(1,3)
- ROT(3,2)=ROT(1,3)*ROT(2,1)-ROT(2,3)*ROT(1,1)
- IF(NCRIST.EQ.7) THEN
- WRITE(IUO1,85) IH,IK,II1,IL
- ELSE
- WRITE(IUO1,80) IH,IK,IL
- ENDIF
- WRITE(IUO1,65) ROT(1,1),ROT(2,1),ROT(3,1)
- WRITE(IUO1,70) ROT(1,2),ROT(2,2),ROT(3,2)
- WRITE(IUO1,75) ROT(1,3),ROT(2,3),ROT(3,3)
- GOTO 37
- 7 DO 17 I=1,3
- DO 27 J=1,3
- ROT(I,J)=0.
- IF(I.EQ.J) ROT(I,J)=1.
- 27 CONTINUE
- 17 CONTINUE
- IF(IVG0.EQ.1) WRITE(IUO1,48)
- IF(IVG0.EQ.2) WRITE(IUO1,47)
- 47 FORMAT(//,25X,'LINEAR CHAIN STUDY ')
- 48 FORMAT(//,35X,'PLANE STUDY')
- 65 FORMAT(26X,'ISURF = (',F6.3,',',F6.3,',',F6.3,')')
- 70 FORMAT(26X,'JSURF = (',F6.3,',',F6.3,',',F6.3,')')
- 75 FORMAT(26X,'KSURF = (',F6.3,',',F6.3,',',F6.3,')')
- 80 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X,
- *I2,') :',/)
- 85 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X,
- *I2,1X,I2,') :',/)
-C
- 37 RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE RZB110(OMEGA,DY1,DY2,DZ1,DZ2)
-C
- A1=COS(OMEGA)
- ALPHA=SIN(OMEGA)
- BETA=A1-3.
- GAMMA=SQRT(3.)*(5./3.-A1)
- DELTA=SQRT(SQRT(3.)*(1./3.+A1)/GAMMA)
- CSA=SQRT(3.)*(-BETA-ALPHA*DELTA)/6.
- SNA=SQRT(1.-CSA*CSA)
- CSB=-SQRT(3.)*BETA/3. -CSA
- SNB=-SQRT(3.)*ALPHA/3. +SNA
- DY1=(SQRT(3.)*CSB-1.)/4.
- DY2=(1.-SQRT(3.)*CSA)/4.
- DZ1=(SQRT(3.)*SNB-SQRT(2.))/4.
- DZ2=(SQRT(3.)*SNA-SQRT(2.))/4.
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE TEST1(COUPUR,NB1,NB2,ATOME,COORD,VAL,NBAT,IRE,NBZ)
-C
- USE DIM_MOD
-C
- DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M),VAL(NATCLU_M)
- DIMENSION IRE(NATCLU_M,2)
-C
- DIST2=0.
- DO 10 I=1,3
- DIST2=DIST2+ATOME(I,NB1)*ATOME(I,NB1)
- 10 CONTINUE
- DIST=SQRT(DIST2)
- V=0.0001
- IF((ATOME(3,NB1).LE.V).AND.(DIST.LE.COUPUR)) THEN
- NBAT=NBAT+1
- NB2=NB2+1
- IRE(NB1,1)=NB2
- IRE(NB1,2)=NBAT
- DO 20 I=1,3
- COORD(I,NB2)=ATOME(I,NB1)
- 20 CONTINUE
- IF(NBZ.EQ.0) THEN
- NBZ=NBZ+1
- VAL(NBZ)=COORD(3,NB2)
- ELSE
- N1=0
- DO N=1,NBZ
- D=ABS(COORD(3,NB2)-VAL(N))
- IF(D.LT.0.0001) N1=N1+1
- ENDDO
- IF(N1.EQ.0) THEN
- NBZ=NBZ+1
- VAL(NBZ)=COORD(3,NB2)
- ENDIF
- ENDIF
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE TEST(NIV,ROT,NATYP,NBZ,NAT2,ISURF,COUP,*)
-C
- USE DIM_MOD
-C
- DIMENSION ATOME1(3,NATCLU_M),COORD1(3,NATCLU_M)
- DIMENSION IRE1(NATCLU_M,2),NATYP(NATM)
- DIMENSION NATYP1(NATM),VALZ1(NATCLU_M),ROT(3,3)
-C
- NMAX1=(2*NIV+3)**3
- NV1=NIV+1
- CALL AMAS(NV1,ATOME1,COORD1,VALZ1,ISURF,COUP,ROT,IRE1,NATYP1,NBZ,N
- &AT2,NCOUCH,NMAX1)
- DO 10 I=1,NAT2
- IF(NATYP(I).NE.NATYP1(I)) RETURN 1
- 10 CONTINUE
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE ARCSIN(U,CST,RANGLE)
-C
-C For a given complex number U, this subroutine calculates its phase
-C Warning : it is implicitely assumed that U = sin(theta) exp(i*phi)
-C with theta > or = to 0 which is always the case when theta is obtained
-C from the coordinates of a given vector r by the ACOS intrinsic function.
-C
-C When sin(theta) = 0, then phi = 0 if cos(theta) = 1 and pi if
-C cos(theta) = -1. Cos(theta) is the variable CST.
-C
- COMPLEX U,CANGLE
-C
- IF(CABS(U).LT.0.0001) THEN
- IF(CST.GT.0.) THEN
- RANGLE=0.
- ELSEIF(CST.LT.0.) THEN
- RANGLE=3.141593
- ENDIF
- ELSE
- CANGLE=(0.,-1.)*CLOG(U/CABS(U))
- RANGLE=REAL(CANGLE)
- ENDIF
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE ATDATA
-C
-C This routine contains the atomic mass and the density of all the
-C elements,and the equivalence between their atomic number and
-C chemical symbol.
-C
-C Value Z = 0 added for empty spheres. The values entered in this
-C case are arbitrary and set to the corresponding Z = 1 value
-C divided by 1836 (the ratio of the mass of the proton and electron).
-C
-C Last modified : 25 Apr 2013
-C
- USE XMRHO_MOD , XM_AT => XMAT, RHO_AT => RHOAT
- REAL XMAT(0:99),RHOAT(0:99)
-C
-C
- DATA XMAT/0.00055,1.00794,4.00260,6.941,9.01218,10.81,12.011,14.00
- &67,15.9994,18.998403,20.179,22.98977,24.305,26.98154,28.0855,30.97
- &376,32.06,35.453,39.948,39.0983,40.08,44.9559,47.88,50.9415,51.996
- &,54.9380,55.847,58.9332,58.69,63.546,65.38,69.72,72.59,74.9216,78.
- &96,79.904,83.80,85.4678,87.62,88.9059,91.22,92.9064,95.94,98.,101.
- &07,102.9055,106.42,107.8682,112.41,114.82,118.69,121.75,127.60,126
- &.9045,131.29,132.9054,137.33,138.9055,140.12,140.9077,144.24,145.,
- &
- * 150.36,151.96,157.25,158.9254,162.50,164.9304,
- * 167.26,168.9342,173.04,174.967,178.49,180.9479,
- * 183.85,186.207,190.2,192.22,195.08,196.9665,
- * 200.59,204.383,207.2,208.9804,209.,210.,222.,
- * 223.,226.0254,227.0278,232.0381,231.0359,
- * 238.0289,237.0482,244.,243.,247.,247.,251.,252./
-C
- DATA RHOAT/0.0007,0.0708,0.122,0.533,1.845,2.34,2.26,0.81,1.14,1.1
- &08,1.207,0.969,1.735,2.6941,2.32,1.82,2.07,1.56,1.40,0.860,1.55,2.
- &980,4.53,6.10,7.18,7.43,7.860,8.9,8.876,8.94,7.112,5.877,5.307,5.7
- &2,4.78,3.11,2.6,1.529,2.54,4.456,6.494,8.55,10.20,11.48,12.39,12.3
- &9,12.00,10.48,8.63,7.30,7.30,6.679,6.23,4.92,3.52,1.870,3.5,6.127,
- &6.637,6.761,6.994,7.20,7.51,5.228,7.8772,8.214,8.525,8.769,9.039,9
- &.294,6.953,9.811,13.29,16.624,19.3,20.98,22.53,22.39,21.41,18.85,1
- &3.522,11.83,11.33,
- * 9.730,9.30,0.0,4.4,0.0,5.,10.05,11.70,15.34,
- * 18.92,20.21,19.80,13.64,13.49,14.,0.0,0.0/
-C
- DO J=0,99
- XM_AT(J)=XMAT(J)
- RHO_AT(J)=RHOAT(J)
- ENDDO
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE AUGER_MULT
-C
-C This subroutine computes all the possible multiplets that are
-C contained in a given Auger transition line. It assumes that
-C the atom has closed shells only.
-C
-C Last modified : 9 March 2006
-C
- USE INIT_A_MOD , LI => LI_C, L2 => LI_I, L1 => LI_A
- USE OUTUNITS_MOD
-C
- CHARACTER*1 SC(0:1),LC(0:6),JC(0:7)
- CHARACTER*3 MULTIPLET(112)
-C
- DATA SC /'1','3'/
- DATA LC /'S','P','D','F','G','H','I'/
- DATA JC /'0','1','2','3','4','5','6','7'/
-C
- WRITE(IUO1,10)
- N_MULT=0
- DO NS=0,1
- DO L=ABS(L1-L2),L1+L2
- DO J=ABS(L-NS),L+NS
- N_MULT=N_MULT+1
- MULTIPLET(N_MULT)=SC(NS)//LC(L)//JC(J)
- WRITE(IUO1,20) MULTIPLET(N_MULT)
- ENDDO
- ENDDO
- ENDDO
-C
- 10 FORMAT(///,26X,'THE POSSIBLE MULTIPLETS ARE :',/,' ')
- 20 FORMAT(58X,A3)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE BESPHE(NL,IBES,X1,FL)
-C
-C This routine computes the spherical Bessel functions for
-C a real argument X1.
-C
-C IBES=1 : Bessel function
-C IBES=2 : Neumann function
-C IBES=3 : Hankel function of the first kind
-C IBES=4 : Hankel function of the second kind
-C IBES=5 : Modified Bessel function
-C IBES=6 : Modified Neumann function
-C IBES=7 : Modified Hankel function
-C
-C Last modified : 8 Nov 2006
-C
-C
- USE DIM_MOD
- USE OUTUNITS_MOD
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2
- COMPLEX*16 ZERO,CNORM
-C
- DOUBLE PRECISION SCALN(0:N_BESS)
-C
- REAL X1
-C
-C
- ECH=37.D0
- COMP=1.D37
- COMM=1.D-37
- X=DBLE(X1)
- NX=INT(X1)
- NREC=5*MAX0(NL-1,NX)
- IF(NREC.GT.N_BESS) GOTO 16
- ITEST=0
- ZERO=(0.D0,0.D0)
- UN=(1.D0,0.D0)
- C1=UN
- I=(0.D0,1.D0)
- C2=I
- DEB=1.D0
- IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN
- IBES1=1
- IF(IBES.EQ.4) C2=-I
- ELSEIF(IBES.EQ.7) THEN
- IBES1=5
- C2=-UN
- ELSE
- IBES1=IBES
- ENDIF
-C
-C Case where the argument is zero
-C
- IF(DABS(X).LT.0.000001D0) THEN
- IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN
- FL(0)=UN
- DO 10 L=1,NL-1
- FL(L)=ZERO
- 10 CONTINUE
- ITEST=1
- ELSE
- ITEST=-1
- ENDIF
- ENDIF
- IF(ITEST) 11,12,13
- 11 WRITE(IUO1,14)
- STOP
- 16 WRITE(IUO1,17) NREC
- STOP
- 15 IBES1=IBES1+1
-C
-C Initial values
-C
- 12 A=-1.D0
- B=1.D0
- IF(IBES1.EQ.1) THEN
- FL(0)=UN*DSIN(X)/X
- FLNN(NREC)=ZERO
- SCALN(NREC)=0.D0
- FLNN(NREC-1)=UN*DEB
- SCALN(NREC-1)=0.D0
- ELSEIF(IBES1.EQ.2) THEN
- GL(0)=-UN*DCOS(X)/X
- GL(1)=GL(0)/X -DSIN(X)/X
- ELSEIF(IBES1.EQ.5) THEN
- A=1.D0
- B=-1.D0
- FL(0)=UN*DSINH(X)/X
- FLNN(NREC)=ZERO
- SCALN(NREC)=0.D0
- FLNN(NREC-1)=UN*DEB
- SCALN(NREC-1)=0.D0
- ELSEIF(IBES1.EQ.6) THEN
- A=1.D0
- B=-1.D0
- GL(0)=UN*DCOSH(X)/X
- GL(1)=(DSINH(X)-GL(0))/X
- ENDIF
-C
-C Downward reccurence for the spherical Bessel function
-C
- IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN
- DO 30 L=NREC-1,1,-1
- ECHEL=0.D0
- SCALN(L-1)=SCALN(L)
- REN=DEXP(SCALN(L)-SCALN(L+1))
- FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X)
- IF(CDABS(FLNN(L-1)).GT.COMP) THEN
- ECHEL=-ECH
- ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN
- ECHEL=ECH
- ENDIF
- IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1)
- FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL)
- 30 CONTINUE
- CNORM=FL(0)/FLNN(0)
- DO 40 L=1,NL-1
- FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L))
- 40 CONTINUE
- ELSE
-C
-C Upward recurrence for the spherical Neumann function
-C
- DO 20 L=1,NL-1
- IF(IBES.EQ.7) C1=(-UN)**(L+2)
- GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X
- IF(IBES1.NE.IBES) THEN
-C
-C Calculation of the spherical Hankel function
-C
- FL(L+1)=C1*(FL(L+1)+C2*GL(L+1))
- ELSE
- FL(L+1)=GL(L+1)
- ENDIF
- 20 CONTINUE
- IF(IBES1.EQ.IBES) THEN
- FL(0)=GL(0)
- FL(1)=GL(1)
- ELSE
- FL(0)=C1*(FL(0)+C2*GL(0))
- FL(1)=C1*(FL(1)+C2*GL(1))
- ENDIF
- IBES1=IBES
- ENDIF
- IF(IBES.NE.IBES1) GOTO 15
-C
- 13 RETURN
-C
- 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION
- &S IS NUL >>>>>>>>>>')
- 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR
- &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL
- &D BE AT LEAST : ',I5,' >>>>>>>>>>')
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE BESPHE2(NL,IBES,X,FL)
-C
-C This routine computes the spherical Bessel functions for
-C a real argument X1.
-C
-C IBES=1 : Bessel function
-C IBES=2 : Neumann function
-C IBES=3 : Hankel function of the first kind
-C IBES=4 : Hankel function of the second kind
-C IBES=5 : Modified Bessel function
-C IBES=6 : Modified Neumann function
-C IBES=7 : Modified Hankel function
-C
-C Last modified : 8 Nov 2006
-C
-C
- USE DIM_MOD
- USE OUTUNITS_MOD
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2
- COMPLEX*16 ZERO,CNORM
-C
- DOUBLE PRECISION SCALN(0:N_BESS)
-C
-C
- ECH=37.D0
- COMP=1.D37
- COMM=1.D-37
- NX=INT(X)
- NREC=5*MAX0(NL-1,NX)
- IF(NREC.GT.N_BESS) GOTO 16
- ITEST=0
- ZERO=(0.D0,0.D0)
- UN=(1.D0,0.D0)
- C1=UN
- I=(0.D0,1.D0)
- C2=I
- DEB=1.D0
- IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN
- IBES1=1
- IF(IBES.EQ.4) C2=-I
- ELSEIF(IBES.EQ.7) THEN
- IBES1=5
- C2=-UN
- ELSE
- IBES1=IBES
- ENDIF
-C
-C Case where the argument is zero
-C
- IF(DABS(X).LT.0.000001D0) THEN
- IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN
- FL(0)=UN
- DO 10 L=1,NL-1
- FL(L)=ZERO
- 10 CONTINUE
- ITEST=1
- ELSE
- ITEST=-1
- ENDIF
- ENDIF
- IF(ITEST) 11,12,13
- 11 WRITE(IUO1,14)
- STOP
- 16 WRITE(IUO1,17) NREC
- STOP
- 15 IBES1=IBES1+1
-C
-C Initial values
-C
- 12 A=-1.D0
- B=1.D0
- IF(IBES1.EQ.1) THEN
- FL(0)=UN*DSIN(X)/X
- FLNN(NREC)=ZERO
- SCALN(NREC)=0.D0
- FLNN(NREC-1)=UN*DEB
- SCALN(NREC-1)=0.D0
- ELSEIF(IBES1.EQ.2) THEN
- GL(0)=-UN*DCOS(X)/X
- GL(1)=GL(0)/X -DSIN(X)/X
- ELSEIF(IBES1.EQ.5) THEN
- A=1.D0
- B=-1.D0
- FL(0)=UN*DSINH(X)/X
- FLNN(NREC)=ZERO
- SCALN(NREC)=0.D0
- FLNN(NREC-1)=UN*DEB
- SCALN(NREC-1)=0.D0
- ELSEIF(IBES1.EQ.6) THEN
- A=1.D0
- B=-1.D0
- GL(0)=UN*DCOSH(X)/X
- GL(1)=(DSINH(X)-GL(0))/X
- ENDIF
-C
-C Downward reccurence for the spherical Bessel function
-C
- IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN
- DO 30 L=NREC-1,1,-1
- ECHEL=0.D0
- SCALN(L-1)=SCALN(L)
- REN=DEXP(SCALN(L)-SCALN(L+1))
- FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X)
- IF(CDABS(FLNN(L-1)).GT.COMP) THEN
- ECHEL=-ECH
- ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN
- ECHEL=ECH
- ENDIF
- IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1)
- FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL)
- 30 CONTINUE
- CNORM=FL(0)/FLNN(0)
- DO 40 L=1,NL-1
- FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L))
- 40 CONTINUE
- ELSE
-C
-C Upward recurrence for the spherical Neumann function
-C
- DO 20 L=1,NL-1
- IF(IBES.EQ.7) C1=(-UN)**(L+2)
- GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X
- IF(IBES1.NE.IBES) THEN
-C
-C Calculation of the spherical Hankel function
-C
- FL(L+1)=C1*(FL(L+1)+C2*GL(L+1))
- ELSE
- FL(L+1)=GL(L+1)
- ENDIF
- 20 CONTINUE
- IF(IBES1.EQ.IBES) THEN
- FL(0)=GL(0)
- FL(1)=GL(1)
- ELSE
- FL(0)=C1*(FL(0)+C2*GL(0))
- FL(1)=C1*(FL(1)+C2*GL(1))
- ENDIF
- IBES1=IBES
- ENDIF
- IF(IBES.NE.IBES1) GOTO 15
-C
- 13 RETURN
-C
- 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION
- &S IS NUL >>>>>>>>>>')
- 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR
- &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL
- &D BE AT LEAST : ',I5,' >>>>>>>>>>')
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE CHECK_VIB(NAT2)
-C
-C This subroutines checks the geometrical environment of each atom
-C to identify those which can move "freely" in one direction, in
-C order to see whether the mean square displacement in this
-C direction is of bulk type or surface type
-C
-C An atom is considered to move freely in one direction if no other
-C atom is present in the tetragonal cell of height ALENGTH * A
-C and base edge 2 * A, whose base is centered on the atom considered
-C
-C Only prototypical atoms are considered as all equivalent atoms are
-C in the same geometrical environment
-C
-C Surface-like atoms are then identified as having I_FREE = 1
-C
-C Last modified : 24 Apr 2013
-C
- USE DIM_MOD
-C
- USE COOR_MOD , COORD => SYM_AT
- USE OUTUNITS_MOD
- USE VIBRAT_MOD
-C
- INTEGER NSUR(NATP_M)
-C
- DATA SMALL /0.0001/
-C
- ALENGTH=4.
-C
-C.................... Checking the z direction ....................
-C
- WRITE(IUO1,11)
- N_SUR=0
-C
-C Loop on the prototypical atoms
-C
- DO JTYP=1,N_PROT
-C
- I_FREE(JTYP)=0
- JAT0=NCORR(1,JTYP)
- XA=COORD(1,JAT0)
- YA=COORD(2,JAT0)
- ZA=COORD(3,JAT0)
-C
-C Loop on the surrounding atoms
-C
- I_ACC=0
-C
- DO JAT=1,NAT2
-C
- IF(JAT.EQ.JAT0) GOTO 10
-C
- X=COORD(1,JAT)
- Y=COORD(2,JAT)
- Z=COORD(3,JAT)
-C
-C Considering only atoms with Z > ZA
-C
- IF(Z.LT.(ZA+SMALL)) GOTO 10
-C
-C Lateral and vertical distances between the two atoms
-C
- D_LAT=(X-XA)*(X-XA)+(Y-YA)*(Y-YA)
- D_VER=(Z-ZA)*(Z-ZA)
-C
- IF(D_VER.LT.(ALENGTH+SMALL)) THEN
- IF(D_LAT.LT.(1.+SMALL)) THEN
- I_ACC=I_ACC+1
- ENDIF
- ENDIF
-C
- IF(I_ACC.GE.1) GOTO 10
-C
- 10 CONTINUE
-C
- ENDDO
-C
- IF(I_ACC.EQ.0) THEN
- I_FREE(JTYP)=1
- N_SUR=N_SUR+1
- NSUR(N_SUR)=JTYP
- ENDIF
-C
- ENDDO
-C
- WRITE(IUO1,12) (NSUR(J),J=1,N_SUR)
-C
- 11 FORMAT(//,18X,'SURFACE-LIKE ATOMS FOR MSD CALCULATIONS: ',/)
- 12 FORMAT(20X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE DJMN(RBETA,R,LMAX)
-C
-C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to
-C order LMAX, following Messiah's convention.
-C They are stored as R(M2,M1,L).
-C
-C Last modified : 20 Oct 2006
-C
- USE DIM_MOD
-C
- USE COEFRLM_MOD
- USE EXPROT_MOD
-C
- INTEGER EPS0
-C
- DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
-C
- DATA SMALL,SQR2 /0.001,1.4142136/
-C
- C=COS(RBETA)*0.5
- S=SIN(RBETA)*0.5
- CC=C+C
- CMUL=-1.
- IF(ABS(S).LT.SMALL) THEN
- IF(C.GT.0.) EPS0=1
- IF(C.LT.0.) EPS0=-1
- DO L=0,LMAX
- DO M1=-L,L
- DO M2=-L,L
- IF(M1.NE.M2*EPS0) THEN
- R(M2,M1,L)=0.
- ELSE
- IF(EPS0.EQ.1) THEN
- R(M2,M1,L)=1.
- ELSE
- IF(MOD(L+M1,2).EQ.0) THEN
- R(M2,M1,L)=1.
- ELSE
- R(M2,M1,L)=-1.
- ENDIF
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ELSE
- S1=S*SQR2
- C1=0.5+C
- R(0,0,0)=1.0
- R(-1,-1,1)=C1
- R(0,-1,1)=S1
- R(1,-1,1)=1.-C1
- R(-1,0,1)=-S1
- R(0,0,1)=CC
- R(1,0,1)=S1
- R(-1,1,1)=1.-C1
- R(0,1,1)=-S1
- R(1,1,1)=C1
-C
- PRODL=-S
- COEF=-S/C1
- CL=-1.
- DO L=2,LMAX
- CL=-CL
- L1=L-1
- FLL1=CC*FLOAT(L+L1)
- FLL2=1./(FLOAT(L*L1)*CC)
- PRODL=-PRODL*S
-C
-C Case M = 0
-C
- R_1=EXPR(0,L)*PRODL
- R(-L,0,L)=R_1
-C
- R(L,0,L)=R_1*CL
- R(0,-L,L)=R_1*CL
-C
- R(0,L,L)=R_1
-C
- CM2=CL
- DO M2=-L1,-1
- CM2=CM2*CMUL
- CF1=CF(L1,0,-M2)/FLL1
- CF2=FLL1/CF(L,0,-M2)
- IF(-M2.LT.L1) THEN
- R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1)
- ELSE
- R_A=CF2*R(M2,0,L1)
- ENDIF
-C
- R(M2,0,L)=R_A
-C
- R(-M2,0,L)=R_A*CM2
- R(0,M2,L)=R_A*CM2
-C
- R(0,-M2,L)=R_A
-C
- ENDDO
-C
- R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0
- &,0)
-C
-C Case M > 0
-C
- PRODM=1.
- CM=CL
- FLLM=0.
- DO M=1,L1
- CM=-CM
- PRODM=PRODM*COEF
- FLLM=FLLM+FLL2
-C
- R_1=EXPR(M,L)*PRODL*PRODM
- R_2=R_1/(PRODM*PRODM)
-C
- R(-L,M,L)=R_1
- R(-L,-M,L)=R_2
-C
- R(L,-M,L)=R_1*CM
- R(M,-L,L)=R_1*CM
- R(L,M,L)=R_2*CM
- R(-M,-L,L)=R_2*CM
-C
- R(-M,L,L)=R_1
- R(M,L,L)=R_2
-C
- CM2=CM
- DO M2=-L1,-M
- CM2=-CM2
- D0=FLOAT(M2)*FLLM
- CF1=CF(L1,M,-M2)/FLL1
- CF2=FLL1/CF(L,M,-M2)
- IF((M.LT.L1).AND.(-M2.LT.L1)) THEN
- R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1)
- R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1)
- ELSE
- R_A=CF2*(1.-D0)*R(M2,M,L1)
- R_B=CF2*(1.+D0)*R(M2,-M,L1)
- ENDIF
-C
- R(M2,M,L)=R_A
- R(M2,-M,L)=R_B
-C
- R(-M2,-M,L)=R_A*CM2
- R(M,M2,L)=R_A*CM2
- R(-M,M2,L)=R_B*CM2
- R(-M2,M,L)=R_B*CM2
-C
- R(-M,-M2,L)=R_A
- R(M,-M2,L)=R_B
-C
- ENDDO
- ENDDO
-C
- PRODM=PRODM*COEF
- R_1=PRODL*PRODM
- R_2=PRODL/PRODM
- R(-L,L,L)=R_1
- R(L,-L,L)=R_1
- R(L,L,L)=R_2
- R(-L,-L,L)=R_2
-C
- ENDDO
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE DJMN2(RBETA,R,LMAX,ISWITCH)
-C
-C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to
-C order LMAX, following Messiah's convention.
-C They are stored as R(M2,M1,L) and multiplied (ISWITCH=1) or divided
-C by EXPF.
-C
-C Last modified : 20 Oct 2006
-C
- USE DIM_MOD
-C
- USE COEFRLM_MOD
- USE EXPFAC_MOD
- USE EXPROT_MOD
-C
- INTEGER EPS0
-C
- DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
-C
- DATA SMALL,SQR2 /0.001,1.4142136/
-C
- C=COS(RBETA)*0.5
- S=SIN(RBETA)*0.5
- CC=C+C
- CMUL=-1.
- IF(ABS(S).LT.SMALL) THEN
- IF(C.GT.0.) EPS0=1
- IF(C.LT.0.) EPS0=-1
- DO L=0,LMAX
- DO M1=-L,L
- DO M2=-L,L
- IF(M1.NE.M2*EPS0) THEN
- R(M2,M1,L)=0.
- ELSE
- IF(EPS0.EQ.1) THEN
- R(M2,M1,L)=1.
- ELSE
- IF(MOD(L+M1,2).EQ.0) THEN
- R(M2,M1,L)=1.
- ELSE
- R(M2,M1,L)=-1.
- ENDIF
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ELSE
- S1=S*SQR2
- C1=0.5+C
- R(0,0,0)=1.0
- R(-1,-1,1)=C1
- R(0,-1,1)=S1
- R(1,-1,1)=1.-C1
- R(-1,0,1)=-S1
- R(0,0,1)=CC
- R(1,0,1)=S1
- R(-1,1,1)=1.-C1
- R(0,1,1)=-S1
- R(1,1,1)=C1
-C
- PRODL=-S
- COEF=-S/C1
- CL=-1.
- DO L=2,LMAX
- CL=-CL
- L1=L-1
- FLL1=CC*FLOAT(L+L1)
- FLL2=1./(FLOAT(L*L1)*CC)
- PRODL=-PRODL*S
-C
-C Case M = 0
-C
- R_1=EXPR(0,L)*PRODL
- R(-L,0,L)=R_1
-C
- R(L,0,L)=R_1*CL
- R(0,-L,L)=R_1*CL
-C
- R(0,L,L)=R_1
-C
- CM2=CL
- DO M2=-L1,-1
- CM2=CM2*CMUL
- CF1=CF(L1,0,-M2)/FLL1
- CF2=FLL1/CF(L,0,-M2)
- IF(-M2.LT.L1) THEN
- R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1)
- ELSE
- R_A=CF2*R(M2,0,L1)
- ENDIF
-C
- R(M2,0,L)=R_A
-C
- R(-M2,0,L)=R_A*CM2
- R(0,M2,L)=R_A*CM2
-C
- R(0,-M2,L)=R_A
-C
- ENDDO
-C
- R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0
- &,0)
-C
-C Case M > 0
-C
- PRODM=1.
- CM=CL
- FLLM=0.
- DO M=1,L1
- CM=-CM
- PRODM=PRODM*COEF
- FLLM=FLLM+FLL2
-C
- R_1=EXPR(M,L)*PRODL*PRODM
- R_2=R_1/(PRODM*PRODM)
-C
- R(-L,M,L)=R_1
- R(-L,-M,L)=R_2
-C
- R(L,-M,L)=R_1*CM
- R(M,-L,L)=R_1*CM
- R(L,M,L)=R_2*CM
- R(-M,-L,L)=R_2*CM
-C
- R(-M,L,L)=R_1
- R(M,L,L)=R_2
-C
- CM2=CM
- DO M2=-L1,-M
- CM2=-CM2
- D0=FLOAT(M2)*FLLM
- CF1=CF(L1,M,-M2)/FLL1
- CF2=FLL1/CF(L,M,-M2)
- IF((M.LT.L1).AND.(-M2.LT.L1)) THEN
- R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1)
- R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1)
- ELSE
- R_A=CF2*(1.-D0)*R(M2,M,L1)
- R_B=CF2*(1.+D0)*R(M2,-M,L1)
- ENDIF
-C
- R(M2,M,L)=R_A
- R(M2,-M,L)=R_B
-C
- R(-M2,-M,L)=R_A*CM2
- R(M,M2,L)=R_A*CM2
- R(-M,M2,L)=R_B*CM2
- R(-M2,M,L)=R_B*CM2
-C
- R(-M,-M2,L)=R_A
- R(M,-M2,L)=R_B
-C
- ENDDO
- ENDDO
-C
- PRODM=PRODM*COEF
- R_1=PRODL*PRODM
- R_2=PRODL/PRODM
- R(-L,L,L)=R_1
- R(L,-L,L)=R_1
- R(L,L,L)=R_2
- R(-L,-L,L)=R_2
-C
- ENDDO
- ENDIF
-C
- IF(ISWITCH.EQ.1) THEN
- DO L=0,LMAX
- DO M1=-L,L
- DO M2=-L,L
- R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)*EXPF(ABS(M2),L)
- ENDDO
- ENDDO
- ENDDO
- ELSEIF(ISWITCH.EQ.2) THEN
- DO L=0,LMAX
- DO M1=-L,L
- DO M2=-L,L
- R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)/EXPF(ABS(M2),L)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE EMETT(JEM,IEMET,Z,COORD,NATYP,EMET,NM,JNEM,*)
-C
-C This routine looks for the position of an absorber of type IEMET(JEM)
-C situated in the plane at Z. The result is stored in EMET(3)
-C
- USE DIM_MOD
-C
- DIMENSION IEMET(NEMET_M)
- DIMENSION EMET(3),DIST(NATCLU_M),COORD(3,NATCLU_M),NATYP(NATM)
-C
- KEMET=0
- JNT=0
- IEM=IEMET(JEM)
- IF(IEM.GT.1) THEN
- DO JTP=1,IEM-1
- JNT=JNT+NATYP(JTP)
- ENDDO
- ENDIF
- NB=NATYP(IEM)
- XMIN=1000000.
-C
- DO J=1,NB
- JN=J+JNT
- DELTAZ=ABS(COORD(3,JN)-Z)
- IF(DELTAZ.LT.0.0001) THEN
- XX=COORD(1,JN)
- XY=COORD(2,JN)
- XZ=COORD(3,JN)
- DIST(J)=SQRT(XX*XX+XY*XY+XZ*XZ)
- IF(DIST(J).LT.XMIN) THEN
- XMIN=DIST(J)
- NM=IEM
- JNEM=J
- DO I=1,3
- EMET(I)=COORD(I,JN)
- ENDDO
- ENDIF
- KEMET=KEMET+1
- ENDIF
- ENDDO
-C
- IF(KEMET.EQ.0) THEN
- NM=IEM
- RETURN 1
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE EULER(RTHETA1,RPHI1,RTHETA2,RPHI2,RALPHA,RBETA,RGAMMA,I
- &ROT)
-C
-C This routine calculates the Euler angles RALPHA,RBETA,RGAMMA corresponding
-C to the rotation r1(RTHETA1,RPHI1) ----> r2(RTHETA2,RPHI2)
-C
-C IROT=1 : r ---> z represented by (0,RTHETA,PI-RPHI)
-C IROT=0 : r ---> z represented by (0,-RTHETA,-RPHI)
-C
-C
- COMPLEX U1,U2
-C
- DATA PI /3.141593/
-C
- IF(IROT.EQ.1) THEN
- EPS=1
- ELSE
- EPS=-1
- ENDIF
- DPHI=RPHI2-RPHI1
- A1=SIN(RTHETA1)*COS(RTHETA2)
- A2=COS(RTHETA1)*SIN(RTHETA2)
- A3=COS(RTHETA1)*COS(RTHETA2)
- A4=SIN(RTHETA1)*SIN(RTHETA2)
- U1=A1-A2*COS(DPHI)-(0.,1.)*SIN(RTHETA2)*SIN(DPHI)
- U2=A1*COS(DPHI)-A2+(0.,1.)*SIN(RTHETA1)*SIN(DPHI)
- U3=A3+A4*COS(DPHI)
- IF(U3.GT.1.) U3=1.
- IF(U3.LT.-1.) U3=-1.
- RBETA=ACOS(U3)
- IF(ABS(SIN(RBETA)).GT.0.0001) THEN
- U1=EPS*U1/SIN(RBETA)
- U2=EPS*U2/SIN(RBETA)
- CALL ARCSIN(U1,U3,RALPHA)
- CALL ARCSIN(U2,U3,RGAMMA)
- ELSE
- RALPHA=0.
- IF(ABS(U3-1.0).LT.0.0001) THEN
- RGAMMA=0.
- ELSE
- RGAMMA=PI
- ENDIF
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE GAUNT(L2,M2,L1,M1,GNT)
-C
-C This subroutine calculates the Gaunt coefficient G(L2,L3|L1)
-C using a downward recursion scheme due to Schulten and Gordon
-C for the Wigner's 3j symbols. The result is stored as GNT(L3),
-C making use of the selection rule M3 = M1 - M2.
-C
-C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
-C
-C Last modified : 8 Dec 2008
-C
-C
- USE DIM_MOD
- USE LOGAMAD_MOD
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- REAL GNT(0:N_GAUNT)
-C
- DOUBLE PRECISION F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT)
- DOUBLE PRECISION A1(0:N_GAUNT),B(0:N_GAUNT)
-C
-C
- DATA PI4/12.566370614359D0/
-C
- L12=L1+L2
- K12=L1-L2
-C
- DO J=1,N_GAUNT
- GNT(J)=0.
- ENDDO
-C
- IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10
-C
- M3=M1-M2
- LM1=L1+M1
- LM2=L2+M2
- KM1=L1-M1
- KM2=L2-M2
-C
- IF(MOD(M1,2).EQ.0) THEN
- COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
- ELSE
- COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
- ENDIF
-C
- F(L12+1)=0.D0
- G(L12+1)=0.D0
- A(L12+1)=0.D0
- A1(L12+1)=0.D0
- D1=GLD(2*L2+1,1)-GLD(2*L12+2,1)
- D2=GLD(2*L1+1,1)-GLD(LM2+1,1)
- D3=GLD(L12+M3+1,1)-GLD(KM2+1,1)
- D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
-C
- IF(MOD(KM1-KM2,2).EQ.0) THEN
- F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
- ELSE
- F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
- ENDIF
-C
- D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1))
- D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1)
-C
- IF(MOD(K12,2).EQ.0) THEN
- G(L12)=DEXP(D5+D6)
- ELSE
- G(L12)=-DEXP(D5+D6)
- ENDIF
-C
- A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3)))
- B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1)
- &))
- A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12)))
-C
- IF(ABS(M3).LE.L12) THEN
- GNT(L12)=SNGL(COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1)))
- ELSE
- GNT(L12)=0.
- ENDIF
-C
- JMIN=MAX0(ABS(K12),ABS(M3))
-C
- DO J=L12-1,JMIN,-1
- J1=J+1
- J2=J+2
- A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL
- &OAT(J*J-M3*M3))
- B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1)))
- A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J)
- &))
- F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1))
- G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1))
- GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1))
-C
- IF(ABS(M3).LE.J) THEN
- GNT(J)=SNGL(GND)
- ELSE
- GNT(J)=0.
- ENDIF
-C
- ENDDO
-C
- 10 RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE GAUNT2(L2,M2,L1,M1,GNT)
-C
-C This subroutine calculates the Gaunt coefficient G(L2,L3|L1)
-C using a downward recursion scheme due to Schulten and Gordon
-C for the Wigner's 3j symbols. The result is stored as GNT(L3),
-C making use of the selection rule M3 = M1 - M2.
-C
-C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
-C
-C Last modified : 8 Dec 2008
-C This is the double precision version
-C
-C
-C
- USE DIM_MOD
- USE LOGAMAD_MOD
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- REAL*8 F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT),A1(0:N_GAUNT)
- REAL*8 B(0:N_GAUNT),GNT(0:N_GAUNT)
-C
-C
- DATA PI4/12.566370614359D0/
-C
- L12=L1+L2
- K12=L1-L2
-C
- DO J=1,N_GAUNT
- GNT(J)=0.D0
- ENDDO
-C
- IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10
-C
- M3=M1-M2
- LM1=L1+M1
- LM2=L2+M2
- KM1=L1-M1
- KM2=L2-M2
-C
- IF(MOD(M1,2).EQ.0) THEN
- COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
- ELSE
- COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
- ENDIF
-C
- F(L12+1)=0.D0
- G(L12+1)=0.D0
- A(L12+1)=0.D0
- A1(L12+1)=0.D0
- D1=GLD(2*L2+1,1)-GLD(2*L12+2,1)
- D2=GLD(2*L1+1,1)-GLD(LM2+1,1)
- D3=GLD(L12+M3+1,1)-GLD(KM2+1,1)
- D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
-C
- IF(MOD(KM1-KM2,2).EQ.0) THEN
- F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
- ELSE
- F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
- ENDIF
-C
- D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1))
- D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1)
-C
- IF(MOD(K12,2).EQ.0) THEN
- G(L12)=DEXP(D5+D6)
- ELSE
- G(L12)=-DEXP(D5+D6)
- ENDIF
-C
- A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3)))
- B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1)
- &))
- A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12)))
-C
- IF(ABS(M3).LE.L12) THEN
- GNT(L12)=COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1))
- ELSE
- GNT(L12)=0.D0
- ENDIF
-C
- JMIN=MAX0(ABS(K12),ABS(M3))
-C
- DO J=L12-1,JMIN,-1
- J1=J+1
- J2=J+2
- A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL
- &OAT(J*J-M3*M3))
- B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1)))
- A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J)
- &))
- F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1))
- G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1))
- GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1))
-C
- IF(ABS(M3).LE.J) THEN
- GNT(J)=GND
- ELSE
- GNT(J)=0.D0
- ENDIF
-C
- ENDDO
-C
- 10 RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE HARSPH(NL,THETA,PHI,YLM,NC)
-C
-C This routine computes the complex spherical harmonics using Condon and
-C Shortley phase convention.
-C
- USE DIM_MOD
-C
- USE EXPFAC2_MOD
- USE FACTSQ_MOD
-C
- COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
-C
- DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
- DATA PI,SMALL /3.141593,0.0001/
-C
- X=COS(THETA)
- IF(ABS(X).LT.SMALL) X=0.0
- IF(ABS(X+1.).LT.SMALL) X=-1.0
- IF(ABS(X-1.).LT.SMALL) X=1.0
-C
- YLM(0,0)=CMPLX(SQ4PI_INV)
- YLM(1,0)=X*SQR3_INV
- DO L=2,NC
- Y=1./FLOAT(L)
- YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
- &-1.5))*YLM(L-2,0)
- ENDDO
-C
- C2=-1.
- IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN
- C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
- ELSE
- C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
- ENDIF
-C
- C1=1.
- COEF=(1.,0.)
- DO M=1,NC
- C1=C1*C2
- COEF=COEF*C
- YMM=SQ4PI_INV*COEF*FSQ(M)
- YLM(M,M)=YMM
- YLM(M,-M)=C1*CONJG(YMM)
- YMMP=X*SQRT(FLOAT(M+M+3))*YMM
- YLM(M+1,M)=YMMP
- YLM(M+1,-M)=C1*CONJG(YMMP)
- IF(M.LT.NC-1) THEN
- DO L=M+2,NC
- YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
- &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
- YLM(L,-M)=C1*CONJG(YLM(L,M))
- ENDDO
- ENDIF
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE HARSPH2(NL,THETA,PHI,YLM,NC)
-C
-C This routine computes the complex spherical harmonics using Condon and
-C Shortley phase convention. This version for m=0 only
-C
- USE DIM_MOD
-C
- USE EXPFAC2_MOD
- USE FACTSQ_MOD
-C
- COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
-C
- DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
- DATA PI,SMALL /3.141593,0.0001/
-C
- X=COS(THETA)
- IF(ABS(X).LT.SMALL) X=0.0
- IF(ABS(X+1.).LT.SMALL) X=-1.0
- IF(ABS(X-1.).LT.SMALL) X=1.0
-C
- YLM(0,0)=CMPLX(SQ4PI_INV)
- YLM(1,0)=X*SQR3_INV
- DO L=2,NC
- Y=1./FLOAT(L)
- YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
- &-1.5))*YLM(L-2,0)
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE HARSPH3(NL,THETA,PHI,YLM2,NC)
-C
-C This routine computes the complex spherical harmonics using Condon and
-C Shortley phase convention.
-C
- USE DIM_MOD
-C
- USE EXPFAC2_MOD
- USE FACTSQ_MOD
-C
- COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
- COMPLEX YLM2(LINMAX)
-C
- DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
- DATA PI,SMALL /3.141593,0.0001/
-C
- X=COS(THETA)
- IF(ABS(X).LT.SMALL) X=0.0
- IF(ABS(X+1.).LT.SMALL) X=-1.0
- IF(ABS(X-1.).LT.SMALL) X=1.0
-C
- YLM(0,0)=CMPLX(SQ4PI_INV)
- YLM(1,0)=X*SQR3_INV
- DO L=2,NC
- Y=1./FLOAT(L)
- YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
- &-1.5))*YLM(L-2,0)
- ENDDO
-C
- C2=-1.
- IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN
- C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
- ELSE
- C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
- ENDIF
-C
- C1=1.
- COEF=(1.,0.)
- DO M=1,NC
- C1=C1*C2
- COEF=COEF*C
- YMM=SQ4PI_INV*COEF*FSQ(M)
- YLM(M,M)=YMM
- YLM(M,-M)=C1*CONJG(YMM)
- YMMP=X*SQRT(FLOAT(M+M+3))*YMM
- YLM(M+1,M)=YMMP
- YLM(M+1,-M)=C1*CONJG(YMMP)
- IF(M.LT.NC-1) THEN
- DO L=M+2,NC
- YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
- &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
- YLM(L,-M)=C1*CONJG(YLM(L,M))
- ENDDO
- ENDIF
- ENDDO
-C
- DO L=0,NC
- IL=L*L+L+1
- DO M=-L,L
- IND=IL+M
- YLM2(IND)=YLM(L,M)
- ENDDO
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE HEADERS(IUO2)
-C
-C This subroutine writes headers containing the main parameters
-C of the calculation in the result file. The number of
-C lines written depends of the spectroscopy
-C
-C Last modified : 31 Jan 2013
-C
- USE DIM_MOD
-C
- USE ALGORITHM_MOD
- USE APPROX_MOD
- USE EXAFS_MOD
- USE HEADER_MOD
- USE INFILES_MOD
- USE INIT_A_MOD
- USE INIT_J_MOD
- USE INIT_L_MOD
- USE INIT_M_MOD
- USE MOYEN_MOD
- USE PARCAL_MOD
- USE PARCAL_A_MOD
- USE TYPCAL_MOD
- USE TYPCAL_A_MOD
- USE TYPEXP_MOD
- USE VALIN_MOD
- USE VALIN_AV_MOD
- USE VALFIN_MOD
- USE VALEX_A_MOD
-C
-C
-C
-C
-C
-C
-C
-C
-C
-C
-C
- WRITE(IUO2,1)
- WRITE(IUO2,2)
-C
-C Input files section:
-C
-C Checking the size of filenames
-C
- N_CHAR1=0
- DO J_CHAR=1,24
- IF(INFILE1(J_CHAR:J_CHAR).EQ.' ') GOTO 500
- N_CHAR1=N_CHAR1+1
- ENDDO
- 500 CONTINUE
-C
- N_CHAR2=0
- DO J_CHAR=1,24
- IF(INFILE2(J_CHAR:J_CHAR).EQ.' ') GOTO 501
- N_CHAR2=N_CHAR2+1
- ENDDO
- 501 CONTINUE
-C
- N_CHAR3=0
- DO J_CHAR=1,24
- IF(INFILE3(J_CHAR:J_CHAR).EQ.' ') GOTO 502
- N_CHAR3=N_CHAR3+1
- ENDDO
- 502 CONTINUE
-C
- N_CHAR4=0
- DO J_CHAR=1,24
- IF(INFILE4(J_CHAR:J_CHAR).EQ.' ') GOTO 503
- N_CHAR4=N_CHAR4+1
- ENDDO
- 503 CONTINUE
-C
- WRITE(IUO2,3) INFILE1(6:N_CHAR1)
- WRITE(IUO2,4) INFILE2(4:N_CHAR2)
- IF(INTERACT.NE.'NOINTER') THEN
- WRITE(IUO2,5) INFILE3(5:N_CHAR3)
- ENDIF
- WRITE(IUO2,6) INFILE4(6:N_CHAR4)
- WRITE(IUO2,2)
-C
-C Type of calculation
-C
- WRITE(IUO2,2)
-C
- IF(SPECTRO.EQ.'PHD') THEN
- WRITE(IUO2,11) SPECTRO,ALGO1
- IF(ALGO1.EQ.'SE') THEN
- WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
- ELSEIF(ALGO1.EQ.'CE') THEN
- WRITE(IUO2,13) NDIF
- ENDIF
- WRITE(IUO2,14) VINT
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- WRITE(IUO2,11) SPECTRO,ALGO1
- IF(ALGO1.EQ.'SE') THEN
- WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
- ELSEIF(ALGO1.EQ.'CE') THEN
- WRITE(IUO2,13) NDIF
- ENDIF
- WRITE(IUO2,14) VINT
- ELSEIF(SPECTRO.EQ.'LED') THEN
- WRITE(IUO2,11) SPECTRO,ALGO1
- IF(ALGO1.EQ.'SE') THEN
- WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
- ELSEIF(ALGO1.EQ.'CE') THEN
- WRITE(IUO2,13) NDIF
- ENDIF
- WRITE(IUO2,14) VINT
- ELSEIF(SPECTRO.EQ.'AED') THEN
- WRITE(IUO2,11) SPECTRO,ALGO2
- IF(ALGO1.EQ.'SE') THEN
- WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
- ELSEIF(ALGO1.EQ.'CE') THEN
- WRITE(IUO2,13) NDIF
- ENDIF
- WRITE(IUO2,14) VINT
- ELSEIF(SPECTRO.EQ.'APC') THEN
- WRITE(IUO2,15) SPECTRO,ALGO1,ALGO2
- WRITE(IUO2,14) VINT
- ELSEIF(SPECTRO.EQ.'EIG') THEN
- WRITE(IUO2,11) SPECTRO,ALGO1
- ELSEIF(SPECTRO.EQ.'RES') THEN
- CONTINUE
- ELSEIF(SPECTRO.EQ.'ELS') THEN
- CONTINUE
- ENDIF
-C
- WRITE(IUO2,2)
-C
-C Initial state parameters
-C
- IF(SPECTRO.EQ.'PHD') THEN
- WRITE(IUO2,21) NI,NLI,S_O,INITL
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- WRITE(IUO2,22) EDGE,NEDGE,INITL
- ELSEIF(SPECTRO.EQ.'LED') THEN
- CONTINUE
- ELSEIF(SPECTRO.EQ.'AED') THEN
- WRITE(IUO2,24) AUGER,MULTIPLET
- ELSEIF(SPECTRO.EQ.'APC') THEN
- WRITE(IUO2,21) NI,NLI,S_O,INITL
- WRITE(IUO2,24) AUGER,MULTIPLET
- ELSEIF(SPECTRO.EQ.'RES') THEN
- CONTINUE
- ELSEIF(SPECTRO.EQ.'ELS') THEN
- CONTINUE
- ENDIF
-C
- WRITE(IUO2,2)
-C
-C Angular and energy parameters
-C
- IF(SPECTRO.EQ.'PHD') THEN
- WRITE(IUO2,35)
- WRITE(IUO2,34) THLUM,PHILUM,ELUM
- WRITE(IUO2,2)
- WRITE(IUO2,36)
- WRITE(IUO2,31) THETA0,THETA1
- WRITE(IUO2,32) PHI0,PHI1
- WRITE(IUO2,33) E0,EFIN
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- WRITE(IUO2,35)
- WRITE(IUO2,33) EK_INI,EK_FIN
- WRITE(IUO2,34) THLUM,PHILUM,ELUM
- ELSEIF(SPECTRO.EQ.'LED') THEN
- WRITE(IUO2,35)
- WRITE(IUO2,31) THLUM,PHILUM
- WRITE(IUO2,2)
- WRITE(IUO2,36)
- WRITE(IUO2,31) THETA0,THETA1
- WRITE(IUO2,32) PHI0,PHI1
- WRITE(IUO2,2)
- WRITE(IUO2,33) E0,EFIN
- ELSEIF(SPECTRO.EQ.'AED') THEN
- WRITE(IUO2,36)
- WRITE(IUO2,31) THETA0_A,THETA1_A
- WRITE(IUO2,32) PHI0_A,PHI1_A
- ELSEIF(SPECTRO.EQ.'APC') THEN
- WRITE(IUO2,35)
- WRITE(IUO2,34) THLUM,PHILUM,ELUM
- WRITE(IUO2,2)
- WRITE(IUO2,37)
- WRITE(IUO2,31) THETA0,THETA1
- WRITE(IUO2,32) PHI0,PHI1
- WRITE(IUO2,33) E0,EFIN
- WRITE(IUO2,2)
- WRITE(IUO2,38)
- WRITE(IUO2,31) THETA0_A,THETA1_A
- WRITE(IUO2,32) PHI0_A,PHI1_A
- ELSEIF(SPECTRO.EQ.'EIG') THEN
- WRITE(IUO2,33) EK_INI,EK_FIN
- ELSEIF(SPECTRO.EQ.'RES') THEN
- CONTINUE
- ELSEIF(SPECTRO.EQ.'ELS') THEN
- CONTINUE
- ENDIF
-C
-C End of headers
-C
- WRITE(IUO2,2)
- WRITE(IUO2,1)
- WRITE(IUO2,39)
-C
-C Formats
-C
- 1 FORMAT('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!','
- &!!!!!!!!!!!!!!!!')
- 2 FORMAT('!',69X,'!')
- 3 FORMAT('!',10X,'data file : ',A19,20X,'!')
- 4 FORMAT('!',10X,'t-matrix file : ',A17,20X,'!')
- 5 FORMAT('!',10X,'rad integral file: ',A20,20X,'!')
- 6 FORMAT('!',10X,'cluster file : ',A19,20X,'!')
-C
- 11 FORMAT('!',10X,'spectroscopy : ',A3,8X,'algorithm : ',A2,
- &10X,'!')
- 12 FORMAT('!',15X,'NO = ',I1,' NDIF = ',I2,' IFWD = ',I1,' IPW = '
- &,I1,' ILENGTH = ',I1,5X,'!')
- 13 FORMAT('!',15X,'NDIF = ',I2,45X,'!')
- 14 FORMAT('!',10X,'inner potential : ',F6.2,' eV',28X,'!')
- 15 FORMAT('!',10X,'spectroscopy: ',A3,10X,'algorithm (photo): ',A2,11
- &X,'!',/,'!',37X,'algorithm (auger): ',A2, 11X,'!')
-C
- 21 FORMAT('!',10X,'initial state : ',I1,A1,1X,A3,' selection rules
- &:',' INITL = ',I2,6X,'!')
- 22 FORMAT('!',10X,'initial state : ',A1,I1,2X,' selection rules:',
- &' INITL = ',I2,8X,'!')
- 24 FORMAT('!',10X,'initial state : ',A6,2X,' multiplet: ',A3,17X,'
- &!')
-C
- 31 FORMAT('!',10X,'THETA_INI: ',F8.2,6X,'THETA_FIN: ',F8.2,15X,'!')
- 32 FORMAT('!',10X,'PHI_INI : ',F8.2,6X,'PHI_FIN : ',F8.2,15X,'!')
- 33 FORMAT('!',10X,'E_INI : ',F8.2,' eV',3X,'E_FIN : ',F8.2,' eV
- &',12X,'!')
- 34 FORMAT('!',10X,'THETA_LUM: ',F8.2,2X,'PHI_LUM: ',F8.2,2X,'E_LUM: '
- &,F8.2,' eV !')
- 35 FORMAT('!',10X,'incoming beam : ',40X,'!')
- 36 FORMAT('!',10X,'outgoing beam : ',40X,'!')
- 37 FORMAT('!',10X,'photoelectron beam:',40X,'!')
- 38 FORMAT('!',10X,'auger beam :',40X,'!')
- 39 FORMAT(71X)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- INTEGER FUNCTION IG(J)
-C
-C This function is returns the value 1 if J is an integer
-C and 2 if it is a half-integer
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-C
- REAL*8 J,JJ
-C
- DATA SMALL /0.0001D0/
-C
- JJ=ABS(J+J)
-C
- LL=INT(JJ+SMALL)
-C
- IF(MOD(LL,2).EQ.0) THEN
- IG=1
- ELSE
- IG=2
- ENDIF
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE LOCATE(XX,N,X,J)
-C
-C
-C This subroutine is taken from the book :
-C "Numerical Recipes : The Art of Scientific
-C Computing" par W.H. PRESS, B.P. FLANNERY,
-C S.A. TEUKOLSKY et W.T. VETTERLING
-C (Cambridge University Press 1992)
-C
-C It performs a search in an ordered table using a bisection method.
-C Given a monotonic array XX(1:N) and a value X, it returns J such
-C that X is between XX(J) and XX(J+1).
-C
- INTEGER J,N
- INTEGER JL,JM,JU
-C
- REAL X,XX(N)
-C
- JL=0
- JU=N+1
- 10 IF(JU-JL.GT.1)THEN
- JM=(JU+JL)/2
- IF((XX(N).GT.XX(1)).EQV.(X.GT.XX(JM)))THEN
- JL=JM
- ELSE
- JU=JM
- ENDIF
- GOTO 10
- ENDIF
- J=JL
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE LPM(E,XLPM,*)
-C
-C This routine generates the electron mean free path
-C
-C ILPM=-1: XLPM is set to 1.E+30
-C ILPM=0 : XLPM is the value given in the input data file
-C ILPM=1 : XLPM computed from Tokutaka et al, Surf. Sci. 149,349 (1985)
-C ILPM=2 : XLPM computed from the Seah and Dench expression
-C
-C Last modified : 15 Sep 2009
-C
- USE LPMOY_MOD , NZ => NZA, XMAT => XMTA, RHO => RHOTA
- USE OUTUNITS_MOD
- USE TESTS_MOD
- USE VALIN_MOD
-C
- E=E+VINT
-C
- IF(ILPM.EQ.-1) THEN
- XLPM=1.E+30
- ELSEIF(ILPM.EQ.0) THEN
- XLPM=XLPM0
- ELSEIF(ILPM.EQ.1) THEN
- Q=FLOAT(NZ)*RHO/XMAT
- CSTE1=ALOG(Q/4.50)/(ALOG(7.74/4.50))
- CSTE2=ALOG(Q/3.32)/(ALOG(7.74/3.32))
- CSTE3=ALOG(Q/3.32)/(ALOG(4.50/3.32))
- A1=0.7271+0.2595*ALOG(E)
- A2=-3.2563+0.9395*ALOG(E)
- A3=-2.5716+0.8226*ALOG(E)
- IF(E.GE.350.) GO TO 10
- XLN=CSTE1*(0.0107-0.0083*ALOG(E))+A1
- GO TO 20
- 10 IF((NZ.GE.24).AND.(NZ.LE.74)) GO TO 30
- XLN=CSTE2*(1.6551-0.2890*ALOG(E))+A2
- GO TO 20
- 30 IF(NZ.GE.42) GO TO 40
- XLN=CSTE3*(0.6847-0.1169*ALOG(E))+A2
- GO TO 20
- 40 XLN=CSTE1*(0.9704-0.1721*ALOG(E))+A3
- 20 XLPM=EXP(XLN)
- ELSEIF(ILPM.EQ.2) THEN
- XLPM=1430./(E**2)+0.54*SQRT(E)
- ELSE
- RETURN 1
- ENDIF
-C
- E=E-VINT
- IF(IPRINT.GT.0) WRITE(IUO1,80) E,XLPM
-C
- 80 FORMAT(/////,2X,'========= E = ',F7.2,' eV',5X,'MEAN',' FREE PATH
- & = ',F6.3,' ANGSTROEMS ','=========')
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE N_J(J1,MJ1,J2,MJ2,MJ6,NJ,I_INT,N_IN)
-C
-C This subroutine calculates Wigner's 3j and 6j coefficients
-C using a downward recursion scheme due to Schulten and Gordon.
-C The 3j are defined as (J1 J2 J) where in fact L1=MJ1, etc are
-C (L1 L2 L)
-C azimuthal quantum numbers, and the 6j as {J1 J2 J} where now
-C {L1 L2 L}
-C J1, L1, etc are the same kind of orbital quantum numbers.
-C The result is stored as NJ(J).
-C
-C The parameter N allows to choose between 3j and 6j calculation, and
-C Clebsch-Gordan. It can take the values :
-C
-C N = 2 ----> Clebsch-Gordan
-C N = 3 ----> Wigner's 3j
-C N = 6 ----> Wigner's 6j
-C
-C The Clebsch-Gordan coefficients are related to Wigner's 3j through :
-C
-C CG(J1,M1,J2,M2|J,MJ) = ( J1 J2 J )*sqrt(2*J+1)*(-1)**(J1-J2+MJ)
-C ( M1 M2 -MJ )
-C I_INT is a flag that returns 1 if the index J of the nj symbol
-C is integer and 0 if it is a half integer.
-C
-C Note : For 3j, MJ6 is ignored while for 6j, we have :
-C
-C J1=J1 MJ1=L1 J2=J2 MJ2=L2 MJ6=L
-C
-C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
-C
-C Last modified : 8 Dec 2008 ----> D. Sebilleau
-C
-C
- USE DIM_MOD
- USE LOGAMAD_MOD
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- REAL*4 NJ(0:N_GAUNT)
-C
- REAL*8 J1,J2,J,MJ1,MJ2,MJ,JP1,JP2
- REAL*8 F(0:N_GAUNT),A(0:N_GAUNT),B(0:N_GAUNT)
- REAL*8 JL12,JK12,MJ6,SIG
- REAL*8 JJ1,JJ2,JL1,JL2,JL3,JJ12,JJ_MIN,JJ_MAX
-C
-C
- DATA SMALL /0.0001D0/
-C
- IS=0
-C
- IF(N_IN.EQ.2) THEN
- N_OU=3
- I_CG=1
- ELSE
- N_OU=N_IN
- I_CG=0
- ENDIF
-C
- IF(N_OU.EQ.3) THEN
-C
-C------------------------------ 3j case ---------------------------------
-C
-C
-C Test to check if J1 and J2 are integer or semi-integer
-C
-C Integer : IG=1
-C Half-integer : IG=2
-C
-C Each angular momentum J is represented by the integer index L and
-C the corresponding MJ by M
-C
- L1=INT(J1+SMALL)
- L2=INT(J2+SMALL)
- M1=INT(MJ1+SIGN(SMALL,MJ1))
- M2=INT(MJ2+SIGN(SMALL,MJ2))
- DIF1=J1-DFLOAT(L1)
- DIF2=J2-DFLOAT(L2)
-C
-C IGx is a flag telling the code which case of Gamma function to use :
-C
-C IGx = 1 : integer case
-C IGx = 2 : half-integer case
-C
- IF(ABS(DIF1).LT.SMALL) THEN
- IG1=1
- ELSE
- IG1=2
- ENDIF
- IF(ABS(DIF2).LT.SMALL) THEN
- IG2=1
- ELSE
- IG2=2
- ENDIF
- IF(IG1.EQ.IG2) THEN
- IGG=1
- IF(IG1.EQ.2) IS=1
- ELSE
- IGG=2
- ENDIF
-C
-C Here, we assume that (J1,J2) are both either integer or half-integer
-C If J is integer, the corresponding index is L = j (for loops or storage)
-C while if J is an half-integer, this index is L= j - 1/2 = int(j)
-C
-C Integer indices are used for loops and for storage while true values
-C are used for the initial values. When J1 and J2 are both half-integers,
-C the values of J are integer and L should be increased by 1
-C
- JL12=J1+J2
- JK12=J1-J2
-C
- L12=INT(JL12 + SIGN(SMALL,JL12))
- K12=INT(JK12 + SIGN(SMALL,JK12))
-C
- LM1=INT(J1+MJ1 + SIGN(SMALL,J1+MJ1))
- LM2=INT(J2+MJ2 + SIGN(SMALL,J2+MJ2))
- KM1=INT(J1-MJ1 + SIGN(SMALL,J1-MJ1))
- KM2=INT(J2-MJ2 + SIGN(SMALL,J2-MJ2))
-C
- MJ=-MJ1-MJ2
-C
- M=INT(MJ+SIGN(SMALL,MJ))
- L12M=INT(JL12+MJ+SIGN(SMALL,JL12+MJ))
- K12M=INT(JL12-MJ+SIGN(SMALL,JL12-MJ))
- L1_2=INT(J1+J1+SIGN(SMALL,J1))
- L2_2=INT(J2+J2+SIGN(SMALL,J2))
- L12_2=INT(JL12+JL12+SIGN(SMALL,JL12))
-C
- IF(IG(JL12).EQ.1) THEN
- I_INT=1
- ELSE
- I_INT=0
- ENDIF
-C
-C Initialisation of the 3j symbol NJ(J) = (J1 J2 J)
-C (MJ1 MJ2 MJ)
-C
- DO L=0,L12
- NJ(L)=0.
- ENDDO
-C
- IF((ABS(MJ1).GT.J1).OR.(ABS(MJ2).GT.J2)) GOTO 10
-C
-C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward
-C recursion scheme. This scheme writes as
-C
-C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0
-C
- F(L12+1)=0.D0
- A(L12+1)=0.D0
- D1=GLD(L2_2+1,1)-GLD(L12_2+2,1)
- D2=GLD(L1_2+1,1)-GLD(LM2+1,1)
- D3=GLD(L12M+1,1)-GLD(KM2+1,1)
- D4=GLD(K12M+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
-C
- N12=INT(JK12-MJ + SIGN(SMALL,JK12-MJ))
-C
- IF(I_CG.EQ.1) THEN
- IF(MOD(N12,2).EQ.0) THEN
- SIG=1.D0
- ELSE
- SIG=-1.D0
- ENDIF
- ENDIF
-C
- IF(MOD(N12,2).EQ.0) THEN
- F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
- ELSE
- F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
- ENDIF
-C
- A(L12)=2.D0*DSQRT(J1*J2*(1.D0+2.D0*JL12)*(JL12*JL12-MJ*MJ))
- B(L12)=-(2.D0*JL12+1.D0)*((J1*J1-J2*J2+JK12)*MJ-JL12*(JL12+1.D0)
- &*(MJ2-MJ1))
-C
- IF(ABS(M).LE.L12) THEN
- IF(I_CG.EQ.0) THEN
- NJ(L12)=SNGL(F(L12))
- ELSE
- NJ(L12)=SNGL(F(L12)*SIG*DSQRT(JL12+JL12+1.D0))
- ENDIF
- ELSE
- NJ(L12)=0.
- ENDIF
-C
- LMIN=MAX0(ABS(K12),ABS(M))
-C
-C Downward recursion for NJ(J)
-C
- DO L=L12-1,LMIN,-1
- LP1=L+1
- LP2=L+2
-C
-C Value of the angular momentum J corresponding to the loop index L
-C
- IF(IGG.EQ.1) THEN
- J=DFLOAT(L)
- JP1=DFLOAT(LP1)
- JP2=DFLOAT(LP2)
- ELSE
- J=DFLOAT(L) + 0.5D0
- JP1=DFLOAT(LP1) + 0.5D0
- JP2=DFLOAT(LP2) + 0.5D0
- ENDIF
-C
- A(L)=DSQRT((J*J-JK12*JK12)*((JL12+1.D0)*(JL12+1.D0)-J*J)*(J*J-
- &MJ*MJ))
- B(L)=-(2.D0*J+1.D0)*(J1*(J1+1.D0)*MJ-J2*(J2+1.D0)*MJ-J*JP1*(MJ
- &2-MJ1))
- F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1))
-C
- IF(ABS(MJ).LE.J) THEN
- IF(I_CG.EQ.0) THEN
- NJ(L)=SNGL(F(L))
- ELSE
- NJ(L)=SNGL(F(L)*SIG*DSQRT(J+J+1.D0))
- ENDIF
- ELSE
- NJ(L)=0.
- ENDIF
-C
- ENDDO
-C
- 10 CONTINUE
-C
- ELSEIF(N_OU.EQ.6) THEN
-C
-C------------------------------ 6j case ---------------------------------
-C
-C Change of notation for greater readability ---> NJ(JJ)
-C
-C True angular momentum value : begins with a J (JJn,JLn)
-C Corresponding integer storage and loop index : begins by L (LJn,LLn)
-C
- JJ1=J1
- JJ2=J2
- JL1=MJ1
- JL2=MJ2
- JL3=MJ6
-C
- LJ1=INT(JJ1+SIGN(SMALL,JJ1))
- LJ2=INT(JJ2+SIGN(SMALL,JJ2))
- LL1=INT(JL1+SIGN(SMALL,JL1))
- LL2=INT(JL2+SIGN(SMALL,JL2))
- LL3=INT(JL3+SIGN(SMALL,JL3))
-C
- JJ12=JJ1-JJ2
- JL12=JL1-JL2
-C
- LJ12=INT(JJ12+SIGN(SMALL,JJ12))
- LL12=INT(JL12+SIGN(SMALL,JL12))
-C
- JJ_MIN=MAX(ABS(LJ12),ABS(LL12))
- JJ_MAX=MIN(JJ1+JJ2,JL1+JL2)
- LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN))
- LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX))
-C
-C Initialisation of the 6j symbol NJ(J) = {J1 J2 J }
-C {L1 L2 L3}
-C
- DO L=0,LJJ_MAX
- NJ(L)=0.
- ENDDO
-C
-C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward
-C recursion scheme. This scheme writes as
-C
-C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0
-C
-C There are two possible initial values as max(|J1-J2|,|L1-L2|) <= J <=
-C min(J1+J2,L1+L2) :
-C
-C {J1 J2 L1+L2} and {J1 J2 J1+J2} = {L1 L2 J1+J2}
-C {L1 L2 L3 } {L1 L2 L3 } {J1 J2 L3 }
-C
-C They can be calculated from equation (6.3.1) of Edmonds page 97
-C
- F(LJJ_MAX+1)=0.D0
- A(LJJ_MAX+1)=0.D0
-C
- IF(ABS(JJ_MAX-JL1-JL2).LT.SMALL) THEN
- F(LJJ_MAX)=SIXJ_IN(JJ1,JJ2,JL1,JL2,JL3)
- ELSE
- F(LJJ_MAX)=SIXJ_IN(JL1,JL2,JJ1,JJ2,JL3)
- ENDIF
- NJ(LJJ_MAX)=SNGL(F(LJJ_MAX))
-C
- A(LJJ_MAX)=SQRT((JJ_MAX*JJ_MAX-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.
- &D0)*(JJ1+JJ2+1.D0)-JJ_MAX*JJ_MAX)*(JJ_MAX*JJ_MAX-(JL1-JL2)*(JL1-JL
- &2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)-JJ_MAX*JJ_MAX))
- B(LJJ_MAX)=(JJ_MAX+JJ_MAX+1.D0)*(JJ_MAX*(JJ_MAX+1.D0)*(-JJ_MAX*(
- &JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1*(JL1+1.D0)*(JJ_MAX
- &*(JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(JJ_M
- &AX*(JJ_MAX+1.D0)-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(JJ_MAX+JJ_MAX)*(J
- &J_MAX+1.D0)*JL3*(JL3+1.D0))
-C
- IF(IG(JJ_MAX).EQ.1) THEN
- I_INT=1
- ELSE
- I_INT=0
- ENDIF
-C
-C Downward recurrence relation
-C
- DO L=LJJ_MAX-1,LJJ_MIN,-1
- LP1=L+1
- LP2=L+2
-C
-C Value of the angular momentum J corresponding to the loop index L
-C
- IF(IG(JJ_MAX).EQ.1) THEN
- J=DFLOAT(L)
- JP1=DFLOAT(LP1)
- JP2=DFLOAT(LP2)
- ELSE
- J=DFLOAT(L) + 0.5D0
- JP1=DFLOAT(LP1) + 0.5D0
- JP2=DFLOAT(LP2) + 0.5D0
- ENDIF
-C
- A(L)=SQRT((J*J-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.D0)*(JJ1+JJ2+1
- &.D0)-J*J)*(J*J-(JL1-JL2)*(JL1-JL2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)
- &-J*J))
- B(L)=(J+J+1)*(J*JP1*(-J*JP1+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1
- &*(JL1+1.D0)*(J*JP1+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(
- &J*JP1-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(J+J)*JP1*JL3*(JL3+1.D0))
-C
- F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1))
- NJ(L)=SNGL(F(L))
-C
- ENDDO
-C
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE ORDRE2(NINI,VALINI,NFIN,VALFIN)
-C
-C Given a set of **integer** numbers VALINI, this routine orders them
-C and suppresses the values appearing more than once. The remaining
-C values are stored in VALFIN.
-C
-C VALINI(K+1).GT.VALINI(K) : decreasing order
-C VALINI(K+1).LT.VALINI(K) : increasing order
-C
-C
-C
- INTEGER VALINI(NINI),VALFIN(NINI),R1
-C
- LOGICAL BUBBLE
-C
- DO J=1,NINI-1
- K=J
- BUBBLE=.TRUE.
-150 IF(K.GE.1.AND.BUBBLE) THEN
- IF(VALINI(K+1).LT.VALINI(K)) THEN
- R1=VALINI(K)
- VALINI(K)=VALINI(K+1)
- VALINI(K+1)=R1
- ELSE
- BUBBLE=.FALSE.
- ENDIF
- K=K-1
- GOTO 150
- ENDIF
- ENDDO
-C
- JFIN=1
- VALFIN(1)=VALINI(1)
- DO J=1,NINI-1
- IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.0) THEN
- JFIN=JFIN+1
- VALFIN(JFIN)=VALINI(J+1)
- ENDIF
- ENDDO
- NFIN=JFIN
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE ORDRE(NINI,VALINI,NFIN,VALFIN)
-C
-C Given a set of **real** numbers VALINI, this routine orders them and
-C suppresses the values appearing more than once. The remaining
-C values are stored in VALFIN.
-C
-C VALINI(K+1).GT.VALINI(K) : decreasing order
-C VALINI(K+1).LT.VALINI(K) : increasing order
-C
-C
- DIMENSION VALINI(NINI),VALFIN(NINI)
-C
- LOGICAL BUBBLE
-C
- DATA SMALL /0.00001/
-C
- DO J=1,NINI-1
- K=J
- BUBBLE=.TRUE.
-150 IF(K.GE.1.AND.BUBBLE) THEN
- IF(VALINI(K+1).GT.VALINI(K)) THEN
- R1=VALINI(K)
- VALINI(K)=VALINI(K+1)
- VALINI(K+1)=R1
- ELSE
- BUBBLE=.FALSE.
- END IF
- K=K-1
- GOTO 150
- ENDIF
- ENDDO
-C
- JFIN=1
- VALFIN(1)=VALINI(1)
- DO J=1,NINI-1
- IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN
- JFIN=JFIN+1
- VALFIN(JFIN)=VALINI(J+1)
- ENDIF
- ENDDO
- NFIN=JFIN
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE PLM(X,PLMM,NC)
-C
-C This routine computes the Legendre functions. It is a modified version
-C of that written by W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY and
-C W.T. VETTERLING in "Numerical Recipes : The Art of Scientific
-C Computing" (Cambridge University Press 1992).
-C
- DIMENSION PLMM(0:100,0:100)
-C
- PLMM(0,0)=1.
- PLMM(1,0)=X
- DO L=2,NC
- PLMM(L,0)=(X*(L+L-1)*PLMM(L-1,0)-(L-1)*PLMM(L-2,0))/L
- ENDDO
-C
- DO M=1,NC
- PMM=1.
- FACT=1.
- SOMX2=SQRT(1.-X*X)
- FACT=1.
- DO I=1,M
- PMM=-PMM*FACT*SOMX2
- FACT=FACT+2.
- ENDDO
- PMMP1=X*FACT*PMM
- PLMM(M,M)=PMM
- PLMM(M+1,M)=PMMP1
- IF(M.LT.NC-1) THEN
- DO L=M+2,NC
- PLL=(X*(L+L-1)*PMMP1-(L+M-1)*PMM)/(L-M)
- PMM=PMMP1
- PMMP1=PLL
- PLMM(L,M)=PLL
- ENDDO
- ENDIF
- ENDDO
-C
- RETURN
-C
- END
-C
-C=============================================================================
-C
- SUBROUTINE POLHAN(ISPHER,NO,NC,RHO,HLM)
-C
-C This routine calculates a function HLM(L,M), related to the the Hankel
-C polynomials and their derivatives with respect to z=1/ikr,
-C necessary for the Rehr-Albers expansion of the propagator.
-C
- USE DIM_MOD
-C
- COMPLEX HLM(0:NO_ST_M,0:NL_M-1),RHO,Z,ONEC
-C
- ONEC=(1.,0.)
-C
- IF(ISPHER.GE.1) THEN
- Z=(0.,-1.)/RHO
-C
-C Case M = 0
-C
- HLM(0,0)=ONEC
- HLM(0,1)=ONEC-Z
- DO L=2,NC
- HLM(0,L)=HLM(0,L-2)-FLOAT(L+L-1)*Z*HLM(0,L-1)
- ENDDO
-C
-C Case M > 0
-C
- IF(NO.GE.1) THEN
- DO M=1,NO
- HLM(M,M)=-Z*HLM(M-1,M-1)*FLOAT(M+M-1)
- HLM(M,M+1)=HLM(M,M)*FLOAT(M+M+1)*(ONEC-Z*FLOAT(M+1))
- DO L=M+2,NC
- HLM(M,L)=HLM(M,L-2)-FLOAT(L+L-1)*Z*(HLM(M,L-1)+HLM(M-1,L-1
- &))
- ENDDO
- ENDDO
- ENDIF
- ELSE
- DO M=0,NO
- DO L=M,NC
- HLM(M,L)=ONEC
- ENDDO
- ENDDO
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE POLLEG(NC,X,PL)
-C
-C This routine computes the Legendre polynomials up to order NC-1
-C
- DIMENSION PL(0:100)
-C
- PL(0)=1.
- PL(1)=X
- DO 10 L=2,NC-1
- L1=L-1
- L2=L-2
- L3=2*L-1
- PL(L)=(X*FLOAT(L3)*PL(L1)-FLOAT(L1)*PL(L2))/FLOAT(L)
- 10 CONTINUE
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- FUNCTION PRSCAL(A1,A2)
-C
-C This function computes the dot product of the two vectors A1 and A2
-C
- DIMENSION A1(3),A2(3)
-C
- PRSCAL=A1(1)*A2(1)+A1(2)*A2(2)+A1(3)*A2(3)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE PRVECT(A1,A2,A3,C)
-C
-C This function computes the vector product of the two vectors A1 and A2.
-C The result is A3; C is a scaling factor
-C
- DIMENSION A1(3),A2(3),A3(3)
-C
- A3(1)=(A1(2)*A2(3)-A1(3)*A2(2))/C
- A3(2)=(A1(3)*A2(1)-A1(1)*A2(3))/C
- A3(3)=(A1(1)*A2(2)-A1(2)*A2(1))/C
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*,*,*,*,*,*,*,*,*,*
- &,*,*,*)
-C
-C This subroutine reads the input data from unit ICOM and writes
-C them in the control file IUO1. Then, it stores the data in
-C the various COMMON blocks
-C
-C Last modified : 26 Apr 2013
-C
- USE DIM_MOD
-C
- USE ADSORB_MOD
- USE AMPLI_MOD
- USE APPROX_MOD
- USE ATOMS_MOD
- USE AUGER_MOD
- USE BASES_MOD
- USE COEFRLM_MOD
- USE CONVACC_MOD
- USE CONVTYP_MOD
- USE C_G_MOD
- USE C_G_A_MOD
- USE C_G_M_MOD
- USE CRANGL_MOD
- USE DEBWAL_MOD , T => TEMP
- USE DEXPFAC2_MOD
- USE DFACTSQ_MOD
- USE EIGEN_MOD
- USE EXAFS_MOD
- USE EXPFAC_MOD
- USE EXPFAC2_MOD
- USE EXPROT_MOD
- USE FACTSQ_MOD
- USE FDIF_MOD
- USE FIXSCAN_MOD
- USE FIXSCAN_A_MOD
- USE HEADER_MOD , AUGER1 => AUGER
- USE INDAT_MOD
- USE INFILES_MOD
- USE INUNITS_MOD
- USE INIT_A_MOD
- USE INIT_J_MOD
- USE INIT_L_MOD
- USE INIT_M_MOD
- USE LIMAMA_MOD
- USE LINLBD_MOD
- USE LOGAMAD_MOD
- USE LPMOY_MOD , XM => XMTA, RH => RHOTA
- USE MILLER_MOD
- USE MOYEN_MOD
- USE MOYEN_A_MOD
- USE OUTFILES_MOD
- USE OUTUNITS_MOD
- USE PARCAL_MOD
- USE PARCAL_A_MOD
- USE RA_MOD
- USE RELADS_MOD
- USE RELAX_MOD
- USE RENORM_MOD
- USE RESEAU_MOD
- USE SPECTRUM_MOD
- USE SPIN_MOD
- USE TESTS_MOD
- USE TYPCAL_MOD
- USE TYPCAL_A_MOD
- USE TYPEM_MOD
- USE TYPEXP_MOD
- USE VALIN_MOD
- USE VALIN_AV_MOD
- USE VALFIN_MOD
- USE VALEX_A_MOD
- USE XMRHO_MOD
-C
-C
-C
-C
- REAL*8 J1,J2,MJ1,MJ2,MJ3,JJ,DXDEN,DEXPF
- REAL*8 JJ_MIN,JJ_MAX,JJ12,JL12,SMALL,SQPI
-C
- REAL TEXTE1(10),TEXTE2(10),TEXTE3(10)
- REAL TEXTE4(10),TEXTE5(10),TEXTE6(10)
- REAL TEXTE6B(10),TEXTE7(10)
- REAL THFWD(NATP_M),THBWD(NATP_M),GLG(0:N_GAUNT),NJ(0:N_GAUNT)
- REAL ALPHAR,BETAR,RACC
-C
-C
-C
- DOUBLE PRECISION FACT1L,FACT2L
-C
-C
-C
-C
-C
- CHARACTER*7 TESLEC,RIEN
-C
-C
- CHARACTER*3 CODRES(8),CODCTR(7),CRIST,CENTR,UNLENGTH
-C
-C
- CHARACTER*1 EDGE_C,EDGE_I,EDGE_A,MULT
- DATA CODRES/'CUB','TET','ORB','MNC','TCN','TRG','HEX','EXT'/
- DATA CODCTR/'P','I','F','R','A','B','C'/
- DATA PIS180,BOHR/0.017453,0.529177/
- DATA SQPI,SMALL /1.772453850906D0,1.D-6/
-C
- I_EXT=0
- I_EXT_A=0
- IVG0=0
- IRET=0
- NCRIST=0
- NCENTR=0
- I_SO=0
- DO I=1,10
- PCREL(I)=0.
- ENDDO
- STEREO=' NO'
-C
-C
-C.......... Reading of the input data in unit ICOM ..........
-C
-C
- READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE1
- READ(ICOM,1) RIEN
- READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE2
- READ(ICOM,1) RIEN
-C
- READ(ICOM,3) CRIST,CENTR,IBAS,NAT
- READ(ICOM,4) A,BSURA,CSURA,UNIT
-C
- IF(IBAS.EQ.0) THEN
- DO JLINE=1,100
- READ(ICOM,5) TESLEC
- IF(TESLEC.EQ.'SPECTRO') THEN
- BACKSPACE ICOM
- BACKSPACE ICOM
- BACKSPACE ICOM
- GOTO 600
- ENDIF
- ENDDO
- ENDIF
-C
- READ(ICOM,6) ALPHAD,BETAD,GAMMAD
- READ(ICOM,7) IH,IK,II,IL
- READ(ICOM,8) NIV,COUPUR,ITEST,IESURF
- IF(NAT.GT.1) THEN
- DO I=1,NAT
- J=3*(I-1)
- READ(ICOM,9) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(I)
- ENDDO
- ELSE
- READ(ICOM,9) X1,Y1,Z1,CHEM(1),NZA
- ENDIF
-C
- READ(ICOM,5) TESLEC
- IF(TESLEC.EQ.'VECBAS ') THEN
- BACKSPACE ICOM
- ELSE
- IRET=10
- GOTO 605
- ENDIF
-C
- DO I=1,8
- IF(CRIST.EQ.CODRES(I)) NCRIST=I
- IF(I.NE.8) THEN
- IF(CENTR.EQ.CODCTR(I)) NCENTR=I
- ENDIF
- ENDDO
- IF((NCRIST.EQ.0).OR.(NCENTR.EQ.0)) THEN
- IRET=1
- GOTO 605
- ENDIF
-C
- IF(NCRIST.EQ.8) THEN
- DO I=1,3
- J=3*(I-1)
- IVN(I)=1
- READ(ICOM,9) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J)
- IF(ABS(VECBAS(1+J)).LT.0.0001) THEN
- IF(ABS(VECBAS(2+J)).LT.0.0001) THEN
- IF(ABS(VECBAS(3+J)).LT.0.0001) THEN
- IVG0=IVG0+1
- IVN(I)=0
- ENDIF
- ENDIF
- ENDIF
- ENDDO
- ELSE
- READ(ICOM,9) X3,Y3,Z3
- READ(ICOM,9) X4,Y4,Z4
- READ(ICOM,9) X5,Y5,Z5
- ENDIF
- READ(ICOM,10) IREL,NREL,(PCREL(I),I=1,2)
- IF(IREL.EQ.1) THEN
- IF(NREL.GT.2) THEN
- NLIGNE=INT(FLOAT(NREL-2)/4.)+1
- DO J=1,NLIGNE
- READ(ICOM,11) (PCREL(I),I=1,4)
- ENDDO
- ENDIF
- IF(NREL.GT.10) THEN
- IRET=4
- GOTO 605
- ENDIF
- ELSEIF(IREL.EQ.0) THEN
- NREL=0
- ENDIF
- IF(NREL.EQ.0) THEN
- DO JREL=1,10
- PCREL(JREL)=0.
- ENDDO
- ENDIF
- READ(ICOM,12) OMEGAD1,OMEGAD2,IADS
-C
- READ(ICOM,1) RIEN
- 600 READ(ICOM,2) TEXTE3
- READ(ICOM,1) RIEN
-C
- READ(ICOM,13) SPECTRO,ISPIN,IDICHR,IPOL
- READ(ICOM,44) I_AMP
-C
- IF(SPECTRO.EQ.'PHD') THEN
- INTERACT='DIPOLAR'
- ELSEIF(SPECTRO.EQ.'LED') THEN
- INTERACT='NOINTER'
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- INTERACT='DIPOLAR'
- ELSEIF(SPECTRO.EQ.'AED') THEN
- INTERACT='COULOMB'
- ELSEIF(SPECTRO.EQ.'APC') THEN
- INTERACT='DIPCOUL'
- ELSEIF(SPECTRO.EQ.'EIG') THEN
- INTERACT='DIPOLAR'
- ENDIF
-C
- IF((IPOL.EQ.0).AND.(IDICHR.GT.0)) THEN
- PRINT 513
- STOP
- ENDIF
- IF((IDICHR.EQ.2).AND.(ISPIN.EQ.0)) THEN
- PRINT 514
- STOP
- ENDIF
-C
- IF(ISPIN.EQ.0) THEN
- NSPIN2=1
- NSPIN=1
- ELSEIF(ISPIN.EQ.1) THEN
- NSPIN2=4
- NSPIN=2
- ENDIF
-C
- IF(SPECTRO.EQ.'LED') THEN
- DO JLINE=1,10
- READ(ICOM,1) RIEN
- ENDDO
- GOTO 607
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- IF(IDICHR.GT.1) THEN
- PRINT 512
- STOP
- ENDIF
- DO JLINE=1,19
- READ(ICOM,1) RIEN
- ENDDO
- GOTO 602
- ELSEIF(SPECTRO.EQ.'AED') THEN
- DO JLINE=1,24
- READ(ICOM,1) RIEN
- ENDDO
- GOTO 603
- ELSEIF(SPECTRO.EQ.'EIG') THEN
- DO JLINE=1,34
- READ(ICOM,1) RIEN
- ENDDO
- GOTO 608
- ENDIF
-C
- IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
- READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE4
- READ(ICOM,1) RIEN
-C
- READ(ICOM,20) NI,NLI,S_O,INITL,I_SO
-C
- IF((NLI.EQ.'s').OR.(NLI.EQ.'S')) THEN
- LI=0
- ELSEIF((NLI.EQ.'p').OR.(NLI.EQ.'P')) THEN
- LI=1
- ELSEIF((NLI.EQ.'d').OR.(NLI.EQ.'D')) THEN
- LI=2
- ELSEIF((NLI.EQ.'f').OR.(NLI.EQ.'F')) THEN
- LI=3
- ELSEIF((NLI.EQ.'g').OR.(NLI.EQ.'G')) THEN
- LI=4
- ELSE
- IRET=5
- GOTO 605
- ENDIF
- IF(LI.GT.LI_M) THEN
- IRET=6
- GOTO 605
- ENDIF
- IF(I_SO.EQ.0) THEN
- S_O=' '
- ELSEIF(I_SO.EQ.1) THEN
- IF(S_O.EQ.'1/2') THEN
- IF(LI.GT.1) IRET=7
- ELSEIF(S_O.EQ.'3/2') THEN
- IF((LI.LT.1).OR.(LI.GT.2)) IRET=7
- ELSEIF(S_O.EQ.'5/2') THEN
- IF((LI.LT.2).OR.(LI.GT.3)) IRET=7
- ELSEIF(S_O.EQ.'7/2') THEN
- IF((LI.LT.3).OR.(LI.GT.4)) IRET=7
- ELSEIF(S_O.EQ.'9/2') THEN
- IF(LI.NE.4) IRET=7
- ENDIF
- ELSEIF(I_SO.EQ.2) THEN
- S_O=' '
- ENDIF
-C
- READ(ICOM,14) IPHI,ITHETA,IE,IFTHET
- READ(ICOM,15) NPHI,NTHETA,NE,NFTHET
- READ(ICOM,16) PHI0,THETA0,E0,R1
- READ(ICOM,16) PHI1,THETA1,EFIN,R2
- READ(ICOM,17) THLUM,PHILUM,ELUM
- READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR
-C
- DO JLINE=1,9
- READ(ICOM,1) RIEN
- ENDDO
- ENDIF
-C
- 607 IF(SPECTRO.EQ.'LED') THEN
- READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE4
- READ(ICOM,1) RIEN
-C
- READ(ICOM,14) IPHI,ITHETA,IE,IFTHET
- READ(ICOM,15) NPHI,NTHETA,NE,NFTHET
- READ(ICOM,16) PHI0,THETA0,E0,R1
- READ(ICOM,16) PHI1,THETA1,EFIN,R2
- READ(ICOM,17) TH_INI,PHI_INI
- READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR
-C
- THLUM=TH_INI
- PHILUM=PHI_INI
- ELUM=0.
- IDICHR=0
- INITL=0
- ENDIF
-C
- IF(SPECTRO.NE.'XAS') THEN
- IF(IPHI.EQ.-1) THEN
- IPHI=1
- I_EXT=0
- ICHKDIR=0
- STEREO='YES'
- IF(ABS(PHI1-PHI0).LT.0.0001) THEN
- PHI0=0.
- PHI1=360.
- NPHI=361
- ENDIF
- IF(ABS(THETA1-THETA0).LT.0.0001) THEN
- THETA0=0.
- THETA1=88.
- NTHETA=89
- ENDIF
- ELSEIF(IPHI.EQ.2) THEN
- IPHI=1
- I_EXT=1
- ELSEIF(IPHI.EQ.3) THEN
- IPHI=1
- I_EXT=-1
- ELSEIF(ITHETA.EQ.2) THEN
- ITHETA=1
- I_EXT=1
- ELSEIF(ITHETA.EQ.3) THEN
- ITHETA=1
- I_EXT=-1
- ELSEIF(IE.EQ.2) THEN
- IE=1
- I_EXT=1
- ELSEIF(IE.EQ.3) THEN
- IE=1
- I_EXT=-1
- ELSEIF(IE.EQ.4) THEN
- IF(SPECTRO.EQ.'PHD') THEN
- IE=1
- I_EXT=2
- IMOD=0
- ELSE
- IE=1
- I_EXT=1
- ENDIF
- ENDIF
- ENDIF
-C
- ICALC=IPHI*IE+IPHI*ITHETA+IE*ITHETA
- IF((ICALC.NE.0).AND.(IFTHET.EQ.0)) IRET=3
-C
-C When the direction of the analyzer might be experimentally
-C inaccurate, the calculation will be done for nine
-C direction across the one given in the data file
-C with an increment of one degree.
-C
- IF(ICHKDIR.EQ.1) THEN
- IF((ITHETA.EQ.1).AND.(IPHI.EQ.0)) THEN
- NPHI=9
- PHI0=PHI0-4.
- PHI1=PHI0+8.
- ELSEIF((IPHI.EQ.1).AND.(ITHETA.EQ.0)) THEN
- NTHETA=9
- THETA0=THETA0-4.
- THETA1=THETA0+8.
- ENDIF
- ENDIF
-C
-C Initialization of the values for the scanned angle and the "fixed" one
-C
- IF(IPHI.EQ.1) THEN
- N_FIXED=NTHETA
- N_SCAN=NPHI
- FIX0=THETA0
- FIX1=THETA1
- SCAN0=PHI0
- SCAN1=PHI1
- IPH_1=0
- ELSEIF(ITHETA.EQ.1) THEN
- N_FIXED=NPHI
- N_SCAN=NTHETA
- FIX0=PHI0
- FIX1=PHI1
- SCAN0=THETA0
- SCAN1=THETA1
- IPH_1=1
- ELSEIF(IE.EQ.1) THEN
- IF(NTHETA.GE.NPHI) THEN
- N_FIXED=NPHI
- N_SCAN=NTHETA
- FIX0=PHI0
- FIX1=PHI1
- SCAN0=THETA0
- SCAN1=THETA1
- IPH_1=1
- ELSE
- N_FIXED=NTHETA
- N_SCAN=NPHI
- FIX0=THETA0
- FIX1=THETA1
- SCAN0=PHI0
- SCAN1=PHI1
- IPH_1=0
- ENDIF
- ENDIF
-C
- 602 IF(SPECTRO.EQ.'XAS') THEN
- READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE5
- READ(ICOM,1) RIEN
-C
- READ(ICOM,39) EDGE,NEDGE,INITL,THLUM,PHILUM
- READ(ICOM,19) NE_X,EK_INI,EK_FIN,EPH_INI
-C
- LI=NEDGE/2
- IF(NEDGE.GT.1) I_SO=2
- IF(EDGE.EQ.'K') THEN
- NI=1
- ELSEIF(EDGE.EQ.'L') THEN
- NI=2
- ELSEIF(EDGE.EQ.'M') THEN
- NI=3
- ELSEIF(EDGE.EQ.'N') THEN
- NI=4
- ELSEIF(EDGE.EQ.'O') THEN
- NI=5
- ELSEIF(EDGE.EQ.'P') THEN
- NI=6
- ENDIF
- ELSE
- DO JLINE=1,5
- READ(ICOM,1) RIEN
- ENDDO
- ENDIF
-C
- 603 IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
-C
- READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE6
- READ(ICOM,1) RIEN
-C
- READ(ICOM,40) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
- READ(ICOM,42) I_MULT,IM1,MULT,IM2
- READ(ICOM,14) IPHI_A,ITHETA_A,IFTHET_A,I_INT
- READ(ICOM,15) NPHI_A,NTHETA_A,NFTHET_A
- READ(ICOM,41) PHI0_A,THETA0_A,R1_A
- READ(ICOM,41) PHI1_A,THETA1_A,R2_A
- READ(ICOM,18) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
-C
- LI_C=NEDGE_C/2
- LI_I=NEDGE_I/2
- LI_A=NEDGE_A/2
-C
- IF((EDGE_I.EQ.EDGE_A).AND.(LI_I.EQ.LI_A)) THEN
- I_SHELL=1
- ELSE
- I_SHELL=0
- ENDIF
-C
- IE_A=0
- NE_A=1
- I_CP_A=0
-C
- IF(EDGE_C.EQ.'K') THEN
- AUGER=' '//EDGE_C//EDGE_I//CHAR(48+NEDGE_I)//EDGE_A//CHAR(48+N
- &EDGE_A)
- ELSE
- AUGER=EDGE_C//CHAR(48+NEDGE_C)//EDGE_I//CHAR(48+NEDGE_I)//EDGE
- &_A//CHAR(48+NEDGE_A)
- ENDIF
- AUGER1=AUGER
-C
- IF(IPHI_A.EQ.-1) THEN
- IPHI_A=1
- I_EXT_A=0
- ICHKDIR_A=0
- STEREO='YES'
- IF(ABS(PHI1_A-PHI0_A).LT.0.0001) THEN
- PHI0_A=0.
- PHI1_A=360.
- NPHI_A=361
- ENDIF
- IF(ABS(THETA1_A-THETA0_A).LT.0.0001) THEN
- THETA0_A=0.
- THETA1_A=88.
- NTHETA_A=89
- ENDIF
- ELSEIF(IPHI_A.EQ.2) THEN
- IPHI_A=1
- I_EXT_A=1
- ELSEIF(IPHI_A.EQ.3) THEN
- IPHI_A=1
- I_EXT_A=-1
- ELSEIF(ITHETA_A.EQ.2) THEN
- ITHETA_A=1
- I_EXT_A=1
- ELSEIF(ITHETA_A.EQ.3) THEN
- ITHETA_A=1
- I_EXT_A=-1
- ENDIF
-C
-C Check for the consistency of the data for the two electrons in
-C APECS, in particular when the sample is rotated (IMOD=1)
-C
- IF(SPECTRO.EQ.'APC') THEN
- IF((LI_C.NE.LI).OR.(IMOD_A.NE.IMOD)) THEN
- IRET=11
- GOTO 605
- ENDIF
- DTH=THETA1-THETA0
- DTH_A=THETA1_A-THETA0_A
- DPH=PHI1-PHI0
- DPH_A=PHI1_A-PHI0_A
- IF((IMOD_A.EQ.1).AND.(IPHI_A.NE.IPHI)) IRET=13
- IF((IMOD_A.EQ.1).AND.(ITHETA_A.NE.ITHETA)) IRET=13
- IF((IMOD_A.EQ.1).AND.(NPHI_A.NE.NPHI)) IRET=13
- IF((IMOD_A.EQ.1).AND.(NTHETA_A.NE.NTHETA)) IRET=13
- IF((IMOD_A.EQ.1).AND.(DTH_A.NE.DTH)) IRET=13
- IF((IMOD_A.EQ.1).AND.(DPH_A.NE.DPH)) IRET=13
- ENDIF
-C
-C When the direction of the analyzer might be experimentally
-C inaccurate, the calculation will be done for nine
-C direction across the one given in the data file
-C with an increment of one degree.
-C
- IF(ICHKDIR_A.EQ.1) THEN
- IF((ITHETA_A.EQ.1).AND.(IPHI_A.EQ.0)) THEN
- NPHI_A=9
- PHI0_A=PHI0_A-4.
- PHI1_A=PHI0_A+8.
- ELSEIF((IPHI_A.EQ.1).AND.(ITHETA_A.EQ.0)) THEN
- NTHETA_A=9
- THETA0_A=THETA0_A-4.
- THETA1_A=THETA0_A+8.
- ENDIF
- ENDIF
-C
-C Initialization of the values for the scanned angle and the "fixed" one
-C
- IF(IPHI_A.EQ.1) THEN
- N_FIXED_A=NTHETA_A
- N_SCAN_A=NPHI_A
- FIX0_A=THETA0_A
- FIX1_A=THETA1_A
- SCAN0_A=PHI0_A
- SCAN1_A=PHI1_A
- IPH_1_A=0
- ELSEIF(ITHETA_A.EQ.1) THEN
- N_FIXED_A=NPHI_A
- N_SCAN_A=NTHETA_A
- FIX0_A=PHI0_A
- FIX1_A=PHI1_A
- SCAN0_A=THETA0_A
- SCAN1_A=THETA1_A
- IPH_1_A=1
- ENDIF
-C
- ELSE
- DO JLINE=1,10
- READ(ICOM,1) RIEN
- ENDDO
- ENDIF
-C
- IF(SPECTRO.EQ.'XAS') THEN
- I_CP=1
- NE=NE_X
- ELSE
- I_CP=0
- ENDIF
-C
- 608 IF(SPECTRO.EQ.'EIG') THEN
-C
- READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE6B
- READ(ICOM,1) RIEN
-C
- READ(ICOM,43) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP
-C
- NE=NE_EIG
- N_LINE_E=INT((FLOAT(NE_EIG)-0.0001)/4.)+1
- N_LAST=4-(4*N_LINE_E-NE_EIG)
-C
- IF(N_LINE_E.GT.1) THEN
- DO JLINE=1,N_LINE_E-1
- J=(JLINE-1)*4
- READ(ICOM,7) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3
- &),I_SPECTRUM(J+4)
- ENDDO
- ENDIF
-C
- J=4*(N_LINE_E-1)
-C
- READ(ICOM,7) (I_SPECTRUM(J+K), K=1,N_LAST)
-C
- READ(ICOM,46) I_PWM,METHOD,RACC,EXPO
- READ(ICOM,47) N_MAX,N_ITER,N_TABLE,SHIFT
- READ(ICOM,48) I_XN,I_VA,I_GN,I_WN
- READ(ICOM,49) LEVIN,ALPHAR,BETAR
-C
- ACC=DBLE(RACC)
- IF(ABS(I_PWM).LE.2) THEN
- I_ACC=0
- N_ITER=N_MAX
- ELSEIF(I_PWM.EQ.3) THEN
- I_ACC=1
- N_ITER=N_MAX
- ELSEIF(I_PWM.EQ.-3) THEN
- I_ACC=-1
- N_ITER=N_MAX
- ELSEIF(I_PWM.EQ.4) THEN
- I_ACC=2
- ELSEIF(I_PWM.EQ.-4) THEN
- I_ACC=-2
- ENDIF
- IF(N_MAX.LT.N_ITER) N_ITER=N_MAX
-C
- ALPHA=DCMPLX(ALPHAR)
- BETA=DCMPLX(BETAR)
-C
-C
- ELSE
- DO JLINE=1,9
- READ(ICOM,1) RIEN
- ENDDO
-C
- ENDIF
-C
- 609 READ(ICOM,1) RIEN
- READ(ICOM,2) TEXTE7
- READ(ICOM,1) RIEN
-C
- READ(ICOM,21) NO,NDIF,ISPHER,I_GR
- READ(ICOM,50) I_REN,N_REN,REN_R,REN_I
-C
- IF(ISPHER.EQ.0) THEN
- IDWSPH=0
- NO=0
- ENDIF
- IF(NO.LT.0) NO=8
- NUMAX(1)=NO/2
-C
- READ(ICOM,22) ISFLIP,IR_DIA,ITRTL,I_TEST
-C
- IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) I_TEST_A=I_TEST
- IF(I_TEST.EQ.1) THEN
- IF(INTERACT.EQ.'DIPOLAR') THEN
- INITL=1
- LI=0
- IPOL=1
- ELSEIF(INTERACT.EQ.'COULOMB') THEN
- LI_C=0
- LI_I=0
- ENDIF
- ENDIF
-C
- READ(ICOM,23) NEMET
-C
- BACKSPACE ICOM
- NLG=INT((NEMET-0.0001)/3) +1
- DO N=1,NLG
- NRL=3*N
- JD=3*(N-1)+1
- IF(N.EQ.NLG) NRL=NEMET
- READ(ICOM,24) NEMO,(IEMET(J), J=JD, NRL)
- IF(N.EQ.1) NEMET1=NEMO
- ENDDO
-C
- READ(ICOM,25) ISOM,NONVOL(JFICH),NPATHP,VINT
-C
- IF(I_TEST.EQ.2) THEN
- IF(ABS(IPOL).EQ.1) THEN
- THLUM=-90.
- PHILUM=0.
- ELSEIF(ABS(IPOL).EQ.2) THEN
- THLUM=0.
- PHILUM=0.
- ENDIF
- IMOD=0
- VINT=0.
- A=1.
- ENDIF
-C
- IF((NFICHLEC.EQ.1).OR.(IBAS.EQ.1)) ISOM=0
-C
- READ(ICOM,26) IFWD,NTHOUT,I_NO,I_RA
-C
- IF(NTHOUT.EQ.NDIF-1) IFWD=0
-C
- IF(I_RA.EQ.1) NO=0
- DO JAT=1,NAT
- READ(ICOM,27) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT)
- IF(I_RA.EQ.0) THEN
- N_RA(JAT)=NO
- NUMAX(JAT)=NO/2
- ELSEIF(I_RA.EQ.1) THEN
- NUMAX(JAT)=N_RA(JAT)/2
- NO=MAX(N_RA(JAT),NO)
- ENDIF
- ENDDO
-C
- READ(ICOM,5) TESLEC
- IF(TESLEC.EQ.'IPW,NCU') THEN
- BACKSPACE ICOM
- ELSE
- IRET=8
- GOTO 605
- ENDIF
-C
- READ(ICOM,28) IPW,NCUT,PCTINT,IPP
- READ(ICOM,29) ILENGTH,RLENGTH,UNLENGTH
- READ(ICOM,30) IDWSPH,ISPEED,IATTS,IPRINT
-C
- IF(IDWSPH.EQ.0) ISPEED=1
-C
- READ(ICOM,31) IDCM,TD,T,RSJ
- READ(ICOM,32) ILPM,XLPM0
-C
- IF((IDCM.GE.1).OR.(ILPM.EQ.1)) THEN
- CALL ATDATA
- ENDIF
- NLEC=INT((NAT-0.0001)/4)+1
-C
- DO I=1,NLEC
- NDEB=4*(I-1) + 1
- NFIN=MIN0(4*I,NAT)
- READ(ICOM,33) (UJ2(J),J=NDEB,NFIN)
- ENDDO
-C
- DO JLINE=1,5
- READ(ICOM,1) RIEN
- ENDDO
- READ(ICOM,5) TESLEC
- IF(TESLEC.EQ.'DATA FI') THEN
- BACKSPACE ICOM
- ELSE
- IRET=9
- GOTO 605
- ENDIF
-C
- READ(ICOM,34) INFILE1,IUI1
- READ(ICOM,34) INFILE2,IUI2
- READ(ICOM,34) INFILE3,IUI3
- READ(ICOM,34) INFILE4,IUI4
- READ(ICOM,34) INFILE5,IUI5
- READ(ICOM,34) INFILE6,IUI6
-C
- IF(SPECTRO.NE.'APC') THEN
- DO JLINE=1,9
- READ(ICOM,1) RIEN
- ENDDO
- ELSE
- DO JLINE=1,6
- READ(ICOM,1) RIEN
- ENDDO
- READ(ICOM,34) INFILE7,IUI7
- READ(ICOM,34) INFILE8,IUI8
- READ(ICOM,34) INFILE9,IUI9
- ENDIF
-C
-C Set up of the switch controlling external
-C reading of the detector directions and
-C averaging over them for an undetected electron
-C
- IF(SPECTRO.EQ.'APC') THEN
- IF((I_EXT.EQ.-1).OR.(I_EXT_A.EQ.-1)) THEN
- IF(I_EXT*I_EXT_A.EQ.0) THEN
- WRITE(IUO1,523)
- I_EXT=-1
- I_EXT_A=-1
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
- READ(IUI6,713) IDIR,NSET
- READ(IUI9,713) IDIR_A,NSET_A
- IF(IDIR.EQ.2) THEN
- IF(NSET.NE.NSET_A) WRITE(IUO1,524) NSET,NSET_A
- STOP
- ENDIF
- ENDIF
- ENDIF
- IF(I_INT.EQ.1) THEN
- I_EXT=2
- ELSEIF(I_INT.EQ.2) THEN
- I_EXT_A=2
- ELSEIF(I_INT.EQ.3) THEN
- I_EXT=2
- I_EXT_A=2
- ENDIF
- ENDIF
-C
- IF(I_EXT.EQ.-1) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,701) IDIR,I_SET,N_POINTS
- READ(IUI6,702) I_PH,N_FIXED,N_SCAN
- DO JS=1,I_SET
- READ(IUI6,703) TH_0(JS),PH_0(JS)
- ENDDO
- CLOSE(IUI6)
- IF(IDIR.NE.2) IRET=12
- IF(I_PH.NE.IPH_1) IPH_1=I_PH
- IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
- IF(I_PH.EQ.0) THEN
- NTHETA=N_FIXED
- NPHI=N_SCAN
- ELSE
- NTHETA=N_SCAN
- NPHI=N_FIXED
- ENDIF
- ICHKDIR=2
- ENDIF
- ENDIF
- IF(I_EXT.GE.1) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,701) IDIR,I_SET,N_POINTS
- CLOSE(IUI6)
- IF((IDIR.NE.1).AND.(I_EXT.EQ.2)) IRET=12
- N_FIXED=N_POINTS
- N_SCAN=1
- NTHETA=N_POINTS
- NPHI=1
- ENDIF
- IF(I_EXT_A.GE.1) THEN
- IF(SPECTRO.EQ.'APC') THEN
- OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
- READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A
- CLOSE(IUI9)
- ELSE
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A
- CLOSE(IUI6)
- ENDIF
- IF((IDIR_A.NE.1).AND.(I_EXT_A.EQ.2)) IRET=12
- N_FIXED_A=N_POINTS_A
- N_SCAN_A=1
- NTHETA_A=N_POINTS_A
- NPHI_A=1
- ENDIF
-C
- IF(I_EXT_A.EQ.-1) THEN
- IF(SPECTRO.EQ.'APC') THEN
- OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
- READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A
- READ(IUI9,702) I_PH_A,N_FIXED_A,N_SCAN_A
- CLOSE(IUI9)
- ELSE
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A
- READ(IUI6,702) I_PH_A,N_FIXED_A,N_SCAN_A
- CLOSE(IUI6)
- ENDIF
- IF(IDIR_A.NE.2) IRET=12
- IF(I_PH_A.EQ.0) THEN
- NTHETA_A=N_FIXED_A
- NPHI_A=N_SCAN_A
- ELSE
- NTHETA_A=N_SCAN_A
- NPHI_A=N_FIXED_A
- ENDIF
- ICHKDIR_A=2
- ENDIF
-C
- DO JLINE=1,5
- READ(ICOM,1) RIEN
- ENDDO
-C
- READ(ICOM,34) OUTFILE1,IUO1
- READ(ICOM,34) OUTFILE2,IUO2
- READ(ICOM,34) OUTFILE3,IUO3
- READ(ICOM,34) OUTFILE4,IUO4
-C
- IUSCR=MAX0(ICOM,IUI2,IUI3,IUI4,IUI5,IUI6,IUI7,IUI8,IUI9,IUO1,IUO2,
- &IUO3,IUO4)+1
- IUSCR2=IUSCR+1
-C
- IF(IADS.GE.1) THEN
- OPEN(UNIT=IUI5, FILE=INFILE5, STATUS='OLD')
- READ(IUI5,1) RIEN
- READ(IUI5,12) NATA,NADS1,NADS2,NADS3
- IF(NATA.EQ.1) THEN
- NADS2=0
- NADS3=0
- ELSEIF(NATA.EQ.2) THEN
- NADS3=0
- ENDIF
- READ(IUI5,35) (NZAT(I),I=NAT+1,NAT+NATA)
- READ(IUI5,36) (CHEM(I),I=NAT+1,NAT+NATA)
- READ(IUI5,37) (UJ2(NAT+J),J=1,NATA)
- READ(IUI5,38) NRELA,(PCRELA(I),I=1,NRELA)
- IF(NRELA.EQ.0) THEN
- DO JRELA=1,3
- PCRELA(JRELA)=0.
- ENDDO
- ENDIF
- NADS=NADS1+NADS2+NADS3
- DO JADS=1,NADS
- READ(IUI5,9) (ADS(I,JADS),I=1,3)
- ENDDO
- CLOSE(IUI5)
- ELSE
- NATA=0
- NRELA=0
- ENDIF
-C
- GOTO 601
-C
- 605 REWIND ICOM
- DO JLINE=1,500
- READ(ICOM,5) TESLEC
- IF(TESLEC.EQ.'CONTROL') THEN
- BACKSPACE ICOM
- READ(ICOM,34) OUTFILE1,IUO1
- GOTO 601
- ENDIF
- ENDDO
-C
- 601 IF((JFICH.EQ.1).OR.(ISOM.EQ.0)) THEN
-c LINE REMOVED BY PYMSSPEC
- ENDIF
- IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
- WRITE(IUO1,105) INDATA(JFICH)
- ENDIF
-C
- IF(IRET.EQ.1) RETURN 1
- IF(IRET.EQ.3) RETURN 3
- IF(IRET.EQ.4) RETURN 4
- IF(IRET.EQ.5) RETURN 5
- IF(IRET.EQ.6) RETURN 6
- IF(IRET.EQ.7) RETURN 7
- IF(IRET.EQ.8) RETURN 8
- IF(IRET.EQ.9) RETURN 9
- IF(IRET.EQ.10) RETURN 10
- IF(IRET.EQ.11) RETURN 11
- IF(IRET.EQ.12) RETURN 12
- IF(IRET.EQ.13) RETURN 13
-C
-C
-C.......... Writing of the input data in unit IUO1 ..........
-C
-C
- WRITE(IUO1,100)
- WRITE(IUO1,101)
- WRITE(IUO1,101)
- WRITE(IUO1,102) TEXTE1
- WRITE(IUO1,101)
- WRITE(IUO1,101)
- WRITE(IUO1,203)
-C
- IF(I_TEST.NE.2) THEN
- WRITE(IUO1,201) TEXTE2
- ELSE
- IF(ABS(IPOL).EQ.1) THEN
- WRITE(IUO1,525)
- ELSEIF(ABS(IPOL).EQ.2) THEN
- WRITE(IUO1,526)
- ENDIF
- ENDIF
-C
- IF(NAT.GT.NATP_M) RETURN 2
- IF(NE.GT.NE_M) RETURN 2
- IF(NEMET.GT.NEMET_M) RETURN 2
-C
- IF(I_TEST.EQ.2) GOTO 606
- IF(IBAS.EQ.0) THEN
- WRITE(IUO1,204) A,IBAS
- GOTO 604
- ENDIF
- WRITE(IUO1,103) CRIST,CENTR,IBAS,NAT
- IF(NCRIST.EQ.1) THEN
- BSURA=1.
- CSURA=1.
- WRITE(IUO1,304) A
- ELSEIF((NCRIST.EQ.2).OR.(NCRIST.EQ.7).OR.(NCRIST.EQ.6)) THEN
- BSURA=1.
- WRITE(IUO1,404) A,CSURA
- IF((NCRIST.EQ.6).AND.(CSURA.EQ.1.)) THEN
- WRITE(IUO1,206) ALPHAD
- ELSEIF(NCRIST.EQ.4) THEN
- WRITE(IUO1,306) BETAD
- ENDIF
- ELSEIF((NCRIST.EQ.3).OR.(NCRIST.EQ.5).OR.(NCRIST.EQ.8)) THEN
- WRITE(IUO1,104) A,BSURA,CSURA
- IF(NCRIST.NE.3) THEN
- WRITE(IUO1,106) ALPHAD,BETAD,GAMMAD
- ENDIF
- ENDIF
- IF(NCRIST.EQ.7) THEN
- WRITE(IUO1,107) IH,IK,II,IL
- ELSE
- WRITE(IUO1,207) IH,IK,IL
- ENDIF
- WRITE(IUO1,108) NIV,COUPUR,ITEST,IESURF
- IF(NAT.GT.1) THEN
- DO I=1,NAT
- J=3*(I-1)
- WRITE(IUO1,109) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(
- &I)
- ENDDO
- ENDIF
- IF(NCRIST.EQ.8) THEN
- DO I=1,3
- J=3*(I-1)
- WRITE(IUO1,209) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J)
- ENDDO
- ENDIF
- IF(IREL.GE.1) THEN
- WRITE(IUO1,110) IREL,NREL,(PCREL(I),I=1,2)
- IF(NREL.GT.2) THEN
- NLIGNE=INT(FLOAT(NREL-2)/4.)+1
- DO J=1,NLIGNE
- WRITE(IUO1,210) (PCREL(I),I=1,4)
- ENDDO
- ENDIF
- IF(NREL.GT.10) RETURN 4
- WRITE(IUO1,112) OMEGAD1,OMEGAD2,IADS
- ENDIF
- IF((IREL.EQ.0).AND.(IADS.EQ.1)) WRITE(IUO1,212) IADS
- IF(IADS.GE.1) THEN
- WRITE(IUO1,501)
- DO JADS=1,NADS
- IF(JADS.LE.NADS1) THEN
- IF(JADS.EQ.1) WRITE(IUO1,303) NAT+1
- WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
- ELSEIF((JADS.GT.NADS1).AND.(JADS.LE.(NADS1+NADS2))) THEN
- IF(JADS.EQ.(NADS1+1)) WRITE(IUO1,303) NAT+2
- WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
- ELSEIF(JADS.GT.(NADS1+NADS2)) THEN
- IF(JADS.EQ.(NADS2+1)) WRITE(IUO1,303) NAT+3
- WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
- ENDIF
- ENDDO
- ENDIF
- IF((IREL.GT.0).OR.(NRELA.GT.0)) WRITE(IUO1,502)
- IF(NRELA.GT.0) THEN
- WRITE(IUO1,311) (PCRELA(I),I=1,NRELA)
- ENDIF
- 604 IF(IREL.GT.0) THEN
- WRITE(IUO1,211) (PCREL(I),I=1,NREL)
- ENDIF
-C
- 606 IF(SPECTRO.EQ.'APC') WRITE(IUO1,517)
-C
- IF(SPECTRO.EQ.'PHD') THEN
-C
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,503)
- ELSE
- WRITE(IUO1,527)
- ENDIF
- ENDIF
- IF(IE.EQ.1) WRITE(IUO1,504)
- IF(ITHETA.EQ.1) WRITE(IUO1,505)
- IF(IFTHET.EQ.1) WRITE(IUO1,506)
- IF(I_AMP.EQ.1) WRITE(IUO1,534)
-C
- WRITE(IUO1,201) TEXTE4
- WRITE(IUO1,113) ISPIN,IDICHR,IPOL
- WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO
- WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
- WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
-C
- IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
- IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
- WRITE(IUO1,508)
- STOP
- ENDIF
- IF(ABS(THLUM).GT.90.0) THEN
- WRITE(IUO1,509)
- STOP
- ENDIF
- ENDIF
-C
- WRITE(IUO1,116) PHI0,THETA0,E0,R1
- WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
- WRITE(IUO1,117) THLUM,PHILUM,ELUM
- WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
-C
- IF(IMOY.GT.3) IMOY=3
- IF(IMOY.LT.0) IMOY=0
- IF(IMOY.EQ.0) NDIR=1
- IF(IMOY.EQ.1) NDIR=5
- IF(IMOY.EQ.2) NDIR=13
- IF(IMOY.EQ.3) NDIR=49
- IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1
-C
- ELSEIF(SPECTRO.EQ.'LED') THEN
-C
- IF(IPHI.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,529)
- ELSE
- WRITE(IUO1,530)
- ENDIF
- ENDIF
- IF(IE.EQ.1) WRITE(IUO1,531)
- IF(ITHETA.EQ.1) WRITE(IUO1,532)
- IF(IFTHET.EQ.1) WRITE(IUO1,506)
- IF(I_AMP.EQ.1) WRITE(IUO1,534)
-C
- WRITE(IUO1,201) TEXTE4
- WRITE(IUO1,141) ISPIN
- WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
- WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
-C
- IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
- IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
- WRITE(IUO1,508)
- STOP
- ENDIF
- ENDIF
-C
- WRITE(IUO1,116) PHI0,THETA0,E0,R1
- WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
- WRITE(IUO1,142) TH_INI,PHI_INI
- WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
-C
- IF(IMOY.GT.3) IMOY=3
- IF(IMOY.LT.0) IMOY=0
- IF(IMOY.EQ.0) NDIR=1
- IF(IMOY.EQ.1) NDIR=5
- IF(IMOY.EQ.2) NDIR=13
- IF(IMOY.EQ.3) NDIR=49
-C
- ELSEIF(SPECTRO.EQ.'XAS') THEN
-C
- WRITE(IUO1,507)
- IF(I_AMP.EQ.1) WRITE(IUO1,534)
- WRITE(IUO1,201) TEXTE5
- WRITE(IUO1,113) ISPIN,IDICHR,IPOL
- WRITE(IUO1,134) EDGE,NEDGE,INITL,THLUM,PHILUM
- WRITE(IUO1,119) NE_X,EK_INI,EK_FIN,EPH_INI
-C
- ELSEIF(SPECTRO.EQ.'AED') THEN
-C
- IF(IPHI_A.EQ.1) THEN
- IF(STEREO.EQ.' NO') THEN
- WRITE(IUO1,515)
- ELSE
- WRITE(IUO1,528)
- ENDIF
- ENDIF
- IF(ITHETA_A.EQ.1) WRITE(IUO1,516)
- IF(I_AMP.EQ.1) WRITE(IUO1,534)
- WRITE(IUO1,201) TEXTE6
- WRITE(IUO1,113) ISPIN,IDICHR,IPOL
- WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
- WRITE(IUO1,140) I_MULT,IM1,MULT,IM2
- WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT
- WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A
- WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A
- WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A
- WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
-C
- IF(IMOY_A.GT.3) IMOY_A=3
- IF(IMOY_A.LT.0) IMOY_A=0
- IF(IMOY_A.EQ.0) NDIR_A=1
- IF(IMOY_A.EQ.1) NDIR_A=5
- IF(IMOY_A.EQ.2) NDIR_A=13
- IF(IMOY_A.EQ.3) NDIR_A=49
-C
- ELSEIF(SPECTRO.EQ.'APC') THEN
-C
- WRITE(IUO1,518)
- IF(IPHI.EQ.1) WRITE(IUO1,503)
- IF(ITHETA.EQ.1) WRITE(IUO1,505)
- IF(IFTHET.EQ.1) WRITE(IUO1,506)
- IF(I_AMP.EQ.1) WRITE(IUO1,534)
-C
- WRITE(IUO1,201) TEXTE4
- WRITE(IUO1,113) ISPIN,IDICHR,IPOL
- WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO
- WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
- WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
-C
- IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
- IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
- WRITE(IUO1,508)
- STOP
- ENDIF
- IF(ABS(THLUM).GT.90.0) THEN
- WRITE(IUO1,509)
- STOP
- ENDIF
- ENDIF
-C
- WRITE(IUO1,116) PHI0,THETA0,E0,R1
- WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
- WRITE(IUO1,117) THLUM,PHILUM,ELUM
- WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
-C
- IF(IMOY.GT.3) IMOY=3
- IF(IMOY.LT.0) IMOY=0
- IF(IMOY.EQ.0) NDIR=1
- IF(IMOY.EQ.1) NDIR=5
- IF(IMOY.EQ.2) NDIR=13
- IF(IMOY.EQ.3) NDIR=49
- IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1
-C
- WRITE(IUO1,519)
- IF(IPHI_A.EQ.1) WRITE(IUO1,515)
- IF(ITHETA_A.EQ.1) WRITE(IUO1,516)
- WRITE(IUO1,201) TEXTE6
- WRITE(IUO1,113) ISPIN,IDICHR,IPOL
- WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
- WRITE(IUO1,140) I_MULT,IM1,MULT,IM2
- WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT
- WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A
- WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A
- WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A
- WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
-C
- IF(IMOY_A.GT.3) IMOY_A=3
- IF(IMOY_A.LT.0) IMOY_A=0
- IF(IMOY_A.EQ.0) NDIR_A=1
- IF(IMOY_A.EQ.1) NDIR_A=5
- IF(IMOY_A.EQ.2) NDIR_A=13
- IF(IMOY_A.EQ.3) NDIR_A=49
-C
- WRITE(IUO1,520)
-C
- ELSEIF(SPECTRO.EQ.'EIG') THEN
-C
- WRITE(IUO1,143) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP
- DO JLINE=1,N_LINE_E-1
- J=(JLINE-1)*4
- WRITE(IUO1,145) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3
- &),I_SPECTRUM(J+4)
- ENDDO
- J=4*(N_LINE_E-1)
- WRITE(IUO1,145) (I_SPECTRUM(J+K),K=1,N_LAST)
-C
- WRITE(IUO1,146) I_PWM,METHOD,RACC,EXPO
- WRITE(IUO1,147) N_MAX,N_ITER,N_TABLE,SHIFT
- WRITE(IUO1,148) I_XN,I_VA,I_GN,I_WN
- WRITE(IUO1,149) LEVIN,ALPHAR,BETAR
- WRITE(IUO1,533)
-C
- ENDIF
-C
- WRITE(IUO1,201) TEXTE7
-C
- IF(SPECTRO.NE.'EIG') THEN
-C
- WRITE(IUO1,121) NO,NDIF,ISPHER,I_GR
- WRITE(IUO1,150) I_REN,N_REN,REN_R,REN_I
-C
- IF(SPECTRO.EQ.'XAS') NDIF=NDIF+1
-C
- WRITE(IUO1,122) ISFLIP,IR_DIA,ITRTL,I_TEST
-C
- IF(ISFLIP.EQ.0) THEN
- NSTEP=3
- ELSE
- NSTEP=1
- ENDIF
- DO N=1,NLG
- NRL=3*N
- JD=3*(N-1)+1
- IF(N.EQ.NLG) NRL=NEMET
- IF(N.EQ.1) NEMO=NEMET1
- IF(N.LT.NLG) THEN
- WRITE(IUO1,123) NEMO,(IEMET(J), J=JD, NRL)
- ELSE
- NTE=NEMET-JD+1
- IF(NTE.EQ.1) WRITE(IUO1,223) NEMO,(IEMET(J),J=JD,NEMET)
- IF(NTE.EQ.2) WRITE(IUO1,323) NEMO,(IEMET(J),J=JD,NEMET)
- IF(NTE.EQ.3) WRITE(IUO1,123) NEMO,(IEMET(J),J=JD,NEMET)
- ENDIF
- ENDDO
- ENDIF
- IF(SPECTRO.NE.'EIG') THEN
- WRITE(IUO1,124) ISOM,NONVOL(JFICH),NPATHP,VINT
- WRITE(IUO1,125) IFWD,NTHOUT,I_NO,I_RA
- DO JAT=1,NAT
- WRITE(IUO1,126) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT)
- RTHFWD(JAT)=THFWD(JAT)*PIS180
- RTHBWD(JAT)=THBWD(JAT)*PIS180
- ENDDO
- WRITE(IUO1,127) IPW,NCUT,PCTINT,IPP
- WRITE(IUO1,128) ILENGTH,RLENGTH,UNLENGTH
- WRITE(IUO1,129) IDWSPH,ISPEED,IATTS,IPRINT
- ELSE
- WRITE(IUO1,144) VINT
- ENDIF
- WRITE(IUO1,130) IDCM,TD,T,RSJ
- WRITE(IUO1,131) ILPM,XLPM0
- DO I=1,NLEC
- NDEB=4*(I-1) + 1
- NFIN=4*I
- IF(I.EQ.NLEC) NFIN=NAT
- NUJ=NFIN-NDEB+1
- IF(NUJ.EQ.1) WRITE(IUO1,132) (UJ2(J),J=NDEB,NFIN)
- IF(NUJ.EQ.2) WRITE(IUO1,232) (UJ2(J),J=NDEB,NFIN)
- IF(NUJ.EQ.3) WRITE(IUO1,332) (UJ2(J),J=NDEB,NFIN)
- IF(NUJ.EQ.4) WRITE(IUO1,432) (UJ2(J),J=NDEB,NFIN)
- ENDDO
- IF(IADS.EQ.1) THEN
- IF(NATA.EQ.1) WRITE(IUO1,133) (UJ2(J),J=NAT+1,NAT+NATA)
- IF(NATA.EQ.2) WRITE(IUO1,233) (UJ2(J),J=NAT+1,NAT+NATA)
- IF(NATA.EQ.3) WRITE(IUO1,333) (UJ2(J),J=NAT+1,NAT+NATA)
- ENDIF
-C
- IF(UNLENGTH.EQ.'ATU') RLENGTH=RLENGTH*BOHR/A
- IF(UNLENGTH.EQ.'ANG') RLENGTH=RLENGTH/A
- IF(IBAS.GT.0) THEN
- OMEGA1=OMEGAD1*PIS180
- OMEGA2=OMEGAD2*PIS180
- ENDIF
- QD=0.
- DO J=1,NATM
- UJ2(J)=UJ2(J)/(A*A)
- ENDDO
- IF(E0.EQ.0.) E0=0.0001
- NPOINT=NPHI*NE*NTHETA
- ISORT1=0
- IF(NPOINT.GT.250) THEN
- ISORT1=1
- WRITE(IUO1,510)
- ENDIF
-C
- IF(IDWSPH.EQ.1) THEN
- NFAC=N_GAUNT
- ELSE
- NFAC=4*NL_M
- ENDIF
- IF(SPECTRO.EQ.'EIG') THEN
-C
-C Switch for including vibrational damping into the MS matrix
-C
-C I_VIB = 0 : no vibrations included
-C I_VIB = 1 : vibrations included
-C
-C and mean free path-like damping
-C
-C I_MFP = 0 : no Im(k) damping included
-C I_MFP = 1 : Im(k) damping included
-C
- I_VIB=MOD(I_DAMP,2)
- IF(I_VIB.EQ.1) THEN
- IDWSPH=1
- ELSE
- IDWSPH=0
- ENDIF
- IF(I_DAMP.LE.1) THEN
- I_MFP=0
- ELSE
- I_MFP=1
- ENDIF
- ENDIF
-C
-C Computing the renormalization coefficients
-C
- IF(I_REN.LE.4) THEN
- CALL COEF_RENORM(NDIF)
- ELSEIF(I_REN.EQ.5) THEN
- CALL COEF_LOEWDIN(NDIF)
- ENDIF
-C
-C Storage of the logarithm of the Gamma function GLD(N+1,N_INT)
-C for integer (N_INT=1) and semi-integer (N_INT=2) values :
-C
-C GLD(N+1,1) = Log(N!) for N integer
-C GLD(N+1/2,2) = Log(N!) for N semi-integer
-C
- IF((ISPHER.GE.0).OR.(I_MULT.EQ.1)) THEN
- GLG(1)=0.0
- GLD(1,1)=0.D0
- GLD(1,2)=DLOG(SQPI/2.D0)
- DO I=2,NFAC
- J=I-1
- GLG(I)=GLG(J)+ALOG(FLOAT(J))
- GLD(I,1)=GLD(J,1)+DLOG(DFLOAT(J))
- GLD(I,2)=GLD(J,2)+DLOG(DFLOAT(J) +0.5D0)
- ENDDO
- ELSEIF((IFTHET.EQ.1).AND.(ITEST.EQ.1)) THEN
- GLG(1)=0.0
- DO I=2,NFAC
- J=I-1
- GLG(I)=GLG(J)+ALOG(FLOAT(J))
- ENDDO
- ENDIF
- EXPF(0,0)=1.
- EXPR(0,0)=1.
- FACT1L=0.D0
- DO L=1,2*NL_M-2
- XDEN=1./SQRT(FLOAT(L+L+1))
- DXDEN=1.D0/DSQRT(DFLOAT(L+L+1))
- FACT1L=FACT1L+DLOG(DFLOAT(L))
- FACT2L=DLOG(DFLOAT(L+1))
- DO M1=0,L
- EXPF(M1,L)=EXP(0.5*(GLG(L+M1+1)-GLG(L-M1+1)))
- DEXPF=DEXP(0.5D0*(GLD(L+M1+1,1)-GLD(L-M1+1,1)))
- EXPR(M1,L)=EXP(0.5*(GLG(L+L+1)-GLG(L+M1+1)-GLG(L-M1+1)))
- EXPF2(L,M1)=EXPF(M1,L)*XDEN
- DEXPF2(L,M1)=DEXPF*DXDEN
- IF(M1.GT.0) THEN
- FACT2L=FACT2L+DLOG(DFLOAT(1+L+M1))
- ENDIF
- IF(L.LT.NL_M) THEN
- DO M2=0,L
- CF(L,M1,M2)=SQRT(FLOAT((L*L-M1*M1)*(L*L-M2*M2)))/FLOAT(L)
- ENDDO
- ENDIF
- ENDDO
- FSQ(L)=EXP(0.5*REAL(FACT2L-FACT1L))
- DFSQ(L)=DEXP(0.5D0*(FACT2L-FACT1L))
- ENDDO
-C
- IF((INITL.LT.-1).OR.(INITL.GT.2)) THEN
- INITL=1
- WRITE(IUO1,511)
- ENDIF
- NEPS=2-ABS(IPOL)
- IF(IDICHR.GE.1) NEPS=1
- ISTEP_LF=ABS(INITL)
- IF(INITL.EQ.-1) THEN
- LF1=LI-1
- LF2=LF1
- ELSEIF(INITL.EQ.1) THEN
- LF1=LI+1
- LF2=LF1
- ELSEIF(INITL.EQ.2) THEN
- LF1=LI-1
- LF2=LI+1
- ELSEIF(INITL.EQ.0) THEN
- LF1=LI
- LF2=LI
- ISTEP_LF=1
- ENDIF
-C
-C Initialization of the values of ji if spin-orbit is taken
-C into account.
-C
-C Here : JI is the loop index going from JF1 to JF2 with :
-C
-C JI=1 : ji = li + 1/2
-C JI=2 : ji = li - 1/2
-C
- IF(I_SO.EQ.0) THEN
- JF1=1
- JF2=2
- ELSEIF(I_SO.EQ.1) THEN
- IF(S_O.EQ.'1/2') THEN
- IF(LI.EQ.0) THEN
- JF1=1
- JF2=1
- ELSEIF(LI.EQ.1) THEN
- JF1=2
- JF2=2
- ENDIF
- ELSEIF(S_O.EQ.'3/2') THEN
- IF(LI.EQ.1) THEN
- JF1=1
- JF2=1
- ELSEIF(LI.EQ.2) THEN
- JF1=2
- JF2=2
- ENDIF
- ELSEIF(S_O.EQ.'5/2') THEN
- IF(LI.EQ.2) THEN
- JF1=1
- JF2=1
- ELSEIF(LI.EQ.3) THEN
- JF1=2
- JF2=2
- ENDIF
- ELSEIF(S_O.EQ.'7/2') THEN
- IF(LI.EQ.3) THEN
- JF1=1
- JF2=1
- ELSEIF(LI.EQ.4) THEN
- JF1=2
- JF2=2
- ENDIF
- ELSEIF(S_O.EQ.'9/2') THEN
- IF(LI.EQ.4) THEN
- JF1=1
- JF2=1
- ELSE
- RETURN 7
- ENDIF
- ELSE
- RETURN 7
- ENDIF
- ELSEIF(I_SO.EQ.2) THEN
- JF1=1
- JF2=2
- ELSE
- RETURN 7
- ENDIF
-C
- IF(NI.LE.5) THEN
- NNL=NI*(NI-1)/2 +LI+1
- ELSEIF(NI.EQ.6) THEN
- NNL=NI*(NI-1)/2 +LI
- ELSEIF(NI.EQ.7) THEN
- NNL=NI*(NI-1)/2 +LI-3
- ENDIF
-C
-C Storage of the Clebsch-Gordan coefficients for the spin-orbit
-C dependent coupling matrix elements in the array CG(MJI,JI,JSPIN).
-C
-C Here : JI=1 : ji = li + 1/2
-C JI=2 : ji = li - 1/2
-C MJI : mji + 1/2
-C JSPIN=1 : msi = +1/2
-C JSPIN=2 : msi = -1/2
-C
-C so that all indices remain integer
-C
- IF((I_SO.GT.0).OR.(ISPIN.EQ.1).OR.(SPECTRO.EQ.'APC')) THEN
- DO JS=1,2
- DO JI=1,2
- DO MJI=-LI,LI+1
- CG(MJI,JI,JS)=0.0
- ENDDO
- ENDDO
- ENDDO
- DO MJI=-LI,LI+1
- CG(MJI,1,1)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1))
- CG(MJI,1,2)=SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1))
- IF((MJI.GT.-LI).AND.(MJI.LT.LI+1)) THEN
- CG(MJI,2,1)=-SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1))
- CG(MJI,2,2)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1))
- ENDIF
- ENDDO
- ENDIF
-C
-C
-C Storage of the Clebsch-Gordan coefficients for the Auger multiplet
-C dependent coupling matrix elements in the array CGA(LJ1,MJ1,LJ2,MJ2,LJ).
-C
-C Here : LJ1 is an integer index related to J1 (LJ1=2*J1)
-C LMJ1 is an integer index related to MJ1 (LMJ1=2*MJ1)
-C LJ2 is an integer index related to J2 (LJ2=2*J2)
-C LMJ2 is an integer index related to MJ2 (LMJ2=2*MJ2)
-C LJ is an integer index related to J :
-C J = FLOAT(LJ) for J integer
-C J = FLOAT(LJ) + 0.5 for J half integer
-C
-C so that all indices remain integer
-C
- IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
- IF(I_MULT.EQ.1) THEN
- N=3
- MJ3=0.D0
- LJ_MAX=2*(LI_I+LI_A+1)
- DO LJ1=0,LJ_MAX
- J1=DFLOAT(LJ1)/2.D0
- DO LMJ1=-LJ1,LJ1,2
- MJ1=DFLOAT(LMJ1)/2.D0
- DO LJ2=0,LJ_MAX
- J2=DFLOAT(LJ2)/2.D0
- DO LMJ2=-LJ2,LJ2,2
- MJ2=DFLOAT(LMJ2)/2.D0
- CALL N_J(J1,MJ1,J2,MJ2,MJ3,NJ,I_INT,N)
-C
- JJ12=J1-J2
- JL12=MJ1-MJ2
-C
- LJ12=INT(JJ12+SIGN(SMALL,JJ12))
- LL12=INT(JL12+SIGN(SMALL,JL12))
-C
- JJ_MIN=ABS(LJ12)
- JJ_MAX=J1+J2
- LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN))
- LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX))
-C
- DO LJJ=LJJ_MIN,LJJ_MAX,1
- IF(I_INT.EQ.1) THEN
- JJ=DFLOAT(LJJ)
- ELSE
- JJ=DFLOAT(LJJ)+0.5D0
- ENDIF
- L_EXP=INT(J1-J2+MJ1+MJ2)
- IF(MOD(L_EXP,2).EQ.0) THEN
- CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=NJ(LJJ)*SQRT(2.*REAL(JJ
- &)+1.)
- ELSE
- CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=-NJ(LJJ)*SQRT(2.*REAL(J
- &J)+1.)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-C
-C Storage of another of the spin Clebsch-Gordan used
-C when the Auger line is multiplet-resolved. It
-C originates from the coupling of SA and SC,
-C the spins of the Auger electron of the original
-C core electron (which is supposed to be the same
-C as that of the photoelectron).
-C
-C CG_S(I,J,K) with : I = 1 ---> MSA = -1/2
-C I = 2 ---> MSA = 1/2
-C J = 1 ---> MSC = -1/2
-C J = 2 ---> MSC = 1/2
-C K = 1 ---> S = 0
-C K = 2 ---> S = 1
-C
-C MS = MSA+MSC
-C
- IF(I_MULT.EQ.1) THEN
- CG_S(1,1,1)=0.
- CG_S(1,1,2)=1.
- CG_S(1,2,1)=-0.707107
- CG_S(1,2,2)= 0.707107
- CG_S(2,1,1)= 0.707107
- CG_S(2,1,2)= 0.707107
- CG_S(2,2,1)= 0.
- CG_S(2,2,2)= 1.
- ENDIF
-C
-C Initialization of the variables used when only one multiplet
-C is taken into account in the Auger peak
-C
- IF(I_MULT.EQ.1) THEN
- MULTIPLET=CHAR(48+IM1)//MULT//CHAR(48+IM2)
- IF(MOD(IM1,2).EQ.0) THEN
- WRITE(IUO1,522) IM1
- STOP
- ENDIF
- S_MUL=(IM1-1)/2
- J_MUL=IM2
- IF(MULT.EQ.'S') THEN
- L_MUL=0
- ELSEIF(MULT.EQ.'P') THEN
- L_MUL=1
- ELSEIF(MULT.EQ.'D') THEN
- L_MUL=2
- ELSEIF(MULT.EQ.'F') THEN
- L_MUL=3
- ELSEIF(MULT.EQ.'G') THEN
- L_MUL=4
- ELSEIF(MULT.EQ.'H') THEN
- L_MUL=5
- ELSEIF(MULT.EQ.'I') THEN
- L_MUL=6
- ELSEIF(MULT.EQ.'K') THEN
- L_MUL=7
- ELSEIF(MULT.EQ.'L') THEN
- L_MUL=8
- ELSEIF(MULT.EQ.'M') THEN
- L_MUL=9
- ELSE
- WRITE(IUO1,521) MULTIPLET
- STOP
- ENDIF
- ENDIF
-C
-C.......... Check of the dimensioning in the Gaussian case ..........
-C
- CALL STOP_EXT(I_EXT,I_EXT_A,SPECTRO)
-C
-C.................... Read FORMAT ....................
-C
-C
- 1 FORMAT(A7)
- 2 FORMAT(21X,10A4)
- 3 FORMAT(7X,A3,9X,A1,9X,I1,6X,I4)
- 4 FORMAT(8X,F6.3,4X,F6.3,4X,F6.3,3X,A3)
- 5 FORMAT(49X,A7)
- 6 FORMAT(7X,F6.2,4X,F6.2,4X,F6.2)
- 7 FORMAT(8X,I2,8X,I2,8X,I2,8X,I2)
- 8 FORMAT(8X,I2,8X,F6.3,3X,I3,9X,I1)
- 9 FORMAT(8X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2)
- 10 FORMAT(9X,I1,8X,I2,7X,F5.1,5X,F5.1)
- 11 FORMAT(7X,F5.1,3(5X,F5.1))
- 12 FORMAT(7X,F6.2,4X,F6.2,6X,I1)
- 13 FORMAT(7X,A3,9X,I1,9X,I1,8X,I2)
- 14 FORMAT(8X,I2,9X,I1,9X,I1,9X,I1,9X,I1)
- 15 FORMAT(7X,I3,7X,I3,7X,I3,7X,I3)
- 16 FORMAT(6X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3)
- 17 FORMAT(6X,F7.2,3X,F7.2,2X,F8.2)
- 18 FORMAT(9X,I1,9X,I1,8X,F5.2,6X,I1)
- 19 FORMAT(7X,I3,6X,F7.2,3X,F7.2,2X,F8.2)
- 20 FORMAT(8X,I1,A1,8X,A3,7X,I2,8X,I2)
- 21 FORMAT(8X,I2,8X,I2,9X,I1,9X,I1)
- 22 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
- 23 FORMAT(8X,I2)
- 24 FORMAT(8X,I2,3(8X,I2))
- 25 FORMAT(9X,I1,8X,I2,6X,I4,8X,F6.2)
- 26 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
- 27 FORMAT(9X,I1,6X,F6.2,7X,I1,7X,F6.2)
- 28 FORMAT(9X,I1,9X,I1,7X,F8.4,4X,I1)
- 29 FORMAT(9X,I1,7X,F6.2,4X,A3)
- 30 FORMAT(9X,I1,8X,I2,9X,I1,9X,I1)
- 31 FORMAT(9X,I1,6X,F8.3,2X,F8.3,5X,F4.2)
- 32 FORMAT(8X,I2,7X,F6.2)
- 33 FORMAT(8X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5)
- 34 FORMAT(9X,A24,5X,I2)
- 35 FORMAT(18X,I2,8X,I2,8X,I2)
- 36 FORMAT(18X,A2,8X,A2,8X,A2)
- 37 FORMAT(18X,F8.5,2X,F8.5,2X,F8.5)
- 38 FORMAT(9X,I1,7X,F5.1,5X,F5.1,5X,F5.1)
- 39 FORMAT(8X,A1,I1,8X,I2,6X,F7.2,3X,F7.2)
- 40 FORMAT(8X,A1,I1,8X,A1,I1,8X,A1,I1)
- 41 FORMAT(6X,F7.2,3X,F7.2,5X,F6.3)
- 42 FORMAT(9X,I1,8X,I1,A1,I1)
- 43 FORMAT(7X,I3,6X,F7.2,3X,F7.2,6X,I1)
- 44 FORMAT(9X,I1)
- 46 FORMAT(8X,I2,6X,A4,9X,F7.5,2X,F6.3)
- 47 FORMAT(5X,I5,6X,I4,6X,I4,8X,F6.3)
- 48 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
- 49 FORMAT(8X,I2,6X,F7.2,3X,F7.2)
- 50 FORMAT(9X,I1,9X,I1,6X,F8.3,2X,F8.3)
-C
-C
-C.................... Write FORMAT ....................
-C
-C
- 100 FORMAT(//////////,'******************************', '*************
- &***************************************')
- 101 FORMAT('*********************',40X,'*********************')
- 102 FORMAT('*********************',10A4,'*********************')
- 103 FORMAT(10X,A3,9X,A1,9X,I1,6X,I4,9X,'CRIST,CENTR,IBAS,NAT')
- 104 FORMAT(11X,F6.3,4X,F6.3,4X,F6.3,15X,'A,BSURA,CSURA')
- 105 FORMAT(///,'ooooooooooooooooooooooooooooooooooooooooo','oooooooooo
- &ooooooooooooooooooooooooooooooo',/,'oooooooooooooooo',50X,'ooooooo
- &ooooooooo',/,'oooooooooooooooo INPUT DATA FILE : ',A24,' ooo
- &ooooooooooooo',/,'oooooooooooooooo',50X,'oooooooooooooooo',/,'oooo
- &oooooooooooooooooooooooo','ooooooooooooooooooooooooooooooooooooooo
- &oooooooooo','ooooo',///)
- 106 FORMAT(10X,F6.2,4X,F6.2,4X,F6.2,16X,'ALPHAD,BETAD,GAMMAD')
- 107 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'H,K,I,L')
- 108 FORMAT(12X,I1,8X,F6.3,3X,I3,9X,I1,9X,'NIV,COUPUR,ITEST,IESURF')
- 109 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2,4X,'ATBAS,CHEM(NAT)','
- &,NZAT(NAT)')
- 110 FORMAT(12X,I1,8X,I2,7X,F5.1,5X,F5.1,7X,'IREL,NREL,PCREL(NREL)')
- 112 FORMAT(10X,F6.2,4X,F6.2,6X,I1,19X,'OMEGA1,OMEGA2,IADS')
- 113 FORMAT(12X,I1,9X,I1,8X,I2,19X,'ISPIN,IDICHR,IPOL')
- 114 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI,ITHETA,IE,',
- &'IFTHET')
- 115 FORMAT(10X,I3,7X,I3,7X,I3,7X,I3,9X,'NPHI,NTHETA,NE,NFTHET')
- 116 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI0,THETA0,E0,R0')
- 117 FORMAT(9X,F7.2,3X,F7.2,2X,F8.2,16X,'THLUM,PHILUM,ELUM')
- 118 FORMAT(12X,I1,9X,I1,8X,F5.2,6X,I1,9X,'IMOD,IMOY,ACCEPT,ICHKDIR')
- 119 FORMAT(10X,I3,6X,F7.2,3X,F7.2,2X,F8.2,6X,'NE,EK_INI,','EK_FIN,EPH_
- &INI')
- 120 FORMAT(11X,I1,A1,8X,A3,7X,I2,8X,I2,9X,'LI,S-O,INITL,I_SO')
- 121 FORMAT(11X,I2,8X,I2,9X,I1,9X,I1,9X,'NO,NDIF,ISPHER,I_GR')
- 122 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'ISFLIP,IR_DIA,ITRTL,I_TEST')
- 123 FORMAT(11X,I2,3(8X,I2),9X,'NEMET,IEMET(NEMET)')
- 124 FORMAT(12X,I1,8X,I2,6X,I4,7X,F6.2,6X,'ISOM,NONVOL,NPATH,VINT')
- 125 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'IFWD,NTHOUT,I_NO,I_RA')
- 126 FORMAT(12X,I1,7X,F6.2,6X,I1,7X,F6.2,6X,'N_RA(NAT),THFWD(NAT)',',IB
- &WD(NAT),THBWD(NAT)')
- 127 FORMAT(12X,I1,9X,I1,7X,F8.4,4X,I1,9X,'IPW,NCUT,PCTINT,IPP')
- 128 FORMAT(12X,I1,7X,F6.2,4X,A3,19X,'ILENGTH,RLENGTH,UNLENGTH')
- 129 FORMAT(12X,I1,8X,I2,9X,I1,9X,I1,9X,'IDWSPH,ISPEED,IATT,IPRINT')
- 130 FORMAT(12X,I1,6X,F8.3,2X,F8.3,5X,F4.2,6X,'IDCM,TD,T,RSJ')
- 131 FORMAT(11X,I2,7X,F6.2,26X,'ILPM,XLPM0')
- 132 FORMAT(11X,F8.5,33X,'UJ2(NAT) : ','SUBSTRATE')
- 133 FORMAT(11X,F8.5,33X,'UJ2(NATA) : ','ADSORBATES')
- 134 FORMAT(11X,A1,I1,8X,I2,6X,F7.2,3X,F7.2,6X,'EDGE,INITL,THLUM,','PHI
- &LUM')
- 135 FORMAT(11X,A1,I1,8X,A1,I1,8X,A1,I1,19X,'EDGE_C,EDGE_I,','EDGE_A')
- 136 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI_A,ITHETA_A,','IFTHET_A,I_
- &INT')
- 137 FORMAT(10X,I3,7X,I3,7X,I3,19X,'NPHI_A,NTHETA_A,NFTHET_A')
- 138 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI0_A,THETA0_A,R0_A')
- 139 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI1_A,THETA1_A,R1_A')
- 140 FORMAT(12X,I1,8X,I1,A1,I1,28X,'I_MULT,MULT')
- 141 FORMAT(12X,I1,39X,'ISPIN')
- 142 FORMAT(9X,F7.2,3X,F7.2,26X,'TH_INI,PHI_INI')
- 143 FORMAT(10X,I3,6X,F7.2,3X,F7.2,6X,I1,9X,'NE,EK_INI,EK_FIN,I_DAMP')
- 144 FORMAT(10X,F6.2,36X,'VINT')
- 145 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'I_SPECTRUM(NE)')
- 146 FORMAT(11X,I2,6X,A4,9X,F7.5,2X,F6.3,5X,'I_PWM,METHOD,ACC,EXPO')
- 147 FORMAT(8X,I5,6X,I4,6X,I4,8X,F6.3,5X,'N_MAX,N_ITER,N_TABLE,SHIFT')
- 148 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'I_XN,I_VA,I_GN,I_WN')
- 149 FORMAT(11X,I2,6X,F7.2,3X,F7.2,16X,'L,ALPHA,BETA')
- 150 FORMAT(12X,I1,9X,I1,6X,F8.3,2X,F8.3,5X,'I_REN,N_REN,REN_R,REN_I')
-C
- 201 FORMAT(///,21X,10A4,////)
- 203 FORMAT('**************************************************',
- &'********************************',//////////)
- 204 FORMAT(11X,F6.3,5X,I1,29X,'A,IBAS')
- 206 FORMAT(10X,F6.2,36X,'ALPHAD')
- 207 FORMAT(11X,I2,8X,I2,8X,I2,19X,'H,K,L')
- 209 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'VECBAS')
- 210 FORMAT(10X,F5.1,3(5X,F5.1),7X,'PCREL(NREL)')
- 211 FORMAT(20X,'SUBSTRATE : ',10(F5.1,','))
- 212 FORMAT(32X,I1,19X,'IADS')
- 216 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI1,THETA1,EFIN,R1')
- 223 FORMAT(11X,I2,1(8X,I2),29X,'NEMET,IEMET(NEMET)')
- 232 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NAT) : ','SUBSTRATE')
- 233 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NATA) : ','ADSORBATES')
-C
- 303 FORMAT(/,33X,'ATOMS OF TYPE ',I1,' :',/)
- 304 FORMAT(11X,F6.3,35X,'A')
- 306 FORMAT(10X,F6.2,36X,'BETAD')
- 309 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'XADS,YADS,ZADS')
- 311 FORMAT(20X,'ADSORBATE : ',3(F5.1,','))
- 323 FORMAT(11X,I2,2(8X,I2),19X,'NEMET,IEMET(NEMET)')
- 332 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NAT) : ','SUBSTRATE')
- 333 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NATA) : ','ADSORBATES')
-C
- 404 FORMAT(11X,F6.3,4X,F6.3,25X,'A,CSURA')
- 432 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5,3X,'UJ2(NAT) : ','SUBSTRA
- &TE')
-C
- 501 FORMAT(//,30X,'POSITION OF THE ADSORBATES :')
- 502 FORMAT(///,25X,'VALUE OF THE RELAXATIONS :',/)
- 503 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL PHOTOELECTRON',' D
- &IFFRACTION')
- 504 FORMAT(///,18X,'TYPE OF CALCULATION : FINE STRUCTURE ','OSCILLATIO
- &NS')
- 505 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR PHOTOELECTRON',' DIFFR
- &ACTION')
- 506 FORMAT(///,23X,'TYPE OF CALCULATION : SCATTERING FACTOR')
- 507 FORMAT(///,28X,'TYPE OF CALCULATION : EXAFS')
- 508 FORMAT(///,2X,' <<<<<<<<<< THE THETA VARIATION EXCEEDS THE ', 'P
- &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///)
- 509 FORMAT(///,2X,' <<<<<<<<<< THE THLUM VARIATION EXCEEDS THE ', 'P
- &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///)
- 510 FORMAT(///,4X,' <<<<<<<<<< AS THE CALCULATION HAS MORE THAN ','25
- &0 POINTS, SOME OUTPUTS HAVE BEEN SUPRESSED >>>>>>>>>>',///)
- 511 FORMAT(///,4X,' <<<<<<<<<< INCORRECT VALUE OF INITL, THE ', 'C
- &ALCULATION IS PERFORMED WITH INITL = 1 >>>>>>>>>>')
- 512 FORMAT(///,4X,' <<<<<<<<<< IMPOSSIBLE TO HAVE A SPIN RESOLVED ','
- &EXAFS EXPERIMENT : DECREASE IDICHR >>>>>>>>>>')
- 513 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IPOL = 0 AND ','ID
- &ICHR > 0 >>>>>>>>>>')
- 514 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IDICHR = 2 AND ','
- &ISPIN = 0 >>>>>>>>>>')
- 515 FORMAT(///,12X,'TYPE OF CALCULATION : AZIMUTHAL AUGER ELECTRON','
- &DIFFRACTION')
- 516 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR AUGER ELECTRON',' DIFF
- &RACTION')
- 517 FORMAT(///,10X,'TYPE OF CALCULATION : AUGER PHOTOELECTRON ','COINC
- &IDENCE SPECTROSCOPY')
- 518 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','-----
- &-------------------')
- 519 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','-----
- &-------------------')
- 520 FORMAT(///,9X,'----------------------------------------------','--
- &--------------------')
- 521 FORMAT(///,4X,' <<<<<<<<<< ',A3,' IS NOT IMPLEMENTED IN THIS ','V
- &ERSION >>>>>>>>>>')
- 522 FORMAT(///,4X,' <<<<<<<<<< WRONG NAME FOR THE MULTIPLET',' >>>>>
- &>>>>>',/,4X,' <<<<<<<<<< ODD NUMBER ','EXPECTED INSTEAD OF',I2,'
- & >>>>>>>>>>')
- 523 FORMAT(///,4X,' <<<<<<<<<< BOTH DETECTOR DIRECTIONS MUST BE ','EI
- &THER INTERNAL OR EXTERNAL >>>>>>>>>>',/,8X,' -----> PROCEEDING WI
- &TH EXTERNAL DIRECTIONS',/)
- 524 FORMAT(///,4X,' <<<<<<<<<< AVERAGING OVER ',I3,' DOMAINS ','FOR P
- &HOTOELECTRON >>>>>>>>>>',/,4X,' <<<<<<<<<< AVERAGING OVER ',I3,
- &' DOMAINS ','FOR AUGER ELECTRON >>>>>>>>>>',/,8X,' -----> IMPOSS
- &IBLE : CHECK INPUT FILES !')
- 525 FORMAT(///,14X,'ATOMIC CALCULATION : Z AXIS ALONG POLARIZATION ','
- &DIRECTION',/,' ',/,' ',/,' ')
- 526 FORMAT(///,18X,'ATOMIC CALCULATION : Z AXIS ALONG LIGHT ','DIRECTI
- &ON',/,' ',/,' ',/,' ')
- 527 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' PHOTOELEC
- &TRON DIFFRACTION')
- 528 FORMAT(///,10X,'TYPE OF CALCULATION : FULL HEMISPHERE',' AUGER ELE
- &CTRON DIFFRACTION')
- 529 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL LEED',' VARIATIONS
- &')
- 530 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' LEED')
- 531 FORMAT(///,18X,'TYPE OF CALCULATION : LEED ENERGY ','VARIATIONS')
- 532 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR LEED',' VARIATIONS')
- 533 FORMAT(///,17X,'TYPE OF CALCULATION : EIGENVALUE',' ANALYSIS')
- 534 FORMAT(///,22X,'THE AMPLITUDES WILL BE PRINTED SEPARATELY')
-C
- 701 FORMAT(6X,I1,1X,I3,2X,I4)
- 702 FORMAT(6X,I1,1X,I3,3X,I3)
- 703 FORMAT(15X,F8.3,3X,F8.3)
- 713 FORMAT(6X,I1,1X,I3)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- FUNCTION SIG2(RJ,JTYP)
-C
-C This routine evaluates the mean square displacements.
-C
- USE DIM_MOD
-C
- USE DEBWAL_MOD , T => TEMP
- USE MASSAT_MOD , XM => XMT
- USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT
- &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT
-C
- REAL MJ
-C
-C
-C
- DATA COEF/145.52539/
- DATA RZ2,RZ4,RZ6/1.644934,1.082323,1.017343/
-C
- A=TD/T
- BJ=QD*RJ
- U=BJ/A
- MJ=XM(JTYP)
- C=COEF/(2.*MJ*TD)
- COMP=RZ2-U*U*RZ4+U*U*U*U*RZ6
- X1=0.
- X2=0.
- X3=0.
- X4=0.
- DO 10 N=1,8
- Z=FLOAT(N)
- X1=X1+EXP(-Z*A)*((A/Z)+(1./(Z*Z)))
- X2=X2+1./(Z**8+U*U*(Z**6))
- X3=X3+EXP(-Z*A)*Z/(Z*Z+U*U)
- X4=X4+EXP(-Z*A)/(Z*Z+U*U)
- 10 CONTINUE
- P1=1.+4.*(RZ2-X1)/(A*A)
- P2=-2.*(1.-COS(BJ))/(BJ*BJ)
- P3=-4.*(COMP-(U**6)*X2)/(A*A)
- P4=4.*SIN(BJ)*X3/(A*BJ)
- P5=4.*COS(BJ)*X4/(A*A)
- SIG2=C*(P1+P2+P3+P4+P5)/(A0*A0)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- DOUBLE PRECISION FUNCTION SIXJ_IN(J1,J2,L1,L2,L3)
-C
-C This function calculates the initial value {J1 J2 L1+L2}
-C {L1 L2 L3 }
-C
-C A 6j symbol {J1 J2 J3} is non zero only if
-C {J4 J5 J6}
-C
-C (J1,J2,J3),(J4,J5,J3),(J2,J4,J6) and (J1,J5,J6) satisfy the triangular inequality :
-C
-C (a,b,c) non zero if |a-b| <= c <= (a+b) . This means also that (a+b) and c must
-C have the same nature (integer or half-integer).
-C
-C (J1,J2,J3) and (J4,J5,J3) are taken care of by the bounds of J3, JJ_MIN and JJ_MAX,
-C as chosen in the N_J routine. Here we check the two last ones.
-C
-C Last modified : 8 Dec 2008
-C
-C
- USE DIM_MOD
- USE LOGAMAD_MOD
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- REAL*8 J1,J2,L1,L2,L3
-C
-C
- DATA SMALL /0.0001/
-C
- IZERO=0
-C
-C Check for unphysical values of L3
-C
- IF(DABS(J2-L1).GT.L3) IZERO=1
- IF(J2+L1.LT.L3) IZERO=1
- IF(IG(J2+L1).NE.IG(L3)) IZERO=1
- IF(DABS(J1-L2).GT.L3) IZERO=1
- IF(J1+L2.LT.L3) IZERO=1
- IF(IG(J1+L2).NE.IG(L3)) IZERO=1
-C
- IF(IZERO.EQ.1) THEN
- SIXJ_IN=0.D0
- ELSE
-C
-C Storage indices of the angular momenta.
-C
- LJ1=INT(J1+SIGN(SMALL,J1))
- LJ2=INT(J2+SIGN(SMALL,J2))
- LL1=INT(L1+SIGN(SMALL,L1))
- LL2=INT(L2+SIGN(SMALL,L2))
- LL3=INT(L3+SIGN(SMALL,L3))
- LL1_2=INT(L1+L1+SIGN(SMALL,L1))
- LL2_2=INT(L2+L2+SIGN(SMALL,L2))
-C
- MSIGN=INT(J1+J2+L1+L2+SIGN(SMALL,J1+J2+L1+L2))
- IF(MOD(MSIGN,2).EQ.0) THEN
- SIGNE=1.D0
- ELSE
- SIGNE=-1.D0
- ENDIF
-C
- D1=GLD(LL1_2+1,1) + GLD(LL2_2+1,1) - GLD(LL1_2+LL2_2+2,1)
- D2=GLD(INT(J1+J2+L1+L2)+2,IG(J1+J2+L1+L2)) - GLD(INT(J1+J2-L1-L2
- &)+1,IG(J1+J2-L1-L2))
- D3=GLD(INT(J1-J2+L1+L2)+1,IG(J1-J2+L1+L2)) - GLD(INT(J1+L2-L3)+1
- &,IG(J1+L2-L3))
- D4=GLD(INT(J2-J1+L1+L2)+1,IG(J2-J1+L1+L2)) -GLD(INT(-J1+L2+L3)+1
- &,IG(-J1+L2+L3))
- D5=GLD(INT(J1-L2+L3)+1,IG(J1-L2+L3)) - GLD(INT(J1+L2+L3)+2,IG(J1
- &+L2+L3))
- D6=GLD(INT(J2+L3-L1)+1,IG(J2+L3-L1)) - GLD(INT(J2-L3+L1)+1,IG(J2
- &-L3+L1))
- D7=GLD(INT(L1+L3-J2)+1,IG(L1+L3-J2)) +GLD(INT(L1+J2+L3)+2,IG(L1+
- &J2+L3))
-C
- SIXJ_IN=SIGNE*DSQRT(DEXP(D1+D2+D3+D4+D5+D6-D7))
-C
- ENDIF
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE SPH_HAR(NL,X,CF,YLM,NC)
-C
-C This routine computes the complex spherical harmonics using Condon and
-C Shortley phase convention.
-C
-C If the angular direction R=(THETAR,PHIR) is given in cartesian
-C coordinates by (XR,YR,ZR), the arguments of the subroutine are :
-C
-C X = ZR = cos(THETAR)
-C CF = XR + i YR = sin(THETAR)*exp(i PHIR)
-C
-C NL is the dimensioning of the YLM array and NC is
-C the maximum l value to be computed.
-C
- USE DIM_MOD
-C
- USE EXPFAC2_MOD
- USE FACTSQ_MOD
-C
- COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF
-C
- DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
-C
-C
- YLM(0,0)=CMPLX(SQ4PI_INV)
- YLM(1,0)=X*SQR3_INV
- DO L=2,NC
- Y=1./FLOAT(L)
- YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
- &-1.5))*YLM(L-2,0)
- ENDDO
-C
- C2=-1.
- C=-0.5*CF
-C
- C1=1.
- COEF=(1.,0.)
- DO M=1,NC
- C1=C1*C2
- COEF=COEF*C
- YMM=SQ4PI_INV*COEF*FSQ(M)
- YLM(M,M)=YMM
- YLM(M,-M)=C1*CONJG(YMM)
- YMMP=X*SQRT(FLOAT(M+M+3))*YMM
- YLM(M+1,M)=YMMP
- YLM(M+1,-M)=C1*CONJG(YMMP)
- IF(M.LT.NC-1) THEN
- DO L=M+2,NC
- YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
- &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
- YLM(L,-M)=C1*CONJG(YLM(L,M))
- ENDDO
- ENDIF
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE SPH_HAR2(NL,X,CF,YLM,NC)
-C
-C This routine computes the complex spherical harmonics using Condon and
-C Shortley phase convention.
-C
-C If the angular direction R=(THETAR,PHIR) is given in cartesian
-C coordinates by (XR,YR,ZR), the arguments of the subroutine are :
-C
-C X = ZR = cos(THETAR)
-C CF = XR + i YR = sin(THETAR)*exp(i PHIR)
-C
-C NL is the dimensioning of the YLM array and NC is
-C the maximum l value to be computed.
-C
-C This is the double precision version of sph_har.f
-C
-C
- USE DIM_MOD
-C
- USE DEXPFAC2_MOD
- USE DFACTSQ_MOD
-C
-C
-C
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- COMPLEX*16 YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF
-C
- DATA SQ4PI_INV,SQR3_INV /0.282094791774D0,0.488602511903D0/
-C
-C
- YLM(0,0)=DCMPLX(SQ4PI_INV)
- YLM(1,0)=X*SQR3_INV
- DO L=2,NC
- Y=1.D0/DFLOAT(L)
- YLM(L,0)=X*DSQRT(4.D0-Y*Y)*YLM(L-1,0) - (1.D0-Y)*DSQRT(1.D0+2.D0
- &/(DFLOAT(L)-1.5D0))*YLM(L-2,0)
- ENDDO
-C
- C2=-1.D0
- C=-0.5D0*CF
-C
- C1=1.D0
- COEF=(1.D0,0.D0)
- DO M=1,NC
- C1=C1*C2
- COEF=COEF*C
- YMM=SQ4PI_INV*COEF*DFSQ(M)
- YLM(M,M)=YMM
- YLM(M,-M)=C1*DCONJG(YMM)
- YMMP=X*DSQRT(DFLOAT(M+M+3))*YMM
- YLM(M+1,M)=YMMP
- YLM(M+1,-M)=C1*DCONJG(YMMP)
- IF(M.LT.NC-1) THEN
- DO L=M+2,NC
- YLM(L,M)=(X*DFLOAT(L+L-1)*DEXPF2(L-1,M)*YLM(L-1,M) - DFLOAT(
- &L+M-1)*DEXPF2(L-2,M)*YLM(L-2,M))/(DEXPF2(L,M)*DFLOAT(L-M))
- YLM(L,-M)=C1*DCONJG(YLM(L,M))
- ENDDO
- ENDIF
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE STOP_EXT(I_EXT,I_EXT_A,SPECTRO)
-C
-C This routine stops the code when the dimension N_TILT_M in the
-C spec.inc file is insufficient for the number of values to
-C Gaussian average over (as generated by the ext_dir.f code)
-C
- USE DIM_MOD
-C
- USE INFILES_MOD
- USE INUNITS_MOD
- USE OUTUNITS_MOD
-C
-C
-C
- CHARACTER*3 SPECTRO
-C
- NSET=1
- NSET_A=1
-C
- IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
- IF(I_EXT.EQ.-1) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,15) IDIR,NSET
- CLOSE(IUI6)
- ENDIF
- IF(I_EXT_A.EQ.-1) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,15) IDIR,NSET_A
- CLOSE(IUI6)
- ENDIF
- ENDIF
- IF(SPECTRO.EQ.'APC') THEN
- IF(I_EXT.EQ.-1) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,15) IDIR,NSET
- CLOSE(IUI6)
- ENDIF
- IF(I_EXT_A.EQ.-1) THEN
- OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
- READ(IUI9,15) IDIR,NSET_A
- CLOSE(IUI9)
- ENDIF
- ENDIF
-C
- IF(MAX(NSET,NSET_A).GT.N_TILT_M) THEN
- WRITE(IUO1,10) MAX(NSET,NSET_A)
- STOP
- ENDIF
-C
- 10 FORMAT(///,16X,'<<<<<<<<<< N_TILT_M SHOULD BE AT LEAST ',I3,' >>
- &>>>>>>>>')
- 15 FORMAT(6X,I1,1X,I3)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI
- &,NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
-C
-C This subroutine stops the code before the long MS calculations
-C when the dimensioning NDIM_M of the treatment routines
-C (treat_aed,treat_apc,treat_phd,treat_xas) is insufficient.
-C
-C
-C Last modified : 06 Oct 2006
-C
- USE DIM_MOD
- USE OUTUNITS_MOD
-C
- CHARACTER*3 SPECTRO
-C
-C
- IF(ISOM.EQ.0) THEN
-C
-C Photoelectron diffraction case
-C
- IF(SPECTRO.EQ.'PHD') THEN
- IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
- NDP=NEMET*NTHETA*NPHI*NE
- ELSEIF(I_EXT.EQ.-1) THEN
- NDP=NEMET*NTHETA*NPHI*NE*2
- ELSEIF(I_EXT.EQ.2) THEN
- NDP=NEMET*NTHETA*NE
- ENDIF
- NTT=NPLAN*NDP
- IF(NTT.GT.NDIM_M) GOTO 10
- IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
-C
-C Auger electron diffraction case
-C
- ELSEIF(SPECTRO.EQ.'AED') THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NEMET*NTHETA_A*NPHI_A*NE
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NEMET*NTHETA_A*NPHI_A*NE*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NEMET*NTHETA_A*NE
- ENDIF
- NTT=NPLAN*NDP
- IF(NTT.GT.NDIM_M) GOTO 20
- IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
-C
-C X-ray absorption case
-C
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- NDP=NEMET*NE
- NTT=NPLAN*NDP
- IF(NTT.GT.NDIM_M) GOTO 30
-C
-C Auger Photoelectron coincidence spectroscopy case
-C
- ELSEIF(SPECTRO.EQ.'APC') THEN
- IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A
- ENDIF
- ELSEIF(I_EXT.EQ.-1) THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A
- ENDIF
- ELSEIF(I_EXT.EQ.2) THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NEMET*NTHETA*NE*NTHETA_A
- ENDIF
- ENDIF
- NTT=NPLAN*NDP
- IF(NTT.GT.NDIM_M) GOTO 40
- IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
- IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
- ENDIF
-C
- ELSE
-C
-C Photoelectron diffraction case
-C
- IF(SPECTRO.EQ.'PHD') THEN
- IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
- NDP=NTHETA*NPHI*NE
- ELSEIF(I_EXT.EQ.-1) THEN
- NDP=NTHETA*NPHI*NE*2
- ELSEIF(I_EXT.EQ.2) THEN
- NDP=NTHETA*NE
- ENDIF
- NTT=NFICHLEC*NDP
- IF(NTT.GT.NDIM_M) GOTO 10
- IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
-C
-C Auger electron diffraction case
-C
- ELSEIF(SPECTRO.EQ.'AED') THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NTHETA_A*NPHI_A*NE
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NTHETA_A*NPHI_A*NE*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NTHETA_A*NE
- ENDIF
- NTT=NFICHLEC*NDP
- IF(NTT.GT.NDIM_M) GOTO 20
- IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
-C
-C X-ray absorption case
-C
- ELSEIF(SPECTRO.EQ.'XAS') THEN
- NDP=NE
- NTT=NFICHLEC*NDP
- IF(NTT.GT.NDIM_M) GOTO 30
-C
-C Auger Photoelectron coincidence spectroscopy case
-C
- ELSEIF(SPECTRO.EQ.'APC') THEN
- IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NTHETA*NPHI*NE*NTHETA_A
- ENDIF
- ELSEIF(I_EXT.EQ.-1) THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NTHETA*NPHI*NE*2*NTHETA_A
- ENDIF
- ELSEIF(I_EXT.EQ.2) THEN
- IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
- NDP=NTHETA*NE*NTHETA_A*NPHI_A
- ELSEIF(I_EXT_A.EQ.-1) THEN
- NDP=NTHETA*NE*NTHETA_A*NPHI_A*2
- ELSEIF(I_EXT_A.EQ.2) THEN
- NDP=NTHETA*NE*NTHETA_A
- ENDIF
- ENDIF
- NTT=NFICHLEC*NDP
- IF(NTT.GT.NDIM_M) GOTO 40
- IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
- IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
- ENDIF
- ENDIF
-C
- GOTO 5
-C
- 10 WRITE(IUO1,11) NTT
- STOP
- 20 WRITE(IUO1,21) NTT
- STOP
- 30 WRITE(IUO1,31) NTT
- STOP
- 40 WRITE(IUO1,41) NTT
- STOP
- 50 WRITE(IUO1,51) MAX(NTHETA,NPHI,NTHETA_A,NPHI_A)
- STOP
-C
- 11 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
- &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
- &_PHD SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
- &AT LEAST ',I8,' >>>>>>>>>>')
- 21 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
- &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
- &_AED SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
- &AT LEAST ',I8,' >>>>>>>>>>')
- 31 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
- &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
- &_XAS SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
- &AT LEAST ',I8,' >>>>>>>>>>')
- 41 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
- &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
- &_APC SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
- &AT LEAST ',I8,' >>>>>>>>>>')
- 51 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL','
- &IN THE INCLUDE FILE - SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
-C
- 5 RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE SUP_ZEROS(TL,LMAX,NE,NAT,IUO1,ITRTL)
-C
-C This routine suppresses possible zeros in the TL arrays so that
-C the code runs faster because of lower values of LMAX. Actually,
-C the TL array is not modified, it is just the LMAX array that is
-C altered. This is particularly useful for energy variations or
-C for matrix inversion
-C
- USE DIM_MOD
-C
- COMPLEX TL_,TL(0:NT_M,4,NATM,NE_M)
-C
- INTEGER LMAX(NATM,NE_M)
-C
- IF(ITRTL.EQ.1) THEN
- SMALL=0.1
- ELSEIF(ITRTL.EQ.2) THEN
- SMALL=0.01
- ELSEIF(ITRTL.EQ.3) THEN
- SMALL=0.001
- ELSEIF(ITRTL.EQ.4) THEN
- SMALL=0.0001
- ELSEIF(ITRTL.EQ.5) THEN
- SMALL=0.00001
- ELSEIF(ITRTL.EQ.6) THEN
- SMALL=0.000001
- ELSEIF(ITRTL.EQ.7) THEN
- SMALL=0.0000001
- ELSEIF(ITRTL.EQ.8) THEN
- SMALL=0.00000001
- ELSE
- ITRTL=9
- SMALL=0.000000001
- ENDIF
-C
- WRITE(IUO1,10)
- WRITE(IUO1,15) ITRTL
-C
- DO JE=1,NE
- WRITE(IUO1,20) JE
- DO JAT=1,NAT
- NONZERO=0
- LM=LMAX(JAT,JE)
- DO L=0,LM
- TL_=TL(L,1,JAT,JE)
- IF((ABS(REAL(TL_)).GE.SMALL).OR.(ABS(AIMAG(TL_)).GE.SMALL))
- &THEN
- NONZERO=NONZERO+1
- ENDIF
- ENDDO
- LMAX(JAT,JE)=NONZERO-1
- WRITE(IUO1,30) JAT,LM,NONZERO-1
- ENDDO
- ENDDO
-C
- WRITE(IUO1,40)
-C
- 10 FORMAT(//,' ---> CHECK FOR ZEROS IN THE TL FILE TO REDUCE',' THE
- & AMOUNT OF COMPUTING :',/)
- 15 FORMAT(/,' (ONLY THE MATRIX ELEMENTS NON ZERO ','TO THE FIRST ',I
- &1,' DECIMAL DIGITS ARE KEPT)',/)
- 20 FORMAT(/,15X,'ENERGY POINT No ',I3,/)
- 30 FORMAT(8X,'PROTOTYPICAL ATOM No ',I5,' INITIAL LMAX = ',I2,' FI
- &NAL LMAX = ',I2)
- 40 FORMAT(//)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- FUNCTION UJ_SQ(JTYP)
-C
-C This routine evaluates the mean square displacements UJ_SQ,
-C first along une direction (x, y or z): UJ2 within the Debye model,
-C using the Debye function formulation
-C
-C X1 is the Debye function phi_1
-C UJ_SQ is given in unit of the square of the lattice parameter A0
-C Temperatures are expressed in Kelvin
-C
-C The coefficient COEF equals:
-C
-C 3 hbar^{2} N_A 10^{3} / (4 k_B)
-C
-C where N_A is the Avogadro number, k_B is Boltzmann's constant
-C and 10^3 arises from the fact that the atomic mass is
-C expressed in grams
-C
-C Then UJ_SQ is obtained as UJ_SQ = (2 + RSJ) UJJ for surface atoms
-C UJ_SQ = 3 UJJ for bulk atoms
-C
-C
-C For empty spheres, two possibilities are provided. By construction,
-C they are very light (their mass is taken as 1/1836 of the mass
-C of a H atom) and so they will vibrate a lot (IDCM = 1). When
-C setting IDCM = 2, their mean square displacement is set to a
-C tiny value so that they hardly vibrate (frozen empty spheres)
-C
-C Last modified : 31 Jan 2017
-C
- USE DIM_MOD
-C
- USE DEBWAL_MOD , T => TEMP
- USE MASSAT_MOD , XM => XMT
- USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT
- &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT
- USE VIBRAT_MOD
-C
- REAL MJ
-C
-C
-C
- DATA COEF /36.381551/ ! 3 hbar^{2} / (4 k_B) for MJ in grams
- DATA RZ2 /1.644934/ ! Pi^2 / 6
- DATA LITTLE /0.01/ ! lowest temperature for calculation of phi_1
-C
- N_MAX=20
-C
-C Computation of the 1D mean square displacement UJ2
-C
- A=TD/T
- MJ=XM(JTYP)
- C=COEF/(MJ*TD)
-C
- X1=0.
- IF(T.GT.LITTLE) THEN
- DO N=1,N_MAX
- Z=FLOAT(N)
- X1=X1+EXP(-Z*A)*(A+1./Z)/Z
- ENDDO
- ENDIF
-C
- P1=1.+4.*(RZ2-X1)/(A*A)
- UJJ=C*P1/(A0*A0)
-C
-C 3D mean square displacement UJ_SQ
-C
- IF(IDCM.EQ.1) THEN
- UJ_SQ=(3.+FLOAT(I_FREE(JTYP))*(RSJ-1.))*UJJ
- ELSEIF(IDCM.EQ.2) THEN
- UJ_SQ=1.0E-20
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE DIRAN(VINT,ECIN,J_EL)
-C
-C This subroutine calculates the direction(s) of the analyzer with
-C or without an angular averaging.
-C
-C DIRANA is the internal direction
-C ANADIR is the external direction
-C
-C J_EL is the type of electron : 1 ---> photoelectron
-C 2 ---> Auger electron
-C
-C Last modified : 23/03/2006
-C
-C
- USE DIRECT_MOD
- USE DIRECT_A_MOD
- USE MOYEN_MOD
- USE MOYEN_A_MOD
- USE OUTUNITS_MOD
- USE TESTS_MOD , I1 => ITEST, I2 => ISORT1, N1 => NPATHP, I3 => ISO
- &M
- USE TYPCAL_MOD
- USE TYPCAL_A_MOD
-C
- COMPLEX COEF,IC
- DATA PI,PIS2,PIS180 /3.141593,1.570796,0.017453/
-C
- IC=(0.,1.)
-C
- IF(J_EL.EQ.1) THEN
- ANADIR(1,1)=SIN(RTHEXT)*COS(RPHI)
- ANADIR(2,1)=SIN(RTHEXT)*SIN(RPHI)
- ANADIR(3,1)=COS(RTHEXT)
- IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN
- CALL REFRAC(VINT,ECIN,RTHEXT,RTHINT)
- ELSE
- RTHINT=RTHEXT
- ENDIF
- IF((IPRINT.GT.0).AND.(I_EXT.NE.2)) THEN
- DTHEXT=RTHEXT/PIS180
- DTHINT=RTHINT/PIS180
- IF(I_TEST.NE.2) WRITE(IUO1,20) DTHEXT,DTHINT
- ENDIF
- DIRANA(1,1)=SIN(RTHINT)*COS(RPHI)
- DIRANA(2,1)=SIN(RTHINT)*SIN(RPHI)
- DIRANA(3,1)=COS(RTHINT)
- THETAR(1)=RTHINT
- PHIR(1)=RPHI
-C
-C The change in the definition below is necessary as RPHI is
-C used to define the rotation axis of the direction of the detector
-C when doing polar variations
-C
- IF(ITHETA.EQ.1) THEN
- IF(RPHI.GT.PIS2) THEN
- RTHEXT=-RTHEXT
- RPHI=RPHI-PI
- ELSEIF(RPHI.LT.-PIS2) THEN
- RTHEXT=-RTHEXT
- RPHI=RPHI+PI
- ENDIF
- ENDIF
-C
- IF(IMOY.GE.1) THEN
- N=2**(IMOY-1)
- S=SIN(ACCEPT*PI/180.)
- RN=FLOAT(N)
- J=1
- DO K1=-N,N
- RK1=FLOAT(K1)
- DO K2=-N,N
- RK2=FLOAT(K2)
- D=SQRT(RK1*RK1+RK2*RK2)
- IF((D-RN).GT.0.000001) GOTO 10
- IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 10
- C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S)
- J=J+1
-C
- ANADIR(1,J)=(RK1*S*COS(RTHEXT)*COS(RPHI) -RK2*S*SIN(RPHI)+
- &C*ANADIR(1,1))/RN
- ANADIR(2,J)=(RK1*S*COS(RTHEXT)*SIN(RPHI) +RK2*S*COS(RPHI)+
- &C*ANADIR(2,1))/RN
- ANADIR(3,J)=(-RK1*S*SIN(RTHEXT) +C*ANADIR(3,1))/RN
- THETA_R=ACOS(ANADIR(3,J))
- COEF=ANADIR(1,J)+IC*ANADIR(2,J)
- CALL ARCSIN(COEF,ANADIR(3,J),PHI_R)
- IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN
- CALL REFRAC(VINT,ECIN,THETA_R,THINT_R)
- ELSE
- THINT_R=THETA_R
- ENDIF
-C
- DIRANA(1,J)=SIN(THINT_R)*COS(PHI_R)
- DIRANA(2,J)=SIN(THINT_R)*SIN(PHI_R)
- DIRANA(3,J)=COS(THINT_R)
-C
- THETAR(J)=THINT_R
- PHIR(J)=PHI_R
- 10 CONTINUE
- ENDDO
- ENDDO
- ENDIF
-C
- ELSEIF(J_EL.EQ.2) THEN
- ANADIR_A(1,1)=SIN(RTHEXT_A)*COS(RPHI_A)
- ANADIR_A(2,1)=SIN(RTHEXT_A)*SIN(RPHI_A)
- ANADIR_A(3,1)=COS(RTHEXT_A)
- IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN
- CALL REFRAC(VINT,ECIN,RTHEXT_A,RTHINT_A)
- ELSE
- RTHINT_A=RTHEXT_A
- ENDIF
- IF((IPRINT.GT.0).AND.(I_EXT_A.NE.2)) THEN
- DTHEXT_A=RTHEXT_A/PIS180
- DTHINT_A=RTHINT_A/PIS180
- IF(I_TEST_A.NE.2) WRITE(IUO1,21) DTHEXT_A,DTHINT_A
- ENDIF
- DIRANA_A(1,1)=SIN(RTHINT_A)*COS(RPHI_A)
- DIRANA_A(2,1)=SIN(RTHINT_A)*SIN(RPHI_A)
- DIRANA_A(3,1)=COS(RTHINT_A)
- THETAR_A(1)=RTHINT_A
- PHIR_A(1)=RPHI_A
-C
-C The change in the definition below is necessary as RPHI is
-C used to define the rotation axis of the direction of the detector
-C when doing polar variations
-C
- IF(ITHETA_A.EQ.1) THEN
- IF(RPHI_A.GT.PIS2) THEN
- RTHEXT_A=-RTHEXT_A
- RPHI_A=RPHI_A-PI
- ELSEIF(RPHI_A.LT.-PIS2) THEN
- RTHEXT_A=-RTHEXT_A
- RPHI_A=RPHI_A+PI
- ENDIF
- ENDIF
-C
- IF(IMOY_A.GE.1) THEN
- N=2**(IMOY_A-1)
- S=SIN(ACCEPT_A*PI/180.)
- RN=FLOAT(N)
- J=1
- DO K1=-N,N
- RK1=FLOAT(K1)
- DO K2=-N,N
- RK2=FLOAT(K2)
- D=SQRT(RK1*RK1+RK2*RK2)
- IF((D-RN).GT.0.000001) GOTO 15
- IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 15
- C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S)
- J=J+1
-C
- ANADIR_A(1,J)=(RK1*S*COS(RTHEXT_A)*COS(RPHI_A) -RK2*S*SIN(
- &RPHI_A)+C*ANADIR_A(1,1))/RN
- ANADIR_A(2,J)=(RK1*S*COS(RTHEXT_A)*SIN(RPHI_A) +RK2*S*COS(
- &RPHI_A)+C*ANADIR_A(2,1))/RN
- ANADIR_A(3,J)=(-RK1*S*SIN(RTHEXT_A) +C*ANADIR_A(3,1))/RN
- THETA_R_A=ACOS(ANADIR_A(3,J))
- COEF=ANADIR_A(1,J)+IC*ANADIR_A(2,J)
- CALL ARCSIN(COEF,ANADIR_A(3,J),PHI_R_A)
- IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN
- CALL REFRAC(VINT,ECIN,THETA_R_A,THINT_R_A)
- ELSE
- THINT_R_A=THETA_R_A
- ENDIF
-C
- DIRANA_A(1,J)=SIN(THINT_R_A)*COS(PHI_R_A)
- DIRANA_A(2,J)=SIN(THINT_R_A)*SIN(PHI_R_A)
- DIRANA_A(3,J)=COS(THINT_R_A)
-C
- THETAR_A(J)=THINT_R_A
- PHIR_A(J)=PHI_R_A
- 15 CONTINUE
- ENDDO
- ENDDO
- ENDIF
-C
- ENDIF
-C
- 20 FORMAT(/,10X,'PHOTOELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T
- &HETA =', F7.2)
- 21 FORMAT(/,10X,'AUGER ELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T
- &HETA =', F7.2)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE REFRAC(VINT,EKIN,RTHETA,RTHINT)
-C
-C This routine calculates the refraction of a plane wave beam induced
-C by the surface potential barrier VINT. EKIN is the kinetic energy
-C outside the crystal.
-C
-C Last modified : 3 Dec 2008
-C
- DATA PIS180,SMALL /0.017453,0.001/
-C
- IF(VINT.LT.0.) VINT=ABS(VINT)
- IF(ABS(VINT).LT.SMALL) THEN
- RTHINT=RTHETA
- ELSE
- U=VINT/(EKIN+VINT)
- DTHETA=RTHETA/PIS180
- REFRA=SIN(RTHETA)*SIN(RTHETA)*(1.-U)
- RTHINT=ASIN(SQRT(REFRA))
- IF(DTHETA.LT.0.) THEN
- RTHINT=-RTHINT
- ENDIF
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL)
-C
-C This subroutine performs a weighted sum of the results
-C corresponding to different directions of the detector.
-C The directions and weights are read from an external input file
-C
-C JEL is the electron undetected (i.e. for which the outgoing
-C directions are integrated over the unit sphere). It is always
-C 1 for one electron spectroscopies (PHD). For APECS, It can be
-C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron
-C detected)
-C
-C Last modified : 31 Jan 2007
-C
- USE DIM_MOD
- USE INFILES_MOD
- USE INUNITS_MOD
- USE OUTUNITS_MOD
-C
-C
- PARAMETER(N_MAX=5810,NPM=20)
-C
- REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M)
- REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX)
- REAL*4 SR_1,SF_1,SR_2,SF_2
- REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX)
- REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX)
-C
- CHARACTER*3 SPECTRO,SPECTRO2
- CHARACTER*5 LIKE
- CHARACTER*13 OUTDATA
-C
-C
-C
-C
- DATA JVOL,JTOT/0,-1/
- DATA LIKE /'-like'/
-C
- REWIND IUO2
-C
- READ(IUO2,15) SPECTRO,OUTDATA
- IF(SPECTRO.NE.'APC') THEN
- READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
- READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
- SPECTRO2='XAS'
- ELSE
- READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
- READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I
- &THETA_A,IE_A
- READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
- READ(IUO2,8) NPHI_A,NTHETA_A
- IF(JEL.EQ.1) THEN
- SPECTRO2='AED'
- ELSEIF(JEL.EQ.2) THEN
- SPECTRO2='PHD'
- ELSEIF(JEL.EQ.0) THEN
- SPECTRO2='XAS'
- ENDIF
- ENDIF
-C
- IF(NPLAN.GT.NPM) THEN
- WRITE(IUO1,4) NPLAN+2
- STOP
- ENDIF
-C
-C Reading the number of angular points
-C
- IF(SPECTRO.NE.'APC') THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,1) N_POINTS
- READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
- N_POINTS_A=1
- ELSE
- IF(JEL.EQ.1) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,1) N_POINTS
- READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
- IF(I_EXT_A.EQ.0) THEN
- N_POINTS_A=NTHETA_A*NPHI_A
- ELSE
- OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
- READ(IUI9,1) N_POINTS_A
- READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
- ENDIF
- NTHETA0=NTHETA_A
- NPHI0=NPHI_A
- ELSEIF(JEL.EQ.2) THEN
- OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
- READ(IUI9,1) N_POINTS_A
- READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
- IF(I_EXT.EQ.0) THEN
- N_POINTS=NTHETA*NPHI
- ELSE
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,1) N_POINTS
- READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
- ENDIF
- NTHETA0=NTHETA
- NPHI0=NPHI
- ELSEIF(JEL.EQ.0) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
- READ(IUI6,1) N_POINTS
- READ(IUI9,1) N_POINTS_A
- READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
- READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
- ENDIF
- ENDIF
-C
- IF(SPECTRO.NE.'APC') THEN
- NANGLE=1
- ELSE
- IF(JEL.EQ.1) THEN
- NANGLE=N_POINTS_A
- ELSEIF(JEL.EQ.2) THEN
- NANGLE=N_POINTS
- ELSEIF(JEL.EQ.0) THEN
- NANGLE=1
- ENDIF
- ENDIF
-C
-C Initialization of the arrays
-C
- DO JE=1,NE
- DO JANGLE=1,NANGLE
- DO JPLAN=1,NPLAN+2
- SUMR_1(JPLAN,JE,JANGLE)=0.
- SUMF_1(JPLAN,JE,JANGLE)=0.
- IF(IDICHR.GT.0) THEN
- SUMR_2(JPLAN,JE,JANGLE)=0.
- SUMF_2(JPLAN,JE,JANGLE)=0.
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-C
-C Reading of the data to be angle integrated
-C
- DO JE=1,NE
-C
- DO JANGLE=1,N_POINTS
- IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE)
- DO JANGLE_A=1,N_POINTS_A
- IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN
- READ(IUI9,2) THA,PHA,W_A(JANGLE_A)
- ENDIF
-C
- DO JPLAN=1,NPLAN+2
-C
- IF(IDICHR.EQ.0) THEN
- IF(SPECTRO.NE.'APC') THEN
- READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE)
- &,SR_1,SF_1
- ELSE
- READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
- &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1
- ENDIF
- ELSE
- IF(SPECTRO.NE.'APC') THEN
- READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
- &),SR_1,SF_1,SR_2,SF_2
- ELSE
- READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
- &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2
- ENDIF
- ENDIF
-C
- IF(JEL.EQ.1) THEN
- SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1
- &*W(JANGLE)
- SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1
- &*W(JANGLE)
- ELSEIF(JEL.EQ.2) THEN
- SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A
- &(JANGLE_A)
- SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A
- &(JANGLE_A)
- ELSEIF(JEL.EQ.0) THEN
- SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A
- &(JANGLE_A)
- SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A
- &(JANGLE_A)
- ENDIF
- IF(IDICHR.GT.0) THEN
- IF(JEL.EQ.1) THEN
- SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR
- &_2*W(JANGLE)
- SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF
- &_2*W(JANGLE)
- ELSEIF(JEL.EQ.2) THEN
- SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W
- &_A(JANGLE_A)
- SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W
- &_A(JANGLE_A)
- ELSEIF(JEL.EQ.0) THEN
- SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W
- &_A(JANGLE_A)
- SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W
- &_A(JANGLE_A)
- ENDIF
- ENDIF
-C
- ENDDO
-C
- ENDDO
- IF(I_EXT_A.NE.0) THEN
- REWIND IUI9
- READ(IUI9,1) NDUM
- READ(IUI9,1) NDUM
- ENDIF
- ENDDO
-C
- IF(I_EXT.NE.0) THEN
- REWIND IUI6
- READ(IUI6,1) NDUM
- READ(IUI6,1) NDUM
- ENDIF
- ENDDO
-C
- CLOSE(IUI6)
- CLOSE(IUI9)
- REWIND IUO2
-C
- WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA
- IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
- WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP
- WRITE(IUO2,18) NE,NPLAN,ISOM
- ELSEIF(JEL.EQ.1) THEN
- WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A
- &,ITHETA_A,IE_A
- WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
- ELSEIF(JEL.EQ.2) THEN
- WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
- WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
- ENDIF
-C
- DO JE=1,NE
- DO JANGLE=1,NANGLE
- IF(SPECTRO.EQ.'APC') THEN
- IF(JEL.EQ.1) THEN
- THETA=DTHETAA(JANGLE)
- PHI=DPHIA(JANGLE)
- ELSEIF(JEL.EQ.2) THEN
- THETA=DTHETA(JANGLE)
- PHI=DPHI(JANGLE)
- ENDIF
- ENDIF
-C
- DO JPLAN=1,NPLAN
- IF(IDICHR.EQ.0) THEN
- IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
- WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
- &MF_1(JPLAN,JE,JANGLE)
- ELSE
- WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
- &JANGLE),SUMF_1(JPLAN,JE,JANGLE)
- ENDIF
- ELSE
- IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
- WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
- &MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG
- &LE)
- ELSE
- WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
- &JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL
- &AN,JE,JANGLE)
- ENDIF
- ENDIF
- ENDDO
-C
- IF(IDICHR.EQ.0) THEN
- IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
- WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
- &F_1(NPLAN+1,JE,JANGLE)
- WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
- &F_1(NPLAN+2,JE,JANGLE)
- ELSE
- WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
- &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE)
- WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
- &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE)
- ENDIF
- ELSE
- IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
- WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
- &F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE
- &,JANGLE)
- WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
- &F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE
- &,JANGLE)
- ELSE
- WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
- &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(
- &NPLAN+1,JE,JANGLE)
- WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
- &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(
- &NPLAN+2,JE,JANGLE)
- ENDIF
- ENDIF
-C
- ENDDO
- ENDDO
-C
- 1 FORMAT(13X,I4)
- 2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6)
- 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
- 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
- &THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>')
- 5 FORMAT(6X,I1,1X,I3,3X,I3)
- 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
- 9 FORMAT(9(2X,I1),2X,I2)
- 13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
- &12.6)
- 15 FORMAT(2X,A3,11X,A13)
- 16 FORMAT(2X,A3,A5,1X,A3,2X,A13)
- 18 FORMAT(I4,2X,I3,2X,I1)
- 19 FORMAT(4(2X,I1))
- 20 FORMAT(8(2X,I1))
- 21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
- 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
- &,E12.6)
- 24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
- &12.6,2X,E12.6,2X,E12.6)
- 33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6)
- 34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
- 43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
- 44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
- &,E12.6)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
-C
-C This routine recomputes the T-matrix elements taking into account the
-C mean square displacements.
-C
-C When the argument X is tiny, no vibrations are taken into account
-C
-C Last modified : 25 Apr 2013
-C
- USE DIM_MOD
-C
- USE TRANS_MOD
-C
- DIMENSION GNT(0:N_GAUNT)
-C
- COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC
-C
- COMPLEX*16 FFL(0:2*NL_M)
-C
- DATA PI4,EPS /12.566371,1.0E-10/
-C
- ZEROC=(0.,0.)
-C
- IF(X.GT.EPS) THEN
-C
-C Standard case: vibrations
-C
- IF(ISPEED.LT.0) THEN
- NSUM_LB=ABS(ISPEED)
- ENDIF
-C
- COEF=PI4*EXP(-X)
- NL2=2*LMAX(JTYP,JE)+2
- IBESP=5
- MG1=0
- MG2=0
-C
- CALL BESPHE(NL2,IBESP,X,FFL)
-C
- DO L=0,LMAX(JTYP,JE)
- XL=FLOAT(L+L+1)
- SL1=ZEROC
-C
- DO L1=0,LMAX(JTYP,JE)
- XL1=FLOAT(L1+L1+1)
- CALL GAUNT(L,MG1,L1,MG2,GNT)
- L2MIN=ABS(L1-L)
- IF(ISPEED.GE.0) THEN
- L2MAX=L1+L
- ELSEIF(ISPEED.LT.0) THEN
- L2MAX=L2MIN+2*(NSUM_LB-1)
- ENDIF
- SL2=0.
-C
- DO L2=L2MIN,L2MAX,2
- XL2=FLOAT(L2+L2+1)
- C=SQRT(XL1*XL2/(PI4*XL))
- SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2)))
- ENDDO
-C
- SL1=SL1+SL2*TL(L1,1,JTYP,JE)
- ENDDO
-C
- TLT(L,1,JTYP,JE)=COEF*SL1
-C
- ENDDO
-C
- ELSE
-C
-C Argument X tiny: no vibrations
-C
- DO L=0,LMAX(JTYP,JE)
-C
- TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE)
-C
- ENDDO
-C
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J
- &E,*)
-C
-C This routine computes a spherical wave scattering factor
-C
-C Last modified : 03/04/2006
-C
- USE DIM_MOD
- USE APPROX_MOD
- USE EXPFAC_MOD
- USE TRANS_MOD
- USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I
- &6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
-C
- DIMENSION PLMM(0:100,0:100)
- DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
-C
- COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
- COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
- COMPLEX RHOJK
-C
-C
- DATA PI/3.141593/
-C
- A=1.
- INTER=0
- IF(ITL.EQ.1) VKE=VK(JE)
- RHOJ=VKE*RJ
- RHOJK=VKE*RJK
- HLM1=(1.,0.)
- HLM2=(1.,0.)
- HLM3=(1.,0.)
- HLM4=(1.,0.)
- IEM=1
- CSTH=COS(BETA)
- IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN
- INTER=1
- BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI))
- ENDIF
- CALL PLM(CSTH,PLMM,LMAX(JAT,JE))
- IF(ISPHER.EQ.0) NO1=0
- IF(ISPHER.EQ.1) THEN
- IF(NO.EQ.8) THEN
- NO1=LMAX(JAT,JE)+1
- ELSE
- NO1=NO
- ENDIF
- CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM)
- IF(IEM.EQ.0) THEN
- HLM4=HLM(0,L)
- ENDIF
- IF(RJK.GT.0.0001) THEN
- NDUM=0
- CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN)
- ENDIF
- CALL DJMN(THRJ,D,L)
- A1=ABS(D(0,M,L))
- IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1
- &
- ENDIF
- MUMAX=MIN0(L,NO1)
- SMU=(0.,0.)
- DO 10 MU=0,MUMAX
- IF(MOD(MU,2).EQ.0) THEN
- B=1.
- ELSE
- B=-1.
- IF(SIN(BETA).LT.0.) THEN
- A=-1.
- ENDIF
- ENDIF
- IF(ISPHER.LE.1) THEN
- ALMU=(1.,0.)
- C=1.
- ENDIF
- IF(ISPHER.EQ.0) GOTO 40
- IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L))
- IF(MU.GT.0) THEN
- C=B*FLOAT(L+L+1)/EXPF(MU,L)
- ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B*
- * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU
- ELSE
- C=1.
- ALMU=CMPLX(D(M,0,L))/BLMU
- ENDIF
- 40 SNU=(0.,0.)
- NU1=INT(0.5*(NO1-MU)+0.0001)
- NUMAX=MIN0(NU1,L-MU)
- DO 20 NU=0,NUMAX
- SLP=(0.,0.)
- LPMIN=MAX0(MU,NU)
- DO 30 LP=LPMIN,LMAX(JAT,JE)
- IF(ISPHER.EQ.1) THEN
- HLM1=HLM(NU,LP)
- IF(RJK.GT.0.0001) HLM3=HLN(0,LP)
- ENDIF
- SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3
- 30 CONTINUE
- IF(ISPHER.EQ.1) THEN
- HLM2=HLM(MU+NU,L)
- ENDIF
- SNU=SNU+SLP*HLM2
- 20 CONTINUE
- SMU=SMU+SNU*C*ALMU*A*B
- 10 CONTINUE
- FSPH=SMU/(VKE*HLM4)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE FACDIF(COSTH,JAT,JE,FTHETA)
-C
-C This routine computes the plane wave scattering factor
-C
- USE DIM_MOD
-C
- USE TRANS_MOD
-C
- DIMENSION PL(0:100)
-C
- COMPLEX FTHETA
-C
- FTHETA=(0.,0.)
- NL=LMAX(JAT,JE)+1
- CALL POLLEG(NL,COSTH,PL)
- DO 20 L=0,NL-1
- FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L)
- 20 CONTINUE
- FTHETA=FTHETA/VK(JE)
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
-C
-C This routine prepares the output for a plot of the scattering factor
-C
- USE DIM_MOD
-C
- USE APPROX_MOD
- USE FDIF_MOD
- USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 =>
- & LF2, I10 => ISTEP_LF
- USE INIT_J_MOD
- USE OUTFILES_MOD
- USE OUTUNITS_MOD
- USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
- USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP
- &, I13 => I_EXT, I14 => I_TEST
- USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO
- &L
- USE VALFIN_MOD
-C
-C
-C
- DIMENSION LMX(NATM,NE_M)
-C
- COMPLEX FSPH,VKE
-C
-C
-C
- DATA PI,CONV/3.141593,0.512314/
-C
- OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
- IF(ISPHER.EQ.0) THEN
- L=0
- LMAX=0
- ELSE
- LMAX=L
- ENDIF
- PHITOT=360.
- THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
- NPHI=(NFTHET+1)*IPHI+(1-IPHI)
- NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
- * (1-ITHETA)
- NE=NFTHET*IE + (1-IE)
- WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
- DO 10 JT=1,NTHT
- DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
- RTHETA=DTHETA*PI/180.
- TEST=SIN(RTHETA)
- IF(TEST.GE.0.) THEN
- POZ=PI
- EPS=1.
- ELSE
- POZ=0.
- EPS=-1.
- ENDIF
- BETA=RTHETA*EPS
- IF(ABS(TEST).LT.0.0001) THEN
- NPHIM=1
- ELSE
- NPHIM=NPHI
- ENDIF
- DO 20 JP=1,NPHIM
- DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
- RPHI=DPHI*PI/180.
- GAMMA=POZ-RPHI
- DO 30 JE=1,NE
- IF(NE.EQ.1) THEN
- ECIN=E0
- ELSE
- ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
- ENDIF
- IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
- DO 40 JAT=1,NAT
- IF(L.GT.LMX(JAT,JE)) GOTO 90
- DO 50 M=-LMAX,LMAX
- CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J
- &AT,JE,*60)
- GOTO 70
- 60 WRITE(IUO1,80)
- STOP
- 70 REFTH=REAL(FSPH)
- XIMFTH=AIMAG(FSPH)
- WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN
- 50 CONTINUE
- GOTO 40
- 90 WRITE(IUO1,100) JAT
- STOP
- 40 CONTINUE
- 30 CONTINUE
- 20 CONTINUE
- 10 CONTINUE
- CLOSE(IUO3)
- 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
- 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X,
- &F8.2)
- 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z
- &ERO >>>>>')
- 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : '
- &,I2,' >>>>>')
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE FINDPATHS(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIMI
- &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
-C
-C This routine generates all the paths and filters them according to the
-C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
-C It corresponds to the spin-independent case from a non spin-orbit
-C resolved initial core state LI
-C
-C Last modified : 16 May 2007
-C
- USE DIM_MOD
-C
- USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
- USE COOR_MOD
- USE DEBWAL_MOD
- USE INIT_L_MOD
- USE PATH_MOD
- USE ROT_MOD
- USE TESTPA_MOD
- USE TESTPB_MOD
- USE TRANS_MOD
- USE TLDW_MOD
- USE VARIA_MOD
-C
- DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
- DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
-C
-C
-C
- COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
- COMPLEX IC,COMPL1,PW(0:NDIF_M)
- COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
- COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
- COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
-C
- DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
-C
- IC=(0.,1.)
- IEULER=1
-C
- IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
- IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
-C
-C I_CP = 0 : all open paths generated
-C I_CP = 1 : only closed paths generated
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO JTYP=1,N_TYP
- IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
- IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
- ND=ND+1
-C
-C I_ABS = 0 : the atom before the scatterer is not the absorber
-C I_ABS = 1 : the atom before the scatterer is the absorber
-C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
-C
- IF(ND.EQ.1) THEN
- I_ABS=1
- ELSE
- I_ABS=0
- ENDIF
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPJ=NATYP(JTYP)
- ELSE
- NBTYPJ=1
- ENDIF
-C
- DO JNUM=1,NBTYPJ
- JATL=NCORR(JNUM,JTYP)
- IF(JATL.EQ.IATL) GOTO 12
- XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
- YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
- ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- JPOS(ND,1)=JTYP
- JPOS(ND,2)=JNUM
- JPOS(ND,3)=JATL
- NPATH(ND)=NPATH(ND)+1.
- IF(ND.GT.1) THEN
- COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
- &R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(ITYP).EQ.0) THEN
- IF(COSTHMIJ.LT.COSFWDI) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(ITYP).EQ.1) THEN
- IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- RHOIJ=VK(JE)*R(ND)
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1.) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THIJ=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
- IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
- ZSURFI=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(ITYP)=SIG2(R(ND-1),ITYP)
- ENDIF
- IF(ABS(ZSURFI).LE.SMALL) THEN
- IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
- CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
- &STHMIJ)
- ELSE
- CSKZ2I=1.
- ENDIF
- UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
- ELSE
- UII=UJ2(ITYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UI2=VK2(JE)*UII
- CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
- ENDIF
- 40 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
- ENDIF
- ENDIF
- IF(ND.EQ.1) THEN
- RHO01=RHOIJ
- TH01=THIJ
- PHI01=PHIIJ
- CALL DJMN2(TH01,RLM01,LF2,2)
- GOTO 30
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- LMJ=LMAX(ITYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
- CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
- CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
- &BMIJ,CMIJ,RHOMI,RHOIJ)
- 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
- &REF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 42
- I_ABS=0
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO KTYP=1,N_TYP
- ND=ND+1
- IF(ND.GT.NDIF) GOTO 20
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPK=NATYP(KTYP)
- ELSE
- NBTYPK=1
- ENDIF
-C
- DO KNUM=1,NBTYPK
- KATL=NCORR(KNUM,KTYP)
- IF(KATL.EQ.JATL) GOTO 22
- JPOS(ND,1)=KTYP
- JPOS(ND,2)=KNUM
- JPOS(ND,3)=KATL
- XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
- YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
- ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF(IT(ND-1).EQ.1) GOTO 32
- RHOJK=R(ND)*VK(JE)
- NPATH(ND)=NPATH(ND)+1.
- COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
- &/(R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(JTYP).EQ.0) THEN
- IF(COSTHIJK.LT.COSFWDJ) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(JTYP).EQ.1) THEN
- IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
- &EN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF(IT(ND-1).EQ.1) GOTO 32
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THJK=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- IF(ND-1.LT.NDIF) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
- ZSURFJ=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(JTYP)=SIG2(R(ND-1),JTYP)
- ENDIF
- IF(ABS(ZSURFJ).LE.SMALL) THEN
- IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
- CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
- &.*COSTHIJK)
- ELSE
- CSKZ2J=1.
- ENDIF
- UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
- ELSE
- UJJ=UJ2(JTYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UJ2=VK2(JE)*UJJ
- CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
- ENDIF
- 50 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
- ENDIF
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- LMJ=LMAX(JTYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
- & IT(ND)=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
- IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- ENDIF
- CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
- &IJK,BIJK,CIJK,RHOIJ,RHOJK)
- CEX(ND)=CEXP(IC*RHOJK)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
- &JK,FREF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 32
- CALL FINDPATHS2(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
- &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
- 32 DIJ=DIJ-R(ND)
- 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDDO
- 20 CONTINUE
- ND=ND-1
- ENDDO
- 42 DIJ=DIJ-R(ND)
- 12 IF(ND.GT.1) THEN
- IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDIF
- ENDDO
- ND=ND-1
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE FINDPATHS2(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
- &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
-C
-C This routine generates all the paths and filters them according to the
-C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
-C It corresponds to the spin-independent case from a non spin-orbit
-C resolved initial core state LI
-C
-C Last modified : 16 May 2007
-C
- USE DIM_MOD
-C
- USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
- USE COOR_MOD
- USE DEBWAL_MOD
- USE INIT_L_MOD
- USE PATH_MOD
- USE ROT_MOD
- USE TESTPA_MOD
- USE TESTPB_MOD
- USE TRANS_MOD
- USE TLDW_MOD
- USE VARIA_MOD
-C
- COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
- COMPLEX IC,COMPL1,PW(0:NDIF_M)
- COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
- COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
- COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
-C
- DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
- DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
-C
-C
-C
- DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
-C
- IC=(0.,1.)
- IEULER=1
-C
- IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
- IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
-C
-C I_CP = 0 : all open paths generated
-C I_CP = 1 : only closed paths generated
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO JTYP=1,N_TYP
- IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
- IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
- ND=ND+1
-C
-C I_ABS = 0 : the atom before the scatterer is not the absorber
-C I_ABS = 1 : the atom before the scatterer is the absorber
-C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
-C
- IF(ND.EQ.1) THEN
- I_ABS=1
- ELSE
- I_ABS=0
- ENDIF
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPJ=NATYP(JTYP)
- ELSE
- NBTYPJ=1
- ENDIF
-C
- DO JNUM=1,NBTYPJ
- JATL=NCORR(JNUM,JTYP)
- IF(JATL.EQ.IATL) GOTO 12
- XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
- YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
- ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- JPOS(ND,1)=JTYP
- JPOS(ND,2)=JNUM
- JPOS(ND,3)=JATL
- NPATH(ND)=NPATH(ND)+1.
- IF(ND.GT.1) THEN
- COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
- &R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(ITYP).EQ.0) THEN
- IF(COSTHMIJ.LT.COSFWDI) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(ITYP).EQ.1) THEN
- IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- RHOIJ=VK(JE)*R(ND)
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1.) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THIJ=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
- IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
- ZSURFI=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(ITYP)=SIG2(R(ND-1),ITYP)
- ENDIF
- IF(ABS(ZSURFI).LE.SMALL) THEN
- IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
- CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
- &STHMIJ)
- ELSE
- CSKZ2I=1.
- ENDIF
- UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
- ELSE
- UII=UJ2(ITYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UI2=VK2(JE)*UII
- CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
- ENDIF
- 40 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
- ENDIF
- ENDIF
- IF(ND.EQ.1) THEN
- RHO01=RHOIJ
- TH01=THIJ
- PHI01=PHIIJ
- CALL DJMN2(TH01,RLM01,LF2,2)
- GOTO 30
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- LMJ=LMAX(ITYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
- CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
- &BMIJ,CMIJ,RHOMI,RHOIJ)
- 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
- &REF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 42
- I_ABS=0
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO KTYP=1,N_TYP
- ND=ND+1
- IF(ND.GT.NDIF) GOTO 20
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPK=NATYP(KTYP)
- ELSE
- NBTYPK=1
- ENDIF
-C
- DO KNUM=1,NBTYPK
- KATL=NCORR(KNUM,KTYP)
- IF(KATL.EQ.JATL) GOTO 22
- JPOS(ND,1)=KTYP
- JPOS(ND,2)=KNUM
- JPOS(ND,3)=KATL
- XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
- YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
- ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF(IT(ND-1).EQ.1) GOTO 32
- RHOJK=R(ND)*VK(JE)
- NPATH(ND)=NPATH(ND)+1.
- COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
- &/(R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(JTYP).EQ.0) THEN
- IF(COSTHIJK.LT.COSFWDJ) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(JTYP).EQ.1) THEN
- IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
- &EN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF(IT(ND-1).EQ.1) GOTO 32
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THJK=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- IF(ND-1.LT.NDIF) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
- ZSURFJ=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(JTYP)=SIG2(R(ND-1),JTYP)
- ENDIF
- IF(ABS(ZSURFJ).LE.SMALL) THEN
- IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
- CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
- &.*COSTHIJK)
- ELSE
- CSKZ2J=1.
- ENDIF
- UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
- ELSE
- UJJ=UJ2(JTYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UJ2=VK2(JE)*UJJ
- CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
- ENDIF
- 50 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
- ENDIF
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- LMJ=LMAX(JTYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
- &=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
- IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- ENDIF
- CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
- &IJK,BIJK,CIJK,RHOIJ,RHOJK)
- CEX(ND)=CEXP(IC*RHOJK)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
- &JK,FREF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 32
- CALL FINDPATHS3(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
- &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
- 32 DIJ=DIJ-R(ND)
- 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDDO
- 20 CONTINUE
- ND=ND-1
- ENDDO
- 42 DIJ=DIJ-R(ND)
- 12 IF(ND.GT.1) THEN
- IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDIF
- ENDDO
- ND=ND-1
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE FINDPATHS3(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
- &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
-C
-C This routine generates all the paths and filters them according to the
-C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
-C It corresponds to the spin-independent case from a non spin-orbit
-C resolved initial core state LI
-C
-C Last modified : 16 May 2007
-C
- USE DIM_MOD
-C
- USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
- USE COOR_MOD
- USE DEBWAL_MOD
- USE INIT_L_MOD
- USE PATH_MOD
- USE ROT_MOD
- USE TESTPA_MOD
- USE TESTPB_MOD
- USE TRANS_MOD
- USE TLDW_MOD
- USE VARIA_MOD
-C
- DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
- DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
-C
-C
-C
- COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
- COMPLEX IC,COMPL1,PW(0:NDIF_M)
- COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
- COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
- COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
-C
- DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
-C
- IC=(0.,1.)
- IEULER=1
-C
- IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
- IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
-C
-C I_CP = 0 : all open paths generated
-C I_CP = 1 : only closed paths generated
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO JTYP=1,N_TYP
- IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
- IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
- ND=ND+1
-C
-C I_ABS = 0 : the atom before the scatterer is not the absorber
-C I_ABS = 1 : the atom before the scatterer is the absorber
-C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
-C
- IF(ND.EQ.1) THEN
- I_ABS=1
- ELSE
- I_ABS=0
- ENDIF
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPJ=NATYP(JTYP)
- ELSE
- NBTYPJ=1
- ENDIF
-C
- DO JNUM=1,NBTYPJ
- JATL=NCORR(JNUM,JTYP)
- IF(JATL.EQ.IATL) GOTO 12
- XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
- YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
- ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- JPOS(ND,1)=JTYP
- JPOS(ND,2)=JNUM
- JPOS(ND,3)=JATL
- NPATH(ND)=NPATH(ND)+1.
- IF(ND.GT.1) THEN
- COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
- &R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(ITYP).EQ.0) THEN
- IF(COSTHMIJ.LT.COSFWDI) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(ITYP).EQ.1) THEN
- IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- RHOIJ=VK(JE)*R(ND)
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1.) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THIJ=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
- IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
- ZSURFI=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(ITYP)=SIG2(R(ND-1),ITYP)
- ENDIF
- IF(ABS(ZSURFI).LE.SMALL) THEN
- IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
- CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
- &STHMIJ)
- ELSE
- CSKZ2I=1.
- ENDIF
- UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
- ELSE
- UII=UJ2(ITYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UI2=VK2(JE)*UII
- CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
- ENDIF
- 40 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
- ENDIF
- ENDIF
- IF(ND.EQ.1) THEN
- RHO01=RHOIJ
- TH01=THIJ
- PHI01=PHIIJ
- CALL DJMN2(TH01,RLM01,LF2,2)
- GOTO 30
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- LMJ=LMAX(ITYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
- CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
- &BMIJ,CMIJ,RHOMI,RHOIJ)
- 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
- &REF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 42
- I_ABS=0
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO KTYP=1,N_TYP
- ND=ND+1
- IF(ND.GT.NDIF) GOTO 20
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPK=NATYP(KTYP)
- ELSE
- NBTYPK=1
- ENDIF
-C
- DO KNUM=1,NBTYPK
- KATL=NCORR(KNUM,KTYP)
- IF(KATL.EQ.JATL) GOTO 22
- JPOS(ND,1)=KTYP
- JPOS(ND,2)=KNUM
- JPOS(ND,3)=KATL
- XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
- YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
- ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF(IT(ND-1).EQ.1) GOTO 32
- RHOJK=R(ND)*VK(JE)
- NPATH(ND)=NPATH(ND)+1.
- COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
- &/(R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(JTYP).EQ.0) THEN
- IF(COSTHIJK.LT.COSFWDJ) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(JTYP).EQ.1) THEN
- IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
- &EN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF(IT(ND-1).EQ.1) GOTO 32
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THJK=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- IF(ND-1.LT.NDIF) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
- ZSURFJ=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(JTYP)=SIG2(R(ND-1),JTYP)
- ENDIF
- IF(ABS(ZSURFJ).LE.SMALL) THEN
- IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
- CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
- &.*COSTHIJK)
- ELSE
- CSKZ2J=1.
- ENDIF
- UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
- ELSE
- UJJ=UJ2(JTYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UJ2=VK2(JE)*UJJ
- CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
- ENDIF
- 50 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
- ENDIF
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- LMJ=LMAX(JTYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
- &=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
- IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- ENDIF
- CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
- &IJK,BIJK,CIJK,RHOIJ,RHOJK)
- CEX(ND)=CEXP(IC*RHOJK)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
- &JK,FREF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 32
- CALL FINDPATHS4(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
- &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
- 32 DIJ=DIJ-R(ND)
- 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDDO
- 20 CONTINUE
- ND=ND-1
- ENDDO
- 42 DIJ=DIJ-R(ND)
- 12 IF(ND.GT.1) THEN
- IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDIF
- ENDDO
- ND=ND-1
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE FINDPATHS4(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
- &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
-C
-C This routine generates all the paths and filters them according to the
-C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
-C It corresponds to the spin-independent case from a non spin-orbit
-C resolved initial core state LI
-C
-C Last modified : 16 May 2007
-C
- USE DIM_MOD
-C
- USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
- USE COOR_MOD
- USE DEBWAL_MOD
- USE INIT_L_MOD
- USE PATH_MOD
- USE ROT_MOD
- USE TESTPA_MOD
- USE TESTPB_MOD
- USE TRANS_MOD
- USE TLDW_MOD
- USE VARIA_MOD
-C
- DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
- DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
-C
-C
-C
- COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
- COMPLEX IC,COMPL1,PW(0:NDIF_M)
- COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
- COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
- COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
-C
- DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
-C
- IC=(0.,1.)
- IEULER=1
-C
- IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
- IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
-C
-C I_CP = 0 : all open paths generated
-C I_CP = 1 : only closed paths generated
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO JTYP=1,N_TYP
- IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
- IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
- ND=ND+1
-C
-C I_ABS = 0 : the atom before the scatterer is not the absorber
-C I_ABS = 1 : the atom before the scatterer is the absorber
-C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
-C
- IF(ND.EQ.1) THEN
- I_ABS=1
- ELSE
- I_ABS=0
- ENDIF
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPJ=NATYP(JTYP)
- ELSE
- NBTYPJ=1
- ENDIF
-C
- DO JNUM=1,NBTYPJ
- JATL=NCORR(JNUM,JTYP)
- IF(JATL.EQ.IATL) GOTO 12
- XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
- YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
- ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- JPOS(ND,1)=JTYP
- JPOS(ND,2)=JNUM
- JPOS(ND,3)=JATL
- NPATH(ND)=NPATH(ND)+1.
- IF(ND.GT.1) THEN
- COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
- &R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(ITYP).EQ.0) THEN
- IF(COSTHMIJ.LT.COSFWDI) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(ITYP).EQ.1) THEN
- IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- RHOIJ=VK(JE)*R(ND)
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1.) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THIJ=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
- IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
- ZSURFI=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(ITYP)=SIG2(R(ND-1),ITYP)
- ENDIF
- IF(ABS(ZSURFI).LE.SMALL) THEN
- IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
- CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
- &STHMIJ)
- ELSE
- CSKZ2I=1.
- ENDIF
- UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
- ELSE
- UII=UJ2(ITYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UI2=VK2(JE)*UII
- CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
- ENDIF
- 40 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
- ENDIF
- ENDIF
- IF(ND.EQ.1) THEN
- RHO01=RHOIJ
- TH01=THIJ
- PHI01=PHIIJ
- CALL DJMN2(TH01,RLM01,LF2,2)
- GOTO 30
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- LMJ=LMAX(ITYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
- CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
- &BMIJ,CMIJ,RHOMI,RHOIJ)
- 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
- &REF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 42
- I_ABS=0
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO KTYP=1,N_TYP
- ND=ND+1
- IF(ND.GT.NDIF) GOTO 20
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPK=NATYP(KTYP)
- ELSE
- NBTYPK=1
- ENDIF
-C
- DO KNUM=1,NBTYPK
- KATL=NCORR(KNUM,KTYP)
- IF(KATL.EQ.JATL) GOTO 22
- JPOS(ND,1)=KTYP
- JPOS(ND,2)=KNUM
- JPOS(ND,3)=KATL
- XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
- YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
- ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF(IT(ND-1).EQ.1) GOTO 32
- RHOJK=R(ND)*VK(JE)
- NPATH(ND)=NPATH(ND)+1.
- COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
- &/(R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(JTYP).EQ.0) THEN
- IF(COSTHIJK.LT.COSFWDJ) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(JTYP).EQ.1) THEN
- IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
- &EN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF(IT(ND-1).EQ.1) GOTO 32
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THJK=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- IF(ND-1.LT.NDIF) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
- ZSURFJ=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(JTYP)=SIG2(R(ND-1),JTYP)
- ENDIF
- IF(ABS(ZSURFJ).LE.SMALL) THEN
- IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
- CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
- &.*COSTHIJK)
- ELSE
- CSKZ2J=1.
- ENDIF
- UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
- ELSE
- UJJ=UJ2(JTYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UJ2=VK2(JE)*UJJ
- CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
- ENDIF
- 50 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
- ENDIF
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- LMJ=LMAX(JTYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
- &=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
- IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- ENDIF
- CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
- &IJK,BIJK,CIJK,RHOIJ,RHOJK)
- CEX(ND)=CEXP(IC*RHOJK)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
- &JK,FREF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 32
- CALL FINDPATHS5(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
- &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
- 32 DIJ=DIJ-R(ND)
- 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDDO
- 20 CONTINUE
- ND=ND-1
- ENDDO
- 42 DIJ=DIJ-R(ND)
- 12 IF(ND.GT.1) THEN
- IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDIF
- ENDDO
- ND=ND-1
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE FINDPATHS5(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
- &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
-C
-C This routine generates all the paths and filters them according to the
-C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
-C It corresponds to the spin-independent case from a non spin-orbit
-C resolved initial core state LI
-C
-C Last modified : 16 May 2007
-C
- USE DIM_MOD
-C
- USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
- USE COOR_MOD
- USE DEBWAL_MOD
- USE INIT_L_MOD
- USE PATH_MOD
- USE ROT_MOD
- USE TESTPA_MOD
- USE TESTPB_MOD
- USE TRANS_MOD
- USE TLDW_MOD
- USE VARIA_MOD
-C
- DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
- DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
-C
-C
-C
- COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
- COMPLEX IC,COMPL1,PW(0:NDIF_M)
- COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
- COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
- COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
-C
- DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
-C
- IC=(0.,1.)
- IEULER=1
-C
- IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
- IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
-C
-C I_CP = 0 : all open paths generated
-C I_CP = 1 : only closed paths generated
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO JTYP=1,N_TYP
- IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
- IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
- ND=ND+1
-C
-C I_ABS = 0 : the atom before the scatterer is not the absorber
-C I_ABS = 1 : the atom before the scatterer is the absorber
-C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
-C
- IF(ND.EQ.1) THEN
- I_ABS=1
- ELSE
- I_ABS=0
- ENDIF
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPJ=NATYP(JTYP)
- ELSE
- NBTYPJ=1
- ENDIF
-C
- DO JNUM=1,NBTYPJ
- JATL=NCORR(JNUM,JTYP)
- IF(JATL.EQ.IATL) GOTO 12
- XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
- YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
- ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- JPOS(ND,1)=JTYP
- JPOS(ND,2)=JNUM
- JPOS(ND,3)=JATL
- NPATH(ND)=NPATH(ND)+1.
- IF(ND.GT.1) THEN
- COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
- &R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(ITYP).EQ.0) THEN
- IF(COSTHMIJ.LT.COSFWDI) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(ITYP).EQ.1) THEN
- IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
- RHOIJ=VK(JE)*R(ND)
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1.) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THIJ=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
- IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
- ZSURFI=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(ITYP)=SIG2(R(ND-1),ITYP)
- ENDIF
- IF(ABS(ZSURFI).LE.SMALL) THEN
- IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
- CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
- &STHMIJ)
- ELSE
- CSKZ2I=1.
- ENDIF
- UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
- ELSE
- UII=UJ2(ITYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UI2=VK2(JE)*UII
- CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
- ENDIF
- 40 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
- ENDIF
- ENDIF
- IF(ND.EQ.1) THEN
- RHO01=RHOIJ
- TH01=THIJ
- PHI01=PHIIJ
- CALL DJMN2(TH01,RLM01,LF2,2)
- GOTO 30
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- LMJ=LMAX(ITYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
- CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
- &BMIJ,CMIJ,RHOMI,RHOIJ)
- 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
- &REF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 42
- I_ABS=0
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
- N_TYP=N_PROT
- ELSE
- N_TYP=1
- ENDIF
-C
- DO KTYP=1,N_TYP
- ND=ND+1
- IF(ND.GT.NDIF) GOTO 20
-C
- IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
- NBTYPK=NATYP(KTYP)
- ELSE
- NBTYPK=1
- ENDIF
-C
- DO KNUM=1,NBTYPK
- KATL=NCORR(KNUM,KTYP)
- IF(KATL.EQ.JATL) GOTO 22
- JPOS(ND,1)=KTYP
- JPOS(ND,2)=KNUM
- JPOS(ND,3)=KATL
- XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
- YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
- ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
- R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
- DIJ=DIJ+R(ND)
- IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
- IF(IT(ND-1).EQ.1) GOTO 32
- RHOJK=R(ND)*VK(JE)
- NPATH(ND)=NPATH(ND)+1.
- COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
- &/(R(ND)*R(ND-1))
- IF(IFWD.EQ.1) THEN
- IF(IBWD(JTYP).EQ.0) THEN
- IF(COSTHIJK.LT.COSFWDJ) THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ELSEIF(IBWD(JTYP).EQ.1) THEN
- IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
- &EN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
- NTHOF=NTHOF+1
- IN(ND-1)=1
- IF(NTHOF.GT.NTHOUT) THEN
- IT(ND-1)=1
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF(IT(ND-1).EQ.1) GOTO 32
- CTROIS1=ZR(ND)/R(ND)
- IF(CTROIS1.GT.1) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- THJK=ACOS(CTROIS1)
- COMPL1= XR(ND)+IC*YR(ND)
- IF(ND-1.LT.NDIF) THEN
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
- ZSURFJ=ZSURF-ZR(ND-1)
- IF(IDCM.EQ.1) THEN
- UJ2(JTYP)=SIG2(R(ND-1),JTYP)
- ENDIF
- IF(ABS(ZSURFJ).LE.SMALL) THEN
- IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
- CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
- &.*COSTHIJK)
- ELSE
- CSKZ2J=1.
- ENDIF
- UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
- ELSE
- UJJ=UJ2(JTYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UJ2=VK2(JE)*UJJ
- CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
- ENDIF
- 50 IF(IDWSPH.EQ.1) THEN
- DW(ND-1)=1.
- ELSE
- DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
- ENDIF
- ENDIF
- IF(IPW.EQ.1) THEN
- CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
- PWI=FTHETA*DW(ND-1)/R(ND)
- PW(ND)=PW(ND-1)*PWI
- CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- LMJ=LMAX(JTYP,JE)
- IF(ND.GT.NCUT) THEN
- IT(ND)=1
- ELSE
- IT(ND)=0
- ENDIF
- CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
- CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
- XMAXT=0.
- DO LJ=0,LMJ
- CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
- DO LF=LF1,LF2,ISTEP_LF
- PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
- XMAXT=AMAX1(XMAXT,CABS(PW1))
- ENDDO
- ENDDO
- IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
- &=0
- ENDIF
- IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
- IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
- CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
- ENDIF
- CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
- IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
- CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
- &IJK,BIJK,CIJK,RHOIJ,RHOJK)
- CEX(ND)=CEXP(IC*RHOJK)/R(ND)
- CEXDW(ND)=CEX(ND)*DW(ND-1)
- IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
- IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
- CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
- &JK,FREF,IJ,DIJ,TAU)
- NPATH2(ND)=NPATH2(ND)+1.
- ENDIF
- ENDIF
- IF(ND.EQ.NDIF) GOTO 32
-c CALL FINDPATHS(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
-c 1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
- 32 DIJ=DIJ-R(ND)
- 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDDO
- 20 CONTINUE
- ND=ND-1
- ENDDO
- 42 DIJ=DIJ-R(ND)
- 12 IF(ND.GT.1) THEN
- IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
- IT(ND-1)=0
- IN(ND-1)=0
- ENDIF
- ENDDO
- ND=ND-1
- ENDDO
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE MATDIF(NO,ND,LF,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A21,B2
- &1,C21,RHO1,RHO2)
-C
-C This routine calculates the Rehr-Albers scattering matrix
-C F_{LAMBDA1,LAMBDA2}. The result is stored in the COMMON block
-C /SCATMAT/ as F21(NSPIN2_M,NLAMBDA_M,NLAMBDA_M,NDIF_M).
-C
-C Last modified : 3 Aug 2007
-C
- USE DIM_MOD
-C
- USE EXPFAC_MOD
- USE LBD_MOD
- USE LINLBD_MOD
- USE RA_MOD
- USE SCATMAT_MOD
- USE TRANS_MOD
- USE TLDW_MOD
-C
- REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
-C
- COMPLEX HLM1(0:NO_ST_M,0:NL_M-1),HLM2(0:NO_ST_M,0:NL_M-1)
- COMPLEX SL,RHO1,RHO2,IC,ZEROC,ONEC,ONEOVK
- COMPLEX SL_2_1,SL_2_2
- COMPLEX EXP1,EXP2,PROD1,PROD2
-C
- DATA PI,SMALL /3.141593,0.0001/
-C
- IC=(0.,1.)
- ZEROC=(0.,0.)
- ONEC=(1.,0.)
- ONEOVK=1./VK(JE)
- IB=0
- LMJ=LMAX(JTYP,JE)
- IF(ABS(ABS(B21)-PI).LT.SMALL) IB=-1
- IF(ABS(B21).LT.SMALL) IB=1
- IF(NO.EQ.8) THEN
- NN2=LMAX(JTYP,JE)+1
- ELSE
- NN2=NO
- ENDIF
-C
-C NO is atom-dependent and is decreased with the rank of the scatterer
-C in the path when I_NO > 0. Here LAMBDA1 depends on the scatterer JTYP
-C while LAMBDA2 depends on the next atom (KTYP) in the path
-C
- IF(I_NO.EQ.0) THEN
- NO1=N_RA(JTYP)
- NO2=N_RA(KTYP)
- ELSE
- NO1=MAX(N_RA(JTYP)-(ND-1)/I_NO,0)
- NO2=MAX(N_RA(KTYP)-ND/I_NO,0)
- ENDIF
- IF(I_ABS.EQ.0) THEN
- NUMAX1=NO1/2
- NUMAX2=NO2/2
- ELSEIF(I_ABS.EQ.1) THEN
- NUMAX1=MIN0(LF,NO1/2)
- NUMAX2=NO2/2
- ELSEIF(I_ABS.EQ.2) THEN
- NUMAX1=NO1/2
- NUMAX2=MIN0(LF,NO2/2)
- ENDIF
- LBDM(1,ND)=(NO1+1)*(NO1+2)/2
- LBDM(2,ND)=(NO2+1)*(NO2+2)/2
-C
- EXP2=-EXP(-IC*A21)
- EXP1=EXP(-IC*C21)
-C
- DO LAMBDA1=1,LBDMAX
- DO LAMBDA2=1,LBDMAX
- F21(1,LAMBDA2,LAMBDA1,ND)=ZEROC
- ENDDO
- ENDDO
-C
- IF(ABS(RHO1-RHO2).GT.SMALL) THEN
- CALL POLHAN(ISPHER,NUMAX1,LMJ,RHO1,HLM1)
- CALL POLHAN(ISPHER,NN2,LMJ,RHO2,HLM2)
- NEQUAL=0
- ELSE
- CALL POLHAN(ISPHER,NN2,LMJ,RHO1,HLM1)
- NEQUAL=1
- ENDIF
-C
-C Calculation of the scattering matrix when the scattering angle
-C is different from 0 and pi
-C
- IF(IB.EQ.0) THEN
- CALL DJMN(B21,RLM,LMJ)
- DO NU1=0,NUMAX1
- MUMAX1=NO1-2*NU1
- IF(I_ABS.EQ.1) MUMAX1=MIN(LF-NU1,MUMAX1)
- DO NU2=0,NUMAX2
- MUMAX2=NO2-2*NU2
-C
-C Case MU1 = 0
-C
- LAMBDA1=LBD(0,NU1)
-C
-C Case MU2 = 0
-C
- LAMBDA2=LBD(0,NU2)
- LMIN=MAX(NU1,NU2)
- SL=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(NU2,L)=HLM1(NU2,L)
- ENDIF
- IF(ISPEED.EQ.1) THEN
- SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TL(L,1,JTYP,JE)*HLM1(NU1,L
- &)*HLM2(NU2,L)
- ELSE
- SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TLT(L,1,JTYP,JE)*HLM1(NU1,
- &L)*HLM2(NU2,L)
- ENDIF
- ENDDO
- F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
-C
-C Case MU2 > 0
-C
- PROD2=ONEC
- SIG2=1.
- DO MU2=1,MUMAX2
- LAMBDA2_1=LBD(MU2,NU2)
- LAMBDA2_2=LBD(-MU2,NU2)
- PROD2=PROD2*EXP2
- SIG2=-SIG2
- LMIN=MAX(NU1,MU2+NU2)
- SL=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
- ENDIF
- C1=EXPF(0,L)/EXPF(MU2,L)
- IF(ISPEED.EQ.1) THEN
- SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TL(L,1,JTYP,JE)*HLM
- &1(NU1,L)*HLM2(MU2+NU2,L)
- ELSE
- SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TLT(L,1,JTYP,JE)*HL
- &M1(NU1,L)*HLM2(MU2+NU2,L)
- ENDIF
- ENDDO
- F21(1,LAMBDA2_1,LAMBDA1,ND)=SL*PROD2*ONEOVK*SIG2
- F21(1,LAMBDA2_2,LAMBDA1,ND)=SL*ONEOVK/PROD2
- ENDDO
-C
-C Case MU1 > 0
-C
- PROD1=ONEC
- SIG1=1.
- DO MU1=1,MUMAX1
- LAMBDA1_1=LBD(MU1,NU1)
- LAMBDA1_2=LBD(-MU1,NU1)
- PROD1=PROD1*EXP1
- SIG1=-SIG1
-C
-C Case MU2 = 0
-C
- LAMBDA2=LBD(0,NU2)
- LMIN=MAX(MU1,NU1,NU2)
- SL=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(NU2,L)=HLM1(NU2,L)
- ENDIF
- C1=EXPF(MU1,L)/EXPF(0,L)
- IF(ISPEED.EQ.1) THEN
- SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TL(L,1,JTYP,JE)*HLM
- &1(NU1,L)*HLM2(NU2,L)
- ELSE
- SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TLT(L,1,JTYP,JE)*HL
- &M1(NU1,L)*HLM2(NU2,L)
- ENDIF
- ENDDO
- F21(1,LAMBDA2,LAMBDA1_1,ND)=SL*PROD1*ONEOVK*SIG1
- F21(1,LAMBDA2,LAMBDA1_2,ND)=SL*ONEOVK/PROD1
-C
-C Case MU2 > 0
-C
- PROD2=ONEC
- SIG2=SIG1
- DO MU2=1,MUMAX2
- LAMBDA2_1=LBD(MU2,NU2)
- LAMBDA2_2=LBD(-MU2,NU2)
- PROD2=PROD2*EXP2
- SIG2=-SIG2
- LMIN=MAX(MU1,NU1,MU2+NU2)
- SL_2_1=ZEROC
- SL_2_2=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
- ENDIF
- C1=EXPF(MU1,L)/EXPF(MU2,L)
- IF(ISPEED.EQ.1) THEN
- SL=FLOAT(L+L+1)*C1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(
- &MU2+NU2,L)
- ELSE
- SL=FLOAT(L+L+1)*C1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2
- &(MU2+NU2,L)
- ENDIF
- SL_2_1=SL_2_1+SL*RLM(MU2,-MU1,L)
- SL_2_2=SL_2_2+SL*RLM(MU2,MU1,L)
- ENDDO
- F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL_2_2*PROD1*PROD2*ONEOVK*
- &SIG2
- F21(1,LAMBDA2_2,LAMBDA1_1,ND)=SL_2_1*PROD1*ONEOVK/PROD2
- F21(1,LAMBDA2_1,LAMBDA1_2,ND)=SL_2_1*ONEOVK*PROD2*SIG2/P
- &ROD1
- F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL_2_2*ONEOVK/(PROD1*PROD2
- &)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-C
-C Calculation of the scattering matrix when the scattering angle
-C is equal to 0 (forward scattering) or pi (backscattering)
-C
- ELSEIF(IB.EQ.1) THEN
- DO NU1=0,NUMAX1
- DO NU2=0,NUMAX2
- MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
- IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
-C
-C Case MU = 0
-C
- LAMBDA1=LBD(0,NU1)
- LAMBDA2=LBD(0,NU2)
- LMIN=MAX(NU1,NU2)
- SL=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(NU2,L)=HLM1(NU2,L)
- ENDIF
- IF(ISPEED.EQ.1) THEN
- SL=SL+FLOAT(L+L+1)*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,
- &L)
- ELSE
- SL=SL+FLOAT(L+L+1)*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2
- &,L)
- ENDIF
- ENDDO
- F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
-C
-C Case MU > 0
-C
- CST1=1.
- DO MU=1,MUMAX1
- LAMBDA1=LBD(MU,NU2)
- LAMBDA2=LBD(-MU,NU2)
- CST1=-CST1
- LMIN=MAX(NU1,MU+NU2)
- SL=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
- ENDIF
- IF(ISPEED.EQ.1) THEN
- SL=SL+FLOAT(L+L+1)*CST1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL
- &M2(MU+NU2,L)
- ELSE
- SL=SL+FLOAT(L+L+1)*CST1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H
- &LM2(MU+NU2,L)
- ENDIF
- ENDDO
- F21(1,LAMBDA1,LAMBDA1,ND)=SL*ONEOVK
- F21(1,LAMBDA2,LAMBDA2,ND)=SL*ONEOVK
- ENDDO
- ENDDO
- ENDDO
- ELSEIF(IB.EQ.-1) THEN
- DO NU1=0,NUMAX1
- DO NU2=0,NUMAX2
- MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
- IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
-C
-C Case MU = 0
-C
- LAMBDA1=LBD(0,NU1)
- LAMBDA2=LBD(0,NU2)
- LMIN=MAX(NU1,NU2)
- SL=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(NU2,L)=HLM1(NU2,L)
- ENDIF
- IF(MOD(L,2).EQ.0) THEN
- CST2=1.0
- ELSE
- CST2=-1.0
- ENDIF
- IF(ISPEED.EQ.1) THEN
- SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2
- &(NU2,L)
- ELSE
- SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM
- &2(NU2,L)
- ENDIF
- ENDDO
- F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
-C
-C Case MU > 0
-C
- CST1=1.
- DO MU=1,MUMAX1
- MUP=-MU
- LAMBDA1_1=LBD(MUP,NU1)
- LAMBDA1_2=LBD(-MUP,NU1)
- LAMBDA2_1=LBD(MU,NU2)
- LAMBDA2_2=LBD(-MU,NU2)
- CST1=-CST1
- LMIN=MAX(NU1,MU+NU2)
- SL=ZEROC
- DO L=LMIN,LMJ
- IF(NEQUAL.EQ.1) THEN
- HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
- ENDIF
- IF(MOD(L,2).EQ.0) THEN
- CST2=CST1
- ELSE
- CST2=-CST1
- ENDIF
- IF(ISPEED.EQ.1) THEN
- SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL
- &M2(MU+NU2,L)
- ELSE
- SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H
- &LM2(MU+NU2,L)
- ENDIF
- ENDDO
- F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL*ONEOVK
- F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL*ONEOVK
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-C
- RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE PATHOP(JPOS,JORDP,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,
- &FREF,IJ,D,TAU)
-C
-C This subroutine calculates the contribution of a given path to
-C the scattering path operator TAU.
-C
-C Last modified : 3 Aug 2007
-C
- USE DIM_MOD
-C
- USE APPROX_MOD
- USE C_RENORM_MOD
- USE EXPFAC_MOD
- USE EXTREM_MOD
- USE INIT_L_MOD
- USE INIT_J_MOD
- USE LBD_MOD
- USE LINLBD_MOD
- USE OUTUNITS_MOD
- USE PATH_MOD
- USE PRINTP_MOD
- USE RA_MOD
- USE RENORM_MOD
- USE ROT_MOD
- USE SCATMAT_MOD , F => F21
- USE TESTS_MOD
- USE TLDW_MOD
- USE TRANS_MOD
- USE VARIA_MOD
-C
- INTEGER JPOS(NDIF_M,3),AMU1
-C
-C
- REAL RLMIJ(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
-C
- COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
- COMPLEX H(NLAMBDA_M,NLAMBDA_M)
- COMPLEX G(NLAMBDA_M,NLAMBDA_M)
- COMPLEX HLM01(0:NO_ST_M,0:NL_M-1),HLMIJ(0:NO_ST_M,0:NL_M-1)
- COMPLEX SUM_NUJ_0,SUM_MUJ_0,SUM_NU1_0
- COMPLEX SUM_NUJ_1,SUM_MUJ_1,SUM_NU1_1
- COMPLEX SUM_NU1_2,SUM_NU1_3
- COMPLEX RHO01,RHOIJ
- COMPLEX RLMF_0,RLMF_1
- COMPLEX CF,CJ,OVK
- COMPLEX EXP_J,EXP_F,SUM_1
- COMPLEX TL_J
- COMPLEX COEF,ONEC,ZEROC
-C
-C
-C
- DATA PI,XCOMP /3.141593,1.E-10/
-C
- ZEROC=(0.,0.)
- ONEC=(1.,0.)
-C
- OVK=(1.,0.)/VK(JE)
- IF(NPATHP.GT.0) THEN
- FM1=FMIN(JORDP)
- XMAX=0.
- ENDIF
- EXP_J=CEXP((0.,-1.)*(PHIIJ-PI))
- EXP_F=CEXP((0.,1.)*PHI01)
- JTYP=JPOS(JORDP,1)
- ITYP=JPOS(1,1)
- JATL=JPOS(JORDP,3)
- IF(I_CP.EQ.0) THEN
- LMJ=LMAX(JTYP,JE)
- ELSE
- LMJ=LF2
- ENDIF
- IF(NO.EQ.8) THEN
- NN2=LMJ+1
- ELSE
- NN2=NO
- ENDIF
- IF(NO.GT.LF2) THEN
- NN=LF2
- ELSE
- NN=NO
- ENDIF
-C
-C NO is atom-dependent and is decreased with the rank of the scatterer
-C in the path when I_NO > 0 (except for the first scatterer ITYP for
-C which there is no such decrease)
-C
- NO1=N_RA(ITYP)
- IF(I_NO.EQ.0) THEN
- IF(IJ.EQ.1) THEN
- NOJ=N_RA(JTYP)
- ELSE
- NOJ=0
- ENDIF
- ELSE
- IF(IJ.EQ.1) THEN
- NOJ= MAX(N_RA(JTYP)-(JORDP-1)/I_NO,0)
- ELSE
- NOJ=0
- ENDIF
- ENDIF
- NUMX=NO1/2
- NUMAXJ=NOJ/2
-C
-C Calculation of the attenuation coefficients along the path
-C
- COEF=CEX(1)*OVK
- DO JSC=2,JORDP
- COEF=COEF*CEXDW(JSC)
- ENDDO
-C
-C Renormalization of the path
-C
- IF(I_REN.GE.1) THEN
- COEF=COEF*C_REN(JORDP)
- write(354,*) JORDP,C_REN(JORDP)
- ENDIF
-C
-C Call of the subroutines used for the R-A termination matrix
-C This termination matrix is now merged into PATHOP
-C
- CALL DJMN2(-THIJ,RLMIJ,LMJ,1)
- CALL POLHAN(ISPHER,NN,LF2,RHO01,HLM01)
- CALL POLHAN(ISPHER,NN2,LMJ,RHOIJ,HLMIJ)
-C
- LBD1M1=LBDM(1,1)
- LBD1M2=LBDM(2,1)
-C
-C Calculation of the L-independent part of TAU, called H
-C
- IF(JORDP.GE.3) THEN
- DO JPAT=2,JORDP-1
- LBD2M=LBDM(1,JPAT)
- LBD3M=LBDM(2,JPAT)
- DO LAMBDA1=1,LBD1M1
- DO LAMBDA3=1,LBD3M
- SUM_1=ZEROC
- DO LAMBDA2=1,LBD2M
- IF(JPAT.GT.2) THEN
- SUM_1=SUM_1+H(LAMBDA2,LAMBDA1)*F(1,LAMBDA3,LAMBDA2,JPA
- &T)
- ELSE
- SUM_1=SUM_1+F(1,LAMBDA2,LAMBDA1,1)*F(1,LAMBDA3,LAMBDA2
- &,2)
- ENDIF
- ENDDO
- G(LAMBDA3,LAMBDA1)=SUM_1
- ENDDO
- ENDDO
- DO LAMBDA1=1,LBD1M1
- DO LAMBDA2=1,LBD3M
- H(LAMBDA2,LAMBDA1)=G(LAMBDA2,LAMBDA1)
- ENDDO
- ENDDO
- ENDDO
- ELSEIF(JORDP.EQ.2) THEN
- DO LAMBDA1=1,LBD1M1
- DO LAMBDA2=1,LBD1M2
- H(LAMBDA2,LAMBDA1)=F(1,LAMBDA2,LAMBDA1,1)
- ENDDO
- ENDDO
- ELSEIF(JORDP.EQ.1) THEN
- DO LAMBDA1=1,LBD1M1
- DO LAMBDA2=1,LBD1M1
- H(LAMBDA2,LAMBDA1)=ONEC
- ENDDO
- ENDDO
- ENDIF
-C
-C Calculation of the path operator TAU
-C
- DO LF=LF1,LF2,ISTEP_LF
- ILF=LF*LF+LF+1
-C
- NU1MAX1=MIN(LF,NUMX)
-C
-C Case MF = 0
-C
- DO LJ=0,LMJ
- ILJ=LJ*LJ+LJ+1
- NUJMAX=MIN(LJ,NUMAXJ)
- IF(JORDP.EQ.1) THEN
- NU1MAX=MIN(NU1MAX1,LJ)
- ELSE
- NU1MAX=NU1MAX1
- ENDIF
-C
- IF(ISPEED.EQ.1) THEN
- TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
- ELSE
- TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
- ENDIF
-C
-C Case MJ = 0
-C
- SUM_NU1_0=ZEROC
-C
- DO NU1=0,NU1MAX
- IF(JORDP.GT.1) THEN
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
- ELSE
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
- ENDIF
-C
- DO MU1=-MU1MAX,MU1MAX
- LAMBDA1=LBD(MU1,NU1)
- AMU1=ABS(MU1)
-C
- RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
-C
- SUM_NUJ_0=ZEROC
-C
- IF(JORDP.GT.1) THEN
- DO NUJ=0,NUJMAX
- MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
-C
- SUM_MUJ_0=ZEROC
-C
- DO MUJ=-MUJMAX,MUJMAX
-C
- LAMBDAJ=LBD(MUJ,NUJ)
-C
- SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0,L
- &J)
- ENDDO
- SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
-C
- ENDDO
- ELSE
- SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
- ENDIF
-C
- SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
-C
- ENDDO
-C
- ENDDO
-C
- TAU(ILJ,ILF,JATL)=TAU(ILJ,ILF,JATL)+TL_J*SUM_NU1_0
-C
- IF(NPATHP.EQ.0) GOTO 35
-C
- FM2=FMAX(JORDP)
- XINT=CABS(TL_J*SUM_NU1_0)
- XMAX=AMAX1(XINT,XMAX)
- FMAX(JORDP)=AMAX1(FM2,XINT)
- IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
- IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
- FREF=FMAX(JORDP)
- ENDIF
- 35 CONTINUE
-C
-C Case MJ > 0
-C
- CJ=ONEC
- DO MJ=1,LJ
- INDJ=ILJ+MJ
- INDJP=ILJ-MJ
- CJ=CJ*EXP_J
-C
- SUM_NU1_0=ZEROC
- SUM_NU1_1=ZEROC
-C
- DO NU1=0,NU1MAX
- IF(JORDP.GT.1) THEN
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
- ELSE
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
- ENDIF
-C
- DO MU1=-MU1MAX,MU1MAX
- LAMBDA1=LBD(MU1,NU1)
- AMU1=ABS(MU1)
-C
- RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
-C
- SUM_NUJ_0=ZEROC
- SUM_NUJ_1=ZEROC
-C
- IF(JORDP.GT.1) THEN
- DO NUJ=0,NUJMAX
- MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
-C
- SUM_MUJ_0=ZEROC
- SUM_MUJ_1=ZEROC
-C
- DO MUJ=-MUJMAX,MUJMAX
-C
- LAMBDAJ=LBD(MUJ,NUJ)
-C
- SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,-
- &MJ,LJ)
- SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,M
- &J,LJ)
-C
- ENDDO
-C
- SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
- SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
-C
- ENDDO
- ELSE
- SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
- SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
- ENDIF
-C
- SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
- SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
-C
- ENDDO
-C
- ENDDO
-C
- TAU(INDJP,ILF,JATL)=TAU(INDJP,ILF,JATL)+CONJG(CJ)*TL_J*SUM_N
- &U1_1
- TAU(INDJ,ILF,JATL)=TAU(INDJ,ILF,JATL)+CJ*TL_J*SUM_NU1_0
-C
- IF(NPATHP.EQ.0) GOTO 45
-C
- FM2=FMAX(JORDP)
- XINT1=CABS(CJ*TL_J*SUM_NU1_0)
- XINT2=CABS(CONJG(CJ)*TL_J*SUM_NU1_1)
- XMAX=AMAX1(XINT1,XINT2,XMAX)
- FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
- IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
- IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
- FREF=FMAX(JORDP)
- ENDIF
- 45 CONTINUE
- ENDDO
- ENDDO
-C
-C Case MF > 0
-C
- CF=ONEC
- DO MF=1,LF
- INDF=ILF+MF
- INDFP=ILF-MF
- CF=CF*EXP_F
-C
- DO LJ=0,LMJ
- ILJ=LJ*LJ+LJ+1
- NUJMAX=MIN(LJ,NUMAXJ)
- IF(JORDP.EQ.1) THEN
- NU1MAX=MIN(NU1MAX1,LJ)
- ELSE
- NU1MAX=NU1MAX1
- ENDIF
-C
- IF(ISPEED.EQ.1) THEN
- TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
- ELSE
- TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
- ENDIF
-C
-C Case MJ = 0
-C
- SUM_NU1_0=ZEROC
- SUM_NU1_1=ZEROC
-C
- DO NU1=0,NU1MAX
- IF(JORDP.GT.1) THEN
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
- ELSE
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
- ENDIF
-C
- DO MU1=-MU1MAX,MU1MAX
- LAMBDA1=LBD(MU1,NU1)
- AMU1=ABS(MU1)
-C
- RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
- RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
-C
- SUM_NUJ_0=ZEROC
-C
- IF(JORDP.GT.1) THEN
- DO NUJ=0,NUJMAX
- MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
-C
- SUM_MUJ_0=ZEROC
-C
- DO MUJ=-MUJMAX,MUJMAX
-C
- LAMBDAJ=LBD(MUJ,NUJ)
-C
- SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0
- &,LJ)
-C
- ENDDO
-C
- SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
-C
- ENDDO
- ELSE
- SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
- ENDIF
-C
- SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
- SUM_NU1_1=SUM_NU1_1+RLMF_1*SUM_NUJ_0
-C
- ENDDO
-C
- ENDDO
-C
- TAU(ILJ,INDF,JATL)=TAU(ILJ,INDF,JATL)+CF*TL_J*SUM_NU1_0
- TAU(ILJ,INDFP,JATL)=TAU(ILJ,INDFP,JATL)+CONJG(CF)*TL_J*SUM_N
- &U1_1
-C
- IF(NPATHP.EQ.0) GOTO 25
-C
- FM2=FMAX(JORDP)
- XINT1=CABS(CF*TL_J*SUM_NU1_0)
- XINT2=CABS(CONJG(CF)*TL_J*SUM_NU1_1)
- XMAX=AMAX1(XINT1,XINT2,XMAX)
- FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
- IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
- IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
- FREF=FMAX(JORDP)
- ENDIF
- 25 CONTINUE
-C
-C Case MJ > 0
-C
- CJ=ONEC
- DO MJ=1,LJ
- INDJ=ILJ+MJ
- INDJP=ILJ-MJ
- CJ=CJ*EXP_J
-C
- SUM_NU1_0=ZEROC
- SUM_NU1_1=ZEROC
- SUM_NU1_2=ZEROC
- SUM_NU1_3=ZEROC
-C
- DO NU1=0,NU1MAX
- IF(JORDP.GT.1) THEN
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
- ELSE
- MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
- ENDIF
-C
- DO MU1=-MU1MAX,MU1MAX
- LAMBDA1=LBD(MU1,NU1)
- AMU1=ABS(MU1)
-C
- RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
- RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
-C
- SUM_NUJ_0=ZEROC
- SUM_NUJ_1=ZEROC
-C
- IF(JORDP.GT.1) THEN
- DO NUJ=0,NUJMAX
- MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
-C
- SUM_MUJ_0=ZEROC
- SUM_MUJ_1=ZEROC
-C
- DO MUJ=-MUJMAX,MUJMAX
-C
- LAMBDAJ=LBD(MUJ,NUJ)
-C
- SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ
- &,-MJ,LJ)
- SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ
- &,MJ,LJ)
-C
- ENDDO
-C
- SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
- SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
-C
- ENDDO
- ELSE
- SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
- SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
- ENDIF
-C
- SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
- SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
- SUM_NU1_2=SUM_NU1_2+RLMF_1*SUM_NUJ_0
- SUM_NU1_3=SUM_NU1_3+RLMF_1*SUM_NUJ_1
-C
- ENDDO
-C
- ENDDO
-C
- TAU(INDJP,INDF,JATL)=TAU(INDJP,INDF,JATL)+CF*CONJG(CJ)*TL_
- &J*SUM_NU1_1
- TAU(INDJP,INDFP,JATL)=TAU(INDJP,INDFP,JATL)+CONJG(CF*CJ)*T
- &L_J*SUM_NU1_3
- TAU(INDJ,INDF,JATL)=TAU(INDJ,INDF,JATL)+CF*CJ*TL_J*SUM_NU1
- &_0
- TAU(INDJ,INDFP,JATL)=TAU(INDJ,INDFP,JATL)+CONJG(CF)*CJ*TL_
- &J*SUM_NU1_2
-C
- IF(NPATHP.EQ.0) GOTO 15
-C
- FM2=FMAX(JORDP)
- XINT1=CABS(CF*CJ*TL_J*SUM_NU1_0)
- XINT2=CABS(CF*CONJG(CJ)*TL_J*SUM_NU1_1)
- XINT3=CABS(CONJG(CF)*CJ*TL_J*SUM_NU1_2)
- XINT4=CABS(CONJG(CF*CJ)*TL_J*SUM_NU1_3)
- XMAX=AMAX1(XINT1,XINT2,XINT3,XINT4,XMAX)
- FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2,XINT3,XINT4)
- IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
- IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
- FREF=FMAX(JORDP)
- ENDIF
- 15 CONTINUE
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-C
- IF(NPATHP.EQ.0) GOTO 16
- FMIN(JORDP)=AMIN1(FM1,XMAX)
- IF(XMAX.GT.FMN(NPATHP)) THEN
- CALL LOCATE(FMN,NPATHP,XMAX,JMX)
- DO KF=NPATHP,JMX+2,-1
- FMN(KF)=FMN(KF-1)
- JON(KF)=JON(KF-1)
- PATH(KF)=PATH(KF-1)
- DMN(KF)=DMN(KF-1)
- DO KD=1,10
- JPON(KF,KD)=JPON(KF-1,KD)
- ENDDO
- ENDDO
- FMN(JMX+1)=XMAX
- JON(JMX+1)=JORDP
- PATH(JMX+1)=NPATH(JORDP)
- DMN(JMX+1)=D
- DO KD=1,JORDP
- JPON(JMX+1,KD)=JPOS(KD,3)
- ENDDO
- ENDIF
- IF((FMIN(JORDP)-FM1).LT.-XCOMP) NPMI(JORDP)=NPATH(JORDP)
- IF((IPRINT.EQ.3).AND.(IJ.EQ.1)) THEN
- WRITE(IUSCR,1) JORDP,NPATH(JORDP),XMAX,D,(JPOS(KD,3),KD=1,JORDP)
- &
- ENDIF
-C
- 16 RETURN
-C
- 1 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE COUMAT(ITL,MI,LF,MF,DELTA,RADIAL,MATRIX)
-C
-C This routine calculates the spin-independent PhD optical matrix
-C elements for dipolar excitations. It is stored in
-C MATRIX(JDIR,JPOL)
-C
-C Here, the conventions are :
-C
-C IPOL=1 : linearly polarized light
-C IPOL=2 : circularly polarized light
-C
-C JPOL=1 : +/x polarization for circular/linear light
-C JPOL=2 : -/y polarization for circular/linear light
-C
-C When IDICHR=0, JDIR = 1,2 and 3 correspond respectively to the x,y
-C and z directions for the linear polarization. But for IDICHR=1,
-C these basis directions are those of the position of the light.
-C
-C Last modified : 8 Dec 2008
-C
- USE DIM_MOD
-C
- USE INIT_L_MOD , L2 => NNL, L3 => LF1, L4 => LF2, L5 => ISTEP_LF
- USE SPIN_MOD , I1 => ISPIN, N1 => NSPIN, N2 => NSPIN2, I2 => ISFLI
- &P, I8 => IR_DIA, N3 => NSTEP
- USE TYPCAL_MOD , I3 => IPHI, I4 => IE, I5 => ITHETA, I6 => IFTHET,
- & I7 => IMOD, I9 => I_CP, I10 => I_EXT
-C
- COMPLEX MATRIX(3,2),SUM_1,SUM_2,DELTA,YLM(3,-1:1),RADIAL
- COMPLEX ONEC,IC,IL,COEF,PROD
-C
- REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1),GNT(0:N_GAUNT)
- REAL THETA(3),PHI(3)
-C
- DATA PI4S3,C_LIN,SQR2 /4.188790,1.447202,1.414214/
- DATA PIS2 /1.570796/
-C
- ONEC=(1.,0.)
- IC=(0.,1.)
-C
- IF(INITL.EQ.0) GOTO 2
-C
- M=MF-MI
-C
- IF(MOD(LF,4).EQ.0) THEN
- IL=ONEC
- ELSEIF(MOD(LF,4).EQ.1) THEN
- IL=IC
- ELSEIF(MOD(LF,4).EQ.2) THEN
- IL=-ONEC
- ELSEIF(MOD(LF,4).EQ.3) THEN
- IL=-IC
- ENDIF
-C
- CALL GAUNT(LI,MI,LF,MF,GNT)
-C
- IF(ITL.EQ.0) THEN
-c COEF=CEXP(IC*DELTA)*CONJG(IL)
- COEF=CEXP(IC*DELTA)*IL
- ELSE
- IF(IDICHR.EQ.0) THEN
-c COEF=PI4S3*CONJG(IL)
- COEF=PI4S3*IL
- ELSE
-c COEF=C_LIN*CONJG(IL)
- COEF=C_LIN*IL
- ENDIF
- ENDIF
-C
- PROD=COEF*RADIAL*GNT(1)
-C
- IF(IDICHR.EQ.0) THEN
- YLM(1,-1)=(0.345494,0.)
- YLM(1,0)=(0.,0.)
- YLM(1,1)=(-0.345494,0.)
- YLM(2,-1)=(0.,-0.345494)
- YLM(2,0)=(0.,0.)
- YLM(2,1)=(0.,-0.345494)
- YLM(3,-1)=(0.,0.)
- YLM(3,0)=(0.488602,0.)
- YLM(3,1)=(0.,0.)
-C
- DO JDIR=1,3
- MATRIX(JDIR,1)=PROD*CONJG(YLM(JDIR,M))
- ENDDO
-C
- ELSEIF(IDICHR.GE.1) THEN
-C
- THETA(1)=PIS2
- PHI(1)=0.
- THETA(2)=PIS2
- PHI(2)=PIS2
- THETA(3)=0.
- PHI(3)=0.
-C
- DO JDIR=1,3
- CALL DJMN(THETA(JDIR),RLM,1)
- SUM_1=RLM(-1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
- SUM_2=RLM(1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
- IF(IPOL.EQ.2) THEN
- MATRIX(JDIR,1)=SQR2*SUM_1
- MATRIX(JDIR,2)=SQR2*SUM_2
- ELSEIF(ABS(IPOL).EQ.1) THEN
- MATRIX(JDIR,1)=(SUM_2-SUM_1)
- MATRIX(JDIR,2)=(SUM_2+SUM_1)*IC
- ENDIF
- ENDDO
- ENDIF
- GOTO 1
-C
- 2 DO JDIR=1,3
- MATRIX(JDIR,1)=ONEC
- MATRIX(JDIR,2)=ONEC
- ENDDO
-C
- 1 RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,NATC
- &LU,NFICHLEC,JFICH,NP)
-C
-C This subroutine computes the PhD formula in the spin-independent case
-C from a non spin-orbit resolved initial core state LI.
-C
-C Alternatively, it can compute the PhD amplitude for the APECS process.
-C
-C The calculation is performed using a series expansion for the
-C expression of the scattering path operator
-C
-C Last modified : 10 Jan 2016
-C
- USE DIM_MOD
-C
- USE ALGORITHM_MOD
- USE AMPLI_MOD
- USE APPROX_MOD
- USE COOR_MOD , NTCLU => NATCLU, NTP => NATYP
- USE C_RENORM_MOD
- USE DEBWAL_MOD
- USE DIRECT_MOD , RTHETA => RTHEXT
- USE EXTREM_MOD
- USE FIXSCAN_MOD
- USE INFILES_MOD
- USE INUNITS_MOD
- USE INIT_L_MOD
- USE INIT_J_MOD
- USE LIMAMA_MOD
- USE LINLBD_MOD
- USE MOYEN_MOD
- USE OUTFILES_MOD
- USE OUTUNITS_MOD
- USE PARCAL_MOD
- USE PATH_MOD
- USE PRINTP_MOD
- USE RENORM_MOD
- USE RESEAU_MOD
- USE SPIN_MOD
- USE TESTPA_MOD
- USE TESTPB_MOD
- USE TESTS_MOD
- USE TRANS_MOD
- USE TYPCAL_MOD
- USE TYPEM_MOD
- USE TYPEXP_MOD
- USE VALIN_MOD , PHLUM => PHILUM
- USE VALIN_AV_MOD
- USE VALFIN_MOD
-C
- REAL NPATH1(0:NDIF_M),NOPA
- REAL LUM(3),AXE(3),EPS(3),DIRLUM(3),E_PH(NE_M)
-C
- COMPLEX IC,ONEC,ZEROC,COEF,PW(0:NDIF_M),DELTA
- COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI
- COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
- COMPLEX YLMR(0:NL_M,-NL_M:NL_M),MATRIX(3,2)
- COMPLEX YLME(0:NL_M,-NL_M:NL_M)
- COMPLEX R2,MLFLI(2,-LI_M:LI_M,3,2,3)
- COMPLEX SJDIR_1,SJDIR_2,SJDIF_1,SJDIF_2
- COMPLEX RHOK(NE_M,NATM,0:18,5,NSPIN2_M),RD
- COMPLEX SLJDIF,ATT_M,MLIL0(2,-LI_M:LI_M,6),SLF_1,SLF_2
- COMPLEX SL0DIF,SMJDIF
-C
- DIMENSION VAL(NATCLU_M),NATYP(NATM),DIRPOL(3,2)
- DIMENSION EMET(3),R_L(9),COORD(3,NATCLU_M)
- DIMENSION R(NDIF_M),XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
- DIMENSION JPOS(NDIF_M,3),JPA(NDIF_M)
-C
-C
-C
- CHARACTER*7 STAT
- CHARACTER*13 OUTDATA1,OUTDATA2
-C
-C
- CHARACTER*24 OUTFILE
- CHARACTER*24 AMPFILE
-C
- DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/
- DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/
-C
- ALGO1='SE'
- ALGO2=' '
- ALGO3=' '
- ALGO4=' '
-C
- I_DIR=0
- NSET=1
- JEL=1
- OUTDATA1='CROSS-SECTION'
- IF(I_AMP.EQ.1) THEN
- I_MI=1
- OUTDATA2='MS AMPLITUDES'
- ELSE
- I_MI=0
- ENDIF
-C
- IF(SPECTRO.EQ.'PHD') THEN
- IOUT=IUO2
- OUTFILE=OUTFILE2
- STAT='UNKNOWN'
- IF(I_MI.EQ.1) THEN
- IOUT2=IUSCR2+1
- N_DOT=1
- DO J_CHAR=1,24
- IF(OUTFILE(J_CHAR:J_CHAR).EQ.'.') GOTO 888
- N_DOT=N_DOT+1
- ENDDO
- 888 CONTINUE
- AMPFILE=OUTFILE(1:N_DOT)//'amp'
- OPEN(UNIT=IOUT2, FILE=AMPFILE, STATUS=STAT)
- ENDIF
- ELSEIF(SPECTRO.EQ.'APC') THEN
- IOUT=IUSCR2+1
- OUTFILE='res/phot.amp'
- STAT='UNKNOWN'
- ENDIF
-C
-C Position of the light when the analyzer is along the z axis :
-C (X_LUM_Z,Y_LUM_Z,Z_LUM_Z)
-C
- RTHLUM=THLUM*PIS180
- RPHLUM=PHLUM*PIS180
- X_LUM_Z=SIN(RTHLUM)*COS(RPHLUM)
- Y_LUM_Z=SIN(RTHLUM)*SIN(RPHLUM)
- Z_LUM_Z=COS(RTHLUM)
-C
- IF(IMOD.EQ.0) THEN
-C
-C The analyzer is rotated
-C
- DIRLUM(1)=X_LUM_Z
- DIRLUM(2)=Y_LUM_Z
- DIRLUM(3)=Z_LUM_Z
- ELSE
-C
-C The sample is rotated ---> light and analyzer rotated
-C
- IF(I_EXT.EQ.0) THEN
- RTH0=THETA0*PIS180
- RPH0=PHI0*PIS180
- RTH=RTH0
- RPH=RPH0
-C
-C R_L is the rotation matrix from 0z to (THETA0,PHI0) expressed as
-C a function of the Euler angles ALPHA=PHI0, BETA=THETA0, GAMMA=-PHI0
-C It is stored as (1 2 3)
-C (4 5 6)
-C (7 8 9)
-C
- R_L(1)=COS(RTH0)*COS(RPH0)*COS(RPH0)+SIN(RPH0)*SIN(RPH0)
- R_L(2)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
- R_L(3)=SIN(RTH0)*COS(RPH0)
- R_L(4)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
- R_L(5)=COS(RTH0)*SIN(RPH0)*SIN(RPH0)+COS(RPH0)*COS(RPH0)
- R_L(6)=SIN(RTH0)*SIN(RPH0)
- R_L(7)=-SIN(RTH0)*COS(RPH0)
- R_L(8)=-SIN(RTH0)*SIN(RPH0)
- R_L(9)=COS(RTH0)
-C
-C Position of the light when the analyzer is along (THETA0,PHI0) : LUM(3)
-C
- LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
- LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
- LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
-C
- ENDIF
- ENDIF
-C
- IC=(0.,1.)
- ONEC=(1.,0.)
- ZEROC=(0.,0.)
- NSCAT=NATCLU-1
- ATTSE=1.
- ATTSJ=1.
- NPATH2(0)=1.
- NPATH(0)=1.
- NPMA(0)=1.
- NPMI(0)=1.
- ZSURF=VAL(1)
-C
- IF((ISOM.EQ.0).OR.(JFICH.EQ.1)) THEN
- OPEN(UNIT=IOUT, FILE=OUTFILE, STATUS=STAT)
- ENDIF
-C
-C Writing the headers in the output file
-C
- CALL HEADERS(IOUT)
-C
- IF((ISOM.EQ.0).OR.((ISOM.GT.0).AND.(JFICH.EQ.1))) THEN
- WRITE(IOUT,12) SPECTRO,OUTDATA1
- WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IP
- &H_1,I_EXT
- IF(I_MI.EQ.1) THEN
- WRITE(IOUT2,12) SPECTRO,OUTDATA2
- WRITE(IOUT2,12) STEREO
- WRITE(IOUT2,19) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,I
- &E,IPH_1,I_EXT
- WRITE(IOUT2,20) PHI0,THETA0,PHI1,THETA1,NONVOL(1)
- ENDIF
- ENDIF
-C
- IF(ISOM.EQ.0) THEN
- WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE
- IF(I_MI.EQ.1) THEN
- WRITE(IOUT2,79) NPLAN,NEMET,NTHETA,NPHI,NE
- ENDIF
- ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN
- WRITE(IOUT,11) NTHETA,NPHI,NE
- IF(I_MI.EQ.1) THEN
- WRITE(IOUT2,11) NTHETA,NPHI,NE
- ENDIF
- ENDIF
-C
-C Construction of the linear index LAMBDA=(MU,NU)
-C
- LAMBDA0=0
- DO N_O=0,NO
- NMX=N_O/2
- DO NU=0,NMX
- DO MU=-N_O,N_O
- NMU=2*NU+ABS(MU)
- IF(NMU.EQ.N_O) THEN
- LAMBDA0=LAMBDA0+1
- LBD(MU,NU)=LAMBDA0
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- LBDMAX=LAMBDA0
- IJK=0
-C
-C Loop over the planes
-C
- DO JPLAN=1,NPLAN
- Z=VAL(JPLAN)
- IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN
- DZZEM=ABS(Z-ZEM)
- IF(DZZEM.LT.SMALL) GOTO 10
- GOTO 1
- ENDIF
- 10 CONTINUE
-C
-C Loop over the different absorbers in a given plane
-C
- DO JEMET=1,NEMET
- CALL EMETT(JEMET,IEMET,Z,SYM_AT,NATYP,EMET,NTYPEM,JNEM,*4)
- GO TO 2
- 4 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN
- IF(I_TEST.NE.2) WRITE(IUO1,51) JPLAN,NTYPEM
- ENDIF
- GO TO 3
- 2 IF((ABS(EMET(3)).GT.COUPUR).AND.(IBAS.EQ.1)) GOTO 5
- IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN
- IF(I_TEST.NE.2) THEN
- WRITE(IUO1,52) JPLAN,EMET(1),EMET(2),EMET(3),NTYPEM
- ENDIF
- ENDIF
- IF(ISOM.EQ.1) NP=JPLAN
- ZSURFE=VAL(1)-EMET(3)
-C
-C Loop over the energies
-C
- DO JE=1,NE
- FMIN(0)=1.
- FMAX(0)=1.
- IF(NE.GT.1) THEN
- ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
- E_PH(JE)=ELUM+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
- ELSEIF(NE.EQ.1) THEN
- ECIN=E0
- E_PH(JE)=ELUM
- ENDIF
- IF(I_TEST.NE.1) THEN
- CFM=8.*PI*E_PH(JE)*FINSTRUC
- ELSE
- CFM=1.
- ENDIF
- CALL LPM(ECIN,XLPM,*6)
- XLPM1=XLPM/A
- IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
- IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN
- IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR
- ENDIF
- IF(ITL.EQ.0) THEN
- VK(JE)=SQRT(ECIN+VINT)*CONV*A*(1.,0.)
- VK2(JE)=CABS(VK(JE)*VK(JE))
- ENDIF
- GAMMA=1./(2.*XLPM1)
- IF(IPOTC.EQ.0) THEN
- VK(JE)=VK(JE)+IC*GAMMA
- ENDIF
- IF(I_TEST.NE.1) THEN
- VKR=REAL(VK(JE))
- ELSE
- VKR=1.
- ENDIF
- IF(I_MI.EQ.1) THEN
- WRITE(IOUT2,21) ECIN,VKR*CFM
- ENDIF
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN
- IF(IDCM.GE.1) WRITE(IUO1,22)
- DO JAT=1,N_PROT
- IF(IDCM.EQ.0) THEN
- XK2UJ2=VK2(JE)*UJ2(JAT)
- ELSE
- XK2UJ2=VK2(JE)*UJ_SQ(JAT)
- WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
- ENDIF
- CALL DWSPH(JAT,JE,XK2UJ2,TLT,ISPEED)
- DO LAT=0,LMAX(JAT,JE)
- TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
- ENDDO
- ENDDO
- ENDIF
- IF(ABS(I_EXT).GE.1) THEN
- OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
- READ(IUI6,13) I_DIR,NSET,N_DUM1
- READ(IUI6,14) I_DUM1,N_DUM2,N_DUM3
- ENDIF
-C
-C Initialization of TAU(INDJ,LINFMAX,JTYP)
-C
- JATL=0
- DO JTYP=1,N_PROT
- NBTYP=NATYP(JTYP)
- LMJ=LMAX(JTYP,JE)
- DO JNUM=1,NBTYP
- JATL=JATL+1
- DO LF=LF1,LF2,ISTEP_LF
- ILF=LF*LF+LF+1
- DO MF=-LF,LF
- INDF=ILF+MF
- DO LJ=0,LMJ
- ILJ=LJ*LJ+LJ+1
- DO MJ=-LJ,LJ
- INDJ=ILJ+MJ
- TAU(INDJ,INDF,JATL)=ZEROC
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-C
-C Storage of the coupling matrix elements MLFLI along the basis
-C directions X,Y ET Z
-C
-C These basis directions refer to the polarization if IDICHR = 0
-C but to the light when IDICHR = 1
-C
-C JBASE = 1 : X
-C JBASE = 2 : Y
-C JBASE = 3 : Z
-C
- DO MI=-LI,LI
- DO LF=LF1,LF2,ISTEP_LF
- LR=1+(1+LF-LI)/2
- DELTA=DLT(JE,NTYPEM,NNL,LR)
- RD=RHOK(JE,NTYPEM,NNL,LR,1)
- DO MF=-LF,LF
- IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 333
- IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 333
- MR=2+MF-MI
- CALL COUMAT(ITL,MI,LF,MF,DELTA,RD,MATRIX)
- DO JBASE=1,3
- MLFLI(1,MI,MR,LR,JBASE)=MATRIX(JBASE,1)
- IF(IDICHR.GE.1) THEN
- MLFLI(2,MI,MR,LR,JBASE)=MATRIX(JBASE,2)
- ENDIF
- ENDDO
- 333 CONTINUE
- ENDDO
- ENDDO
- ENDDO
-C
-C Calculation of the scattering path operator TAU
-C
- IF(I_TEST.EQ.2) GOTO 666
- PW(0)=ONEC
- PW(1)=ONEC
- ND=0
- TH01=0.
- PHI01=0.
- RHO01=ZEROC
- THMI=0.
- PHMI=0.
- RHOMI=ZEROC
- JATLEM=JNEM
- IF(NTYPEM.GT.1) THEN
- DO JAEM=NTYPEM-1,1,-1
- JATLEM=JATLEM+NATYP(JAEM)
- ENDDO
- ENDIF
- DO JD=1,NDIF
- NPATH2(JD)=0.
- NPATH(JD)=0.
- IT(JD)=0
- IN(JD)=0
- FMIN(JD)=1.E+20
- FMAX(JD)=0.
- ENDDO
- NTHOF=0
-C
-C Calculation of the maximal intensity for the paths of order NCUT
-C (plane waves). This will be taken as a reference for the IPW filter.
-C
- IF(IPW.EQ.1) THEN
- NDIFOLD=NDIF
- NOOLD=NO
- ISPHEROLD=ISPHER
- NDIF=NCUT
- NO=0
- ISPHER=0
- IREF=1
- IPW=0
- IJ=0
- DIJ=0.
- FREF=0.
- CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PH
- &MI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
- NDIF=NDIFOLD
- NO=NOOLD
- ISPHER=ISPHEROLD
- PW(0)=ONEC
- PW(1)=ONEC
- IPW=1
- ND=0
- TH01=0.
- PHI01=0.
- RHO01=ZEROC
- THMI=0.
- PHMI=0.
- RHOMI=ZEROC
- JATLEM=JNEM
- IF(NTYPEM.GT.1) THEN
- DO JAEM=NTYPEM-1,1,-1
- JATLEM=JATLEM+NATYP(JAEM)
- ENDDO
- ENDIF
- DO JD=1,NDIF
- NPATH2(JD)=0.
- NPATH(JD)=0.
- IT(JD)=0
- IN(JD)=0
- FMIN(JD)=1.E+20
- FMAX(JD)=0.
- ENDDO
- NTHOF=0
-C
-C New initialization of TAU(INDJ,INDF,JATL) after the PW calculation
-C
- JATL=0
- DO JTYP=1,N_PROT
- NBTYP=NATYP(JTYP)
- LMJ=LMAX(JTYP,JE)
- DO JNUM=1,NBTYP
- JATL=JATL+1
- DO LF=LF1,LF2,ISTEP_LF
- ILF=LF*LF+LF+1
- DO MF=-LF,LF
- INDF=ILF+MF
- DO LJ=0,LMJ
- ILJ=LJ*LJ+LJ+1
- DO MJ=-LJ,LJ
- INDJ=ILJ+MJ
- TAU(INDJ,INDF,JATL)=ZEROC
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-C
-C Generation and print-out of the paths
-C
- IF (NPATHP.GT.0) THEN
- DO JP=1,NPATHP-1
- FMN(JP)=0.
- PATH(JP)=0.
- JON(JP)=0
- ENDDO
- FMN(NPATHP)=-1.
- PATH(NPATHP)=0.
- JON(NPATHP)=0
- ENDIF
- IREF=0
- IJ=1
- IF(IPRINT.EQ.3) THEN
- OPEN(UNIT=IUSCR, STATUS='SCRATCH')
- ENDIF
- DIJ=0.
- CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHMI
- &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
- IF(NPATHP.EQ.0) GOTO 15
- IF(NSCAT.GT.1) THEN
- XPATOT=REAL((DFLOAT(NSCAT)**DFLOAT(NDIF+1) -1.D0)/DFLOAT(NSCA
- &T-1))
- ELSE
- XPATOT=FLOAT(NDIF+1)
- ENDIF
- IF(XPATOT.LT.2.14748E+09) THEN
- NPATOT=INT(XPATOT)
- IF(NPATOT.LT.NPATHP) NPATHP=NPATOT-1
- ENDIF
- WRITE(IUO1,84) NPATHP
- WRITE(IUO1,81)
- DO JPT=1,NPATHP
- IF(PATH(NPATHP).GT.2.14E+09) THEN
- WRITE(IUO1,82) JPT,JON(JPT),PATH(JPT),FMN(JPT),DMN(JPT),JNE
- &M,(JPON(JPT,KD),KD=1,JON(JPT))
- ELSE
- WRITE(IUO1,83) JPT,JON(JPT),INT(PATH(JPT)),FMN(JPT),DMN(JPT
- &),JNEM,(JPON(JPT,KD),KD=1,JON(JPT))
- ENDIF
- ENDDO
- IF(IPRINT.EQ.3) THEN
- IF(XPATOT.GT.2.14748E+09) GOTO 172
- WRITE(IUO1,85)
- WRITE(IUO1,71)
- NPATOT=INT(XPATOT)
- DO JOP=0,NDIF
- IF(JOP.EQ.0) THEN
- XINT0=FMAX(0)
- DIST0=0.
- WRITE(IUO1,70) JOP,JOP+1,XINT0,DIST0,JNEM
- GOTO 75
- ENDIF
- WRITE(IUO1,77)
- DO JLINE=1,NPATOT-1
- READ(IUSCR,69,ERR=75,END=75) JOPA,NOPA,XMAX,DIST0,(JPA(KD
- &),KD=1,JOPA)
- IF(JOPA.EQ.JOP) THEN
- IF(NOPA.GT.2.14E+09) THEN
- WRITE(IUO1,76) JOPA,NOPA,XMAX,DIST0,JNEM,(JPA(KD),KD=1
- &,JOPA)
- ELSE
- WRITE(IUO1,70) JOPA,INT(NOPA),XMAX,DIST0,JNEM,(JPA(KD)
- &,KD=1,JOPA)
- ENDIF
- ENDIF
- ENDDO
- IF(JOP.EQ.NDIF) WRITE(IUO1,80)
- 75 REWIND IUSCR
- ENDDO
- GOTO 73
- 172 WRITE(IUO1,74)
- CLOSE(IUSCR,STATUS='DELETE')
- 73 ENDIF
- DO JD=0,NDIF
- NPATH1(JD)=REAL(DFLOAT(NSCAT)**DFLOAT(JD))
- IF(NPATH1(JD).GT.2.14E+09) THEN
- IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
- WRITE(IUO1,53) JD,NPATH1(JD),NPATH2(JD),FMIN(JD),NPMI(JD),F
- &MAX(JD),NPMA(JD)
- IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
- ELSE
- IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
- WRITE(IUO1,58) JD,INT(NPATH1(JD)+0.1),INT(NPATH2(JD)+0.1),F
- &MIN(JD),INT(NPMI(JD)+0.1),FMAX(JD),INT(NPMA(JD)+0.1)
- IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
- ENDIF
- ENDDO
- 666 CONTINUE
-C
-C Calculation of the Photoelectron Diffraction formula
-C
-C
-C Loop over the 'fixed' angle
-C
- 15 DO J_FIXED=1,N_FIXED
- IF(N_FIXED.GT.1) THEN
- IF(I_EXT.EQ.0) THEN
- FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
- XINCRF=FLOAT(J_FIXED-1)*FIX_STEP
- ELSE
- XINCRF=0.
- ENDIF
- ELSEIF(N_FIXED.EQ.1) THEN
- XINCRF=0.
- ENDIF
- IF(ABS(I_EXT).GE.1) THEN
- READ(IUI6,86) JSET,JLINE,THD,PHD
- IF(I_EXT.EQ.-1) BACKSPACE IUI6
- THETA0=THD
- PHI0=PHD
- ENDIF
- IF(IPH_1.EQ.1) THEN
- IF(I_EXT.EQ.0) THEN
- DPHI=PHI0+XINCRF
- ELSE
- DPHI=PHD
- ENDIF
- RPHI=DPHI*PIS180
- IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
- ELSE
- ISAUT=0
- IF(I_EXT.EQ.0) THEN
- DTHETA=THETA0+XINCRF
- ELSE
- DTHETA=THD
- ENDIF
- RTHETA=DTHETA*PIS180
- IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
- IF(I_EXT.GE.1) ISAUT=0
- IF(I_TEST.EQ.2) ISAUT=0
- IF(ISAUT.GT.0) GOTO 8
- IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
- IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
- IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
-C
-C THETA-dependent number of PHI points for stereographic
-C representation (to obtain a uniform sampling density).
-C (Courtesy of J. Osterwalder - University of Zurich)
-C
- IF(STEREO.EQ.'YES') THEN
- N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+SMALL)+1
- ENDIF
-C
- ENDIF
- IF((N_FIXED.GT.1).AND.(IMOD.EQ.1)) THEN
-C
-C When there are several sets of scans (N_FIXED > 1),
-C the initial position LUM of the light is recalculated
-C for each initial position (RTH,RPH) of the analyzer
-C
- IF(IPH_1.EQ.1) THEN
- RTH=THETA0*PIS180
- RPH=RPHI
- ELSE
- RTH=RTHETA
- RPH=PHI0*PIS180
- ENDIF
-C
- R_L(1)=COS(RTH)*COS(RPH)
- R_L(2)=-SIN(RPH)
- R_L(3)=SIN(RTH)*COS(RPH)
- R_L(4)=COS(RTH)*SIN(RPH)
- R_L(5)=COS(RPH)
- R_L(6)=SIN(RTH)*SIN(RPH)
- R_L(7)=-SIN(RTH)
- R_L(8)=0.
- R_L(9)=COS(RTH)
-C
- LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
- LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
- LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
- ENDIF
-C
-C Loop over the scanned angle
-C
- DO J_SCAN=1,N_SCAN
- IF(N_SCAN.GT.1) THEN
- XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1)
- ELSEIF(N_SCAN.EQ.1) THEN
- XINCRS=0.
- ENDIF
- IF(I_EXT.EQ.-1) THEN
- READ(IUI6,86) JSET,JLINE,THD,PHD
- BACKSPACE IUI6
- ENDIF
- IF(IPH_1.EQ.1) THEN
- ISAUT=0
- IF(I_EXT.EQ.0) THEN
- DTHETA=THETA0+XINCRS
- ELSE
- DTHETA=THD
- ENDIF
- RTHETA=DTHETA*PIS180
- IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
- IF(I_EXT.GE.1) ISAUT=0
- IF(I_TEST.EQ.2) ISAUT=0
- IF(ISAUT.GT.0) GOTO 8
- IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
- IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
- IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
- ELSE
- IF(I_EXT.EQ.0) THEN
- DPHI=PHI0+XINCRS
- ELSE
- DPHI=PHD
- ENDIF
- RPHI=DPHI*PIS180
- IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
- ENDIF
-C
-C Loop over the sets of directions to average over (for gaussian average)
-C
-C
- SSETDIR_1=0.
- SSETDIF_1=0.
- SSETDIR_2=0.
- SSETDIF_2=0.
-C
- SSET2DIR_1=0.
- SSET2DIF_1=0.
- SSET2DIR_2=0.
- SSET2DIF_2=0.
-C
- IF(I_EXT.EQ.-1) THEN
- JREF=INT(NSET)/2+1
- ELSE
- JREF=1
- ENDIF
-C
- DO J_SET=1,NSET
- IF(I_EXT.EQ.-1) THEN
- READ(IUI6,86) JSET,JLINE,THD,PHD,W
- DTHETA=THD
- DPHI=PHD
- RTHETA=DTHETA*PIS180
- RPHI=DPHI*PIS180
-C
-C Here, there are several sets of scans (NSET > 1), so
-C the initial position LUM of the light must be
-C recalculated for each initial position of the analyzer
-C
- RTH=TH_0(J_SET)*PIS180
- RPH=PH_0(J_SET)*PIS180
-C
- IF(IMOD.EQ.1) THEN
- R_L(1)=COS(RTH)*COS(RPH)
- R_L(2)=-SIN(RPH)
- R_L(3)=SIN(RTH)*COS(RPH)
- R_L(4)=COS(RTH)*SIN(RPH)
- R_L(5)=COS(RPH)
- R_L(6)=SIN(RTH)*SIN(RPH)
- R_L(7)=-SIN(RTH)
- R_L(8)=0.
- R_L(9)=COS(RTH)
-C
- LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
- LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
- LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
-C
- ENDIF
- ELSE
- W=1.
- ENDIF
-C
- IF(I_EXT.EQ.-1) PRINT 89
-C
- CALL DIRAN(VINT,ECIN,JEL)
-C
- IF(J_SET.EQ.JREF) THEN
- DTHETAP=DTHETA
- DPHIP=DPHI
- ENDIF
-C
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO1,88) DTHETA,DPHI
- ENDIF
-C
-C .......... Case IMOD=1 only ..........
-C
-C Calculation of the position of the light when the analyzer is at
-C (THETA,PHI). DIRLUM is the direction of the light and its initial
-C value (at (THETA0,PHI0)) is LUM. AXE is the direction of the theta
-C rotation axis and EPS is defined so that (AXE,DIRLUM,EPS) is a
-C direct orthonormal basis. The transform of a vector R by a rotation
-C of OMEGA about AXE is then given by
-C
-C R' = R COS(OMEGA) + (AXE.R)(1-COS(OMEGA)) AXE + (AXE^R) SIN(OMEGA)
-C
-C Here, DIRANA is the internal direction of the analyzer and ANADIR
-C its external position
-C
-C Note that when the initial position of the analyzer is (RTH,RPH)
-C which coincides with (RTH0,RPH0) only for the first fixed angle
-C
- IF(IMOD.EQ.1) THEN
- IF(ITHETA.EQ.1) THEN
- AXE(1)=-SIN(RPH)
- AXE(2)=COS(RPH)
- AXE(3)=0.
- RANGLE=RTHETA-RTH
- ELSEIF(IPHI.EQ.1) THEN
- AXE(1)=0.
- AXE(2)=0.
- AXE(3)=1.
- RANGLE=RPHI-RPH
- ENDIF
- CALL PRVECT(AXE,LUM,EPS,CVECT)
- PRS=PRSCAL(AXE,LUM)
- IF(J_SCAN.EQ.1) THEN
- DIRLUM(1)=LUM(1)
- DIRLUM(2)=LUM(2)
- DIRLUM(3)=LUM(3)
- ELSE
- DIRLUM(1)=LUM(1)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(1)+
- &SIN(RANGLE)*EPS(1)
- DIRLUM(2)=LUM(2)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(2)+
- &SIN(RANGLE)*EPS(2)
- DIRLUM(3)=LUM(3)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(3)+
- &SIN(RANGLE)*EPS(3)
- ENDIF
- ENDIF
- IF(DIRLUM(3).GT.1.) DIRLUM(3)=1.
- IF(DIRLUM(3).LT.-1.) DIRLUM(3)=-1.
- THETALUM=ACOS(DIRLUM(3))
- IF(I_TEST.EQ.2) THETALUM=-THETALUM
- COEF=DIRLUM(1)+IC*DIRLUM(2)
- CALL ARCSIN(COEF,DIRLUM(3),PHILUM)
- ANALUM=ANADIR(1,1)*DIRLUM(1) + ANADIR(2,1)*DIRLUM(2) +ANADIR(
- &3,1)*DIRLUM(3)
-C
- SEPSDIR_1=0.
- SEPSDIF_1=0.
- SEPSDIR_2=0.
- SEPSDIF_2=0.
-C
-C Loop over the directions of polarization
-C
- DO JEPS=1,NEPS
- IF((JEPS.EQ.1).AND.(IPOL.GE.0)) THEN
- DIRPOL(1,JEPS)=COS(THETALUM)*COS(PHILUM)
- DIRPOL(2,JEPS)=COS(THETALUM)*SIN(PHILUM)
- DIRPOL(3,JEPS)=-SIN(THETALUM)
- ELSE
- DIRPOL(1,JEPS)=-SIN(PHILUM)
- DIRPOL(2,JEPS)=COS(PHILUM)
- DIRPOL(3,JEPS)=0.
- ENDIF
- IF(ABS(IPOL).EQ.1) THEN
- IF(IPRINT.GT.0) THEN
- WRITE(IUO1,61) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),
- & (DIRPOL(K,1),K=1,3),ANALUM
- ENDIF
- ELSE
- IF((JEPS.EQ.1).AND.(IPRINT.GT.0)) THEN
- WRITE(IUO1,63) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),ANA
- &LUM
- ENDIF
- ENDIF
- IF((JEPS.EQ.1).AND.(I_EXT.EQ.-1)) PRINT 89
-C
-C Calculation of the coupling matrix MLIL0
-C
- DO MI=-LI,LI
- DO LF=LF1,LF2,ISTEP_LF
- LR=1+(1+LF-LI)/2
- LRR=3*(LR-1)
- DO MF=-LF,LF
- MR=2+MF-MI
- IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 777
- IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 777
- LMR=LRR+MR
- IF(IDICHR.EQ.0) THEN
- IF(I_TEST.NE.1) THEN
- MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRPOL(1,JEPS)
- & +MLFLI(1,MI,MR,LR,2)*DIRPOL(2,JEPS) +MLFLI(1,MI,MR,LR,3)*DIRPOL(3
- &,JEPS)
- ELSE
- MLIL0(1,MI,LMR)=ONEC
- ENDIF
- ELSEIF(IDICHR.GE.1) THEN
- IF(I_TEST.NE.1) THEN
- MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRLUM(1) +MLF
- &LI(1,MI,MR,LR,2)*DIRLUM(2) +MLFLI(1,MI,MR,LR,3)*DIRLUM(3)
- MLIL0(2,MI,LMR)=MLFLI(2,MI,MR,LR,1)*DIRLUM(1) +MLF
- &LI(2,MI,MR,LR,2)*DIRLUM(2) +MLFLI(2,MI,MR,LR,3)*DIRLUM(3)
- ELSE
- MLIL0(1,MI,LMR)=ONEC
- ENDIF
- ENDIF
- 777 CONTINUE
- ENDDO
- ENDDO
- ENDDO
-C
- SRDIF_1=0.
- SRDIR_1=0.
- SRDIF_2=0.
- SRDIR_2=0.
-C
-C Loop over the different directions of the analyzer contained in a cone
-C
- DO JDIR=1,NDIR
- IF(IATTS.EQ.1) THEN
- ATTSE=EXP(-ZSURFE*GAMMA/DIRANA(3,JDIR))
- ENDIF
-C
- SMIDIR_1=0.
- SMIDIF_1=0.
- SMIDIR_2=0.
- SMIDIF_2=0.
-C
-C Loop over the equiprobable azimuthal quantum numbers MI corresponding
-C to the initial state LI
-C
- LME=LMAX(1,JE)
- CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME)
- DO MI=-LI,LI
- SJDIR_1=ZEROC
- SJDIF_1=ZEROC
- SJDIR_2=ZEROC
- SJDIF_2=ZEROC
-C
-C Calculation of the direct emission (used a a reference for the
-C output), which is not contained in the calculation of TAU
-C
- DO LF=LF1,LF2,ISTEP_LF
- LR=1+(1+LF-LI)/2
- LRR=3*(LR-1)
- ILF=LF*LF+LF+1
- IF(ISPEED.EQ.1) THEN
- R2=TL(LF,1,1,JE)
- ELSE
- R2=TLT(LF,1,1,JE)
- ENDIF
- IF(I_REN.GE.1) R2=R2*C_REN(0)
- DO MF=-LF,LF
- MR=2+MF-MI
- LMR=LRR+MR
- INDF=ILF+MF
- IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 444
- IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 444
- SJDIR_1=SJDIR_1+YLME(LF,MF)*ATTSE*MLIL0(1,MI,LMR)*R2
- IF(IDICHR.GE.1) THEN
- SJDIR_2=SJDIR_2+YLME(LF,MF)*ATTSE*MLIL0(2,MI,LMR)*R2
- &
- ENDIF
-C
-C Contribution of the absorber to TAU (initialization of SJDIF)
-C
- IF(I_TEST.EQ.2) GOTO 444
- SL0DIF=ZEROC
- DO L0=0,LME
- IL0=L0*L0+L0+1
- SL0DIF=SL0DIF+YLME(L0,0)*TAU(IL0,INDF,1)
- DO M0=1,L0
- IND01=IL0+M0
- IND02=IL0-M0
- SL0DIF=SL0DIF+(YLME(L0,M0)*TAU(IND01,INDF,1)+YLME(L
- &0,-M0)*TAU(IND02,INDF,1))
- ENDDO
- ENDDO
- SJDIF_1=SJDIF_1+SL0DIF*MLIL0(1,MI,LMR)
- IF(IDICHR.GE.1) THEN
- SJDIF_2=SJDIF_2+SL0DIF*MLIL0(2,MI,LMR)
- ENDIF
- 444 CONTINUE
- ENDDO
- ENDDO
- SJDIF_1=SJDIF_1*ATTSE
- IF(IDICHR.GE.1) THEN
- SJDIF_2=SJDIF_2*ATTSE
- ENDIF
-C
-C Loop over the last atom J encountered by the photoelectron
-C before escaping the solid
-C
- IF(I_TEST.EQ.2) GOTO 111
- DO JTYP=2,N_PROT
- NBTYP=NATYP(JTYP)
- LMJ=LMAX(JTYP,JE)
- DO JNUM=1,NBTYP
- JATL=NCORR(JNUM,JTYP)
- XOJ=SYM_AT(1,JATL)-EMET(1)
- YOJ=SYM_AT(2,JATL)-EMET(2)
- ZOJ=SYM_AT(3,JATL)-EMET(3)
- ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ)
- ZSURFJ=VAL(1)-SYM_AT(3,JATL)
- CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLMR,LMJ)
- IF(IATTS.EQ.1) THEN
- ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR))
- ENDIF
- CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+ZOJ*DIRANA
- &(3,JDIR))/ROJ
- IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78
- CTROIS1=ZOJ/ROJ
- IF(CTROIS1.GT.1.) THEN
- CTROIS1=1.
- ELSEIF(CTROIS1.LT.-1.) THEN
- CTROIS1=-1.
- ENDIF
- IF(IDCM.GE.1) THEN
- UJ2(JTYP)=UJ_SQ(JTYP)
- ENDIF
- IF(ABS(ZSURFJ).LE.SMALL) THEN
- IF(ABS(CSTHJR-1.).GT.SMALL) THEN
- CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)*(DIRANA(3,JDIR)-CTRO
- &IS1)/(2.-2.*CSTHJR)
- ELSE
- CSKZ2J=1.
- ENDIF
- UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
- ELSE
- UJJ=UJ2(JTYP)
- ENDIF
- IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
- XK2UJ2=VK2(JE)*UJJ
- CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
- ENDIF
- 78 IF(IDWSPH.EQ.1) THEN
- DWTER=1.
- ELSE
- DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR))
- ENDIF
- IF(JATL.EQ.JATLEM) THEN
- ATT_M=ATTSE*DWTER
- ELSE
- ATT_M=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*CSTHJR)
- ENDIF
-C
- SLF_1=ZEROC
- SLF_2=ZEROC
- DO LF=LF1,LF2,ISTEP_LF
- LR=1+(1+LF-LI)/2
- LRR=3*(LR-1)
- ILF=LF*LF+LF+1
- DO MF=-LF,LF
- MR=2+MF-MI
- INDF=ILF+MF
- IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 555
- IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 555
- LMR=LRR+MR
- SLJDIF=ZEROC
- DO LJ=0,LMJ
- ILJ=LJ*LJ+LJ+1
- SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDF,JATL)
- IF(LJ.GT.0) THEN
- DO MJ=1,LJ
- INDJ1=ILJ+MJ
- INDJ2=ILJ-MJ
- SMJDIF=SMJDIF+(YLMR(LJ,MJ)*TAU(INDJ1,INDF,JATL)+YL
- &MR(LJ,-MJ)*TAU(INDJ2,INDF,JATL))
- ENDDO
- ENDIF
- SLJDIF=SLJDIF+SMJDIF
- ENDDO
- SLF_1=SLF_1+SLJDIF*MLIL0(1,MI,LMR)
- IF(IDICHR.GE.1) THEN
- SLF_2=SLF_2+SLJDIF*MLIL0(2,MI,LMR)
- ENDIF
- 555 CONTINUE
- ENDDO
- ENDDO
- SJDIF_1=SJDIF_1+SLF_1*ATT_M
- IF(IDICHR.GE.1) THEN
- SJDIF_2=SJDIF_2+SLF_2*ATT_M
- ENDIF
-C
-C End of the loops over the last atom J
-C
- ENDDO
- ENDDO
-C
-C Writing the amplitudes in file IOUT for APECS, or
-C in file IOUT2 for PhD (orientated orbitals' case)
-C
- 111 IF(SPECTRO.EQ.'APC') THEN
- WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEPS,
- &JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1
- IF(IDICHR.GE.1) THEN
- WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEP
- &S,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2
- ENDIF
- ELSE
- IF(I_MI.EQ.1) THEN
- WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JE
- &PS,JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1
- IF(IDICHR.GE.1) THEN
- WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,
- &JEPS,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2
- ENDIF
- ENDIF
-C
-C Computing the square modulus
-C
- SMIDIF_1=SMIDIF_1+CABS(SJDIR_1+SJDIF_1)*CABS(SJDIR_1+SJD
- &IF_1)
- SMIDIR_1=SMIDIR_1+CABS(SJDIR_1)*CABS(SJDIR_1)
- IF(IDICHR.GE.1) THEN
- SMIDIF_2=SMIDIF_2+CABS(SJDIR_2+SJDIF_2)*CABS(SJDIR_2+S
- &JDIF_2)
- SMIDIR_2=SMIDIR_2+CABS(SJDIR_2)*CABS(SJDIR_2)
- ENDIF
- ENDIF
-C
-C End of the loop over MI
-C
- ENDDO
-C
- IF(SPECTRO.EQ.'APC') GOTO 220
- SRDIR_1=SRDIR_1+SMIDIR_1
- SRDIF_1=SRDIF_1+SMIDIF_1
- IF(IDICHR.GE.1) THEN
- SRDIR_2=SRDIR_2+SMIDIR_2
- SRDIF_2=SRDIF_2+SMIDIF_2
- ENDIF
- 220 CONTINUE
-C
-C End of the loop on the directions of the analyzer
-C
- ENDDO
-C
- IF(SPECTRO.EQ.'APC') GOTO 221
- SEPSDIF_1=SEPSDIF_1+SRDIF_1*VKR*CFM/NDIR
- SEPSDIR_1=SEPSDIR_1+SRDIR_1*VKR*CFM/NDIR
- IF(IDICHR.GE.1) THEN
- SEPSDIF_2=SEPSDIF_2+SRDIF_2*VKR*CFM/NDIR
- SEPSDIR_2=SEPSDIR_2+SRDIR_2*VKR*CFM/NDIR
- ENDIF
- 221 CONTINUE
-C
-C End of the loop on the polarization
-C
- ENDDO
-C
- SSETDIR_1=SSETDIR_1+SEPSDIR_1*W
- SSETDIF_1=SSETDIF_1+SEPSDIF_1*W
- IF(ICHKDIR.EQ.2) THEN
- IF(JSET.EQ.JREF) THEN
- SSET2DIR_1=SEPSDIR_1
- SSET2DIF_1=SEPSDIF_1
- ENDIF
- ENDIF
- IF(IDICHR.GE.1) THEN
- SSETDIR_2=SSETDIR_2+SEPSDIR_2*W
- SSETDIF_2=SSETDIF_2+SEPSDIF_2*W
- IF(ICHKDIR.EQ.2) THEN
- IF(JSET.EQ.JREF) THEN
- SSET2DIR_2=SEPSDIR_2
- SSET2DIF_2=SEPSDIF_2
- ENDIF
- ENDIF
- ENDIF
-C
-C End of the loop on the set averaging
-C
- ENDDO
-C
- IF(SPECTRO.EQ.'APC') GOTO 222
- IF(IDICHR.EQ.0) THEN
- IF(ISOM.EQ.2) THEN
- WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
- &ETDIF_1
- IF(ICHKDIR.EQ.2) THEN
- WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
- &SSET2DIF_1
- ENDIF
- ELSE
- WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
- &ETDIF_1
- IF(ICHKDIR.EQ.2) THEN
- WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
- &SSET2DIF_1
- ENDIF
- ENDIF
- ELSE
- IF(ISOM.EQ.2) THEN
- WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
- &ETDIF_1,SSETDIR_2,SSETDIF_2
- IF(ICHKDIR.EQ.2) THEN
- WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
- &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2
- ENDIF
- ELSE
- WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
- &ETDIF_1,SSETDIR_2,SSETDIF_2
- IF(ICHKDIR.EQ.2) THEN
- WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
- &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2
- ENDIF
- ENDIF
- ENDIF
- 222 CONTINUE
-C
-C End of the loop on the scanned angle
-C
- ENDDO
-C
- 8 CONTINUE
-C
-C End of the loop on the fixed angle
-C
- ENDDO
-C
-C End of the loop on the energy
-C
- CLOSE(IUI6)
- ENDDO
-C
- 3 CONTINUE
-C
-C End of the loop on the emitters
-C
- ENDDO
-C
- GO TO 1
- 5 IPLAN=JPLAN-1
- IJK=IJK+1
- IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN
- IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN
- ENDIF
- 1 CONTINUE
-C
-C End of the loop on the planes
-C
- ENDDO
-C
- IF(ABS(I_EXT).GE.1) CLOSE(IUI6)
- IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*)
- IF(SPECTRO.EQ.'APC') CLOSE(IOUT)
- IF(SPECTRO.EQ.'APC') GOTO 7
-c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN
- IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN
- NP=0
- CALL TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
- ENDIF
- IF(I_EXT.EQ.2) THEN
- CALL WEIGHT_SUM(ISOM,I_EXT,0,1)
- ENDIF
- GOTO 7
- 6 WRITE(IUO1,55)
-C
- 9 FORMAT(9(2X,I1),2X,I2)
- 11 FORMAT(I4,2X,I4,2X,I4)
- 12 FORMAT(2X,A3,11X,A13)
- 13 FORMAT(6X,I1,1X,I3,2X,I4)
- 14 FORMAT(6X,I1,1X,I3,3X,I3)
- 19 FORMAT(2(2X,I1),1X,I2,6(2X,I1),2X,I2)
- 20 FORMAT(2(5X,F6.2,2X,F6.2),2X,I1)
- 21 FORMAT(10X,E12.6,3X,E12.6)
- 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,2
- &5X,' BY DEBYE UNCORRELATED MODEL:',/)
- 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
- 51 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' DOES NOT CONTAIN ',
- *'ANY ABSORBER OF TYPE ',I2,' *******')
- 52 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' POSITION OF ','THE AB
- &SORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X,'******* ',19X
- &,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******')
- 53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1,/,
- &10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1,/,10X,' MINIMAL INTENS
- &ITY : ',E12.6,2X,'No OF THE PATH : ',F15.1,
- & /,10X,' MAXIMAL INTENSITY : ',E12.6,2X,'No OF T
- &HE PATH : ',F15.1)
- 54 FORMAT(//,7X,'DUE TO THE SIZE OF THE CLUSTER, THE SUMMATION',
- *' HAS BEEN TRUNCATED TO THE ',I2,' TH PLANE')
- 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
- *'AVAILABLE >>>>>>>>>>')
- 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
- *'MEAN FREE PATH = ',F6.3,' * A',//)
- 57 FORMAT(25X,'CLUSTER RADIUS = ',F6.3,' *A')
- 58 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',I10,/,10
- &X,' EFFECTIVE NUMBER OF PATHS : ',I10, /,10X,' MI
- &NIMAL INTENSITY : ',E12.6,2X,'No OF THE PATH : ',I10,
- & /,10X,' MAXIMAL INTENSITY : ',E12.6,
- & 2X,'No OF THE PATH : ',I10)
- 59 FORMAT(//,15X,'THE SCATTERING DIRECTION IS GIVEN INSIDE ',
- *'THE CRYSTAL')
- 60 FORMAT(7X,'THE POSITIONS OF THE ATOMS ARE GIVEN WITH RESPECT ',
- *'TO THE ABSORBER')
- 61 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6.
- &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI
- &GHT ', ' : (',F6.3,',',F6.3,',',F6.3,
- & ')',/,16X,'DIRECTION OF THE POLARIZATION : (
- &', F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZER.LIGHT ','
- & : ',F7.4)
- 63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6.
- &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI
- &GHT ', ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZE
- &R.LIGHT : ',F7.4)
- 65 FORMAT(////,3X,'++++++++++++++++++',9X,
- *'THETA = ',F6.2,' DEGREES',9X,'++++++++',
- *'++++++++++',///)
- 66 FORMAT(////,3X,'++++++++++++++++++',9X,
- *'PHI = ',F6.2,' DEGREES',9X,'++++++++++',
- *'++++++++++',///)
- 67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
- 68 FORMAT(10X,' CUT-OFF INTENSITY : ',E12.6)
- 69 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
- 70 FORMAT(2X,I2,2X,I10,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
- 71 FORMAT(//,1X,'JDIF',4X,'No OF THE PATH',2X,'INTENSITY',3X,'LENGTH'
- &,4X,'ABSORBER',2X,'ORDER OF THE SCATTERERS',/)
- 72 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1
- &2.6,2X,E12.6)
- 74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ','=====
- &>')
- 76 FORMAT(2X,I2,2X,E12.6,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
- 77 FORMAT(' ')
- 79 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
- 80 FORMAT(///)
- 81 FORMAT(//,1X,'RANK',1X,'ORDER',4X,'No PATH',3X,'INTENSITY',3X,'LEN
- >H',4X,'ABS',3X,'ORDER OF THE SCATTERERS',/)
- 82 FORMAT(I3,4X,I2,1X,E12.6,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X))
- 83 FORMAT(I3,4X,I2,1X,I10,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X))
- 84 FORMAT(/////,18X,'THE ',I3,' MORE INTENSE PATHS BY DECREASING',' O
- &RDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ','OF A)')
- 85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ',/,24X,'(THE L
- &ENGTH IS GIVEN IN UNITS OF A)')
- 86 FORMAT(2X,I3,1X,I4,5X,F8.3,3X,F8.3,3X,E12.6)
- 87 FORMAT(2X,I2,2X,I3,2X,I2,2X,I3,2X,I3,2X,I3,2X,I1,2X,I2,2X,I2,2X,E1
- &2.6,2X,E12.6,2X,E12.6,2X,E12.6)
- 88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =', F6.2)
- 89 FORMAT(/,4X,'..........................................','........
- &.............................')
-C
- 7 RETURN
-C
- END
-C
-C=======================================================================
-C
- SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
-C
-C This routine sums up the calculations corresponding to different
-C absorbers or different planes when this has to be done
-C (parameter ISOM in the input data file).
-C
-C Last modified : 24 Jan 2013
-C
- USE DIM_MOD
- USE OUTUNITS_MOD
- USE TYPEXP_MOD , DUMMY => SPECTRO
- USE VALIN_MOD
- USE VALFIN_MOD
-C
- PARAMETER(N_HEAD=5000,N_FILES=1000)
-C
- CHARACTER*3 SPECTRO
-C
- CHARACTER*13 OUTDATA
- CHARACTER*72 HEAD(N_HEAD,N_FILES)
-C
- REAL TAB(NDIM_M,4)
- REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M)
-C
-C
- DATA JVOL,JTOT/0,-1/
-C
- REWIND IUO2
-C
-C Reading and storing the headers:
-C
- NHEAD=0
- DO JLINE=1,N_HEAD
- READ(IUO2,888) HEAD(JLINE,JFICH)
- NHEAD=NHEAD+1
- IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333
- ENDDO
-C
- 333 CONTINUE
-C
- READ(IUO2,15) SPECTRO,OUTDATA
- READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IPH_1
- &,I_EXT
-C
- IF(I_EXT.EQ.2) THEN
- IPH_1=0
- ENDIF
-C
- IF(ISOM.EQ.0) THEN
-C
-C........ ISOM = 0 : case of independent input files .................
-C
- READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE
-C
- IF(IPH_1.EQ.1) THEN
- N_FIXED=NPHI
- FIX0=PHI0
- FIX1=PHI1
- N_SCAN=NTHETA
- ELSE
- N_FIXED=NTHETA
- FIX0=THETA0
- FIX1=THETA1
- IF(STEREO.EQ.'YES') THEN
- NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
- &+1
- IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
- ENDIF
- N_SCAN=NPHI
- ENDIF
-C
- IF(I_EXT.EQ.-1) THEN
- N_SCAN=2*N_SCAN
- ENDIF
-C
- IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
- NDP=NEMET*NTHETA*NPHI*NE
- ELSEIF(I_EXT.EQ.-1) THEN
- NDP=NEMET*NTHETA*NPHI*NE*2
- ELSEIF(I_EXT.EQ.2) THEN
- NDP=NEMET*NTHETA*NE
- N_FIXED=NTHETA
- N_SCAN=NPHI
- IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
- ENDIF
-C
- NTT=NPLAN*NDP
- IF(NTT.GT.NDIM_M) GOTO 5
-C
- DO JPLAN=1,NPLAN
- DO JEMET=1,NEMET
- DO JE=1,NE
-C
- DO J_FIXED=1,N_FIXED
- IF(N_FIXED.GT.1) THEN
- XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
- ELSEIF(N_FIXED.EQ.1) THEN
- XINCRF=0.
- ENDIF
- IF(IPH_1.EQ.1) THEN
- JPHI=J_FIXED
- ELSE
- THETA=THETA0+XINCRF
- JTHETA=J_FIXED
- IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11
- ENDIF
- IF(STEREO.EQ.' NO') THEN
- N_SCAN_R=N_SCAN
- ELSE
- RTHETA=THETA*0.017453
- FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
- N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
- ENDIF
-C
- DO J_SCAN=1,N_SCAN_R
- IF(IPH_1.EQ.1) THEN
- JTHETA=J_SCAN
- ELSE
- JPHI=J_SCAN
- ENDIF
-C
- JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN + (JE-1)*N
- &_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI
-C
- IF(I_EXT.LE.0) THEN
- IF(STEREO.EQ.' NO') THEN
- JPHI2=JPHI
- ELSE
- JPHI2=(JTHETA-1)*NPHI+JPHI
- ENDIF
- ELSE
- JPHI2=JTHETA
- ENDIF
-C
- READ(IUO2,2) JPL
- IF(JPLAN.EQ.JPL) THEN
- BACKSPACE IUO2
- IF(IDICHR.EQ.0) THEN
- READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
- &),TAB(JLIN,1),TAB(JLIN,2)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
- ENDIF
- ELSE
- READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
- &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
- &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
- ENDIF
- ENDIF
- ELSE
- BACKSPACE IUO2
- DO JL=JLIN,JPLAN*NDP
- TAB(JL,1)=0.0
- TAB(JL,2)=0.0
- TAB(JL,3)=0.0
- TAB(JL,4)=0.0
- ENDDO
- GOTO 10
- ENDIF
- ENDDO
- ENDDO
- 11 CONTINUE
- ENDDO
- ENDDO
- 10 CONTINUE
- ENDDO
-C
- REWIND IUO2
-C
-C Skipping the NHEAD lines of headers before rewriting:
-C
- DO JLINE=1,NHEAD
- READ(IUO2,888) HEAD(JLINE,JFICH)
- ENDDO
-C
- WRITE(IUO2,15) SPECTRO,OUTDATA
- WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
- WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
-C
- DO JE=1,NE
- DO JTHETA=1,NTHETA
- IF(STEREO.EQ.' NO') THEN
- NPHI_R=NPHI
- ELSE
- RTHETA=DTHETA(JTHETA)*0.017453
- FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
- NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
- NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
- ENDIF
- DO JPHI=1,NPHI_R
- TOTDIF_1=0.
- TOTDIR_1=0.
- VOLDIF_1=0.
- VOLDIR_1=0.
- TOTDIF_2=0.
- TOTDIR_2=0.
- VOLDIF_2=0.
- VOLDIR_2=0.
- IF(I_EXT.EQ.-1) THEN
- TOTDIF2_1=0.
- TOTDIR2_1=0.
- VOLDIF2_1=0.
- VOLDIR2_1=0.
- TOTDIF2_2=0.
- TOTDIR2_2=0.
- VOLDIF2_2=0.
- VOLDIR2_2=0.
- ENDIF
-C
- DO JPLAN=1,NPLAN
-C
- SF_1=0.
- SR_1=0.
- SF_2=0.
- SR_2=0.
- IF(I_EXT.EQ.-1) THEN
- SF2_1=0.
- SR2_1=0.
- SF2_2=0.
- SR2_2=0.
- ENDIF
-C
- DO JEMET=1,NEMET
- JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (JE-1)*NTHE
- &TA*NPHI +(JTHETA-1)*NPHI + JPHI
- SF_1=SF_1+TAB(JLIN,2)
- SR_1=SR_1+TAB(JLIN,1)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- SF2_1=SF2_1+TAB(JLIN2,2)
- SR2_1=SR2_1+TAB(JLIN2,1)
- ENDIF
- IF(IDICHR.GE.1) THEN
- SF_2=SF_2+TAB(JLIN,4)
- SR_2=SR_2+TAB(JLIN,3)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- SF2_2=SF2_2+TAB(JLIN2,4)
- SR2_2=SR2_2+TAB(JLIN2,3)
- ENDIF
- ENDIF
- ENDDO
- IF(I_EXT.LE.0) THEN
- IF(STEREO.EQ.' NO') THEN
- JPHI2=JPHI
- ELSE
- JPHI2=(JTHETA-1)*NPHI+JPHI
- ENDIF
- ELSE
- JPHI2=JTHETA
- ENDIF
- IF(IDICHR.EQ.0) THEN
- WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
- &_1,SF_1
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
- &SR2_1,SF2_1
- ENDIF
- ELSE
- WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S
- &R_1,SF_1,SR_2,SF_2
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
- &,SR2_1,SF2_1,SR2_2,SF2_2
- ENDIF
- ENDIF
- IF(JPLAN.GT.NONVOL(JFICH)) THEN
- VOLDIF_1=VOLDIF_1+SF_1
- VOLDIR_1=VOLDIR_1+SR_1
- IF(I_EXT.EQ.-1) THEN
- VOLDIF2_1=VOLDIF2_1+SF2_1
- VOLDIR2_1=VOLDIR2_1+SR2_1
- ENDIF
- IF(IDICHR.GE.1) THEN
- VOLDIF_2=VOLDIF_2+SF_2
- VOLDIR_2=VOLDIR_1+SR_2
- IF(I_EXT.EQ.-1) THEN
- VOLDIF2_2=VOLDIF2_2+SF2_2
- VOLDIR2_2=VOLDIR2_1+SR2_2
- ENDIF
- ENDIF
- ENDIF
- TOTDIF_1=TOTDIF_1+SF_1
- TOTDIR_1=TOTDIR_1+SR_1
- IF(I_EXT.EQ.-1) THEN
- TOTDIF2_1=TOTDIF2_1+SF2_1
- TOTDIR2_1=TOTDIR2_1+SR2_1
- ENDIF
- IF(IDICHR.GE.1) THEN
- TOTDIF_2=TOTDIF_2+SF_2
- TOTDIR_2=TOTDIR_2+SR_2
- IF(I_EXT.EQ.-1) THEN
- TOTDIF2_2=TOTDIF2_2+SF2_2
- TOTDIR2_2=TOTDIR2_2+SR2_2
- ENDIF
- ENDIF
- ENDDO
- IF(IDICHR.EQ.0) THEN
- WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOLD
- &IR_1,VOLDIF_1
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO
- &LDIR2_1,VOLDIF2_1
- ENDIF
- WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOTD
- &IR_1,TOTDIF_1
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO
- &TDIR2_1,TOTDIF2_1
- ENDIF
- ELSE
- WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOL
- &DIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V
- &OLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
- ENDIF
- WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOT
- &DIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T
- &OTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO
-C
- ELSE
-C
-C........ ISOM not= 0 : multiple input files to be summed up ..........
-C
- READ(IUO2,7) NTHETA,NPHI,NE
-C
- IF(IPH_1.EQ.1) THEN
- N_FIXED=NPHI
- FIX0=PHI0
- FIX1=PHI1
- N_SCAN=NTHETA
- ELSE
- N_FIXED=NTHETA
- FIX0=THETA0
- FIX1=THETA1
- IF(STEREO.EQ.'YES') THEN
- NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001)
- &+1
- IF(NTHETA*NPHI.GT.NPH_M) GOTO 37
- ENDIF
- N_SCAN=NPHI
- ENDIF
-C
- IF(I_EXT.EQ.-1) THEN
- N_SCAN=2*N_SCAN
- ENDIF
-C
- IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
- NDP=NTHETA*NPHI*NE
- ELSEIF(I_EXT.EQ.-1) THEN
- NDP=NTHETA*NPHI*NE*2
- ELSEIF(I_EXT.EQ.2) THEN
- NDP=NTHETA*NE
- N_FIXED=NTHETA
- N_SCAN=NPHI
- IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35
- ENDIF
-C
- NTT=NFICHLEC*NDP
- IF(NTT.GT.NDIM_M) GOTO 5
-C
- IF(ISOM.EQ.1) THEN
- NPLAN=NP
- NF=NP
- ELSEIF(ISOM.EQ.2) THEN
- NEMET=NFICHLEC
- NF=NFICHLEC
- NPLAN=1
- ENDIF
-C
- DO JF=1,NF
-C
-C Reading the headers for each file:
-C
- IF(JF.GT.1) THEN
- DO JLINE=1,NHEAD
- READ(IUO2,888) HEAD(JLINE,JF)
- ENDDO
- ENDIF
-C
- DO JE=1,NE
-C
- DO J_FIXED=1,N_FIXED
- IF(N_FIXED.GT.1) THEN
- XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1)
- ELSEIF(N_FIXED.EQ.1) THEN
- XINCRF=0.
- ENDIF
- IF(IPH_1.EQ.1) THEN
- JPHI=J_FIXED
- ELSE
- THETA=THETA0+XINCRF
- JTHETA=J_FIXED
- IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12
- ENDIF
- IF(STEREO.EQ.' NO') THEN
- N_SCAN_R=N_SCAN
- ELSE
- RTHETA=THETA*0.017453
- FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
- N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
- ENDIF
-C
- DO J_SCAN=1,N_SCAN_R
- IF(IPH_1.EQ.1) THEN
- JTHETA=J_SCAN
- ELSE
- JPHI=J_SCAN
- ENDIF
-C
- JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI +
- &JPHI
- IF(I_EXT.LE.0) THEN
- IF(STEREO.EQ.' NO') THEN
- JPHI2=JPHI
- ELSE
- JPHI2=(JTHETA-1)*NPHI+JPHI
- ENDIF
- ELSE
- JPHI2=JTHETA
- ENDIF
-C
- IF(ISOM.EQ.1) THEN
- READ(IUO2,2) JPL
- IF(JF.EQ.JPL) THEN
- BACKSPACE IUO2
- IF(IDICHR.EQ.0) THEN
- READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(
- &JE),TAB(JLIN,1),TAB(JLIN,2)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
- ENDIF
- ELSE
- READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
- &(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),EC
- &IN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
- ENDIF
- ENDIF
- ELSE
- BACKSPACE IUO2
- DO JLINE=1,NHEAD
- BACKSPACE IUO2
- ENDDO
- DO JL=JLIN,JF*NDP
- TAB(JL,1)=0.0
- TAB(JL,2)=0.0
- TAB(JL,3)=0.0
- TAB(JL,4)=0.0
- ENDDO
- GOTO 13
- ENDIF
- ELSEIF(ISOM.EQ.2) THEN
- IF(IDICHR.EQ.0) THEN
- READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
- &),TAB(JLIN,1),TAB(JLIN,2)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2)
- ENDIF
- ELSE
- READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
- &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN
- &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4)
- ENDIF
- ENDIF
- ENDIF
- ENDDO
- 12 CONTINUE
- ENDDO
- ENDDO
- 13 CONTINUE
- ENDDO
-C
- REWIND IUO2
-C
-C Writing the headers:
-C
- DO JLINE=1,2
- WRITE(IUO2,888) HEAD(JLINE,1)
- ENDDO
- DO JF=1,NFICHLEC
- DO JLINE=3,6
- WRITE(IUO2,888) HEAD(JLINE,JF)
- ENDDO
- WRITE(IUO2,888) HEAD(2,JF)
- ENDDO
- DO JLINE=7,NHEAD
- WRITE(IUO2,888) HEAD(JLINE,1)
- ENDDO
-C
- WRITE(IUO2,15) SPECTRO,OUTDATA
- WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
- WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
-C
- IF(ISOM.EQ.1) THEN
-C
- DO JE=1,NE
-C
- DO JTHETA=1,NTHETA
- IF(STEREO.EQ.' NO') THEN
- NPHI_R=NPHI
- ELSE
- RTHETA=DTHETA(JTHETA)*0.017453
- FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
- NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
- NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
- ENDIF
- DO JPHI=1,NPHI_R
-C
- TOTDIF_1=0.
- TOTDIR_1=0.
- VOLDIF_1=0.
- VOLDIR_1=0.
- TOTDIF_2=0.
- TOTDIR_2=0.
- VOLDIF_2=0.
- VOLDIR_2=0.
- IF(I_EXT.EQ.-1) THEN
- TOTDIF2_1=0.
- TOTDIR2_1=0.
- VOLDIF2_1=0.
- VOLDIR2_1=0.
- TOTDIF2_2=0.
- TOTDIR2_2=0.
- VOLDIF2_2=0.
- VOLDIR2_2=0.
- ENDIF
-C
- DO JPLAN=1,NPLAN
- JF=JPLAN
-C
- JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JP
- &HI
-C
- SR_1=TAB(JLIN,1)
- SF_1=TAB(JLIN,2)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- SF2_1=TAB(JLIN2,2)
- SR2_1=TAB(JLIN2,1)
- ENDIF
- IF(I_EXT.LE.0) THEN
- IF(STEREO.EQ.' NO') THEN
- JPHI2=JPHI
- ELSE
- JPHI2=(JTHETA-1)*NPHI+JPHI
- ENDIF
- ELSE
- JPHI2=JTHETA
- ENDIF
- IF(IDICHR.EQ.0) THEN
- WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
- &SR_1,SF_1
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
- &),SR2_1,SF2_1
- ENDIF
- ELSE
- SR_2=TAB(JLIN,3)
- SF_2=TAB(JLIN,4)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- SF2_2=TAB(JLIN2,4)
- SR2_2=TAB(JLIN2,3)
- ENDIF
- WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
- &,SR_1,SF_1,SR_2,SF_2
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
- &E),SR2_1,SF2_1,SR2_2,SF2_2
- ENDIF
- ENDIF
- IF(NONVOL(JPLAN).EQ.0) THEN
- VOLDIF_1=VOLDIF_1+SF_1
- VOLDIR_1=VOLDIR_1+SR_1
- IF(I_EXT.EQ.-1) THEN
- VOLDIF2_1=VOLDIF2_1+SF2_1
- VOLDIR2_1=VOLDIR2_1+SR2_1
- ENDIF
- IF(IDICHR.GE.1) THEN
- VOLDIF_2=VOLDIF_2+SF_2
- VOLDIR_2=VOLDIR_2+SR_2
- IF(I_EXT.EQ.-1) THEN
- VOLDIF2_2=VOLDIF2_2+SF2_2
- VOLDIR2_2=VOLDIR2_1+SR2_2
- ENDIF
- ENDIF
- ENDIF
- TOTDIF_1=TOTDIF_1+SF_1
- TOTDIR_1=TOTDIR_1+SR_1
- IF(I_EXT.EQ.-1) THEN
- TOTDIF2_1=TOTDIF2_1+SF2_1
- TOTDIR2_1=TOTDIR2_1+SR2_1
- ENDIF
- IF(IDICHR.GE.1) THEN
- TOTDIF_2=TOTDIF_2+SF_2
- TOTDIR_2=TOTDIR_2+SR_2
- IF(I_EXT.EQ.-1) THEN
- TOTDIF2_2=TOTDIF2_2+SF2_2
- TOTDIR2_2=TOTDIR2_2+SR2_2
- ENDIF
- ENDIF
- ENDDO
-C
- IF(IDICHR.EQ.0) THEN
- WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO
- &LDIR_1,VOLDIF_1
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
- &VOLDIR2_1,VOLDIF2_1
- ENDIF
- WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO
- &TDIR_1,TOTDIF_1
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
- &TOTDIR2_1,TOTDIF2_1
- ENDIF
- ELSE
- WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V
- &OLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
- &,VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
- ENDIF
- WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T
- &OTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE)
- &,TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2
- ENDIF
- ENDIF
-C
- ENDDO
- ENDDO
- ENDDO
- ELSEIF(ISOM.EQ.2) THEN
- DO JE=1,NE
-C
- DO JTHETA=1,NTHETA
- IF(STEREO.EQ.' NO') THEN
- NPHI_R=NPHI
- ELSE
- RTHETA=DTHETA(JTHETA)*0.017453
- FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1)
- NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1
- NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1
- ENDIF
- DO JPHI=1,NPHI_R
-C
- SF_1=0.
- SR_1=0.
- SF_2=0.
- SR_2=0.
- IF(I_EXT.EQ.-1) THEN
- SF2_1=0.
- SR2_1=0.
- SF2_2=0.
- SR2_2=0.
- ENDIF
-C
- DO JEMET=1,NEMET
- JF=JEMET
-C
- JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + J
- &PHI
-C
- SF_1=SF_1+TAB(JLIN,2)
- SR_1=SR_1+TAB(JLIN,1)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- SF2_1=SF2_1+TAB(JLIN2,2)
- SR2_1=SR2_1+TAB(JLIN2,1)
- ENDIF
- IF(IDICHR.GE.1) THEN
- SF_2=SF_2+TAB(JLIN,4)
- SR_2=SR_2+TAB(JLIN,3)
- IF(I_EXT.EQ.-1) THEN
- JLIN2=NTT+JLIN
- SF2_2=SF2_2+TAB(JLIN2,4)
- SR2_2=SR2_2+TAB(JLIN2,3)
- ENDIF
- ENDIF
- ENDDO
- IF(I_EXT.LE.0) THEN
- IF(STEREO.EQ.' NO') THEN
- JPHI2=JPHI
- ELSE
- JPHI2=(JTHETA-1)*NPHI+JPHI
- ENDIF
- ELSE
- JPHI2=JTHETA
- ENDIF
- IF(IDICHR.EQ.0) THEN
- WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR
- &_1,SF_1
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE
- &),SR2_1,SF2_1
- ENDIF
- ELSE
- WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S
- &R_1,SF_1,SR_2,SF_2
- IF(I_EXT.EQ.-1) THEN
- WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J
- &E),SR2_1,SF2_1,SR2_2,SF2_2
- ENDIF
- ENDIF
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ENDIF
-C
- GOTO 6
-C
- 5 WRITE(IUO1,4)
- STOP
- 35 WRITE(IUO1,36) N_FIXED
- STOP
- 37 WRITE(IUO1,38) NTHETA*NPHI
- STOP
-C
- 1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
- 2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
- 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
- 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
- &THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>')
- 7 FORMAT(I4,2X,I4,2X,I4)
- 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
- 9 FORMAT(9(2X,I1),2X,I2)
- 15 FORMAT(2X,A3,11X,A13)
- 22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1
- &2.6,2X,E12.6)
- 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
- &,E12.6)
- 25 FORMAT(37X,E12.6,2X,E12.6)
- 36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL ',
- &'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<<
- &SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
- 38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE I
- &NCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE AT
- &LEAST ',I6,' >>>>>>>>>>')
- 888 FORMAT(A72)
-C
- 6 RETURN
-C
- END