epsi
/
msspec_python3
3
0
Fork 0
Code Issues 6 Pull Requests Releases Wiki Activity
msspec_python3/msspec/spec/fortran/spec.f

13298 lines
382 KiB
Fortran
Raw Blame History

C
C
C ************************************************************
C * ******************************************************** *
C * * * *
C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * *
C * * PHOTOELECTRON DIFFRACTION CODE * *
C * * BASED ON SERIES EXPANSION * *
C * * * *
C * ******************************************************** *
C ************************************************************
C
C
C
C
C Written by D. Sebilleau, Groupe Theorie,
C Departement Materiaux-Nanosciences,
C Institut de Physique de Rennes,
C UMR CNRS-Universite 6251,
C Universite de Rennes-1,
C 35042 Rennes-Cedex,
C France
C
C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada
C
C-----------------------------------------------------------------------
C
C As a general rule in this code, although there might be a few
C exceptions (...), a variable whose name starts with a 'I' is a
C switch, with a 'J' is a loop index and with a 'N' is a number.
C
C The main subroutines are :
C
C * PHDDIF : computes the photoelectron diffraction
C formula
C
C * LEDDIF : computes the low-energy electron
C diffraction formula
C
C * XASDIF : computes the EXAFS or XANES formula
C depending on the energy
C
C * AEDDIF : computes the Auger electron diffraction
C formula
C
C * FINDPATHS : generates the multiple scattering
C paths the electron will follow
C
C * PATHOP : calculates the contribution of a given
C path to the scattering path operator
C
C * MATDIF : computes the Rehr-Albers scattering
C matrices
C
C A subroutine called NAME_A is the Auger equivalent of subroutine
C NAME. The essentail difference between NAME and NAME_A is that
C they do not contain the same arrays.
C
C Always remember, when changing the input data file, to keep the
C format. The rule here is that the last digit of any integer or
C character data must correspond to the tab (+) while for real data,
C the tab precedes the point.
C
C Do not forget, before submitting a calculation, to check the
C consistency of the input data with the corresponding maximal
C values in the include file.
C
C-----------------------------------------------------------------------
C
C Please report any bug or problem to me at :
C
C didier.sebilleau@univ-rennes1.fr
C
C
C
C Last modified : 10 Jan 2016
C
C=======================================================================
C
SUBROUTINE DO_MAIN()
C
C This routine reads the various input files and calls the subroutine
C performing the requested calculation
C
USE DIM_MOD
C
USE ADSORB_MOD
USE APPROX_MOD
USE ATOMS_MOD
USE AUGER_MOD
USE BASES_MOD
USE CLUSLIM_MOD
USE COOR_MOD
USE DEBWAL_MOD
USE INDAT_MOD
USE INIT_A_MOD
USE INIT_L_MOD
USE INIT_J_MOD
USE INIT_M_MOD
USE INFILES_MOD
USE INUNITS_MOD
USE LIMAMA_MOD
USE LPMOY_MOD
USE MASSAT_MOD
USE MILLER_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD
USE PARCAL_A_MOD
USE RELADS_MOD
USE RELAX_MOD
USE RESEAU_MOD
USE SPIN_MOD
USE TESTS_MOD
USE TRANS_MOD
USE TL_AED_MOD
USE TYPCAL_MOD
USE TYPCAL_A_MOD
USE TYPEM_MOD
USE TYPEXP_MOD
USE VALIN_MOD
USE XMRHO_MOD
C
DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3)
DIMENSION ROT(3,3),EMET(3)
DIMENSION VAL2(NATCLU_M)
DIMENSION IRE(NATCLU_M,2)
DIMENSION REL(NATCLU_M),RHOT(NATM)
DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M)
DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM)
DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M)
DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M)
DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM)
C
COMPLEX TLSTAR
COMPLEX RHOR(NE_M,NATM,0:18,5,NSPIN2_M)
COMPLEX TLSTAR_A
COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E
COMPLEX RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHOR5STAR
C
INTEGER INV(2)
C
CHARACTER RIEN
CHARACTER*1 B
CHARACTER*2 R
C
C
C
C
C
C
CHARACTER*30 TUNIT,DUMMY
C
DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/
DATA INV /0,0/
C
LE_MAX=0
C
C! READ(*,776) NFICHLEC
C! READ(*,776) ICOM
C! DO JF=1,NFICHLEC
C! READ(*,777) INDATA(JF)
C! ENDDO
C
C.......... Loop on the data files ..........
C
NFICHLEC=1
ICOM = 5
DO JFICH=1,NFICHLEC
C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD')
OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD')
CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*5
&20,*540,*550,*570,*580,*590,*630)
C
C.......... Atomic case index ..........
C
I_AT=0
IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1
IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1
IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1
IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1
IF(SPECTRO.EQ.'APC') THEN
IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1
ENDIF
C
IF(IBAS.EQ.1) THEN
IF(ITEST.EQ.0) THEN
NEQ=(2*NIV+1)**3
ELSE
NEQ=(2*NIV+3)**3
ENDIF
IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518
ENDIF
C
IF(SPECTRO.EQ.'APC') THEN
N_EL=2
ELSE
N_EL=1
ENDIF
IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
IF(I_MULT.EQ.0) THEN
LE_MIN=ABS(LI_C-ABS(LI_I-LI_A))
LE_MAX=LI_C+LI_A+LI_I
ELSE
LE_MIN=ABS(LI_C-L_MUL)
LE_MAX=LI_C+L_MUL
ENDIF
ENDIF
C
C.......... Test of the dimensions against the input values ..........
C
IF(NO.GT.NO_ST_M) GOTO 600
IF(LE_MAX.GT.LI_M) GOTO 620
C
OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD')
OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD')
IF(INTERACT.EQ.'DIPCOUL') THEN
OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD')
OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD')
ENDIF
C
C.......... Reading of the TL and radial matrix elements files ..........
C.......... (dipolar excitation or no excitation case) ..........
C
IF(INTERACT.NE.'COULOMB') THEN
IF(SPECTRO.EQ.'APC') WRITE(IUO1,418)
READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE
IF(ISPIN.EQ.0) THEN
IF(NAT1.EQ.1) THEN
WRITE(IUO1,561)
ELSE
WRITE(IUO1,560) NAT1
ENDIF
ENDIF
IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN
READ(IUI2,530) E_MIN,E_MAX,DE
ENDIF
IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN
NLG=INT(NAT1-0.0001)/4 +1
DO NN=1,NLG
NRL=4*NN
JD=4*(NN-1)+1
IF(NN.EQ.NLG) NRL=NAT1
READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL)
WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL)
ENDDO
C
C Temporary storage of LMAX. Waiting for a version of PHAGEN
C with LMAX dependent on the energy
C
DO JE=1,NE
DO JAT=1,NAT1
LMAX(JAT,JE)=LMAX(JAT,1)
ENDDO
ENDDO
C
NL1=1
DO JAT=1,NAT1
NL1=MAX0(NL1,LMAX(JAT,1)+1)
ENDDO
IF(NL1.GT.NL_M) GOTO 184
ENDIF
IF(ITL.EQ.0) READ(IUI3,101) NATR,NER
IF(ISPIN.EQ.1) THEN
READ(IUI3,106) L_IN,NATR,NER
IF(LI.NE.L_IN) GOTO 606
ENDIF
NAT2=NAT+NATA
IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180
IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182
C
C.......... DL generated by MUFPOT and RHOR given ..........
C.......... by S. M. Goldberg, C. S. Fadley ..........
C.......... and S. Kono, J. Electron Spectr. ..........
C.......... Relat. Phenom. 21, 285 (1981) ..........
C
IF(ITL.EQ.0) THEN
DO JAT=1,NAT2
IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN
READ(IUI3,102) RIEN
READ(IUI3,102) RIEN
READ(IUI3,102) RIEN
ENDIF
DO JE=1,NE
IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121
READ(IUI3,103) ENERGIE
READ(IUI3,102) RIEN
READ(IUI3,102) RIEN
READ(IUI3,102) RIEN
121 CONTINUE
DO L=0,LMAX(JAT,JE)
READ(IUI2,7) VK(JE),TL(L,1,JAT,JE)
TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,1.)*TL(L,1,
&JAT,JE))
ENDDO
IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5
DO LL=1,18
READ(IUI3,104) RH1,RH2,DEF1,DEF2
RHOR(JE,JAT,LL,1,1)=CMPLX(RH1)
RHOR(JE,JAT,LL,2,1)=CMPLX(RH2)
DLT(JE,JAT,LL,1)=CMPLX(DEF1)
DLT(JE,JAT,LL,2)=CMPLX(DEF2)
ENDDO
5 CONTINUE
ENDDO
ENDDO
ELSE
C
C.......... TL and RHOR calculated by PHAGEN ..........
C
DO JE=1,NE
NLG=INT(NAT2-0.0001)/4 +1
IF(NE.GT.1) WRITE(IUO1,563) JE
DO NN=1,NLG
NRL=4*NN
JD=4*(NN-1)+1
IF(NN.EQ.NLG) NRL=NAT2
READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL)
WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL)
ENDDO
NL1=1
DO JAT=1,NAT2
NL1=MAX0(NL1,LMAX(JAT,1)+1)
ENDDO
IF(NL1.GT.NL_M) GOTO 184
DO JAT=1,NAT2
READ(IUI2,*) DUMMY
DO L=0,LMAX(JAT,JE)
IF(LMAX_MODE.EQ.0) THEN
READ(IUI2,9) VK(JE),TLSTAR
ELSE
READ(IUI2,9) VK(JE),TLSTAR
ENDIF
TL(L,1,JAT,JE)=CONJG(TLSTAR)
VK(JE)=CONJG(VK(JE))
ENDDO
ENDDO
C
IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333
IF(JE.EQ.1) THEN
DO JDUM=1,7
READ(IUI3,102) RIEN
ENDDO
ENDIF
C
C Reading or regular (RHOR) and irregular (RHOI) radial integrals
C
C 1-2 : dipole terms
C 3-5 : quadrupole terms
C
DO JEMET=1,NEMET
C
JM=IEMET(JEMET)
READ(IUI3,105) RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHO
&R5STAR
RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR)
RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR)
RHOR(JE,JM,NNL,3,1)=CONJG(RHOR3STAR)
RHOR(JE,JM,NNL,4,1)=CONJG(RHOR4STAR)
RHOR(JE,JM,NNL,5,1)=CONJG(RHOR5STAR)
C
ENDDO
C
333 VK(JE)=VK(JE)*A
VK2(JE)=CABS(VK(JE)*VK(JE))
ENDDO
ENDIF
C
CLOSE(IUI2)
CLOSE(IUI3)
C
C.......... Suppression of possible zeros in the TL array ..........
C.......... (in case of the use of matrix inversion and ..........
C.......... for energy variations) ..........
C
IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN
CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL)
ENDIF
ENDIF
C
C.......... Reading of the TL and radial matrix elements files ..........
C.......... (Coulomb excitation case) ..........
C
IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN
IERR=0
IF(INTERACT.EQ.'COULOMB') THEN
IRD1=IUI2
IRD2=IUI3
ELSEIF(INTERACT.EQ.'DIPCOUL') THEN
IRD1=IUI7
IRD2=IUI8
ENDIF
IF(SPECTRO.EQ.'APC') WRITE(IUO1,419)
READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A
IF(ISPIN.EQ.0) THEN
IF(NAT1_A.EQ.1) THEN
WRITE(IUO1,561)
ELSE
WRITE(IUO1,560) NAT1_A
ENDIF
ENDIF
IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN
READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A
ENDIF
IF(ITL_A.EQ.1) THEN
READ(IRD2,107) LI_C2,LI_I2,LI_A2
READ(IRD2,117) LE_MIN1,N_CHANNEL
LE_MAX1=LE_MIN1+N_CHANNEL-1
IF(I_TEST_A.NE.1) THEN
IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO 610
ELSE
LI_C2=0
LI_I2=1
LI_A2=0
LE_MIN1=1
N_CHANNEL=1
ENDIF
ENDIF
IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN
NLG=INT(NAT1_A-0.0001)/4 +1
DO NN=1,NLG
NRL=4*NN
JD=4*(NN-1)+1
IF(NN.EQ.NLG) NRL=NAT1_A
READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL)
WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL)
ENDDO
C
C Temporary storage of LMAX_A. Waiting for a version of PHAGEN
C with LMAX_A dependent on the energy
C
DO JE=1,NE1_A
DO JAT=1,NAT1_A
LMAX_A(JAT,JE)=LMAX_A(JAT,1)
ENDDO
ENDDO
C
NL1_A=1
DO JAT=1,NAT1_A
NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1)
ENDDO
IF(NL1_A.GT.NL_M) GOTO 184
ENDIF
IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A
IF(ISPIN.EQ.1) THEN
READ(IRD2,106) L_IN_A,NATR_A,NER_A
IF(LI_C.NE.L_IN_A) GOTO 606
ENDIF
NAT2_A=NAT+NATA
NAT2=NAT2_A
IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180
IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) GOTO
&182
C
C.......... DL generated by MUFPOT and RHOR given ..........
C.......... by S. M. Goldberg, C. S. Fadley ..........
C.......... and S. Kono, J. Electron Spectr. ..........
C.......... Relat. Phenom. 21, 285 (1981) ..........
C
IF(ITL_A.EQ.0) THEN
CONTINUE
ELSE
C
C.......... TL_A and RHOR_A calculated by PHAGEN ..........
C
DO JE=1,NE_A
NLG=INT(NAT2_A-0.0001)/4 +1
IF(NE_A.GT.1) WRITE(IUO1,563) JE
DO NN=1,NLG
NRL=4*NN
JD=4*(NN-1)+1
IF(NN.EQ.NLG) NRL=NAT2_A
READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL)
WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL)
ENDDO
DO JAT=1,NAT2_A
READ(IRD1,*) DUMMY
DO L=0,LMAX_A(JAT,JE)
IF(LMAX_MODE_A.EQ.0) THEN
READ(IRD1,9) VK_A(JE),TLSTAR
ELSE
READ(IRD1,7) VK_A(JE),TLSTAR
ENDIF
TL_A(L,1,JAT,JE)=CONJG(TLSTAR)
VK_A(JE)=CONJG(VK_A(JE))
ENDDO
ENDDO
C
IF(IFTHET_A.EQ.1) GOTO 331
DO LE=LE_MIN,LE_MAX
DO JEMET=1,NEMET
JM=IEMET(JEMET)
READ(IRD2,109) L_E,LB_MIN,LB_MAX
IF(I_TEST_A.EQ.1) THEN
L_E=1
LB_MIN=0
LB_MAX=1
ENDIF
IF(LE.NE.L_E) IERR=1
L_BOUNDS(L_E,1)=LB_MIN
L_BOUNDS(L_E,2)=LB_MAX
DO LB=LB_MIN,LB_MAX
READ(IRD2,108) L_A,RAD_D,RAD_E
RHOR_A(LE,JM,L_A,1,1)=RAD_D
RHOR_A(LE,JM,L_A,2,1)=RAD_E
IF(I_TEST_A.EQ.1) THEN
IF(LB.EQ.LB_MIN) THEN
RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0)
RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0)
ELSEIF(LB.EQ.LB_MAX) THEN
RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0)
RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0)
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
331 VK_A(JE)=VK_A(JE)*A
VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE))
ENDDO
ENDIF
C
CLOSE(IRD1)
CLOSE(IRD2)
C
C.......... Suppression of possible zeros in the TL array ..........
C.......... (in case of the use of matrix inversion and ..........
C.......... for energy variations) ..........
C
IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN
CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL)
ENDIF
IF(SPECTRO.EQ.'APC') WRITE(IUO1,420)
C
ENDIF
C
C.......... Check of the consistency of the two TL and radial ..........
C.......... matrix elements for APECS ..........
C
IF(SPECTRO.EQ.'APC') THEN
C
I_TL_FILE=0
I_RD_FILE=0
C
IF(NAT1.NE.NAT1_A) I_TL_FILE=1
IF(NE1.NE.NE1_A) I_TL_FILE=1
IF(ITL.NE.ITL_A) I_TL_FILE=1
IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1
C
IF(LI_C.NE.LI_C2) I_RD_FILE=1
IF(LI_I.NE.LI_I2) I_RD_FILE=1
IF(LI_A.NE.LI_A2) I_RD_FILE=1
C
IF(I_TL_FILE.EQ.1) GOTO 608
IF(I_RD_FILE.EQ.1) GOTO 610
IF(IERR.EQ.1) GOTO 610
C
ENDIF
C
C.......... Calculation of the scattering factor (only) ..........
C
IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8
IF(IFTHET.EQ.1) THEN
CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE)
ELSEIF(IFTHET_A.EQ.1) THEN
c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A)
ENDIF
WRITE(IUO1,57)
STOP
C
8 IF(IBAS.EQ.0) THEN
C
C............... Reading of an external cluster ...............
C
C
C Cluster originating from CLUSTER_NEW.F : IPHA=0
C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems)
C Other cluster : the first line must be text; then
C free format : Atomic number,X,Y,Z,number
C of the corresponding prototypical atom ;
C All atoms corresponding to the same
C prototypical atom must follow each other.
C Moreover, the blocks of equivalent atoms
C must be ordered by increasing number of
C prototypical atom.
C
VALZ_MIN=1000.0
VALZ_MAX=-1000.0
C
OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD')
READ(IUI4,778,ERR=892) IPHA
GOTO 893
892 IPHA=3
IF(UNIT.EQ.'ANG') THEN
CUNIT=1./A
TUNIT='ANGSTROEMS'
ELSEIF(UNIT.EQ.'LPU') THEN
CUNIT=1.
TUNIT='UNITS OF THE LATTICE PARAMETER'
ELSEIF(UNIT.EQ.'ATU') THEN
CUNIT=BOHR/A
TUNIT='ATOMIC UNITS'
ELSE
GOTO 890
ENDIF
893 NATCLU=0
DO JAT=1,NAT2
NATYP(JAT)=0
ENDDO
IF(IPHA.EQ.0) THEN
CUNIT=1.
TUNIT='UNITS OF THE LATTICE PARAMETER'
ELSEIF(IPHA.EQ.1) THEN
CUNIT=BOHR/A
TUNIT='ATOMIC UNITS'
IEMET(1)=1
ELSEIF(IPHA.EQ.2) THEN
CUNIT=1./A
TUNIT='ANGSTROEMS'
IEMET(1)=1
ENDIF
IF(IPRINT.EQ.2) THEN
IF(I_AT.NE.1) THEN
WRITE(IUO1,558) IUI4,TUNIT
IF(IPHA.EQ.3) WRITE(IUO1,549)
ENDIF
ENDIF
JATM=0
DO JLINE=1,10000
IF(IPHA.EQ.0) THEN
READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT
ELSEIF(IPHA.EQ.1) THEN
READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
ELSEIF(IPHA.EQ.2) THEN
READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT
ELSEIF(IPHA.EQ.3) THEN
READ(IUI4,*,END=780) NN,X,Y,Z,JAT
ENDIF
JATM=MAX0(JAT,JATM)
NATCLU=NATCLU+1
IF(IPHA.NE.3) THEN
CHEM(JAT)=R
ELSE
CHEM(JAT)='XX'
ENDIF
NZAT(JAT)=NN
NATYP(JAT)=NATYP(JAT)+1
COORD(1,NATCLU)=X*CUNIT
COORD(2,NATCLU)=Y*CUNIT
COORD(3,NATCLU)=Z*CUNIT
VALZ(NATCLU)=Z*CUNIT
IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN
WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,NATCLU),COORD
&(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT)
ENDIF
ENDDO
780 NBZ=NATCLU
IF(JATM.NE.NAT) GOTO 514
CLOSE(IUI4)
C
IF(NATCLU.GT.NATCLU_M) GOTO 510
DO JA1=1,NATCLU
DO JA2=1,NATCLU
DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(COORD(2
&,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**2)
IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO 895
ENDDO
ENDDO
C
D_UP=VALZ_MAX-VALZ(1)
D_DO=VALZ(1)-VALZ_MIN
IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN
I_INV=1
ELSE
I_INV=0
ENDIF
ELSE
C
C............... Construction of an internal cluster ...............
C
CALL BASE
CALL ROTBAS(ROT)
IF(IVG0.EQ.2) THEN
NMAX=NIV+1
ELSE
NMAX=(2*NIV+1)**3
ENDIF
IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN
WRITE(IUO1,37)
WRITE(IUO1,38) NIV
DO NUM=1,NMAX
CALL NUMAT(NUM,NIV,IA,IB,IC)
WRITE(IUO1,17) NUM,IA,IB,IC
ENDDO
WRITE(IUO1,39)
ENDIF
CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,NBZ,N
&AT2,NCOUCH,NMAX)
IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN
CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,NCOUCH)
&
IF(IREL.EQ.1) THEN
DO JP=1,NPLAN
VAL(JP)=VAL2(JP)
ENDDO
ENDIF
ENDIF
ENDIF
C
C Storage of the extremal values of x and y for each plane. They define
C the exterior of the cluster when a new cluster has to be build to
C support a point-group
C
IF(I_GR.GE.1) THEN
IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
WRITE(IUO1,50) NPLAN
DO K=1,NPLAN
WRITE(IUO1,29) K,VAL(K)
X_MAX(K)=0.
X_MIN(K)=0.
Y_MAX(K)=0.
Y_MIN(K)=0.
ENDDO
ENDIF
DO JAT=1,NATCLU
X=COORD(1,JAT)
Y=COORD(2,JAT)
Z=COORD(3,JAT)
DO JPLAN=1,NPLAN
IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN
X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN))
X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN))
Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN))
Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN))
ENDIF
ENDDO
ENDDO
ENDIF
C
C Instead of the symmetrization of the cluster (this version only)
C
N_PROT=NAT
NAT_ST=0
DO JTYP=1,JATM
NB_AT=NATYP(JTYP)
IF(NB_AT.GT.NAT_EQ_M) GOTO 614
DO JA=1,NB_AT
NAT_ST=NAT_ST+1
NCORR(JA,JTYP)=NAT_ST
ENDDO
ENDDO
DO JC=1,3
DO JA=1,NATCLU
SYM_AT(JC,JA)=COORD(JC,JA)
ENDDO
ENDDO
C
C Checking surface-like atoms for mean square displacements
C calculations
C
CALL CHECK_VIB(NAT2)
C
C.......... Set up of the variables used for an internal ..........
C.......... calculation of the mean free path and/or of ..........
C.......... the mean square displacements ..........
C
IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN
DO JTYP=1,NAT2
XMT(JTYP)=XMAT(NZAT(JTYP))
RHOT(JTYP)=RHOAT(NZAT(JTYP))
ENDDO
XMTA=XMT(1)
RHOTA=RHOT(1)
NZA=NZAT(1)
ENDIF
IF(IDCM.GT.0) THEN
CALL CHNOT(3,VECBAS,VEC)
DO J=1,3
VB1(J)=VEC(J,1)
VB2(J)=VEC(J,2)
VB3(J)=VEC(J,3)
ENDDO
CPR=1.
CALL PRVECT(VB2,VB3,VBS,CPR)
VM=PRSCAL(VB1,VBS)
QD=(6.*PI*PI*NAT/VM)**(1./3.)
ENDIF
C
C.......... Writing of the contents of the cluster, ..........
C.......... of the position of the different planes ..........
C.......... and of their respective absorbers in ..........
C.......... the control file IUO1 ..........
C
IF(I_AT.EQ.1) GOTO 153
IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN
WRITE(IUO1,40)
NCA=0
DO J=1,NAT
DO I=1,NMAX
NCA=NCA+1
WRITE(IUO1,20) J,I
WRITE(IUO1,21) (ATOME(L,NCA),L=1,3)
K=IRE(NCA,1)
IF(K.EQ.0) THEN
WRITE(IUO1,22)
ELSE
WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2)
ENDIF
ENDDO
ENDDO
WRITE(IUO1,41)
ENDIF
IF(IBAS.EQ.1) THEN
WRITE(IUO1,24)
NATCLU=0
DO I=1,NAT
NN=NATYP(I)
NATCLU=NATCLU+NATYP(I)
WRITE(IUO1,26) NN,I
ENDDO
IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3
WRITE(IUO1,782) NATCLU
IF(NATCLU.GT.NATCLU_M) GOTO 516
IF(IPRINT.EQ.3) WRITE(IUO1,559)
IF(IPRINT.EQ.3) THEN
NBTA=0
DO JT=1,NAT2
NBJT=NATYP(JT)
DO JN=1,NBJT
NBTA=NBTA+1
WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),COORD(3,N
&BTA),JT,JN,CHEM(JT)
ENDDO
ENDDO
ENDIF
ENDIF
153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN
CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56)
ENDIF
IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN
CALL ORDRE(NBZ,VALZ,NPLAN,VAL)
IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN
DO K=1,NPLAN
IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K)
ENDDO
ENDIF
C
IF(I_AT.EQ.0) WRITE(IUO1,30)
IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN
WRITE(IUO1,31) (IEMET(J),J=1,NEMET)
ENDIF
ZEM=1.E+20
DO L=1,NPLAN
Z=VAL(L)
DO JEMED=1,NEMET
CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93)
IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET(3)
IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3)
GO TO 33
93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM
33 CONTINUE
ENDDO
ENDDO
C
C.......... Loop on the electrons involved in the ..........
C.......... spectroscopy : N_EL = 1 for PHD, XAS ..........
C.......... LEED or AED and N_EL = 2 for APC ..........
C
DO J_EL=1,N_EL
C
C.......... Writing the information on the spectroscopies ..........
C.......... in the control file IUO1 ..........
C
IF(SPECTRO.EQ.'XAS') GOTO 566
IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,236)
ELSE
WRITE(IUO1,248)
ENDIF
ENDIF
IF(ITHETA.EQ.1) WRITE(IUO1,245)
IF(I_TEST.EQ.1) WRITE(IUO1,234)
ENDIF
C
C---------- Photoelectron diffraction case (PHD) ----------
C
IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
IF(SPECTRO.EQ.'PHD') THEN
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,35)
ELSE
WRITE(IUO1,246)
ENDIF
ENDIF
IF(ITHETA.EQ.1) WRITE(IUO1,44)
IF(IE.EQ.1) WRITE(IUO1,58)
IF(INITL.EQ.0) WRITE(IUO1,118)
IF(I_TEST.EQ.1) WRITE(IUO1,234)
ENDIF
IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN
WRITE(IUO1,418)
WRITE(IUO1,18)
ENDIF
IF(J_EL.EQ.2) GOTO 222
IF(IPRINT.GT.0) THEN
WRITE(IUO1,92)
WRITE(IUO1,91)
IF(ISPIN.EQ.0) THEN
WRITE(IUO1,335)
ELSE
WRITE(IUO1,336)
ENDIF
WRITE(IUO1,91)
IF(IPOTC.EQ.0) THEN
WRITE(IUO1,339)
ELSE
WRITE(IUO1,334)
ENDIF
WRITE(IUO1,91)
IF(INITL.NE.0) THEN
WRITE(IUO1,337)
WRITE(IUO1,91)
IF(IPOL.EQ.0) THEN
WRITE(IUO1,88)
ELSEIF(ABS(IPOL).EQ.1) THEN
WRITE(IUO1,87)
ELSEIF(IPOL.EQ.2) THEN
WRITE(IUO1,89)
ENDIF
WRITE(IUO1,91)
IF(IDICHR.GT.0) THEN
WRITE(IUO1,338)
ENDIF
WRITE(IUO1,91)
WRITE(IUO1,92)
WRITE(IUO1,90)
WRITE(IUO1,43) THLUM,PHILUM
IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN
WRITE(IUO1,45)
ENDIF
ENDIF
C
IF(INITL.EQ.2) THEN
WRITE(IUO1,79) LI,LI-1,LI+1
IF(I_SO.EQ.1) THEN
WRITE(IUO1,80) S_O
ENDIF
DO JE=1,NE
DO JEM=1,NEMET
JTE=IEMET(JEM)
IF(ISPIN.EQ.0) THEN
WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,1,1),RHOR(JE,JTE
&,NNL,2,1)
IF(ITL.EQ.0) THEN
WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1),DLT(JE,JTE,N
&NL,2)
ENDIF
ENDIF
ENDDO
ENDDO
ELSEIF(INITL.EQ.-1) THEN
WRITE(IUO1,82) LI,LI-1
IF(I_SO.EQ.1) THEN
WRITE(IUO1,80) S_O
ENDIF
DO JE=1,NE
DO JEM=1,NEMET
JTE=IEMET(JEM)
IF(ISPIN.EQ.0) THEN
WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,1,1)
IF(ITL.EQ.0) THEN
WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,1)
ENDIF
ENDIF
ENDDO
ENDDO
ELSEIF(INITL.EQ.1) THEN
WRITE(IUO1,82) LI,LI+1
IF(I_SO.EQ.1) THEN
WRITE(IUO1,80) S_O
ENDIF
DO JE=1,NE
DO JEM=1,NEMET
JTE=IEMET(JEM)
IF(ISPIN.EQ.0) THEN
WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,2,1)
IF(ITL.EQ.0) THEN
WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,2)
ENDIF
ENDIF
ENDDO
ENDDO
ENDIF
C
IF(I_AT.EQ.0) THEN
IF(INV(J_EL).EQ.0) THEN
IF(NDIF.EQ.1) THEN
IF(ISPHER.EQ.1) THEN
WRITE(IUO1,83)
ELSEIF(ISPHER.EQ.0) THEN
WRITE(IUO1,84)
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,97) NDIF
ELSE
WRITE(IUO1,98) NDIF
ENDIF
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,122)
ELSE
WRITE(IUO1,120)
ENDIF
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,85)
ELSE
WRITE(IUO1,86)
ENDIF
ENDIF
C
ENDIF
222 CONTINUE
ENDIF
C
C---------- LEED case (LED) ----------
C
IF(SPECTRO.EQ.'LED') THEN
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,252)
ELSE
WRITE(IUO1,258)
ENDIF
ENDIF
IF(ITHETA.EQ.1) WRITE(IUO1,254)
IF(IE.EQ.1) WRITE(IUO1,256)
IF(IPRINT.GT.0) THEN
WRITE(IUO1,92)
WRITE(IUO1,91)
IF(ISPIN.EQ.0) THEN
WRITE(IUO1,335)
ELSE
WRITE(IUO1,336)
ENDIF
WRITE(IUO1,91)
IF(IPOTC.EQ.0) THEN
WRITE(IUO1,339)
ELSE
WRITE(IUO1,334)
ENDIF
WRITE(IUO1,91)
WRITE(IUO1,92)
WRITE(IUO1,260)
WRITE(IUO1,261) THLUM,PHILUM
IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN
WRITE(IUO1,45)
ENDIF
C
IF(I_AT.EQ.0) THEN
IF(INV(J_EL).EQ.0) THEN
IF(NDIF.EQ.1) THEN
IF(ISPHER.EQ.1) THEN
WRITE(IUO1,83)
ELSEIF(ISPHER.EQ.0) THEN
WRITE(IUO1,84)
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,97) NDIF
ELSE
WRITE(IUO1,98) NDIF
ENDIF
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,122)
ELSE
WRITE(IUO1,120)
ENDIF
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,85)
ELSE
WRITE(IUO1,86)
ENDIF
ENDIF
C
ENDIF
ENDIF
C
C---------- Auger diffraction case (AED) ----------
C
IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
IF(SPECTRO.EQ.'AED') THEN
IF(IPHI_A.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,235)
ELSE
WRITE(IUO1,247)
ENDIF
ENDIF
IF(ITHETA_A.EQ.1) WRITE(IUO1,244)
IF(I_TEST_A.EQ.1) WRITE(IUO1,234)
ENDIF
IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN
WRITE(IUO1,419)
WRITE(IUO1,18)
ENDIF
IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN
IF(IPRINT.GT.0) THEN
WRITE(IUO1,92)
WRITE(IUO1,91)
IF(ISPIN.EQ.0) THEN
WRITE(IUO1,335)
ELSE
WRITE(IUO1,336)
ENDIF
WRITE(IUO1,91)
IF(IPOTC_A.EQ.0) THEN
WRITE(IUO1,339)
ELSE
WRITE(IUO1,334)
ENDIF
WRITE(IUO1,91)
WRITE(IUO1,92)
WRITE(IUO1,95) AUGER
CALL AUGER_MULT
IF(I_MULT.EQ.0) THEN
WRITE(IUO1,154)
ELSE
WRITE(IUO1,155) MULTIPLET
ENDIF
C
DO JEM=1,NEMET
JTE=IEMET(JEM)
WRITE(IUO1,112) JTE
DO LE=LE_MIN,LE_MAX
WRITE(IUO1,119) LE
LA_MIN=L_BOUNDS(LE,1)
LA_MAX=L_BOUNDS(LE,2)
DO LA=LA_MIN,LA_MAX
IF(ISPIN.EQ.0) THEN
WRITE(IUO1,115) LA,RHOR_A(LE,JTE,LA,1,1),RHOR_A(LE
&,JTE,LA,2,1)
ENDIF
ENDDO
ENDDO
ENDDO
C
IF(I_AT.EQ.0) THEN
IF(INV(J_EL).EQ.0) THEN
IF(NDIF.EQ.1) THEN
IF(ISPHER.EQ.1) THEN
WRITE(IUO1,83)
ELSEIF(ISPHER.EQ.0) THEN
WRITE(IUO1,84)
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,97) NDIF
ELSE
WRITE(IUO1,98) NDIF
ENDIF
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,122)
ELSE
WRITE(IUO1,120)
ENDIF
ENDIF
ELSE
IF(ISPHER.EQ.0) THEN
WRITE(IUO1,85)
ELSE
WRITE(IUO1,86)
ENDIF
ENDIF
C
ENDIF
ENDIF
ENDIF
C
C.......... Check of the dimensioning of the treatment routine ..........
C
CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,NPH
&I_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
C
C.......... Call of the subroutine performing either ..........
C.......... the PhD, LEED, AED, EXAFS or APECS calculation ..........
C
566 IF(ISPIN.EQ.0) THEN
IF(SPECTRO.EQ.'PHD') THEN
CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,NATC
&LU,NFICHLEC,JFICH,NP)
ELSEIF(SPECTRO.EQ.'LED') THEN
c CALL LEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c 1 NATCLU,NFICHLEC,JFICH,NP)
ELSEIF(SPECTRO.EQ.'AED') THEN
c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
ELSEIF(SPECTRO.EQ.'XAS') THEN
c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP)
ELSEIF(SPECTRO.EQ.'APC') THEN
c IF(J_EL.EQ.1) THEN
c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c 1 NATCLU,NFICHLEC,JFICH,NP)
c ELSEIF(J_EL.EQ.2) THEN
c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A,
c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
c ENDIF
ENDIF
ELSEIF(ISPIN.EQ.1) THEN
c IF(SPECTRO.EQ.'PHD') THEN
c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,
c 1 NATCLU,NFICHLEC,JFICH,NP)
c ELSEIF(SPECTRO.EQ.'AED') THEN
c CALL AEDDIF_SP
c ELSEIF(SPECTRO.EQ.'XAS') THEN
c CALL XASDIF_SP
c ENDIF
continue
ENDIF
C
C.......... End of the MS calculation : ..........
C.......... direct exit or treatment of the results ..........
C
C
C.......... End of the loop on the electrons ..........
C
ENDDO
C
IF(SPECTRO.EQ.'PHD') THEN
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,52)
ELSE
WRITE(IUO1,249)
ENDIF
ENDIF
IF(ITHETA.EQ.1) WRITE(IUO1,49)
IF(IE.EQ.1) WRITE(IUO1,59)
ELSEIF(SPECTRO.EQ.'LED') THEN
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,253)
ELSE
WRITE(IUO1,259)
ENDIF
ENDIF
IF(ITHETA.EQ.1) WRITE(IUO1,255)
IF(IE.EQ.1) WRITE(IUO1,257)
ELSEIF(SPECTRO.EQ.'XAS') THEN
WRITE(IUO1,51)
ELSEIF(SPECTRO.EQ.'AED') THEN
IF(IPHI_A.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,237)
ELSE
WRITE(IUO1,250)
ENDIF
ENDIF
IF(ITHETA_A.EQ.1) WRITE(IUO1,238)
ELSEIF(SPECTRO.EQ.'APC') THEN
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,239)
ELSE
WRITE(IUO1,251)
ENDIF
ENDIF
IF(ITHETA.EQ.1) WRITE(IUO1,240)
ENDIF
C
CLOSE(ICOM)
IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
WRITE(IUO1,562)
ENDIF
IF(ISOM.EQ.0) CLOSE(IUO2)
IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1)
C
C.......... End of the loop on the data files ..........
C
ENDDO
C
IF(ISOM.NE.0) THEN
JFF=1
IF(ISPIN.EQ.0) THEN
IF(SPECTRO.NE.'XAS') THEN
CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP)
ELSE
c CALL TREAT_XAS(ISOM,NFICHLEC,NP)
ENDIF
ELSEIF(ISPIN.EQ.1) THEN
c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP)
c ELSEIF(SPECTRO.EQ.'XAS') THEN
c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP)
c ENDIF
continue
ENDIF
ENDIF
C
IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
IF(ISOM.NE.0) CLOSE(IUO2)
C STOP
GOTO 999
C
1 WRITE(IUO1,60)
STOP
2 WRITE(IUO1,61)
STOP
55 WRITE(IUO1,65)
STOP
56 WRITE(IUO1,64)
STOP
74 WRITE(IUO1,75)
STOP
99 WRITE(IUO1,100)
STOP
180 WRITE(IUO1,181)
STOP
182 WRITE(IUO1,183)
STOP
184 WRITE(IUO1,185)
STOP
504 WRITE(IUO1,505)
STOP
510 WRITE(IUO1,511) IUI4
STOP
514 WRITE(IUO1,515)
STOP
516 WRITE(IUO1,517)
STOP
518 WRITE(IUO1,519)
WRITE(IUO1,889)
STOP
520 WRITE(IUO1,521)
STOP
540 WRITE(IUO1,541)
STOP
550 WRITE(IUO1,551)
STOP
570 WRITE(IUO1,571)
STOP
580 WRITE(IUO1,581)
STOP
590 WRITE(IUO1,591)
STOP
600 WRITE(IUO1,601)
STOP
602 WRITE(IUO1,603)
STOP
604 WRITE(IUO1,605)
STOP
606 WRITE(IUO1,607)
STOP
608 WRITE(IUO1,609)
STOP
610 WRITE(IUO1,611)
STOP
614 WRITE(IUO1,615) NB_AT
STOP
620 WRITE(IUO1,621) LE_MAX
STOP
630 WRITE(IUO1,631)
STOP
890 WRITE(IUO1,891)
STOP
895 WRITE(IUO1,896) JA1,JA2
C
3 FORMAT(5(5X,I4))
7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9)
9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6)
17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',':
&(',I3,',',I3,',',I3,')')
18 FORMAT(' ',/)
20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5)
21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,',
&',F7.3,')')
22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER')
23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,'
&,',F7.3,')',5X,'NEW NUMBER : ',I4)
24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/)
26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2)
29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3)
30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/)
31 FORMAT(38X,10(I2,3X),//)
34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS P
&OSITIONED AT (',F7.3,',',F7.3,',',F7.3,')')
35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL PHOTO
&ELECTRON DIFFRACTION CALCULATION #####', '#####',/////)
36 FORMAT(/////,'########## BEGINNING ', 'OF THE EX
&AFS CALCULATION ##########',/////)
37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE A
&TOMS GENERATED +++++++++++++++++++')
38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///)
39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++',
&'++++++++++++++++++++++++++++++++',/////)
40 FORMAT(/////,'======================', ' CONTENTS OF THE RE
&DUCED CLUSTER ======================',///)
41 FORMAT(///,'====================================================',
&'============================',/////)
43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,'
&DEGREES')
44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR PHOTOELECTR
&ON DIFFRACTION CALCULATION #####', '#####',/////)
45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE SURF
&ACE)')
49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON DIFFRA
&CTION CALCULATION ##########')
50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :')
51 FORMAT(/////,'########## END OF THE ', 'EXAFS CALCU
&LATION ##########')
52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON DI
&FFRACTION CALCULATION #####','#####')
57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE')
58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE STRUCTURE
& OSCILLATIONS CALCULATION #####', '#####',/////)
59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE OSCILLATI
&ONS CALCULATION #####','#####')
60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M)
&- CHECK THE DIMENSIONING >>>>>>>>>>')
61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', '
& >>>>>>>>>>')
64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ','CLUST
&ER HAS NOT CONVERGED YET >>>>>>>>>>')
65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ',
&'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>')
75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ',
& 'IN MAIN ET READ_DATA >>>>>>>>>>')
79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ',
& I1,',',I1,/)
80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',A3
&,')',//)
81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)')
82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1)
83 FORMAT(//,32X,'(SPHERICAL WAVES)')
84 FORMAT(//,34X,'(PLANE WAVES)')
85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)')
86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)')
87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +')
88 FORMAT(24X,'+ NON POLARIZED LIGHT +')
89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +')
90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/)
91 FORMAT(24X,'+',35X,'+')
92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++')
94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS PR
&ESENT IN THIS PLANE')
95 FORMAT(////,31X,'AUGER LINE :',A6,//)
97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')')
&
98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',I1,
&')')
100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE',' >>
&>>>>>>>>')
101 FORMAT(24X,I3,24X,I3)
102 FORMAT(A1)
103 FORMAT(31X,F7.2)
104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5)
105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,E1
&2.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9)
106 FORMAT(12X,I3,12X,I3,12X,I3)
107 FORMAT(5X,I2,5X,I2,5X,I2)
108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5)
109 FORMAT(5X,I2,12X,I2,11X,I2)
110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
& :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//)
111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
&: (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')')
112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,'
&: ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)',/,
&8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//)
113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ',
* 'TYPE ',I2,' : (',F8.5,',',F8.5,')')
114 FORMAT(/)
115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.5
&,')')
117 FORMAT(12X,I2,5X,I2)
118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/)
119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE INTEGRAL'
&)
120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ','I
&NVERSION)')
122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ','INVER
&SION)')
125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4)
154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,'
&',/,' ')
155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ','LINE'
&,' ',/,' ',/,' ')
181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A
&ND PHASE SHIFTS FILES >>>>>>>>>>')
183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A
&ND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>')
185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ','FILE
& >>>>>>>>>>')
234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX ELEME
&NTS TAKEN INTO ACCOUNT <-----',///)
235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL AUGER
& DIFFRACTION CALCULATION #####', '#####',/////)
236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL APECS
& DIFFRACTION CALCULATION #####', '#####',/////)
237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER DIFFR
&ACTION CALCULATION #####', '#####',/////)
238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER DIFFRACT
&ION CALCULATION #####', '#####',/////)
239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS DIFFR
&ACTION CALCULATION #####', '#####',/////)
240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS DIFFRACT
&ION CALCULATION #####', '#####',/////)
244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER DI
&FFRACTION CALCULATION #####', '#####',/////)
245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS DI
&FFRACTION CALCULATION #####', '#####',/////)
246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE PHOT
&OELECTRON DIFFRACTION CALCULATION ','##########',/////)
247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE AUGE
&R DIFFRACTION CALCULATION ', '##########',/////)
248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE APEC
&S DIFFRACTION CALCULATION ', '##########',/////)
249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON D
&IFFRACTION CALCULATION #####','#####')
250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER DIFF
&RACTION CALCULATION #####', '#####',/////)
251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS DIFF
&RACTION CALCULATION #####', '#####',/////)
252 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL LEED
&CALCULATION #####', '#####',/////)
253 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL LEED CALCUL
&ATION #####', '#####',/////)
254 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR LEED CAL
&CULATION #####', '#####',/////)
255 FORMAT(/////,6X,'########## END ', 'OF THE POLAR LEED CALCULATI
&ON #####', '#####',/////)
256 FORMAT(/////,5X,'########## BEGINNING ', 'OF THE ENERGY LEED CA
&LCULATION #####', '#####',/////)
257 FORMAT(/////,5X,'########## END ', 'OF THE ENERGY LEED CALCULAT
&ION #####', '#####',/////)
258 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE LEED
& CALCULATION ', '##########',/////)
259 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE LEED CALCULATIO
&N #####','#####')
260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/)
261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ',F6.2,' DE
&GREES')
334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +')
335 FORMAT(24X,'+ STANDARD +')
336 FORMAT(24X,'+ SPIN-POLARIZED +')
337 FORMAT(24X,'+ WITH +')
338 FORMAT(24X,'+ IN DICHROIC MODE +')
339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +')
418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','-----
&-------------------')
419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','-----
&-------------------')
420 FORMAT(///,9X,'----------------------------------------------','--
&--------------------')
444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(',
&F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')')
445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.5
&,',',F8.5,')')
505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE DIME
&NSIONING >>>>>>>>>>')
511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ','CONSIS
&TENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' >>>>>>>>>>')
515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ','N
&AT IN THE DATA AND CLUSTER FILES >>>>>>>>>>')
517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ','
&IBWD >>>>>>>>>>')
519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT',' CONSIS
&TENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE >>>>>>>>>>
&')
521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH',
&' THE VALUE OF LI >>>>>>>>>>')
530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4)
535 FORMAT(29X,F8.5,1X,F8.5)
541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ','CORR
&ESPOND TO NAT >>>>>>>>>>')
543 FORMAT(5X,F12.9,5X,F12.9)
549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM'
&,/)
551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ','CORRES
&POND TO NAT >>>>>>>>>>')
555 FORMAT(4(7X,I2))
556 FORMAT(28X,4(I2,5X))
557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,A2)
&
558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' :
&',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,'A
&TOM',/)
559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' N
&o ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/)
560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL A
&TOMS : ',//)
561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM :
& ',//)
562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',13X
&,'oooooooooooooooo',///)
563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/)
571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ','CORR
&ESPOND TO NAT >>>>>>>>>>')
581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD A
&ND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>')
591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT CON
&SISTENT WITH THE INPUT DATA FILE >>>>>>>>>>')
601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ','>
&>>>>>>>>>',//)
603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ',
&'.inc FILE >>>>>>>>>>',//)
605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ','>>>>
&>>>>>>',//)
607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ',
&'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS FILE
& >>>>>>>>>>',//)
609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ','>>>
&>>>>>>>',//)
611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ','ELECTR
&ON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',17X,'WITH T
&HE INPUT DATA FILE ',16X,'>>>>>>>>>>',//)
613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ','TH
&E DIMENSIONNING FILE >>>>>>>>>>',//)
615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ','
&THE DIMENSIONNING FILE >>>>>>>>>>',//)
621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ','THE
&DIMENSIONNING FILE >>>>>>>>>>',//)
631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE IDE
&NTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH ELECTRONS IN
& CLUSTER ROTATION MODE',' >>>>>>>>>>',//)
776 FORMAT(I2)
777 FORMAT(A24)
778 FORMAT(30X,I1)
779 FORMAT(11X,A2,5X,I2,3F10.4,I5)
782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,' ATOMS
&')
889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M >>
&>>>>>>>>')
891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''','UNIT
&S >>>>>>>>>>')
896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' AT
&OMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' ARE
& IDENTICAL >>>>>>>>>>')
C
999 END
C
C=======================================================================
C
SUBROUTINE AMAS(NIV,ATOME,COORD,VALZ,ISURF,COUPUR,ROT,IRE,NATYP,NB
&Z,NAT2,NCOUCH,NMAX)
C
C This routine generates a cluster from the knowledge of its
C lattice vectors
C
USE DIM_MOD
C
USE ADSORB_MOD , NCOUCH1 => NCOUCH
USE BASES_MOD
USE MILLER_MOD , IM1 => IH, IM2 => IK, IM3 => II, IM4 => IL
USE OUTUNITS_MOD
USE RESEAU_MOD
C
DIMENSION VALZ(NATCLU_M)
DIMENSION ROT(3,3),IRE(NATCLU_M,2),NATYP(NATM),ITA(NATCLU_M)
DIMENSION ATOME(3,NATCLU_M),ATRSU(3,NATCLU_M),COORD(3,NATCLU_M)
DIMENSION ROTINV(3,3),XINIT(3,1),XFIN(3,1)
C
C
C
NCOUCH=0
WRITE(IUO1,10) ISURF
10 FORMAT(//,18X,'ATOM (0,0,0) ON THE SURFACE PLANE IS OF TYPE ',I2)
NBZ=0
CALL INVMAT(ROT,ROTINV)
IF(IVG0.EQ.0) THEN
CALL CHBASE(NATP_M,ATBAS)
ENDIF
NB1=0
NB2=0
DO NTYP=1,NAT
NBAT=0
DO NUM=1,NMAX
NB1=NB1+1
IRE(NB1,1)=0
IRE(NB1,2)=0
IF(IVG0.LE.1) THEN
CALL NUMAT(NUM,NIV,IA,IB,IC)
ELSE
BSURA=1.
CSURA=1.
ENDIF
IF(IVG0.LE.1) THEN
XA=FLOAT(IA)
XB=FLOAT(IB)
XC=FLOAT(IC)
ELSEIF(IVG0.EQ.2) THEN
XA=FLOAT(NUM-1)
XB=FLOAT(NUM-1)
XC=FLOAT(NUM-1)
ENDIF
IF(IVG0.EQ.1) THEN
IF(IVN(1).EQ.0) THEN
ITA(NUM)=IA
ELSEIF(IVN(2).EQ.0) THEN
ITA(NUM)=IB
ELSEIF(IVN(3).EQ.0) THEN
ITA(NUM)=IC
ENDIF
IF((ITA(NUM).EQ.ITA(NUM-1)).AND.(NUM.GT.1)) GOTO 30
ENDIF
DO J=1,3
K=J+3*(NTYP-1)
O=ATBAS(K)
ATOME(J,NB1)=O+XA*VECBAS(J)+XB*VECBAS(J+3)+XC*VECBAS(J+6)
ENDDO
DO I=1,3
M=I+3*(ISURF-1)
XINIT(I,1)=ATOME(I,NB1)-ATBAS(M)
ENDDO
CALL MULMAT(ROTINV,3,3,XINIT,3,1,XFIN)
DO I=1,3
ATRSU(I,NB1)=XFIN(I,1)
ENDDO
CALL TEST1(COUPUR,NB1,NB2,ATRSU,COORD,VALZ,NBAT,IRE,NBZ)
30 CONTINUE
ENDDO
NATYP(NTYP)=NBAT
ENDDO
IF(IADS.GE.1) THEN
N0=NBZ
DO JADS=1,NADS1
NB1=NB1+1
DO I=1,3
COORD(I,NB1)=ADS(I,JADS)
ENDDO
N1=0
DO N=1,N0
D=ABS(COORD(3,NB1)-VALZ(N))
IF(D.LT.0.0001) N1=N1+1
ENDDO
IF(N1.EQ.0) THEN
N0=N0+1
VALZ(N0)=COORD(3,NB1)
ENDIF
ENDDO
NANEW1=NADS1+NADS2
NATYP(NAT+1)=NADS1
IF(NANEW1.EQ.NADS1) GOTO 99
DO JADS=NADS1+1,NANEW1
NB1=NB1+1
DO I=1,3
COORD(I,NB1)=ADS(I,JADS)
ENDDO
N1=0
DO N=1,N0
D=ABS(COORD(3,NB1)-VALZ(N))
IF(D.LT.0.0001) N1=N1+1
ENDDO
IF(N1.EQ.0) THEN
N0=N0+1
VALZ(N0)=COORD(3,NB1)
ENDIF
ENDDO
NATYP(NAT+2)=NADS2
NANEW2=NANEW1+NADS3
IF(NANEW2.EQ.NANEW1) GOTO 99
DO JADS=NANEW1+1,NANEW2
NB1=NB1+1
DO I=1,3
COORD(I,NB1)=ADS(I,JADS)
ENDDO
N1=0
DO N=1,N0
D=ABS(COORD(3,NB1)-VALZ(N))
IF(D.LT.0.0001) N1=N1+1
ENDDO
IF(N1.EQ.0) THEN
N0=N0+1
VALZ(N0)=COORD(3,NB1)
ENDIF
ENDDO
NATYP(NAT+3)=NADS3
99 CONTINUE
NCOUCH=N0-NBZ
NBZ=N0
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE BASE
C
C This routine generates the lattice basis vectors for a given Bravais
C lattice NCRIST centered according to NCENTR
C
USE DIM_MOD
USE BASES_MOD
USE CRANGL_MOD
USE OUTUNITS_MOD
USE RESEAU_MOD
USE VECSYS_MOD
C
CHARACTER*15 BRAV(8),CENT(7)
CHARACTER*31 RESEAU
C
C
DIMENSION CUB(9),MNC(9),TCN(9),TRG(9),HEX(9)
C
C
C
DATA CUB /1.,0.,0., 0.,1.,0., 0.,0.,1./
DATA MNC /1.,0.,1., 0.,1.,0., 0.,0.,1./
DATA TCN /1.,0.,1., 1.,1.,1., 0.,0.,1./
DATA TRG /0.,1.,1., -0.866025,-0.5,1., 0.866025,-0.5,1./
DATA HEX /1.,0.,0., -0.5,0.866025,0., 0.,0.,1./
DATA PIS180 /0.017453/
DATA BRAV /' CUBIQUE',' TETRAGONAL',' ORTHORHOMBIQUE','
& MONOCLINIQUE',' TRICLINIQUE',' TRIGONAL',' HEXAGO
&NAL',' EXTERNE'/
DATA CENT /' ','CENTRE',' FACES CENTREES','(RHOMBOEDRIQUE)',' FACE
& A CENTREE',' FACE B CENTREE',' FACE C CENTREE'/
C
ALPHAR=ALPHAD*PIS180
BETAR=BETAD*PIS180
GAMMAR=GAMMAD*PIS180
NAT3=NAT*3
GO TO (1,1,1,2,3,4,5,6) NCRIST
C
1 DO I=1,9
VECBAS(I)=CUB(I)
ENDDO
IF(NCRIST.NE.1) THEN
VECBAS(9)=CSURA
IF(NCRIST.EQ.3) THEN
VECBAS(5)=BSURA
ENDIF
ENDIF
GO TO 6
C
2 DO I=1,9
VECBAS(I)=MNC(I)
ENDDO
VECBAS(1)=SIN(BETAR)
VECBAS(3)=COS(BETAR)
VECBAS(5)=BSURA
VECBAS(9)=CSURA
GO TO 6
C
3 DO I=1,9
VECBAS(I)=TCN(I)
ENDDO
VECBAS(1)=SIN(BETAR)
VECBAS(3)=COS(BETAR)
A2Y=(COS(GAMMAR)-COS(ALPHAR)*COS(BETAR))/SIN(BETAR)
VECBAS(4)=BSURA*A2Y
VECBAS(5)=BSURA*SQRT(SIN(ALPHAR)*SIN(ALPHAR)-A2Y*A2Y)
VECBAS(6)=BSURA*COS(ALPHAR)
VECBAS(9)=CSURA
GO TO 6
C
4 IF(((NCENTR.EQ.4).AND.(CSURA.NE.1.)).OR.(NCENTR.EQ.1)) GO TO 5
ETA=-2.*SIN(ALPHAR/2.)/SQRT(3.)
DZETA=SQRT(1.-ETA*ETA)
DO I=1,3
J=I+2*(I-1)
J1=J+1
J2=J+2
VECBAS(J)=TRG(J)*ETA
VECBAS(J1)=TRG(J1)*ETA
VECBAS(J2)=TRG(J2)*DZETA
ENDDO
GO TO 6
C
5 DO I=1,9
VECBAS(I)=HEX(I)
ENDDO
VECBAS(9)=CSURA
C
6 DO I=1,3
ASYS(I)=VECBAS(I)
BSYS(I)=VECBAS(I+3)
CSYS(I)=VECBAS(I+6)
ENDDO
DCA=ABS(CSURA-1.)
IF((NCRIST.EQ.6).AND.(DCA.LT.0.0001)) GO TO 8
IF(NCRIST.EQ.8) GO TO 8
IF(NCENTR.GT.1) THEN
CALL CENTRE(VECBAS)
IF(NCENTR.EQ.4) THEN
DO I=1,9
VECBAS(I)=VECBAS(I)*SQRT((1.-CSURA*CSURA)*3.)
ENDDO
DO I=1,3
ASYS(I)=VECBAS(I)
BSYS(I)=VECBAS(I+3)
CSYS(I)=VECBAS(I+6)
ENDDO
ENDIF
ENDIF
C
8 RESEAU=BRAV(NCRIST)//' '//CENT(NCENTR)
WRITE(IUO1,80) RESEAU,NAT
WRITE(IUO1,81) (VECBAS(I),I=1,9)
WRITE(IUO1,82)
WRITE(IUO1,83) (ATBAS(I),I=1,NAT3)
C
80 FORMAT(////,10X,'RESEAU CRISTALLIN DE TYPE : ',A29,/,16X,
* 'CONTENANT',I3,' ATOMES DANS LA MAILLE ELEMENTAIRE',//)
81 FORMAT(28X,'VECTEURS GENERATEURS :',//,26X,'A1 = (',F6.3,',',
*F6.3,',',F6.3,')',/,26X,'A2 = (',F6.3,',',F6.3,',',F6.3,')',/,
*26X,'A3 = (',F6.3,',',F6.3,',',F6.3,')')
82 FORMAT(/,21X,'POSITIONS DES ATOMES DANS LA MAILLE :',/)
83 FORMAT(29X,'(',F6.3,',',F6.3,',',F6.3,')')
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE CENTRE(VECBAS)
C
C This routine modifies the Bravais lattice basis vectors according to
C the way the lattice is centered
C
USE RESEAU_MOD
C
DIMENSION VECBAS(9),V1(9)
C
C
C
DO I=1,9
V1(I)=VECBAS(I)
ENDDO
N1=NCENTR-1
GO TO (2,3,4,5,6,7) N1
C
2 DO I=1,3
VECBAS(I)=-0.5*V1(I)+0.5*V1(I+3)+0.5*V1(I+6)
VECBAS(I+3)=0.5*V1(I)-0.5*V1(I+3)+0.5*V1(I+6)
VECBAS(I+6)=0.5*V1(I)+0.5*V1(I+3)-0.5*V1(I+6)
ENDDO
GO TO 8
C
3 DO I=1,3
VECBAS(I)=0.5*(V1(I+3)+V1(I+6))
VECBAS(I+3)=0.5*(V1(I)+V1(I+6))
VECBAS(I+6)=0.5*(V1(I)+V1(I+3))
ENDDO
GO TO 8
C
4 DO I=1,3
VECBAS(I)=(2./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6)
VECBAS(I+3)=(-1./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6)
VECBAS(I+6)=(-1./3.)*V1(I)-(2./3.)*V1(I+3)+(1./3.)*V1(I+6)
ENDDO
DO I=1,3
VECBAS(3*I)=VECBAS(3*I)*SQRT(3./(1.-CSURA*CSURA))
ENDDO
GO TO 8
C
5 DO I=1,3
VECBAS(I+6)=0.5*(V1(I+3)+V1(I+6))
ENDDO
GO TO 8
C
6 DO I=1,3
VECBAS(I+6)=0.5*(V1(I)+V1(I+6))
ENDDO
GO TO 8
C
7 DO I=1,3
VECBAS(I+3)=0.5*(V1(I)+V1(I+3))
ENDDO
C
8 RETURN
C
END
C
C=======================================================================
C
SUBROUTINE CHBASE(NAT,ATBAS)
C
USE VECSYS_MOD
C
DIMENSION ATBAS(3*NAT),BASVEC(3,3),BAS1(1,3),BAS2(1,3)
C
DO J=1,3
BASVEC(1,J)=ASYS(J)
BASVEC(2,J)=BSYS(J)
BASVEC(3,J)=CSYS(J)
ENDDO
C
DO JAT=1,NAT
DO J=1,3
K=J+3*(JAT-1)
BAS1(1,J)=ATBAS(K)
ENDDO
CALL MULMAT(BAS1,1,3,BASVEC,3,3,BAS2)
DO J=1,3
K=J+3*(JAT-1)
ATBAS(K)=BAS2(1,J)
ENDDO
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE CHNOT(NVEC,VEC1,VEC2)
C
C This routine linearizes the storage of a two index array
C
DIMENSION VEC1(3*NVEC),VEC2(3,NVEC)
C
DO J=1,NVEC
DO I=1,3
VEC2(I,J)=VEC1(I+3*(J-1))
ENDDO
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE INVMAT(B,BINV)
C
USE OUTUNITS_MOD
DIMENSION B(3,3),BINV(3,3)
C
C
A1=B(1,1)*B(2,2)*B(3,3)
A2=B(2,1)*B(3,2)*B(1,3)
A3=B(3,1)*B(1,2)*B(2,3)
A4=B(1,1)*B(3,2)*B(2,3)
A5=B(2,1)*B(1,2)*B(3,3)
A6=B(3,1)*B(2,2)*B(1,3)
DET=A1+A2+A3-A4-A5-A6
C
IF(ABS(DET).LT.0.0001) GO TO 10
C
DO I=1,3
DO J=1,3
DO K=1,3
L=(I-J)*(I-K)*(J-K)
IF(L.NE.0) THEN
XNUM1=B(J,J)*B(K,K)-B(J,K)*B(K,J)
XNUM2=B(I,K)*B(K,J)-B(K,K)*B(I,J)
BINV(I,I)=XNUM1/DET
BINV(I,J)=XNUM2/DET
ENDIF
ENDDO
ENDDO
ENDDO
GO TO 50
C
10 WRITE(IUO1,60)
C
60 FORMAT(5X,'NON INVERTIBLE MATRIX')
C
50 CONTINUE
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE MULMAT(A1,IL1,IC1,A2,IL2,IC2,A3)
C
C This routine performs the matrix multiplication of A1(IL1,IC1) by
C A2(IL2,IC2) with the result stored in A3(IL1,IC2)
C
USE OUTUNITS_MOD
DIMENSION A1(IL1,IC1),A2(IL2,IC2),A3(IL1,IC2)
C
C
IF(IC1.NE.IL2) THEN
WRITE(IUO1,10)
ELSE
DO I=1,IL1
DO J=1,IC2
A3(I,J)=0.
DO K=1,IC1
A3(I,J)=A3(I,J)+A1(I,K)*A2(K,J)
ENDDO
ENDDO
ENDDO
ENDIF
C
10 FORMAT(5X,'THESE MATRICES CANNOT BE MULTIPLIED')
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE NUMAT(NUM,NIVA,IL,IM,IN)
C
USE OUTUNITS_MOD
DIMENSION I(100)
C
C
L=2*NIVA+1
IF(L.GT.100) THEN
WRITE(IUO1,5)
STOP
ENDIF
L1=NIVA+1
C
DO K=1,L
IF(K.LE.L1) THEN
I(K)=K-1
ELSE
I(K)=L1-K
ENDIF
ENDDO
C
Q1=FLOAT(NUM)/FLOAT(L*L)
JR1=NUM-L*L*INT(Q1+0.0001)
JS1=INT(Q1+0.9999)
Q2=FLOAT(JR1)/FLOAT(L)
JS2=INT(Q2+0.9999)
IF(JR1.EQ.0) JS2=L
Q3=FLOAT(NUM)/FLOAT(L)
JR3=INT(Q3+0.0001)
JS3=NUM-L*JR3
IF(JS3.EQ.0) JS3=L
IL=I(JS1)
IM=I(JS2)
IN=I(JS3)
C
5 FORMAT(///,'<<<<<<<<<< INCREASE THE SIZE OF I IN',' THE NUMAT SU
&BROUTINE >>>>>>>>>>')
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE RELA(NINI,NFIN,NAT,VALINI,VALFIN,VALFIN2,COORD,NTYP,REL
&,L)
C
USE DIM_MOD
C
USE ADSORB_MOD , I1 => IADS, N1 => NADS1, N2 => NADS2, N3 => NADS3
&
USE OUTUNITS_MOD
USE RELADS_MOD
USE RELAX_MOD
C
DIMENSION VALINI(NATCLU_M),VALFIN(NATCLU_M),REL(NATCLU_M)
DIMENSION NTYP(NATM),COORD(3,NATCLU_M),LSP(2),DZA(2),DZB(2)
DIMENSION DYA(2),DYB(2),VALFIN2(NATCLU_M),KZ(1000)
C
DATA SMALL /0.0001/
C
IF((IREL.EQ.1).OR.((IREL.EQ.0).AND.(NRELA.GT.0))) THEN
C
CALL ORDRE(NINI,VALINI,NFIN,VALFIN)
WRITE(IUO1,70) NFIN
DO JPLAN=1,NFIN
IF(JPLAN.LE.NRELA) THEN
X1=1.
X2=0.
PCADS=PCRELA(JPLAN)
ELSEIF((JPLAN.GT.NRELA).AND.(JPLAN.LE.L)) THEN
X1=0.
X2=0.
ELSE
X1=0.
X2=1.
PCSUBS=PCREL(JPLAN-L)
ENDIF
REL(JPLAN)=0.
IF(JPLAN.GT.NREL+L) GO TO 20
IF(JPLAN.EQ.NFIN) GO TO 20
DPLAN=VALFIN(JPLAN)-VALFIN(JPLAN+1)
REL(JPLAN)=DPLAN*(X1*PCADS+X2*PCSUBS)/100.
20 DREL=VALFIN(JPLAN)+REL(JPLAN)
WRITE(IUO1,30) JPLAN,VALFIN(JPLAN),DREL
ENDDO
C
NBR=0
DO JTYP=1,NAT
NBAT=NTYP(JTYP)
DO NUM=1,NBAT
NBR=NBR+1
DO JPLAN=1,NFIN
DIF=ABS(COORD(3,NBR)-VALFIN(JPLAN))
IF(DIF.LT.SMALL) THEN
COORD(3,NBR)=COORD(3,NBR)+REL(JPLAN)
ENDIF
ENDDO
ENDDO
ENDDO
C
DO JPLAN=1,NFIN
VALFIN(JPLAN)=VALFIN(JPLAN)+REL(JPLAN)
ENDDO
C
ELSEIF(IREL.GE.2) THEN
C
IP=0
LSP(2)=0
OMEGA=OMEGA1
97 XN1=1.
XN2=0.
IP=IP+1
CALL ORDRE(NINI,VALINI,NFIN,VALFIN)
ZP=VALFIN(IP)
CALL RZB110(OMEGA,DY1,DY2,DZ1,DZ2)
DZA(IP)=DZ1
DZB(IP)=DZ2
DYA(IP)=DY1
DYB(IP)=DY2
IF(ABS(OMEGA).LT.SMALL) THEN
LSP(IP)=1
ELSE
LSP(IP)=2
ENDIF
IF(LSP(IP).EQ.1) GOTO 95
NBR=0
C
DO JTYP=1,NAT-NATA
NBAT=NTYP(JTYP)
XN1=XN1+1.-FLOAT(JTYP)
XN2=XN2-1.+FLOAT(JTYP)
DO JNUM=1,NBAT
NBR=NBR+1
ZAT=COORD(3,NBR)-ZP
IF(ABS(ZAT).LT.SMALL) THEN
YAT=COORD(2,NBR)
COORD(2,NBR)=YAT-XN1*DYA(IP)-XN2*DYB(IP)
COORD(3,NBR)=ZAT+ZP+XN1*DZA(IP)+XN2*DZB(IP)
ENDIF
ENDDO
ENDDO
C
95 OMEGA=OMEGA2
IF((IREL.EQ.3).AND.(IP.EQ.1)) GOTO 97
LS=0
DO I=1,IP
LS=LS+LSP(I)
ENDDO
NBZ1=NFIN+LS-IP
DO K=1,IP
IF(LSP(K).EQ.2) THEN
IF((K.EQ.2).AND.(LS.EQ.3)) THEN
KN=K-1
ELSE
KN=K
ENDIF
VALINI(NBZ1-KN+1)=VALFIN(L+K)+DZB(K)
REL(NBZ1-KN+1)=DZB(K)
ELSE
VALINI(NBZ1-K+1)=VALFIN(L+K)
REL(NBZ1-K+1)=0.
ENDIF
ENDDO
C
IL=0
IR=0
DO J=1,NFIN
IS=0
IF(J.LE.NRELA) THEN
X1=1.
X2=0.
X3=0.
PCADS=PCRELA(J)
IS=1
ELSEIF((J.GT.NRELA).AND.(J.LE.L)) THEN
X1=0.
X2=0.
X3=0.
ELSEIF((J.GT.L).AND.(J.LE.(L+IP))) THEN
IR=IR+1
IF(LSP(IR).EQ.1) THEN
IF((IR.EQ.1).AND.(LSP(2).EQ.2)) GOTO 31
X1=0.
X2=1.
X3=0.
LT=MAX0(LSP(1),LSP(2))-1
PCSUBS=PCREL(J-L-LT)
IL=1
IS=1
31 CONTINUE
ELSE
X1=0.
X2=0.
X3=1.
ENDIF
ELSEIF((J.GT.(L+IP)).AND.(J.LE.(L+IP+NREL))) THEN
X1=0.
X2=1.
X3=0.
LT=MAX0(LSP(1),LSP(2))+IP-1
PCSUBS=PCREL(J-L-LT+IL+1)
IS=1
ELSE
X1=0.
X2=0.
X3=0.
ENDIF
DPLAN=VALFIN(J)-VALFIN(J+1)
REL(J)=X3*DZA(IR)+DPLAN*(X1*PCADS+X2*PCSUBS)/100.
VALINI(J)=VALFIN(J)+REL(J)
IF(IS.EQ.1) THEN
NBR=0
DO JTYP=1,NAT
NBAT=NTYP(JTYP)
DO NUM=1,NBAT
NBR=NBR+1
DIF=ABS(COORD(3,NBR)-VALFIN(J))
IF(DIF.LT.SMALL) THEN
COORD(3,NBR)=VALINI(J)
ENDIF
ENDDO
ENDDO
ENDIF
ENDDO
C
CALL ORDRE(NBZ1,VALINI,NFIN,VALFIN2)
WRITE(IUO1,65) NFIN
KZ(1)=0
KZ(2)=LSP(1)
KZ(3)=MAX0(LSP(1),LSP(2))
DO KK=4,NFIN
KZ(KK)=LS
ENDDO
DO JPLAN=1,NFIN
IF(JPLAN.LE.L) THEN
WRITE(IUO1,55) JPLAN,VALFIN(JPLAN),VALFIN2(JPLAN)
VALINI(JPLAN)=VALFIN(JPLAN)
ELSEIF((JPLAN.GT.L).AND.(JPLAN.LE.(L+LS))) THEN
K=KZ(JPLAN-L) - INT((JPLAN-L)/2)
IPLAN=JPLAN-K
WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN)
VALINI(JPLAN)=VALFIN(IPLAN)
ELSEIF(JPLAN.GT.(L+LS)) THEN
IPLAN=JPLAN-LS+IP
WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN)
VALINI(JPLAN)=VALFIN(IPLAN)
ENDIF
ENDDO
ENDIF
C
30 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3,
* ' BEFORE RELAXATION AND : ',F6.3,' AFTER')
55 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3,
* ' BEFORE RELAXATION AND : ',F6.3,' AFTER')
65 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ')
70 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ')
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE ROTBAS(ROT)
C
C This routine calculates the basis vectors related to a surface
C characterized by its Miller indices (IH,IK,II,IL)
C
USE MILLER_MOD
USE OUTUNITS_MOD
USE RESEAU_MOD
USE VECSYS_MOD , A1 => ASYS, A2 => BSYS, A3 => CSYS
C
DIMENSION ROT(3,3),VECT(3,3),A1STAR(3),A2STAR(3),A3STAR(3),B1(3)
DIMENSION VECT1(3),XNORM(3),CHBASE(3,3),VECT2(3,3)
C
C
C
DATA PI /3.141593/
C
IF((NCRIST.EQ.8).AND.(IVG0.GE.1)) GOTO 7
XH=FLOAT(IH)
XK=FLOAT(IK)
XI=FLOAT(II)
XL=FLOAT(IL)
XI1=-XH-XK
II1=INT(XI1)
IF((NCRIST.EQ.7).AND.(XI.NE.XI1)) WRITE(IUO1,5) IH,IK,II1,IL
5 FORMAT(5X,'THE SURFACE INDICES ARE NOT CORRECT,',/,5X, 'FOR THE RE
&ST OF THE CALCULATION, THEY ARE TAKEN AS ','(',I2,1X,I2,1X,I2,1X,I
&2,')')
CPR=1.
CALL PRVECT(A2,A3,B1,CPR)
OMEGA=PRSCAL(A1,B1)/(2.*PI)
CALL PRVECT(A2,A3,A1STAR,OMEGA)
CALL PRVECT(A3,A1,A2STAR,OMEGA)
CALL PRVECT(A1,A2,A3STAR,OMEGA)
DO 10 I=1,3
VECT1(I)=XH*A1STAR(I)+XK*A2STAR(I)+XL*A3STAR(I)
10 CONTINUE
DO 15 I=1,3
ROT(I,3)=VECT1(I)/SQRT(PRSCAL(VECT1,VECT1))
15 CONTINUE
DO 20 I=1,3
CHBASE(I,1)=A1(I)
CHBASE(I,2)=A2(I)
CHBASE(I,3)=A3(I)
DO 25 J=1,3
VECT(I,J)=0.
25 CONTINUE
20 CONTINUE
XHKL=XH*XK*XL
XHK=XH*XK
XHL=XH*XL
XKL=XK*XL
IF(XHKL.NE.0.) THEN
VECT(1,1)=-1./XH
VECT(2,1)=1./XK
VECT(1,2)=-1./XH
VECT(3,2)=1./XL
VECT(2,3)=-1./XK
VECT(3,3)=1./XL
ELSEIF(XHK.NE.0.) THEN
VECT(1,1)=-1./XH
VECT(2,1)=1./XK
ELSEIF(XHL.NE.0.) THEN
VECT(1,2)=-1./XH
VECT(3,2)=1./XL
ELSEIF(XKL.NE.0.) THEN
VECT(2,3)=-1./XK
VECT(3,3)=1./XL
ELSEIF(XH.NE.0.) THEN
VECT(2,2)=1./XH
ELSEIF(XK.NE.0.) THEN
VECT(3,3)=1./XK
ELSEIF(XL.NE.0.) THEN
VECT(1,1)=1./XL
ENDIF
CALL MULMAT(CHBASE,3,3,VECT,3,3,VECT2)
DO 35 I=1,3
XNORM(I)=SQRT(VECT2(1,I)**2+VECT2(2,I)**2+VECT2(3,I)**2)
35 CONTINUE
XMIN=AMIN1(XNORM(1),XNORM(2),XNORM(3))
XMAX=AMAX1(XNORM(1),XNORM(2),XNORM(3))
DO 40 I=1,3
IF(XHKL.NE.0.) THEN
IF(ABS(XMIN-XNORM(I)).LT.0.0001) THEN
DO 45 J=1,3
ROT(J,1)=VECT2(J,I)/XNORM(I)
45 CONTINUE
ENDIF
ELSE
IF(ABS(XMAX-XNORM(I)).LT.0.0001) THEN
DO 50 J=1,3
ROT(J,1)=VECT2(J,I)/XNORM(I)
50 CONTINUE
ENDIF
ENDIF
40 CONTINUE
ROT(1,2)=ROT(2,3)*ROT(3,1)-ROT(3,3)*ROT(2,1)
ROT(2,2)=ROT(3,3)*ROT(1,1)-ROT(3,1)*ROT(1,3)
ROT(3,2)=ROT(1,3)*ROT(2,1)-ROT(2,3)*ROT(1,1)
IF(NCRIST.EQ.7) THEN
WRITE(IUO1,85) IH,IK,II1,IL
ELSE
WRITE(IUO1,80) IH,IK,IL
ENDIF
WRITE(IUO1,65) ROT(1,1),ROT(2,1),ROT(3,1)
WRITE(IUO1,70) ROT(1,2),ROT(2,2),ROT(3,2)
WRITE(IUO1,75) ROT(1,3),ROT(2,3),ROT(3,3)
GOTO 37
7 DO 17 I=1,3
DO 27 J=1,3
ROT(I,J)=0.
IF(I.EQ.J) ROT(I,J)=1.
27 CONTINUE
17 CONTINUE
IF(IVG0.EQ.1) WRITE(IUO1,48)
IF(IVG0.EQ.2) WRITE(IUO1,47)
47 FORMAT(//,25X,'LINEAR CHAIN STUDY ')
48 FORMAT(//,35X,'PLANE STUDY')
65 FORMAT(26X,'ISURF = (',F6.3,',',F6.3,',',F6.3,')')
70 FORMAT(26X,'JSURF = (',F6.3,',',F6.3,',',F6.3,')')
75 FORMAT(26X,'KSURF = (',F6.3,',',F6.3,',',F6.3,')')
80 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X,
*I2,') :',/)
85 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X,
*I2,1X,I2,') :',/)
C
37 RETURN
C
END
C
C=======================================================================
C
SUBROUTINE RZB110(OMEGA,DY1,DY2,DZ1,DZ2)
C
A1=COS(OMEGA)
ALPHA=SIN(OMEGA)
BETA=A1-3.
GAMMA=SQRT(3.)*(5./3.-A1)
DELTA=SQRT(SQRT(3.)*(1./3.+A1)/GAMMA)
CSA=SQRT(3.)*(-BETA-ALPHA*DELTA)/6.
SNA=SQRT(1.-CSA*CSA)
CSB=-SQRT(3.)*BETA/3. -CSA
SNB=-SQRT(3.)*ALPHA/3. +SNA
DY1=(SQRT(3.)*CSB-1.)/4.
DY2=(1.-SQRT(3.)*CSA)/4.
DZ1=(SQRT(3.)*SNB-SQRT(2.))/4.
DZ2=(SQRT(3.)*SNA-SQRT(2.))/4.
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE TEST1(COUPUR,NB1,NB2,ATOME,COORD,VAL,NBAT,IRE,NBZ)
C
USE DIM_MOD
C
DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M),VAL(NATCLU_M)
DIMENSION IRE(NATCLU_M,2)
C
DIST2=0.
DO 10 I=1,3
DIST2=DIST2+ATOME(I,NB1)*ATOME(I,NB1)
10 CONTINUE
DIST=SQRT(DIST2)
V=0.0001
IF((ATOME(3,NB1).LE.V).AND.(DIST.LE.COUPUR)) THEN
NBAT=NBAT+1
NB2=NB2+1
IRE(NB1,1)=NB2
IRE(NB1,2)=NBAT
DO 20 I=1,3
COORD(I,NB2)=ATOME(I,NB1)
20 CONTINUE
IF(NBZ.EQ.0) THEN
NBZ=NBZ+1
VAL(NBZ)=COORD(3,NB2)
ELSE
N1=0
DO N=1,NBZ
D=ABS(COORD(3,NB2)-VAL(N))
IF(D.LT.0.0001) N1=N1+1
ENDDO
IF(N1.EQ.0) THEN
NBZ=NBZ+1
VAL(NBZ)=COORD(3,NB2)
ENDIF
ENDIF
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE TEST(NIV,ROT,NATYP,NBZ,NAT2,ISURF,COUP,*)
C
USE DIM_MOD
C
DIMENSION ATOME1(3,NATCLU_M),COORD1(3,NATCLU_M)
DIMENSION IRE1(NATCLU_M,2),NATYP(NATM)
DIMENSION NATYP1(NATM),VALZ1(NATCLU_M),ROT(3,3)
C
NMAX1=(2*NIV+3)**3
NV1=NIV+1
CALL AMAS(NV1,ATOME1,COORD1,VALZ1,ISURF,COUP,ROT,IRE1,NATYP1,NBZ,N
&AT2,NCOUCH,NMAX1)
DO 10 I=1,NAT2
IF(NATYP(I).NE.NATYP1(I)) RETURN 1
10 CONTINUE
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE ARCSIN(U,CST,RANGLE)
C
C For a given complex number U, this subroutine calculates its phase
C Warning : it is implicitely assumed that U = sin(theta) exp(i*phi)
C with theta > or = to 0 which is always the case when theta is obtained
C from the coordinates of a given vector r by the ACOS intrinsic function.
C
C When sin(theta) = 0, then phi = 0 if cos(theta) = 1 and pi if
C cos(theta) = -1. Cos(theta) is the variable CST.
C
COMPLEX U,CANGLE
C
IF(CABS(U).LT.0.0001) THEN
IF(CST.GT.0.) THEN
RANGLE=0.
ELSEIF(CST.LT.0.) THEN
RANGLE=3.141593
ENDIF
ELSE
CANGLE=(0.,-1.)*CLOG(U/CABS(U))
RANGLE=REAL(CANGLE)
ENDIF
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE ATDATA
C
C This routine contains the atomic mass and the density of all the
C elements,and the equivalence between their atomic number and
C chemical symbol.
C
C Value Z = 0 added for empty spheres. The values entered in this
C case are arbitrary and set to the corresponding Z = 1 value
C divided by 1836 (the ratio of the mass of the proton and electron).
C
C Last modified : 25 Apr 2013
C
USE XMRHO_MOD , XM_AT => XMAT, RHO_AT => RHOAT
REAL XMAT(0:99),RHOAT(0:99)
C
C
DATA XMAT/0.00055,1.00794,4.00260,6.941,9.01218,10.81,12.011,14.00
&67,15.9994,18.998403,20.179,22.98977,24.305,26.98154,28.0855,30.97
&376,32.06,35.453,39.948,39.0983,40.08,44.9559,47.88,50.9415,51.996
&,54.9380,55.847,58.9332,58.69,63.546,65.38,69.72,72.59,74.9216,78.
&96,79.904,83.80,85.4678,87.62,88.9059,91.22,92.9064,95.94,98.,101.
&07,102.9055,106.42,107.8682,112.41,114.82,118.69,121.75,127.60,126
&.9045,131.29,132.9054,137.33,138.9055,140.12,140.9077,144.24,145.,
&
* 150.36,151.96,157.25,158.9254,162.50,164.9304,
* 167.26,168.9342,173.04,174.967,178.49,180.9479,
* 183.85,186.207,190.2,192.22,195.08,196.9665,
* 200.59,204.383,207.2,208.9804,209.,210.,222.,
* 223.,226.0254,227.0278,232.0381,231.0359,
* 238.0289,237.0482,244.,243.,247.,247.,251.,252./
C
DATA RHOAT/0.0007,0.0708,0.122,0.533,1.845,2.34,2.26,0.81,1.14,1.1
&08,1.207,0.969,1.735,2.6941,2.32,1.82,2.07,1.56,1.40,0.860,1.55,2.
&980,4.53,6.10,7.18,7.43,7.860,8.9,8.876,8.94,7.112,5.877,5.307,5.7
&2,4.78,3.11,2.6,1.529,2.54,4.456,6.494,8.55,10.20,11.48,12.39,12.3
&9,12.00,10.48,8.63,7.30,7.30,6.679,6.23,4.92,3.52,1.870,3.5,6.127,
&6.637,6.761,6.994,7.20,7.51,5.228,7.8772,8.214,8.525,8.769,9.039,9
&.294,6.953,9.811,13.29,16.624,19.3,20.98,22.53,22.39,21.41,18.85,1
&3.522,11.83,11.33,
* 9.730,9.30,0.0,4.4,0.0,5.,10.05,11.70,15.34,
* 18.92,20.21,19.80,13.64,13.49,14.,0.0,0.0/
C
DO J=0,99
XM_AT(J)=XMAT(J)
RHO_AT(J)=RHOAT(J)
ENDDO
C
END
C
C=======================================================================
C
SUBROUTINE AUGER_MULT
C
C This subroutine computes all the possible multiplets that are
C contained in a given Auger transition line. It assumes that
C the atom has closed shells only.
C
C Last modified : 9 March 2006
C
USE INIT_A_MOD , LI => LI_C, L2 => LI_I, L1 => LI_A
USE OUTUNITS_MOD
C
CHARACTER*1 SC(0:1),LC(0:6),JC(0:7)
CHARACTER*3 MULTIPLET(112)
C
DATA SC /'1','3'/
DATA LC /'S','P','D','F','G','H','I'/
DATA JC /'0','1','2','3','4','5','6','7'/
C
WRITE(IUO1,10)
N_MULT=0
DO NS=0,1
DO L=ABS(L1-L2),L1+L2
DO J=ABS(L-NS),L+NS
N_MULT=N_MULT+1
MULTIPLET(N_MULT)=SC(NS)//LC(L)//JC(J)
WRITE(IUO1,20) MULTIPLET(N_MULT)
ENDDO
ENDDO
ENDDO
C
10 FORMAT(///,26X,'THE POSSIBLE MULTIPLETS ARE :',/,' ')
20 FORMAT(58X,A3)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE BESPHE(NL,IBES,X1,FL)
C
C This routine computes the spherical Bessel functions for
C a real argument X1.
C
C IBES=1 : Bessel function
C IBES=2 : Neumann function
C IBES=3 : Hankel function of the first kind
C IBES=4 : Hankel function of the second kind
C IBES=5 : Modified Bessel function
C IBES=6 : Modified Neumann function
C IBES=7 : Modified Hankel function
C
C Last modified : 8 Nov 2006
C
C
USE DIM_MOD
USE OUTUNITS_MOD
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2
COMPLEX*16 ZERO,CNORM
C
DOUBLE PRECISION SCALN(0:N_BESS)
C
REAL X1
C
C
ECH=37.D0
COMP=1.D37
COMM=1.D-37
X=DBLE(X1)
NX=INT(X1)
NREC=5*MAX0(NL-1,NX)
IF(NREC.GT.N_BESS) GOTO 16
ITEST=0
ZERO=(0.D0,0.D0)
UN=(1.D0,0.D0)
C1=UN
I=(0.D0,1.D0)
C2=I
DEB=1.D0
IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN
IBES1=1
IF(IBES.EQ.4) C2=-I
ELSEIF(IBES.EQ.7) THEN
IBES1=5
C2=-UN
ELSE
IBES1=IBES
ENDIF
C
C Case where the argument is zero
C
IF(DABS(X).LT.0.000001D0) THEN
IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN
FL(0)=UN
DO 10 L=1,NL-1
FL(L)=ZERO
10 CONTINUE
ITEST=1
ELSE
ITEST=-1
ENDIF
ENDIF
IF(ITEST) 11,12,13
11 WRITE(IUO1,14)
STOP
16 WRITE(IUO1,17) NREC
STOP
15 IBES1=IBES1+1
C
C Initial values
C
12 A=-1.D0
B=1.D0
IF(IBES1.EQ.1) THEN
FL(0)=UN*DSIN(X)/X
FLNN(NREC)=ZERO
SCALN(NREC)=0.D0
FLNN(NREC-1)=UN*DEB
SCALN(NREC-1)=0.D0
ELSEIF(IBES1.EQ.2) THEN
GL(0)=-UN*DCOS(X)/X
GL(1)=GL(0)/X -DSIN(X)/X
ELSEIF(IBES1.EQ.5) THEN
A=1.D0
B=-1.D0
FL(0)=UN*DSINH(X)/X
FLNN(NREC)=ZERO
SCALN(NREC)=0.D0
FLNN(NREC-1)=UN*DEB
SCALN(NREC-1)=0.D0
ELSEIF(IBES1.EQ.6) THEN
A=1.D0
B=-1.D0
GL(0)=UN*DCOSH(X)/X
GL(1)=(DSINH(X)-GL(0))/X
ENDIF
C
C Downward reccurence for the spherical Bessel function
C
IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN
DO 30 L=NREC-1,1,-1
ECHEL=0.D0
SCALN(L-1)=SCALN(L)
REN=DEXP(SCALN(L)-SCALN(L+1))
FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X)
IF(CDABS(FLNN(L-1)).GT.COMP) THEN
ECHEL=-ECH
ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN
ECHEL=ECH
ENDIF
IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1)
FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL)
30 CONTINUE
CNORM=FL(0)/FLNN(0)
DO 40 L=1,NL-1
FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L))
40 CONTINUE
ELSE
C
C Upward recurrence for the spherical Neumann function
C
DO 20 L=1,NL-1
IF(IBES.EQ.7) C1=(-UN)**(L+2)
GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X
IF(IBES1.NE.IBES) THEN
C
C Calculation of the spherical Hankel function
C
FL(L+1)=C1*(FL(L+1)+C2*GL(L+1))
ELSE
FL(L+1)=GL(L+1)
ENDIF
20 CONTINUE
IF(IBES1.EQ.IBES) THEN
FL(0)=GL(0)
FL(1)=GL(1)
ELSE
FL(0)=C1*(FL(0)+C2*GL(0))
FL(1)=C1*(FL(1)+C2*GL(1))
ENDIF
IBES1=IBES
ENDIF
IF(IBES.NE.IBES1) GOTO 15
C
13 RETURN
C
14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION
&S IS NUL >>>>>>>>>>')
17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR
&RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL
&D BE AT LEAST : ',I5,' >>>>>>>>>>')
C
END
C
C=======================================================================
C
SUBROUTINE BESPHE2(NL,IBES,X,FL)
C
C This routine computes the spherical Bessel functions for
C a real argument X1.
C
C IBES=1 : Bessel function
C IBES=2 : Neumann function
C IBES=3 : Hankel function of the first kind
C IBES=4 : Hankel function of the second kind
C IBES=5 : Modified Bessel function
C IBES=6 : Modified Neumann function
C IBES=7 : Modified Hankel function
C
C Last modified : 8 Nov 2006
C
C
USE DIM_MOD
USE OUTUNITS_MOD
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2
COMPLEX*16 ZERO,CNORM
C
DOUBLE PRECISION SCALN(0:N_BESS)
C
C
ECH=37.D0
COMP=1.D37
COMM=1.D-37
NX=INT(X)
NREC=5*MAX0(NL-1,NX)
IF(NREC.GT.N_BESS) GOTO 16
ITEST=0
ZERO=(0.D0,0.D0)
UN=(1.D0,0.D0)
C1=UN
I=(0.D0,1.D0)
C2=I
DEB=1.D0
IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN
IBES1=1
IF(IBES.EQ.4) C2=-I
ELSEIF(IBES.EQ.7) THEN
IBES1=5
C2=-UN
ELSE
IBES1=IBES
ENDIF
C
C Case where the argument is zero
C
IF(DABS(X).LT.0.000001D0) THEN
IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN
FL(0)=UN
DO 10 L=1,NL-1
FL(L)=ZERO
10 CONTINUE
ITEST=1
ELSE
ITEST=-1
ENDIF
ENDIF
IF(ITEST) 11,12,13
11 WRITE(IUO1,14)
STOP
16 WRITE(IUO1,17) NREC
STOP
15 IBES1=IBES1+1
C
C Initial values
C
12 A=-1.D0
B=1.D0
IF(IBES1.EQ.1) THEN
FL(0)=UN*DSIN(X)/X
FLNN(NREC)=ZERO
SCALN(NREC)=0.D0
FLNN(NREC-1)=UN*DEB
SCALN(NREC-1)=0.D0
ELSEIF(IBES1.EQ.2) THEN
GL(0)=-UN*DCOS(X)/X
GL(1)=GL(0)/X -DSIN(X)/X
ELSEIF(IBES1.EQ.5) THEN
A=1.D0
B=-1.D0
FL(0)=UN*DSINH(X)/X
FLNN(NREC)=ZERO
SCALN(NREC)=0.D0
FLNN(NREC-1)=UN*DEB
SCALN(NREC-1)=0.D0
ELSEIF(IBES1.EQ.6) THEN
A=1.D0
B=-1.D0
GL(0)=UN*DCOSH(X)/X
GL(1)=(DSINH(X)-GL(0))/X
ENDIF
C
C Downward reccurence for the spherical Bessel function
C
IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN
DO 30 L=NREC-1,1,-1
ECHEL=0.D0
SCALN(L-1)=SCALN(L)
REN=DEXP(SCALN(L)-SCALN(L+1))
FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X)
IF(CDABS(FLNN(L-1)).GT.COMP) THEN
ECHEL=-ECH
ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN
ECHEL=ECH
ENDIF
IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1)
FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL)
30 CONTINUE
CNORM=FL(0)/FLNN(0)
DO 40 L=1,NL-1
FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L))
40 CONTINUE
ELSE
C
C Upward recurrence for the spherical Neumann function
C
DO 20 L=1,NL-1
IF(IBES.EQ.7) C1=(-UN)**(L+2)
GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X
IF(IBES1.NE.IBES) THEN
C
C Calculation of the spherical Hankel function
C
FL(L+1)=C1*(FL(L+1)+C2*GL(L+1))
ELSE
FL(L+1)=GL(L+1)
ENDIF
20 CONTINUE
IF(IBES1.EQ.IBES) THEN
FL(0)=GL(0)
FL(1)=GL(1)
ELSE
FL(0)=C1*(FL(0)+C2*GL(0))
FL(1)=C1*(FL(1)+C2*GL(1))
ENDIF
IBES1=IBES
ENDIF
IF(IBES.NE.IBES1) GOTO 15
C
13 RETURN
C
14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION
&S IS NUL >>>>>>>>>>')
17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR
&RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL
&D BE AT LEAST : ',I5,' >>>>>>>>>>')
C
END
C
C=======================================================================
C
SUBROUTINE CHECK_VIB(NAT2)
C
C This subroutines checks the geometrical environment of each atom
C to identify those which can move "freely" in one direction, in
C order to see whether the mean square displacement in this
C direction is of bulk type or surface type
C
C An atom is considered to move freely in one direction if no other
C atom is present in the tetragonal cell of height ALENGTH * A
C and base edge 2 * A, whose base is centered on the atom considered
C
C Only prototypical atoms are considered as all equivalent atoms are
C in the same geometrical environment
C
C Surface-like atoms are then identified as having I_FREE = 1
C
C Last modified : 24 Apr 2013
C
USE DIM_MOD
C
USE COOR_MOD , COORD => SYM_AT
USE OUTUNITS_MOD
USE VIBRAT_MOD
C
INTEGER NSUR(NATP_M)
C
DATA SMALL /0.0001/
C
ALENGTH=4.
C
C.................... Checking the z direction ....................
C
WRITE(IUO1,11)
N_SUR=0
C
C Loop on the prototypical atoms
C
DO JTYP=1,N_PROT
C
I_FREE(JTYP)=0
JAT0=NCORR(1,JTYP)
XA=COORD(1,JAT0)
YA=COORD(2,JAT0)
ZA=COORD(3,JAT0)
C
C Loop on the surrounding atoms
C
I_ACC=0
C
DO JAT=1,NAT2
C
IF(JAT.EQ.JAT0) GOTO 10
C
X=COORD(1,JAT)
Y=COORD(2,JAT)
Z=COORD(3,JAT)
C
C Considering only atoms with Z > ZA
C
IF(Z.LT.(ZA+SMALL)) GOTO 10
C
C Lateral and vertical distances between the two atoms
C
D_LAT=(X-XA)*(X-XA)+(Y-YA)*(Y-YA)
D_VER=(Z-ZA)*(Z-ZA)
C
IF(D_VER.LT.(ALENGTH+SMALL)) THEN
IF(D_LAT.LT.(1.+SMALL)) THEN
I_ACC=I_ACC+1
ENDIF
ENDIF
C
IF(I_ACC.GE.1) GOTO 10
C
10 CONTINUE
C
ENDDO
C
IF(I_ACC.EQ.0) THEN
I_FREE(JTYP)=1
N_SUR=N_SUR+1
NSUR(N_SUR)=JTYP
ENDIF
C
ENDDO
C
WRITE(IUO1,12) (NSUR(J),J=1,N_SUR)
C
11 FORMAT(//,18X,'SURFACE-LIKE ATOMS FOR MSD CALCULATIONS: ',/)
12 FORMAT(20X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE DJMN(RBETA,R,LMAX)
C
C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to
C order LMAX, following Messiah's convention.
C They are stored as R(M2,M1,L).
C
C Last modified : 20 Oct 2006
C
USE DIM_MOD
C
USE COEFRLM_MOD
USE EXPROT_MOD
C
INTEGER EPS0
C
DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
DATA SMALL,SQR2 /0.001,1.4142136/
C
C=COS(RBETA)*0.5
S=SIN(RBETA)*0.5
CC=C+C
CMUL=-1.
IF(ABS(S).LT.SMALL) THEN
IF(C.GT.0.) EPS0=1
IF(C.LT.0.) EPS0=-1
DO L=0,LMAX
DO M1=-L,L
DO M2=-L,L
IF(M1.NE.M2*EPS0) THEN
R(M2,M1,L)=0.
ELSE
IF(EPS0.EQ.1) THEN
R(M2,M1,L)=1.
ELSE
IF(MOD(L+M1,2).EQ.0) THEN
R(M2,M1,L)=1.
ELSE
R(M2,M1,L)=-1.
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ELSE
S1=S*SQR2
C1=0.5+C
R(0,0,0)=1.0
R(-1,-1,1)=C1
R(0,-1,1)=S1
R(1,-1,1)=1.-C1
R(-1,0,1)=-S1
R(0,0,1)=CC
R(1,0,1)=S1
R(-1,1,1)=1.-C1
R(0,1,1)=-S1
R(1,1,1)=C1
C
PRODL=-S
COEF=-S/C1
CL=-1.
DO L=2,LMAX
CL=-CL
L1=L-1
FLL1=CC*FLOAT(L+L1)
FLL2=1./(FLOAT(L*L1)*CC)
PRODL=-PRODL*S
C
C Case M = 0
C
R_1=EXPR(0,L)*PRODL
R(-L,0,L)=R_1
C
R(L,0,L)=R_1*CL
R(0,-L,L)=R_1*CL
C
R(0,L,L)=R_1
C
CM2=CL
DO M2=-L1,-1
CM2=CM2*CMUL
CF1=CF(L1,0,-M2)/FLL1
CF2=FLL1/CF(L,0,-M2)
IF(-M2.LT.L1) THEN
R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1)
ELSE
R_A=CF2*R(M2,0,L1)
ENDIF
C
R(M2,0,L)=R_A
C
R(-M2,0,L)=R_A*CM2
R(0,M2,L)=R_A*CM2
C
R(0,-M2,L)=R_A
C
ENDDO
C
R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0
&,0)
C
C Case M > 0
C
PRODM=1.
CM=CL
FLLM=0.
DO M=1,L1
CM=-CM
PRODM=PRODM*COEF
FLLM=FLLM+FLL2
C
R_1=EXPR(M,L)*PRODL*PRODM
R_2=R_1/(PRODM*PRODM)
C
R(-L,M,L)=R_1
R(-L,-M,L)=R_2
C
R(L,-M,L)=R_1*CM
R(M,-L,L)=R_1*CM
R(L,M,L)=R_2*CM
R(-M,-L,L)=R_2*CM
C
R(-M,L,L)=R_1
R(M,L,L)=R_2
C
CM2=CM
DO M2=-L1,-M
CM2=-CM2
D0=FLOAT(M2)*FLLM
CF1=CF(L1,M,-M2)/FLL1
CF2=FLL1/CF(L,M,-M2)
IF((M.LT.L1).AND.(-M2.LT.L1)) THEN
R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1)
R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1)
ELSE
R_A=CF2*(1.-D0)*R(M2,M,L1)
R_B=CF2*(1.+D0)*R(M2,-M,L1)
ENDIF
C
R(M2,M,L)=R_A
R(M2,-M,L)=R_B
C
R(-M2,-M,L)=R_A*CM2
R(M,M2,L)=R_A*CM2
R(-M,M2,L)=R_B*CM2
R(-M2,M,L)=R_B*CM2
C
R(-M,-M2,L)=R_A
R(M,-M2,L)=R_B
C
ENDDO
ENDDO
C
PRODM=PRODM*COEF
R_1=PRODL*PRODM
R_2=PRODL/PRODM
R(-L,L,L)=R_1
R(L,-L,L)=R_1
R(L,L,L)=R_2
R(-L,-L,L)=R_2
C
ENDDO
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE DJMN2(RBETA,R,LMAX,ISWITCH)
C
C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to
C order LMAX, following Messiah's convention.
C They are stored as R(M2,M1,L) and multiplied (ISWITCH=1) or divided
C by EXPF.
C
C Last modified : 20 Oct 2006
C
USE DIM_MOD
C
USE COEFRLM_MOD
USE EXPFAC_MOD
USE EXPROT_MOD
C
INTEGER EPS0
C
DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
DATA SMALL,SQR2 /0.001,1.4142136/
C
C=COS(RBETA)*0.5
S=SIN(RBETA)*0.5
CC=C+C
CMUL=-1.
IF(ABS(S).LT.SMALL) THEN
IF(C.GT.0.) EPS0=1
IF(C.LT.0.) EPS0=-1
DO L=0,LMAX
DO M1=-L,L
DO M2=-L,L
IF(M1.NE.M2*EPS0) THEN
R(M2,M1,L)=0.
ELSE
IF(EPS0.EQ.1) THEN
R(M2,M1,L)=1.
ELSE
IF(MOD(L+M1,2).EQ.0) THEN
R(M2,M1,L)=1.
ELSE
R(M2,M1,L)=-1.
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ELSE
S1=S*SQR2
C1=0.5+C
R(0,0,0)=1.0
R(-1,-1,1)=C1
R(0,-1,1)=S1
R(1,-1,1)=1.-C1
R(-1,0,1)=-S1
R(0,0,1)=CC
R(1,0,1)=S1
R(-1,1,1)=1.-C1
R(0,1,1)=-S1
R(1,1,1)=C1
C
PRODL=-S
COEF=-S/C1
CL=-1.
DO L=2,LMAX
CL=-CL
L1=L-1
FLL1=CC*FLOAT(L+L1)
FLL2=1./(FLOAT(L*L1)*CC)
PRODL=-PRODL*S
C
C Case M = 0
C
R_1=EXPR(0,L)*PRODL
R(-L,0,L)=R_1
C
R(L,0,L)=R_1*CL
R(0,-L,L)=R_1*CL
C
R(0,L,L)=R_1
C
CM2=CL
DO M2=-L1,-1
CM2=CM2*CMUL
CF1=CF(L1,0,-M2)/FLL1
CF2=FLL1/CF(L,0,-M2)
IF(-M2.LT.L1) THEN
R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1)
ELSE
R_A=CF2*R(M2,0,L1)
ENDIF
C
R(M2,0,L)=R_A
C
R(-M2,0,L)=R_A*CM2
R(0,M2,L)=R_A*CM2
C
R(0,-M2,L)=R_A
C
ENDDO
C
R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0
&,0)
C
C Case M > 0
C
PRODM=1.
CM=CL
FLLM=0.
DO M=1,L1
CM=-CM
PRODM=PRODM*COEF
FLLM=FLLM+FLL2
C
R_1=EXPR(M,L)*PRODL*PRODM
R_2=R_1/(PRODM*PRODM)
C
R(-L,M,L)=R_1
R(-L,-M,L)=R_2
C
R(L,-M,L)=R_1*CM
R(M,-L,L)=R_1*CM
R(L,M,L)=R_2*CM
R(-M,-L,L)=R_2*CM
C
R(-M,L,L)=R_1
R(M,L,L)=R_2
C
CM2=CM
DO M2=-L1,-M
CM2=-CM2
D0=FLOAT(M2)*FLLM
CF1=CF(L1,M,-M2)/FLL1
CF2=FLL1/CF(L,M,-M2)
IF((M.LT.L1).AND.(-M2.LT.L1)) THEN
R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1)
R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1)
ELSE
R_A=CF2*(1.-D0)*R(M2,M,L1)
R_B=CF2*(1.+D0)*R(M2,-M,L1)
ENDIF
C
R(M2,M,L)=R_A
R(M2,-M,L)=R_B
C
R(-M2,-M,L)=R_A*CM2
R(M,M2,L)=R_A*CM2
R(-M,M2,L)=R_B*CM2
R(-M2,M,L)=R_B*CM2
C
R(-M,-M2,L)=R_A
R(M,-M2,L)=R_B
C
ENDDO
ENDDO
C
PRODM=PRODM*COEF
R_1=PRODL*PRODM
R_2=PRODL/PRODM
R(-L,L,L)=R_1
R(L,-L,L)=R_1
R(L,L,L)=R_2
R(-L,-L,L)=R_2
C
ENDDO
ENDIF
C
IF(ISWITCH.EQ.1) THEN
DO L=0,LMAX
DO M1=-L,L
DO M2=-L,L
R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)*EXPF(ABS(M2),L)
ENDDO
ENDDO
ENDDO
ELSEIF(ISWITCH.EQ.2) THEN
DO L=0,LMAX
DO M1=-L,L
DO M2=-L,L
R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)/EXPF(ABS(M2),L)
ENDDO
ENDDO
ENDDO
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE EMETT(JEM,IEMET,Z,COORD,NATYP,EMET,NM,JNEM,*)
C
C This routine looks for the position of an absorber of type IEMET(JEM)
C situated in the plane at Z. The result is stored in EMET(3)
C
USE DIM_MOD
C
DIMENSION IEMET(NEMET_M)
DIMENSION EMET(3),DIST(NATCLU_M),COORD(3,NATCLU_M),NATYP(NATM)
C
KEMET=0
JNT=0
IEM=IEMET(JEM)
IF(IEM.GT.1) THEN
DO JTP=1,IEM-1
JNT=JNT+NATYP(JTP)
ENDDO
ENDIF
NB=NATYP(IEM)
XMIN=1000000.
C
DO J=1,NB
JN=J+JNT
DELTAZ=ABS(COORD(3,JN)-Z)
IF(DELTAZ.LT.0.0001) THEN
XX=COORD(1,JN)
XY=COORD(2,JN)
XZ=COORD(3,JN)
DIST(J)=SQRT(XX*XX+XY*XY+XZ*XZ)
IF(DIST(J).LT.XMIN) THEN
XMIN=DIST(J)
NM=IEM
JNEM=J
DO I=1,3
EMET(I)=COORD(I,JN)
ENDDO
ENDIF
KEMET=KEMET+1
ENDIF
ENDDO
C
IF(KEMET.EQ.0) THEN
NM=IEM
RETURN 1
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE EULER(RTHETA1,RPHI1,RTHETA2,RPHI2,RALPHA,RBETA,RGAMMA,I
&ROT)
C
C This routine calculates the Euler angles RALPHA,RBETA,RGAMMA corresponding
C to the rotation r1(RTHETA1,RPHI1) ----> r2(RTHETA2,RPHI2)
C
C IROT=1 : r ---> z represented by (0,RTHETA,PI-RPHI)
C IROT=0 : r ---> z represented by (0,-RTHETA,-RPHI)
C
C
COMPLEX U1,U2
C
DATA PI /3.141593/
C
IF(IROT.EQ.1) THEN
EPS=1
ELSE
EPS=-1
ENDIF
DPHI=RPHI2-RPHI1
A1=SIN(RTHETA1)*COS(RTHETA2)
A2=COS(RTHETA1)*SIN(RTHETA2)
A3=COS(RTHETA1)*COS(RTHETA2)
A4=SIN(RTHETA1)*SIN(RTHETA2)
U1=A1-A2*COS(DPHI)-(0.,1.)*SIN(RTHETA2)*SIN(DPHI)
U2=A1*COS(DPHI)-A2+(0.,1.)*SIN(RTHETA1)*SIN(DPHI)
U3=A3+A4*COS(DPHI)
IF(U3.GT.1.) U3=1.
IF(U3.LT.-1.) U3=-1.
RBETA=ACOS(U3)
IF(ABS(SIN(RBETA)).GT.0.0001) THEN
U1=EPS*U1/SIN(RBETA)
U2=EPS*U2/SIN(RBETA)
CALL ARCSIN(U1,U3,RALPHA)
CALL ARCSIN(U2,U3,RGAMMA)
ELSE
RALPHA=0.
IF(ABS(U3-1.0).LT.0.0001) THEN
RGAMMA=0.
ELSE
RGAMMA=PI
ENDIF
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE GAUNT(L2,M2,L1,M1,GNT)
C
C This subroutine calculates the Gaunt coefficient G(L2,L3|L1)
C using a downward recursion scheme due to Schulten and Gordon
C for the Wigner's 3j symbols. The result is stored as GNT(L3),
C making use of the selection rule M3 = M1 - M2.
C
C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
C
C Last modified : 8 Dec 2008
C
C
USE DIM_MOD
USE LOGAMAD_MOD
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL GNT(0:N_GAUNT)
C
DOUBLE PRECISION F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT)
DOUBLE PRECISION A1(0:N_GAUNT),B(0:N_GAUNT)
C
C
DATA PI4/12.566370614359D0/
C
L12=L1+L2
K12=L1-L2
C
DO J=1,N_GAUNT
GNT(J)=0.
ENDDO
C
IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10
C
M3=M1-M2
LM1=L1+M1
LM2=L2+M2
KM1=L1-M1
KM2=L2-M2
C
IF(MOD(M1,2).EQ.0) THEN
COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
ELSE
COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
ENDIF
C
F(L12+1)=0.D0
G(L12+1)=0.D0
A(L12+1)=0.D0
A1(L12+1)=0.D0
D1=GLD(2*L2+1,1)-GLD(2*L12+2,1)
D2=GLD(2*L1+1,1)-GLD(LM2+1,1)
D3=GLD(L12+M3+1,1)-GLD(KM2+1,1)
D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
C
IF(MOD(KM1-KM2,2).EQ.0) THEN
F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
ELSE
F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
ENDIF
C
D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1))
D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1)
C
IF(MOD(K12,2).EQ.0) THEN
G(L12)=DEXP(D5+D6)
ELSE
G(L12)=-DEXP(D5+D6)
ENDIF
C
A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3)))
B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1)
&))
A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12)))
C
IF(ABS(M3).LE.L12) THEN
GNT(L12)=SNGL(COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1)))
ELSE
GNT(L12)=0.
ENDIF
C
JMIN=MAX0(ABS(K12),ABS(M3))
C
DO J=L12-1,JMIN,-1
J1=J+1
J2=J+2
A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL
&OAT(J*J-M3*M3))
B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1)))
A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J)
&))
F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1))
G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1))
GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1))
C
IF(ABS(M3).LE.J) THEN
GNT(J)=SNGL(GND)
ELSE
GNT(J)=0.
ENDIF
C
ENDDO
C
10 RETURN
C
END
C
C=======================================================================
C
SUBROUTINE GAUNT2(L2,M2,L1,M1,GNT)
C
C This subroutine calculates the Gaunt coefficient G(L2,L3|L1)
C using a downward recursion scheme due to Schulten and Gordon
C for the Wigner's 3j symbols. The result is stored as GNT(L3),
C making use of the selection rule M3 = M1 - M2.
C
C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
C
C Last modified : 8 Dec 2008
C This is the double precision version
C
C
C
USE DIM_MOD
USE LOGAMAD_MOD
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL*8 F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT),A1(0:N_GAUNT)
REAL*8 B(0:N_GAUNT),GNT(0:N_GAUNT)
C
C
DATA PI4/12.566370614359D0/
C
L12=L1+L2
K12=L1-L2
C
DO J=1,N_GAUNT
GNT(J)=0.D0
ENDDO
C
IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10
C
M3=M1-M2
LM1=L1+M1
LM2=L2+M2
KM1=L1-M1
KM2=L2-M2
C
IF(MOD(M1,2).EQ.0) THEN
COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
ELSE
COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4)
ENDIF
C
F(L12+1)=0.D0
G(L12+1)=0.D0
A(L12+1)=0.D0
A1(L12+1)=0.D0
D1=GLD(2*L2+1,1)-GLD(2*L12+2,1)
D2=GLD(2*L1+1,1)-GLD(LM2+1,1)
D3=GLD(L12+M3+1,1)-GLD(KM2+1,1)
D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
C
IF(MOD(KM1-KM2,2).EQ.0) THEN
F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
ELSE
F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
ENDIF
C
D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1))
D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1)
C
IF(MOD(K12,2).EQ.0) THEN
G(L12)=DEXP(D5+D6)
ELSE
G(L12)=-DEXP(D5+D6)
ENDIF
C
A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3)))
B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1)
&))
A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12)))
C
IF(ABS(M3).LE.L12) THEN
GNT(L12)=COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1))
ELSE
GNT(L12)=0.D0
ENDIF
C
JMIN=MAX0(ABS(K12),ABS(M3))
C
DO J=L12-1,JMIN,-1
J1=J+1
J2=J+2
A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL
&OAT(J*J-M3*M3))
B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1)))
A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J)
&))
F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1))
G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1))
GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1))
C
IF(ABS(M3).LE.J) THEN
GNT(J)=GND
ELSE
GNT(J)=0.D0
ENDIF
C
ENDDO
C
10 RETURN
C
END
C
C=======================================================================
C
SUBROUTINE HARSPH(NL,THETA,PHI,YLM,NC)
C
C This routine computes the complex spherical harmonics using Condon and
C Shortley phase convention.
C
USE DIM_MOD
C
USE EXPFAC2_MOD
USE FACTSQ_MOD
C
COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
C
DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
DATA PI,SMALL /3.141593,0.0001/
C
X=COS(THETA)
IF(ABS(X).LT.SMALL) X=0.0
IF(ABS(X+1.).LT.SMALL) X=-1.0
IF(ABS(X-1.).LT.SMALL) X=1.0
C
YLM(0,0)=CMPLX(SQ4PI_INV)
YLM(1,0)=X*SQR3_INV
DO L=2,NC
Y=1./FLOAT(L)
YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
&-1.5))*YLM(L-2,0)
ENDDO
C
C2=-1.
IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN
C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
ELSE
C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
ENDIF
C
C1=1.
COEF=(1.,0.)
DO M=1,NC
C1=C1*C2
COEF=COEF*C
YMM=SQ4PI_INV*COEF*FSQ(M)
YLM(M,M)=YMM
YLM(M,-M)=C1*CONJG(YMM)
YMMP=X*SQRT(FLOAT(M+M+3))*YMM
YLM(M+1,M)=YMMP
YLM(M+1,-M)=C1*CONJG(YMMP)
IF(M.LT.NC-1) THEN
DO L=M+2,NC
YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
&L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
YLM(L,-M)=C1*CONJG(YLM(L,M))
ENDDO
ENDIF
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE HARSPH2(NL,THETA,PHI,YLM,NC)
C
C This routine computes the complex spherical harmonics using Condon and
C Shortley phase convention. This version for m=0 only
C
USE DIM_MOD
C
USE EXPFAC2_MOD
USE FACTSQ_MOD
C
COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
C
DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
DATA PI,SMALL /3.141593,0.0001/
C
X=COS(THETA)
IF(ABS(X).LT.SMALL) X=0.0
IF(ABS(X+1.).LT.SMALL) X=-1.0
IF(ABS(X-1.).LT.SMALL) X=1.0
C
YLM(0,0)=CMPLX(SQ4PI_INV)
YLM(1,0)=X*SQR3_INV
DO L=2,NC
Y=1./FLOAT(L)
YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
&-1.5))*YLM(L-2,0)
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE HARSPH3(NL,THETA,PHI,YLM2,NC)
C
C This routine computes the complex spherical harmonics using Condon and
C Shortley phase convention.
C
USE DIM_MOD
C
USE EXPFAC2_MOD
USE FACTSQ_MOD
C
COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C
COMPLEX YLM2(LINMAX)
C
DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
DATA PI,SMALL /3.141593,0.0001/
C
X=COS(THETA)
IF(ABS(X).LT.SMALL) X=0.0
IF(ABS(X+1.).LT.SMALL) X=-1.0
IF(ABS(X-1.).LT.SMALL) X=1.0
C
YLM(0,0)=CMPLX(SQ4PI_INV)
YLM(1,0)=X*SQR3_INV
DO L=2,NC
Y=1./FLOAT(L)
YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
&-1.5))*YLM(L-2,0)
ENDDO
C
C2=-1.
IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN
C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
ELSE
C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI)
ENDIF
C
C1=1.
COEF=(1.,0.)
DO M=1,NC
C1=C1*C2
COEF=COEF*C
YMM=SQ4PI_INV*COEF*FSQ(M)
YLM(M,M)=YMM
YLM(M,-M)=C1*CONJG(YMM)
YMMP=X*SQRT(FLOAT(M+M+3))*YMM
YLM(M+1,M)=YMMP
YLM(M+1,-M)=C1*CONJG(YMMP)
IF(M.LT.NC-1) THEN
DO L=M+2,NC
YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
&L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
YLM(L,-M)=C1*CONJG(YLM(L,M))
ENDDO
ENDIF
ENDDO
C
DO L=0,NC
IL=L*L+L+1
DO M=-L,L
IND=IL+M
YLM2(IND)=YLM(L,M)
ENDDO
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE HEADERS(IUO2)
C
C This subroutine writes headers containing the main parameters
C of the calculation in the result file. The number of
C lines written depends of the spectroscopy
C
C Last modified : 31 Jan 2013
C
USE DIM_MOD
C
USE ALGORITHM_MOD
USE APPROX_MOD
USE EXAFS_MOD
USE HEADER_MOD
USE INFILES_MOD
USE INIT_A_MOD
USE INIT_J_MOD
USE INIT_L_MOD
USE INIT_M_MOD
USE MOYEN_MOD
USE PARCAL_MOD
USE PARCAL_A_MOD
USE TYPCAL_MOD
USE TYPCAL_A_MOD
USE TYPEXP_MOD
USE VALIN_MOD
USE VALIN_AV_MOD
USE VALFIN_MOD
USE VALEX_A_MOD
C
C
C
C
C
C
C
C
C
C
C
WRITE(IUO2,1)
WRITE(IUO2,2)
C
C Input files section:
C
C Checking the size of filenames
C
N_CHAR1=0
DO J_CHAR=1,24
IF(INFILE1(J_CHAR:J_CHAR).EQ.' ') GOTO 500
N_CHAR1=N_CHAR1+1
ENDDO
500 CONTINUE
C
N_CHAR2=0
DO J_CHAR=1,24
IF(INFILE2(J_CHAR:J_CHAR).EQ.' ') GOTO 501
N_CHAR2=N_CHAR2+1
ENDDO
501 CONTINUE
C
N_CHAR3=0
DO J_CHAR=1,24
IF(INFILE3(J_CHAR:J_CHAR).EQ.' ') GOTO 502
N_CHAR3=N_CHAR3+1
ENDDO
502 CONTINUE
C
N_CHAR4=0
DO J_CHAR=1,24
IF(INFILE4(J_CHAR:J_CHAR).EQ.' ') GOTO 503
N_CHAR4=N_CHAR4+1
ENDDO
503 CONTINUE
C
WRITE(IUO2,3) INFILE1(6:N_CHAR1)
WRITE(IUO2,4) INFILE2(4:N_CHAR2)
IF(INTERACT.NE.'NOINTER') THEN
WRITE(IUO2,5) INFILE3(5:N_CHAR3)
ENDIF
WRITE(IUO2,6) INFILE4(6:N_CHAR4)
WRITE(IUO2,2)
C
C Type of calculation
C
WRITE(IUO2,2)
C
IF(SPECTRO.EQ.'PHD') THEN
WRITE(IUO2,11) SPECTRO,ALGO1
IF(ALGO1.EQ.'SE') THEN
WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
ELSEIF(ALGO1.EQ.'CE') THEN
WRITE(IUO2,13) NDIF
ENDIF
WRITE(IUO2,14) VINT
ELSEIF(SPECTRO.EQ.'XAS') THEN
WRITE(IUO2,11) SPECTRO,ALGO1
IF(ALGO1.EQ.'SE') THEN
WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
ELSEIF(ALGO1.EQ.'CE') THEN
WRITE(IUO2,13) NDIF
ENDIF
WRITE(IUO2,14) VINT
ELSEIF(SPECTRO.EQ.'LED') THEN
WRITE(IUO2,11) SPECTRO,ALGO1
IF(ALGO1.EQ.'SE') THEN
WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
ELSEIF(ALGO1.EQ.'CE') THEN
WRITE(IUO2,13) NDIF
ENDIF
WRITE(IUO2,14) VINT
ELSEIF(SPECTRO.EQ.'AED') THEN
WRITE(IUO2,11) SPECTRO,ALGO2
IF(ALGO1.EQ.'SE') THEN
WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH
ELSEIF(ALGO1.EQ.'CE') THEN
WRITE(IUO2,13) NDIF
ENDIF
WRITE(IUO2,14) VINT
ELSEIF(SPECTRO.EQ.'APC') THEN
WRITE(IUO2,15) SPECTRO,ALGO1,ALGO2
WRITE(IUO2,14) VINT
ELSEIF(SPECTRO.EQ.'EIG') THEN
WRITE(IUO2,11) SPECTRO,ALGO1
ELSEIF(SPECTRO.EQ.'RES') THEN
CONTINUE
ELSEIF(SPECTRO.EQ.'ELS') THEN
CONTINUE
ENDIF
C
WRITE(IUO2,2)
C
C Initial state parameters
C
IF(SPECTRO.EQ.'PHD') THEN
WRITE(IUO2,21) NI,NLI,S_O,INITL
ELSEIF(SPECTRO.EQ.'XAS') THEN
WRITE(IUO2,22) EDGE,NEDGE,INITL
ELSEIF(SPECTRO.EQ.'LED') THEN
CONTINUE
ELSEIF(SPECTRO.EQ.'AED') THEN
WRITE(IUO2,24) AUGER,MULTIPLET
ELSEIF(SPECTRO.EQ.'APC') THEN
WRITE(IUO2,21) NI,NLI,S_O,INITL
WRITE(IUO2,24) AUGER,MULTIPLET
ELSEIF(SPECTRO.EQ.'RES') THEN
CONTINUE
ELSEIF(SPECTRO.EQ.'ELS') THEN
CONTINUE
ENDIF
C
WRITE(IUO2,2)
C
C Angular and energy parameters
C
IF(SPECTRO.EQ.'PHD') THEN
WRITE(IUO2,35)
WRITE(IUO2,34) THLUM,PHILUM,ELUM
WRITE(IUO2,2)
WRITE(IUO2,36)
WRITE(IUO2,31) THETA0,THETA1
WRITE(IUO2,32) PHI0,PHI1
WRITE(IUO2,33) E0,EFIN
ELSEIF(SPECTRO.EQ.'XAS') THEN
WRITE(IUO2,35)
WRITE(IUO2,33) EK_INI,EK_FIN
WRITE(IUO2,34) THLUM,PHILUM,ELUM
ELSEIF(SPECTRO.EQ.'LED') THEN
WRITE(IUO2,35)
WRITE(IUO2,31) THLUM,PHILUM
WRITE(IUO2,2)
WRITE(IUO2,36)
WRITE(IUO2,31) THETA0,THETA1
WRITE(IUO2,32) PHI0,PHI1
WRITE(IUO2,2)
WRITE(IUO2,33) E0,EFIN
ELSEIF(SPECTRO.EQ.'AED') THEN
WRITE(IUO2,36)
WRITE(IUO2,31) THETA0_A,THETA1_A
WRITE(IUO2,32) PHI0_A,PHI1_A
ELSEIF(SPECTRO.EQ.'APC') THEN
WRITE(IUO2,35)
WRITE(IUO2,34) THLUM,PHILUM,ELUM
WRITE(IUO2,2)
WRITE(IUO2,37)
WRITE(IUO2,31) THETA0,THETA1
WRITE(IUO2,32) PHI0,PHI1
WRITE(IUO2,33) E0,EFIN
WRITE(IUO2,2)
WRITE(IUO2,38)
WRITE(IUO2,31) THETA0_A,THETA1_A
WRITE(IUO2,32) PHI0_A,PHI1_A
ELSEIF(SPECTRO.EQ.'EIG') THEN
WRITE(IUO2,33) EK_INI,EK_FIN
ELSEIF(SPECTRO.EQ.'RES') THEN
CONTINUE
ELSEIF(SPECTRO.EQ.'ELS') THEN
CONTINUE
ENDIF
C
C End of headers
C
WRITE(IUO2,2)
WRITE(IUO2,1)
WRITE(IUO2,39)
C
C Formats
C
1 FORMAT('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!','
&!!!!!!!!!!!!!!!!')
2 FORMAT('!',69X,'!')
3 FORMAT('!',10X,'data file : ',A19,20X,'!')
4 FORMAT('!',10X,'t-matrix file : ',A17,20X,'!')
5 FORMAT('!',10X,'rad integral file: ',A20,20X,'!')
6 FORMAT('!',10X,'cluster file : ',A19,20X,'!')
C
11 FORMAT('!',10X,'spectroscopy : ',A3,8X,'algorithm : ',A2,
&10X,'!')
12 FORMAT('!',15X,'NO = ',I1,' NDIF = ',I2,' IFWD = ',I1,' IPW = '
&,I1,' ILENGTH = ',I1,5X,'!')
13 FORMAT('!',15X,'NDIF = ',I2,45X,'!')
14 FORMAT('!',10X,'inner potential : ',F6.2,' eV',28X,'!')
15 FORMAT('!',10X,'spectroscopy: ',A3,10X,'algorithm (photo): ',A2,11
&X,'!',/,'!',37X,'algorithm (auger): ',A2, 11X,'!')
C
21 FORMAT('!',10X,'initial state : ',I1,A1,1X,A3,' selection rules
&:',' INITL = ',I2,6X,'!')
22 FORMAT('!',10X,'initial state : ',A1,I1,2X,' selection rules:',
&' INITL = ',I2,8X,'!')
24 FORMAT('!',10X,'initial state : ',A6,2X,' multiplet: ',A3,17X,'
&!')
C
31 FORMAT('!',10X,'THETA_INI: ',F8.2,6X,'THETA_FIN: ',F8.2,15X,'!')
32 FORMAT('!',10X,'PHI_INI : ',F8.2,6X,'PHI_FIN : ',F8.2,15X,'!')
33 FORMAT('!',10X,'E_INI : ',F8.2,' eV',3X,'E_FIN : ',F8.2,' eV
&',12X,'!')
34 FORMAT('!',10X,'THETA_LUM: ',F8.2,2X,'PHI_LUM: ',F8.2,2X,'E_LUM: '
&,F8.2,' eV !')
35 FORMAT('!',10X,'incoming beam : ',40X,'!')
36 FORMAT('!',10X,'outgoing beam : ',40X,'!')
37 FORMAT('!',10X,'photoelectron beam:',40X,'!')
38 FORMAT('!',10X,'auger beam :',40X,'!')
39 FORMAT(71X)
C
RETURN
C
END
C
C=======================================================================
C
INTEGER FUNCTION IG(J)
C
C This function is returns the value 1 if J is an integer
C and 2 if it is a half-integer
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
REAL*8 J,JJ
C
DATA SMALL /0.0001D0/
C
JJ=ABS(J+J)
C
LL=INT(JJ+SMALL)
C
IF(MOD(LL,2).EQ.0) THEN
IG=1
ELSE
IG=2
ENDIF
C
END
C
C=======================================================================
C
SUBROUTINE LOCATE(XX,N,X,J)
C
C
C This subroutine is taken from the book :
C "Numerical Recipes : The Art of Scientific
C Computing" par W.H. PRESS, B.P. FLANNERY,
C S.A. TEUKOLSKY et W.T. VETTERLING
C (Cambridge University Press 1992)
C
C It performs a search in an ordered table using a bisection method.
C Given a monotonic array XX(1:N) and a value X, it returns J such
C that X is between XX(J) and XX(J+1).
C
INTEGER J,N
INTEGER JL,JM,JU
C
REAL X,XX(N)
C
JL=0
JU=N+1
10 IF(JU-JL.GT.1)THEN
JM=(JU+JL)/2
IF((XX(N).GT.XX(1)).EQV.(X.GT.XX(JM)))THEN
JL=JM
ELSE
JU=JM
ENDIF
GOTO 10
ENDIF
J=JL
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE LPM(E,XLPM,*)
C
C This routine generates the electron mean free path
C
C ILPM=-1: XLPM is set to 1.E+30
C ILPM=0 : XLPM is the value given in the input data file
C ILPM=1 : XLPM computed from Tokutaka et al, Surf. Sci. 149,349 (1985)
C ILPM=2 : XLPM computed from the Seah and Dench expression
C
C Last modified : 15 Sep 2009
C
USE LPMOY_MOD , NZ => NZA, XMAT => XMTA, RHO => RHOTA
USE OUTUNITS_MOD
USE TESTS_MOD
USE VALIN_MOD
C
E=E+VINT
C
IF(ILPM.EQ.-1) THEN
XLPM=1.E+30
ELSEIF(ILPM.EQ.0) THEN
XLPM=XLPM0
ELSEIF(ILPM.EQ.1) THEN
Q=FLOAT(NZ)*RHO/XMAT
CSTE1=ALOG(Q/4.50)/(ALOG(7.74/4.50))
CSTE2=ALOG(Q/3.32)/(ALOG(7.74/3.32))
CSTE3=ALOG(Q/3.32)/(ALOG(4.50/3.32))
A1=0.7271+0.2595*ALOG(E)
A2=-3.2563+0.9395*ALOG(E)
A3=-2.5716+0.8226*ALOG(E)
IF(E.GE.350.) GO TO 10
XLN=CSTE1*(0.0107-0.0083*ALOG(E))+A1
GO TO 20
10 IF((NZ.GE.24).AND.(NZ.LE.74)) GO TO 30
XLN=CSTE2*(1.6551-0.2890*ALOG(E))+A2
GO TO 20
30 IF(NZ.GE.42) GO TO 40
XLN=CSTE3*(0.6847-0.1169*ALOG(E))+A2
GO TO 20
40 XLN=CSTE1*(0.9704-0.1721*ALOG(E))+A3
20 XLPM=EXP(XLN)
ELSEIF(ILPM.EQ.2) THEN
XLPM=1430./(E**2)+0.54*SQRT(E)
ELSE
RETURN 1
ENDIF
C
E=E-VINT
IF(IPRINT.GT.0) WRITE(IUO1,80) E,XLPM
C
80 FORMAT(/////,2X,'========= E = ',F7.2,' eV',5X,'MEAN',' FREE PATH
& = ',F6.3,' ANGSTROEMS ','=========')
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE N_J(J1,MJ1,J2,MJ2,MJ6,NJ,I_INT,N_IN)
C
C This subroutine calculates Wigner's 3j and 6j coefficients
C using a downward recursion scheme due to Schulten and Gordon.
C The 3j are defined as (J1 J2 J) where in fact L1=MJ1, etc are
C (L1 L2 L)
C azimuthal quantum numbers, and the 6j as {J1 J2 J} where now
C {L1 L2 L}
C J1, L1, etc are the same kind of orbital quantum numbers.
C The result is stored as NJ(J).
C
C The parameter N allows to choose between 3j and 6j calculation, and
C Clebsch-Gordan. It can take the values :
C
C N = 2 ----> Clebsch-Gordan
C N = 3 ----> Wigner's 3j
C N = 6 ----> Wigner's 6j
C
C The Clebsch-Gordan coefficients are related to Wigner's 3j through :
C
C CG(J1,M1,J2,M2|J,MJ) = ( J1 J2 J )*sqrt(2*J+1)*(-1)**(J1-J2+MJ)
C ( M1 M2 -MJ )
C I_INT is a flag that returns 1 if the index J of the nj symbol
C is integer and 0 if it is a half integer.
C
C Note : For 3j, MJ6 is ignored while for 6j, we have :
C
C J1=J1 MJ1=L1 J2=J2 MJ2=L2 MJ6=L
C
C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975)
C
C Last modified : 8 Dec 2008 ----> D. Sebilleau
C
C
USE DIM_MOD
USE LOGAMAD_MOD
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL*4 NJ(0:N_GAUNT)
C
REAL*8 J1,J2,J,MJ1,MJ2,MJ,JP1,JP2
REAL*8 F(0:N_GAUNT),A(0:N_GAUNT),B(0:N_GAUNT)
REAL*8 JL12,JK12,MJ6,SIG
REAL*8 JJ1,JJ2,JL1,JL2,JL3,JJ12,JJ_MIN,JJ_MAX
C
C
DATA SMALL /0.0001D0/
C
IS=0
C
IF(N_IN.EQ.2) THEN
N_OU=3
I_CG=1
ELSE
N_OU=N_IN
I_CG=0
ENDIF
C
IF(N_OU.EQ.3) THEN
C
C------------------------------ 3j case ---------------------------------
C
C
C Test to check if J1 and J2 are integer or semi-integer
C
C Integer : IG=1
C Half-integer : IG=2
C
C Each angular momentum J is represented by the integer index L and
C the corresponding MJ by M
C
L1=INT(J1+SMALL)
L2=INT(J2+SMALL)
M1=INT(MJ1+SIGN(SMALL,MJ1))
M2=INT(MJ2+SIGN(SMALL,MJ2))
DIF1=J1-DFLOAT(L1)
DIF2=J2-DFLOAT(L2)
C
C IGx is a flag telling the code which case of Gamma function to use :
C
C IGx = 1 : integer case
C IGx = 2 : half-integer case
C
IF(ABS(DIF1).LT.SMALL) THEN
IG1=1
ELSE
IG1=2
ENDIF
IF(ABS(DIF2).LT.SMALL) THEN
IG2=1
ELSE
IG2=2
ENDIF
IF(IG1.EQ.IG2) THEN
IGG=1
IF(IG1.EQ.2) IS=1
ELSE
IGG=2
ENDIF
C
C Here, we assume that (J1,J2) are both either integer or half-integer
C If J is integer, the corresponding index is L = j (for loops or storage)
C while if J is an half-integer, this index is L= j - 1/2 = int(j)
C
C Integer indices are used for loops and for storage while true values
C are used for the initial values. When J1 and J2 are both half-integers,
C the values of J are integer and L should be increased by 1
C
JL12=J1+J2
JK12=J1-J2
C
L12=INT(JL12 + SIGN(SMALL,JL12))
K12=INT(JK12 + SIGN(SMALL,JK12))
C
LM1=INT(J1+MJ1 + SIGN(SMALL,J1+MJ1))
LM2=INT(J2+MJ2 + SIGN(SMALL,J2+MJ2))
KM1=INT(J1-MJ1 + SIGN(SMALL,J1-MJ1))
KM2=INT(J2-MJ2 + SIGN(SMALL,J2-MJ2))
C
MJ=-MJ1-MJ2
C
M=INT(MJ+SIGN(SMALL,MJ))
L12M=INT(JL12+MJ+SIGN(SMALL,JL12+MJ))
K12M=INT(JL12-MJ+SIGN(SMALL,JL12-MJ))
L1_2=INT(J1+J1+SIGN(SMALL,J1))
L2_2=INT(J2+J2+SIGN(SMALL,J2))
L12_2=INT(JL12+JL12+SIGN(SMALL,JL12))
C
IF(IG(JL12).EQ.1) THEN
I_INT=1
ELSE
I_INT=0
ENDIF
C
C Initialisation of the 3j symbol NJ(J) = (J1 J2 J)
C (MJ1 MJ2 MJ)
C
DO L=0,L12
NJ(L)=0.
ENDDO
C
IF((ABS(MJ1).GT.J1).OR.(ABS(MJ2).GT.J2)) GOTO 10
C
C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward
C recursion scheme. This scheme writes as
C
C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0
C
F(L12+1)=0.D0
A(L12+1)=0.D0
D1=GLD(L2_2+1,1)-GLD(L12_2+2,1)
D2=GLD(L1_2+1,1)-GLD(LM2+1,1)
D3=GLD(L12M+1,1)-GLD(KM2+1,1)
D4=GLD(K12M+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1)
C
N12=INT(JK12-MJ + SIGN(SMALL,JK12-MJ))
C
IF(I_CG.EQ.1) THEN
IF(MOD(N12,2).EQ.0) THEN
SIG=1.D0
ELSE
SIG=-1.D0
ENDIF
ENDIF
C
IF(MOD(N12,2).EQ.0) THEN
F(L12)=DSQRT(DEXP(D1+D2+D3+D4))
ELSE
F(L12)=-DSQRT(DEXP(D1+D2+D3+D4))
ENDIF
C
A(L12)=2.D0*DSQRT(J1*J2*(1.D0+2.D0*JL12)*(JL12*JL12-MJ*MJ))
B(L12)=-(2.D0*JL12+1.D0)*((J1*J1-J2*J2+JK12)*MJ-JL12*(JL12+1.D0)
&*(MJ2-MJ1))
C
IF(ABS(M).LE.L12) THEN
IF(I_CG.EQ.0) THEN
NJ(L12)=SNGL(F(L12))
ELSE
NJ(L12)=SNGL(F(L12)*SIG*DSQRT(JL12+JL12+1.D0))
ENDIF
ELSE
NJ(L12)=0.
ENDIF
C
LMIN=MAX0(ABS(K12),ABS(M))
C
C Downward recursion for NJ(J)
C
DO L=L12-1,LMIN,-1
LP1=L+1
LP2=L+2
C
C Value of the angular momentum J corresponding to the loop index L
C
IF(IGG.EQ.1) THEN
J=DFLOAT(L)
JP1=DFLOAT(LP1)
JP2=DFLOAT(LP2)
ELSE
J=DFLOAT(L) + 0.5D0
JP1=DFLOAT(LP1) + 0.5D0
JP2=DFLOAT(LP2) + 0.5D0
ENDIF
C
A(L)=DSQRT((J*J-JK12*JK12)*((JL12+1.D0)*(JL12+1.D0)-J*J)*(J*J-
&MJ*MJ))
B(L)=-(2.D0*J+1.D0)*(J1*(J1+1.D0)*MJ-J2*(J2+1.D0)*MJ-J*JP1*(MJ
&2-MJ1))
F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1))
C
IF(ABS(MJ).LE.J) THEN
IF(I_CG.EQ.0) THEN
NJ(L)=SNGL(F(L))
ELSE
NJ(L)=SNGL(F(L)*SIG*DSQRT(J+J+1.D0))
ENDIF
ELSE
NJ(L)=0.
ENDIF
C
ENDDO
C
10 CONTINUE
C
ELSEIF(N_OU.EQ.6) THEN
C
C------------------------------ 6j case ---------------------------------
C
C Change of notation for greater readability ---> NJ(JJ)
C
C True angular momentum value : begins with a J (JJn,JLn)
C Corresponding integer storage and loop index : begins by L (LJn,LLn)
C
JJ1=J1
JJ2=J2
JL1=MJ1
JL2=MJ2
JL3=MJ6
C
LJ1=INT(JJ1+SIGN(SMALL,JJ1))
LJ2=INT(JJ2+SIGN(SMALL,JJ2))
LL1=INT(JL1+SIGN(SMALL,JL1))
LL2=INT(JL2+SIGN(SMALL,JL2))
LL3=INT(JL3+SIGN(SMALL,JL3))
C
JJ12=JJ1-JJ2
JL12=JL1-JL2
C
LJ12=INT(JJ12+SIGN(SMALL,JJ12))
LL12=INT(JL12+SIGN(SMALL,JL12))
C
JJ_MIN=MAX(ABS(LJ12),ABS(LL12))
JJ_MAX=MIN(JJ1+JJ2,JL1+JL2)
LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN))
LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX))
C
C Initialisation of the 6j symbol NJ(J) = {J1 J2 J }
C {L1 L2 L3}
C
DO L=0,LJJ_MAX
NJ(L)=0.
ENDDO
C
C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward
C recursion scheme. This scheme writes as
C
C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0
C
C There are two possible initial values as max(|J1-J2|,|L1-L2|) <= J <=
C min(J1+J2,L1+L2) :
C
C {J1 J2 L1+L2} and {J1 J2 J1+J2} = {L1 L2 J1+J2}
C {L1 L2 L3 } {L1 L2 L3 } {J1 J2 L3 }
C
C They can be calculated from equation (6.3.1) of Edmonds page 97
C
F(LJJ_MAX+1)=0.D0
A(LJJ_MAX+1)=0.D0
C
IF(ABS(JJ_MAX-JL1-JL2).LT.SMALL) THEN
F(LJJ_MAX)=SIXJ_IN(JJ1,JJ2,JL1,JL2,JL3)
ELSE
F(LJJ_MAX)=SIXJ_IN(JL1,JL2,JJ1,JJ2,JL3)
ENDIF
NJ(LJJ_MAX)=SNGL(F(LJJ_MAX))
C
A(LJJ_MAX)=SQRT((JJ_MAX*JJ_MAX-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.
&D0)*(JJ1+JJ2+1.D0)-JJ_MAX*JJ_MAX)*(JJ_MAX*JJ_MAX-(JL1-JL2)*(JL1-JL
&2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)-JJ_MAX*JJ_MAX))
B(LJJ_MAX)=(JJ_MAX+JJ_MAX+1.D0)*(JJ_MAX*(JJ_MAX+1.D0)*(-JJ_MAX*(
&JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1*(JL1+1.D0)*(JJ_MAX
&*(JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(JJ_M
&AX*(JJ_MAX+1.D0)-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(JJ_MAX+JJ_MAX)*(J
&J_MAX+1.D0)*JL3*(JL3+1.D0))
C
IF(IG(JJ_MAX).EQ.1) THEN
I_INT=1
ELSE
I_INT=0
ENDIF
C
C Downward recurrence relation
C
DO L=LJJ_MAX-1,LJJ_MIN,-1
LP1=L+1
LP2=L+2
C
C Value of the angular momentum J corresponding to the loop index L
C
IF(IG(JJ_MAX).EQ.1) THEN
J=DFLOAT(L)
JP1=DFLOAT(LP1)
JP2=DFLOAT(LP2)
ELSE
J=DFLOAT(L) + 0.5D0
JP1=DFLOAT(LP1) + 0.5D0
JP2=DFLOAT(LP2) + 0.5D0
ENDIF
C
A(L)=SQRT((J*J-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.D0)*(JJ1+JJ2+1
&.D0)-J*J)*(J*J-(JL1-JL2)*(JL1-JL2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)
&-J*J))
B(L)=(J+J+1)*(J*JP1*(-J*JP1+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1
&*(JL1+1.D0)*(J*JP1+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(
&J*JP1-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(J+J)*JP1*JL3*(JL3+1.D0))
C
F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1))
NJ(L)=SNGL(F(L))
C
ENDDO
C
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE ORDRE2(NINI,VALINI,NFIN,VALFIN)
C
C Given a set of **integer** numbers VALINI, this routine orders them
C and suppresses the values appearing more than once. The remaining
C values are stored in VALFIN.
C
C VALINI(K+1).GT.VALINI(K) : decreasing order
C VALINI(K+1).LT.VALINI(K) : increasing order
C
C
C
INTEGER VALINI(NINI),VALFIN(NINI),R1
C
LOGICAL BUBBLE
C
DO J=1,NINI-1
K=J
BUBBLE=.TRUE.
150 IF(K.GE.1.AND.BUBBLE) THEN
IF(VALINI(K+1).LT.VALINI(K)) THEN
R1=VALINI(K)
VALINI(K)=VALINI(K+1)
VALINI(K+1)=R1
ELSE
BUBBLE=.FALSE.
ENDIF
K=K-1
GOTO 150
ENDIF
ENDDO
C
JFIN=1
VALFIN(1)=VALINI(1)
DO J=1,NINI-1
IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.0) THEN
JFIN=JFIN+1
VALFIN(JFIN)=VALINI(J+1)
ENDIF
ENDDO
NFIN=JFIN
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE ORDRE(NINI,VALINI,NFIN,VALFIN)
C
C Given a set of **real** numbers VALINI, this routine orders them and
C suppresses the values appearing more than once. The remaining
C values are stored in VALFIN.
C
C VALINI(K+1).GT.VALINI(K) : decreasing order
C VALINI(K+1).LT.VALINI(K) : increasing order
C
C
DIMENSION VALINI(NINI),VALFIN(NINI)
C
LOGICAL BUBBLE
C
DATA SMALL /0.00001/
C
DO J=1,NINI-1
K=J
BUBBLE=.TRUE.
150 IF(K.GE.1.AND.BUBBLE) THEN
IF(VALINI(K+1).GT.VALINI(K)) THEN
R1=VALINI(K)
VALINI(K)=VALINI(K+1)
VALINI(K+1)=R1
ELSE
BUBBLE=.FALSE.
END IF
K=K-1
GOTO 150
ENDIF
ENDDO
C
JFIN=1
VALFIN(1)=VALINI(1)
DO J=1,NINI-1
IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN
JFIN=JFIN+1
VALFIN(JFIN)=VALINI(J+1)
ENDIF
ENDDO
NFIN=JFIN
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE PLM(X,PLMM,NC)
C
C This routine computes the Legendre functions. It is a modified version
C of that written by W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY and
C W.T. VETTERLING in "Numerical Recipes : The Art of Scientific
C Computing" (Cambridge University Press 1992).
C
DIMENSION PLMM(0:100,0:100)
C
PLMM(0,0)=1.
PLMM(1,0)=X
DO L=2,NC
PLMM(L,0)=(X*(L+L-1)*PLMM(L-1,0)-(L-1)*PLMM(L-2,0))/L
ENDDO
C
DO M=1,NC
PMM=1.
FACT=1.
SOMX2=SQRT(1.-X*X)
FACT=1.
DO I=1,M
PMM=-PMM*FACT*SOMX2
FACT=FACT+2.
ENDDO
PMMP1=X*FACT*PMM
PLMM(M,M)=PMM
PLMM(M+1,M)=PMMP1
IF(M.LT.NC-1) THEN
DO L=M+2,NC
PLL=(X*(L+L-1)*PMMP1-(L+M-1)*PMM)/(L-M)
PMM=PMMP1
PMMP1=PLL
PLMM(L,M)=PLL
ENDDO
ENDIF
ENDDO
C
RETURN
C
END
C
C=============================================================================
C
SUBROUTINE POLHAN(ISPHER,NO,NC,RHO,HLM)
C
C This routine calculates a function HLM(L,M), related to the the Hankel
C polynomials and their derivatives with respect to z=1/ikr,
C necessary for the Rehr-Albers expansion of the propagator.
C
USE DIM_MOD
C
COMPLEX HLM(0:NO_ST_M,0:NL_M-1),RHO,Z,ONEC
C
ONEC=(1.,0.)
C
IF(ISPHER.GE.1) THEN
Z=(0.,-1.)/RHO
C
C Case M = 0
C
HLM(0,0)=ONEC
HLM(0,1)=ONEC-Z
DO L=2,NC
HLM(0,L)=HLM(0,L-2)-FLOAT(L+L-1)*Z*HLM(0,L-1)
ENDDO
C
C Case M > 0
C
IF(NO.GE.1) THEN
DO M=1,NO
HLM(M,M)=-Z*HLM(M-1,M-1)*FLOAT(M+M-1)
HLM(M,M+1)=HLM(M,M)*FLOAT(M+M+1)*(ONEC-Z*FLOAT(M+1))
DO L=M+2,NC
HLM(M,L)=HLM(M,L-2)-FLOAT(L+L-1)*Z*(HLM(M,L-1)+HLM(M-1,L-1
&))
ENDDO
ENDDO
ENDIF
ELSE
DO M=0,NO
DO L=M,NC
HLM(M,L)=ONEC
ENDDO
ENDDO
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE POLLEG(NC,X,PL)
C
C This routine computes the Legendre polynomials up to order NC-1
C
DIMENSION PL(0:100)
C
PL(0)=1.
PL(1)=X
DO 10 L=2,NC-1
L1=L-1
L2=L-2
L3=2*L-1
PL(L)=(X*FLOAT(L3)*PL(L1)-FLOAT(L1)*PL(L2))/FLOAT(L)
10 CONTINUE
C
RETURN
C
END
C
C=======================================================================
C
FUNCTION PRSCAL(A1,A2)
C
C This function computes the dot product of the two vectors A1 and A2
C
DIMENSION A1(3),A2(3)
C
PRSCAL=A1(1)*A2(1)+A1(2)*A2(2)+A1(3)*A2(3)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE PRVECT(A1,A2,A3,C)
C
C This function computes the vector product of the two vectors A1 and A2.
C The result is A3; C is a scaling factor
C
DIMENSION A1(3),A2(3),A3(3)
C
A3(1)=(A1(2)*A2(3)-A1(3)*A2(2))/C
A3(2)=(A1(3)*A2(1)-A1(1)*A2(3))/C
A3(3)=(A1(1)*A2(2)-A1(2)*A2(1))/C
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*,*,*,*,*,*,*,*,*,*
&,*,*,*)
C
C This subroutine reads the input data from unit ICOM and writes
C them in the control file IUO1. Then, it stores the data in
C the various COMMON blocks
C
C Last modified : 26 Apr 2013
C
USE DIM_MOD
C
USE ADSORB_MOD
USE AMPLI_MOD
USE APPROX_MOD
USE ATOMS_MOD
USE AUGER_MOD
USE BASES_MOD
USE COEFRLM_MOD
USE CONVACC_MOD
USE CONVTYP_MOD
USE C_G_MOD
USE C_G_A_MOD
USE C_G_M_MOD
USE CRANGL_MOD
USE DEBWAL_MOD , T => TEMP
USE DEXPFAC2_MOD
USE DFACTSQ_MOD
USE EIGEN_MOD
USE EXAFS_MOD
USE EXPFAC_MOD
USE EXPFAC2_MOD
USE EXPROT_MOD
USE FACTSQ_MOD
USE FDIF_MOD
USE FIXSCAN_MOD
USE FIXSCAN_A_MOD
USE HEADER_MOD , AUGER1 => AUGER
USE INDAT_MOD
USE INFILES_MOD
USE INUNITS_MOD
USE INIT_A_MOD
USE INIT_J_MOD
USE INIT_L_MOD
USE INIT_M_MOD
USE LIMAMA_MOD
USE LINLBD_MOD
USE LOGAMAD_MOD
USE LPMOY_MOD , XM => XMTA, RH => RHOTA
USE MILLER_MOD
USE MOYEN_MOD
USE MOYEN_A_MOD
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD
USE PARCAL_A_MOD
USE RA_MOD
USE RELADS_MOD
USE RELAX_MOD
USE RESEAU_MOD
USE SPECTRUM_MOD
USE SPIN_MOD
USE TESTS_MOD
USE TYPCAL_MOD
USE TYPCAL_A_MOD
USE TYPEM_MOD
USE TYPEXP_MOD
USE VALIN_MOD
USE VALIN_AV_MOD
USE VALFIN_MOD
USE VALEX_A_MOD
USE XMRHO_MOD
C
C
C
C
REAL*8 J1,J2,MJ1,MJ2,MJ3,JJ,DXDEN,DEXPF
REAL*8 JJ_MIN,JJ_MAX,JJ12,JL12,SMALL,SQPI
C
REAL TEXTE1(10),TEXTE2(10),TEXTE3(10)
REAL TEXTE4(10),TEXTE5(10),TEXTE6(10)
REAL TEXTE6B(10),TEXTE7(10)
REAL THFWD(NATP_M),THBWD(NATP_M),GLG(0:N_GAUNT),NJ(0:N_GAUNT)
REAL ALPHAR,BETAR,RACC
C
C
C
DOUBLE PRECISION FACT1L,FACT2L
C
C
C
C
C
CHARACTER*7 TESLEC,RIEN
C
C
CHARACTER*3 CODRES(8),CODCTR(7),CRIST,CENTR,UNLENGTH
C
C
CHARACTER*1 EDGE_C,EDGE_I,EDGE_A,MULT
DATA CODRES/'CUB','TET','ORB','MNC','TCN','TRG','HEX','EXT'/
DATA CODCTR/'P','I','F','R','A','B','C'/
DATA PIS180,BOHR/0.017453,0.529177/
DATA SQPI,SMALL /1.772453850906D0,1.D-6/
C
I_EXT=0
I_EXT_A=0
IVG0=0
IRET=0
NCRIST=0
NCENTR=0
I_SO=0
DO I=1,10
PCREL(I)=0.
ENDDO
STEREO=' NO'
C
C
C.......... Reading of the input data in unit ICOM ..........
C
C
READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE1
READ(ICOM,1) RIEN
READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE2
READ(ICOM,1) RIEN
C
READ(ICOM,3) CRIST,CENTR,IBAS,NAT
READ(ICOM,4) A,BSURA,CSURA,UNIT
C
IF(IBAS.EQ.0) THEN
DO JLINE=1,100
READ(ICOM,5) TESLEC
IF(TESLEC.EQ.'SPECTRO') THEN
BACKSPACE ICOM
BACKSPACE ICOM
BACKSPACE ICOM
GOTO 600
ENDIF
ENDDO
ENDIF
C
READ(ICOM,6) ALPHAD,BETAD,GAMMAD
READ(ICOM,7) IH,IK,II,IL
READ(ICOM,8) NIV,COUPUR,ITEST,IESURF
IF(NAT.GT.1) THEN
DO I=1,NAT
J=3*(I-1)
READ(ICOM,9) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(I)
ENDDO
ELSE
READ(ICOM,9) X1,Y1,Z1,CHEM(1),NZA
ENDIF
C
READ(ICOM,5) TESLEC
IF(TESLEC.EQ.'VECBAS ') THEN
BACKSPACE ICOM
ELSE
IRET=10
GOTO 605
ENDIF
C
DO I=1,8
IF(CRIST.EQ.CODRES(I)) NCRIST=I
IF(I.NE.8) THEN
IF(CENTR.EQ.CODCTR(I)) NCENTR=I
ENDIF
ENDDO
IF((NCRIST.EQ.0).OR.(NCENTR.EQ.0)) THEN
IRET=1
GOTO 605
ENDIF
C
IF(NCRIST.EQ.8) THEN
DO I=1,3
J=3*(I-1)
IVN(I)=1
READ(ICOM,9) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J)
IF(ABS(VECBAS(1+J)).LT.0.0001) THEN
IF(ABS(VECBAS(2+J)).LT.0.0001) THEN
IF(ABS(VECBAS(3+J)).LT.0.0001) THEN
IVG0=IVG0+1
IVN(I)=0
ENDIF
ENDIF
ENDIF
ENDDO
ELSE
READ(ICOM,9) X3,Y3,Z3
READ(ICOM,9) X4,Y4,Z4
READ(ICOM,9) X5,Y5,Z5
ENDIF
READ(ICOM,10) IREL,NREL,(PCREL(I),I=1,2)
IF(IREL.EQ.1) THEN
IF(NREL.GT.2) THEN
NLIGNE=INT(FLOAT(NREL-2)/4.)+1
DO J=1,NLIGNE
READ(ICOM,11) (PCREL(I),I=1,4)
ENDDO
ENDIF
IF(NREL.GT.10) THEN
IRET=4
GOTO 605
ENDIF
ELSEIF(IREL.EQ.0) THEN
NREL=0
ENDIF
IF(NREL.EQ.0) THEN
DO JREL=1,10
PCREL(JREL)=0.
ENDDO
ENDIF
READ(ICOM,12) OMEGAD1,OMEGAD2,IADS
C
READ(ICOM,1) RIEN
600 READ(ICOM,2) TEXTE3
READ(ICOM,1) RIEN
C
READ(ICOM,13) SPECTRO,ISPIN,IDICHR,IPOL
READ(ICOM,44) I_AMP
C
IF(SPECTRO.EQ.'PHD') THEN
INTERACT='DIPOLAR'
ELSEIF(SPECTRO.EQ.'LED') THEN
INTERACT='NOINTER'
ELSEIF(SPECTRO.EQ.'XAS') THEN
INTERACT='DIPOLAR'
ELSEIF(SPECTRO.EQ.'AED') THEN
INTERACT='COULOMB'
ELSEIF(SPECTRO.EQ.'APC') THEN
INTERACT='DIPCOUL'
ELSEIF(SPECTRO.EQ.'EIG') THEN
INTERACT='DIPOLAR'
ENDIF
C
IF((IPOL.EQ.0).AND.(IDICHR.GT.0)) THEN
PRINT 513
STOP
ENDIF
IF((IDICHR.EQ.2).AND.(ISPIN.EQ.0)) THEN
PRINT 514
STOP
ENDIF
C
IF(ISPIN.EQ.0) THEN
NSPIN2=1
NSPIN=1
ELSEIF(ISPIN.EQ.1) THEN
NSPIN2=4
NSPIN=2
ENDIF
C
IF(SPECTRO.EQ.'LED') THEN
DO JLINE=1,10
READ(ICOM,1) RIEN
ENDDO
GOTO 607
ELSEIF(SPECTRO.EQ.'XAS') THEN
IF(IDICHR.GT.1) THEN
PRINT 512
STOP
ENDIF
DO JLINE=1,19
READ(ICOM,1) RIEN
ENDDO
GOTO 602
ELSEIF(SPECTRO.EQ.'AED') THEN
DO JLINE=1,24
READ(ICOM,1) RIEN
ENDDO
GOTO 603
ELSEIF(SPECTRO.EQ.'EIG') THEN
DO JLINE=1,34
READ(ICOM,1) RIEN
ENDDO
GOTO 608
ENDIF
C
IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE4
READ(ICOM,1) RIEN
C
READ(ICOM,20) NI,NLI,S_O,INITL,I_SO
C
IF((NLI.EQ.'s').OR.(NLI.EQ.'S')) THEN
LI=0
ELSEIF((NLI.EQ.'p').OR.(NLI.EQ.'P')) THEN
LI=1
ELSEIF((NLI.EQ.'d').OR.(NLI.EQ.'D')) THEN
LI=2
ELSEIF((NLI.EQ.'f').OR.(NLI.EQ.'F')) THEN
LI=3
ELSEIF((NLI.EQ.'g').OR.(NLI.EQ.'G')) THEN
LI=4
ELSE
IRET=5
GOTO 605
ENDIF
IF(LI.GT.LI_M) THEN
IRET=6
GOTO 605
ENDIF
IF(I_SO.EQ.0) THEN
S_O=' '
ELSEIF(I_SO.EQ.1) THEN
IF(S_O.EQ.'1/2') THEN
IF(LI.GT.1) IRET=7
ELSEIF(S_O.EQ.'3/2') THEN
IF((LI.LT.1).OR.(LI.GT.2)) IRET=7
ELSEIF(S_O.EQ.'5/2') THEN
IF((LI.LT.2).OR.(LI.GT.3)) IRET=7
ELSEIF(S_O.EQ.'7/2') THEN
IF((LI.LT.3).OR.(LI.GT.4)) IRET=7
ELSEIF(S_O.EQ.'9/2') THEN
IF(LI.NE.4) IRET=7
ENDIF
ELSEIF(I_SO.EQ.2) THEN
S_O=' '
ENDIF
C
READ(ICOM,14) IPHI,ITHETA,IE,IFTHET
READ(ICOM,15) NPHI,NTHETA,NE,NFTHET
READ(ICOM,16) PHI0,THETA0,E0,R1
READ(ICOM,16) PHI1,THETA1,EFIN,R2
READ(ICOM,17) THLUM,PHILUM,ELUM
READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR
C
DO JLINE=1,9
READ(ICOM,1) RIEN
ENDDO
ENDIF
C
607 IF(SPECTRO.EQ.'LED') THEN
READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE4
READ(ICOM,1) RIEN
C
READ(ICOM,14) IPHI,ITHETA,IE,IFTHET
READ(ICOM,15) NPHI,NTHETA,NE,NFTHET
READ(ICOM,16) PHI0,THETA0,E0,R1
READ(ICOM,16) PHI1,THETA1,EFIN,R2
READ(ICOM,17) TH_INI,PHI_INI
READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR
C
THLUM=TH_INI
PHILUM=PHI_INI
ELUM=0.
IDICHR=0
INITL=0
ENDIF
C
IF(SPECTRO.NE.'XAS') THEN
IF(IPHI.EQ.-1) THEN
IPHI=1
I_EXT=0
ICHKDIR=0
STEREO='YES'
IF(ABS(PHI1-PHI0).LT.0.0001) THEN
PHI0=0.
PHI1=360.
NPHI=361
ENDIF
IF(ABS(THETA1-THETA0).LT.0.0001) THEN
THETA0=0.
THETA1=88.
NTHETA=89
ENDIF
ELSEIF(IPHI.EQ.2) THEN
IPHI=1
I_EXT=1
ELSEIF(IPHI.EQ.3) THEN
IPHI=1
I_EXT=-1
ELSEIF(ITHETA.EQ.2) THEN
ITHETA=1
I_EXT=1
ELSEIF(ITHETA.EQ.3) THEN
ITHETA=1
I_EXT=-1
ELSEIF(IE.EQ.2) THEN
IE=1
I_EXT=1
ELSEIF(IE.EQ.3) THEN
IE=1
I_EXT=-1
ELSEIF(IE.EQ.4) THEN
IF(SPECTRO.EQ.'PHD') THEN
IE=1
I_EXT=2
IMOD=0
ELSE
IE=1
I_EXT=1
ENDIF
ENDIF
ENDIF
C
ICALC=IPHI*IE+IPHI*ITHETA+IE*ITHETA
IF((ICALC.NE.0).AND.(IFTHET.EQ.0)) IRET=3
C
C When the direction of the analyzer might be experimentally
C inaccurate, the calculation will be done for nine
C direction across the one given in the data file
C with an increment of one degree.
C
IF(ICHKDIR.EQ.1) THEN
IF((ITHETA.EQ.1).AND.(IPHI.EQ.0)) THEN
NPHI=9
PHI0=PHI0-4.
PHI1=PHI0+8.
ELSEIF((IPHI.EQ.1).AND.(ITHETA.EQ.0)) THEN
NTHETA=9
THETA0=THETA0-4.
THETA1=THETA0+8.
ENDIF
ENDIF
C
C Initialization of the values for the scanned angle and the "fixed" one
C
IF(IPHI.EQ.1) THEN
N_FIXED=NTHETA
N_SCAN=NPHI
FIX0=THETA0
FIX1=THETA1
SCAN0=PHI0
SCAN1=PHI1
IPH_1=0
ELSEIF(ITHETA.EQ.1) THEN
N_FIXED=NPHI
N_SCAN=NTHETA
FIX0=PHI0
FIX1=PHI1
SCAN0=THETA0
SCAN1=THETA1
IPH_1=1
ELSEIF(IE.EQ.1) THEN
IF(NTHETA.GE.NPHI) THEN
N_FIXED=NPHI
N_SCAN=NTHETA
FIX0=PHI0
FIX1=PHI1
SCAN0=THETA0
SCAN1=THETA1
IPH_1=1
ELSE
N_FIXED=NTHETA
N_SCAN=NPHI
FIX0=THETA0
FIX1=THETA1
SCAN0=PHI0
SCAN1=PHI1
IPH_1=0
ENDIF
ENDIF
C
602 IF(SPECTRO.EQ.'XAS') THEN
READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE5
READ(ICOM,1) RIEN
C
READ(ICOM,39) EDGE,NEDGE,INITL,THLUM,PHILUM
READ(ICOM,19) NE_X,EK_INI,EK_FIN,EPH_INI
C
LI=NEDGE/2
IF(NEDGE.GT.1) I_SO=2
IF(EDGE.EQ.'K') THEN
NI=1
ELSEIF(EDGE.EQ.'L') THEN
NI=2
ELSEIF(EDGE.EQ.'M') THEN
NI=3
ELSEIF(EDGE.EQ.'N') THEN
NI=4
ELSEIF(EDGE.EQ.'O') THEN
NI=5
ELSEIF(EDGE.EQ.'P') THEN
NI=6
ENDIF
ELSE
DO JLINE=1,5
READ(ICOM,1) RIEN
ENDDO
ENDIF
C
603 IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
C
READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE6
READ(ICOM,1) RIEN
C
READ(ICOM,40) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
READ(ICOM,42) I_MULT,IM1,MULT,IM2
READ(ICOM,14) IPHI_A,ITHETA_A,IFTHET_A,I_INT
READ(ICOM,15) NPHI_A,NTHETA_A,NFTHET_A
READ(ICOM,41) PHI0_A,THETA0_A,R1_A
READ(ICOM,41) PHI1_A,THETA1_A,R2_A
READ(ICOM,18) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
C
LI_C=NEDGE_C/2
LI_I=NEDGE_I/2
LI_A=NEDGE_A/2
C
IF((EDGE_I.EQ.EDGE_A).AND.(LI_I.EQ.LI_A)) THEN
I_SHELL=1
ELSE
I_SHELL=0
ENDIF
C
IE_A=0
NE_A=1
I_CP_A=0
C
IF(EDGE_C.EQ.'K') THEN
AUGER=' '//EDGE_C//EDGE_I//CHAR(48+NEDGE_I)//EDGE_A//CHAR(48+N
&EDGE_A)
ELSE
AUGER=EDGE_C//CHAR(48+NEDGE_C)//EDGE_I//CHAR(48+NEDGE_I)//EDGE
&_A//CHAR(48+NEDGE_A)
ENDIF
AUGER1=AUGER
C
IF(IPHI_A.EQ.-1) THEN
IPHI_A=1
I_EXT_A=0
ICHKDIR_A=0
STEREO='YES'
IF(ABS(PHI1_A-PHI0_A).LT.0.0001) THEN
PHI0_A=0.
PHI1_A=360.
NPHI_A=361
ENDIF
IF(ABS(THETA1_A-THETA0_A).LT.0.0001) THEN
THETA0_A=0.
THETA1_A=88.
NTHETA_A=89
ENDIF
ELSEIF(IPHI_A.EQ.2) THEN
IPHI_A=1
I_EXT_A=1
ELSEIF(IPHI_A.EQ.3) THEN
IPHI_A=1
I_EXT_A=-1
ELSEIF(ITHETA_A.EQ.2) THEN
ITHETA_A=1
I_EXT_A=1
ELSEIF(ITHETA_A.EQ.3) THEN
ITHETA_A=1
I_EXT_A=-1
ENDIF
C
C Check for the consistency of the data for the two electrons in
C APECS, in particular when the sample is rotated (IMOD=1)
C
IF(SPECTRO.EQ.'APC') THEN
IF((LI_C.NE.LI).OR.(IMOD_A.NE.IMOD)) THEN
IRET=11
GOTO 605
ENDIF
DTH=THETA1-THETA0
DTH_A=THETA1_A-THETA0_A
DPH=PHI1-PHI0
DPH_A=PHI1_A-PHI0_A
IF((IMOD_A.EQ.1).AND.(IPHI_A.NE.IPHI)) IRET=13
IF((IMOD_A.EQ.1).AND.(ITHETA_A.NE.ITHETA)) IRET=13
IF((IMOD_A.EQ.1).AND.(NPHI_A.NE.NPHI)) IRET=13
IF((IMOD_A.EQ.1).AND.(NTHETA_A.NE.NTHETA)) IRET=13
IF((IMOD_A.EQ.1).AND.(DTH_A.NE.DTH)) IRET=13
IF((IMOD_A.EQ.1).AND.(DPH_A.NE.DPH)) IRET=13
ENDIF
C
C When the direction of the analyzer might be experimentally
C inaccurate, the calculation will be done for nine
C direction across the one given in the data file
C with an increment of one degree.
C
IF(ICHKDIR_A.EQ.1) THEN
IF((ITHETA_A.EQ.1).AND.(IPHI_A.EQ.0)) THEN
NPHI_A=9
PHI0_A=PHI0_A-4.
PHI1_A=PHI0_A+8.
ELSEIF((IPHI_A.EQ.1).AND.(ITHETA_A.EQ.0)) THEN
NTHETA_A=9
THETA0_A=THETA0_A-4.
THETA1_A=THETA0_A+8.
ENDIF
ENDIF
C
C Initialization of the values for the scanned angle and the "fixed" one
C
IF(IPHI_A.EQ.1) THEN
N_FIXED_A=NTHETA_A
N_SCAN_A=NPHI_A
FIX0_A=THETA0_A
FIX1_A=THETA1_A
SCAN0_A=PHI0_A
SCAN1_A=PHI1_A
IPH_1_A=0
ELSEIF(ITHETA_A.EQ.1) THEN
N_FIXED_A=NPHI_A
N_SCAN_A=NTHETA_A
FIX0_A=PHI0_A
FIX1_A=PHI1_A
SCAN0_A=THETA0_A
SCAN1_A=THETA1_A
IPH_1_A=1
ENDIF
C
ELSE
DO JLINE=1,10
READ(ICOM,1) RIEN
ENDDO
ENDIF
C
IF(SPECTRO.EQ.'XAS') THEN
I_CP=1
NE=NE_X
ELSE
I_CP=0
ENDIF
C
608 IF(SPECTRO.EQ.'EIG') THEN
C
READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE6B
READ(ICOM,1) RIEN
C
READ(ICOM,43) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP
C
NE=NE_EIG
N_LINE_E=INT((FLOAT(NE_EIG)-0.0001)/4.)+1
N_LAST=4-(4*N_LINE_E-NE_EIG)
C
IF(N_LINE_E.GT.1) THEN
DO JLINE=1,N_LINE_E-1
J=(JLINE-1)*4
READ(ICOM,7) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3
&),I_SPECTRUM(J+4)
ENDDO
ENDIF
C
J=4*(N_LINE_E-1)
C
READ(ICOM,7) (I_SPECTRUM(J+K), K=1,N_LAST)
C
READ(ICOM,46) I_PWM,METHOD,RACC,EXPO
READ(ICOM,47) N_MAX,N_ITER,N_TABLE,SHIFT
READ(ICOM,48) I_XN,I_VA,I_GN,I_WN
READ(ICOM,49) LEVIN,ALPHAR,BETAR
C
ACC=DBLE(RACC)
IF(ABS(I_PWM).LE.2) THEN
I_ACC=0
N_ITER=N_MAX
ELSEIF(I_PWM.EQ.3) THEN
I_ACC=1
N_ITER=N_MAX
ELSEIF(I_PWM.EQ.-3) THEN
I_ACC=-1
N_ITER=N_MAX
ELSEIF(I_PWM.EQ.4) THEN
I_ACC=2
ELSEIF(I_PWM.EQ.-4) THEN
I_ACC=-2
ENDIF
IF(N_MAX.LT.N_ITER) N_ITER=N_MAX
C
ALPHA=DCMPLX(ALPHAR)
BETA=DCMPLX(BETAR)
C
C
ELSE
DO JLINE=1,9
READ(ICOM,1) RIEN
ENDDO
C
ENDIF
C
609 READ(ICOM,1) RIEN
READ(ICOM,2) TEXTE7
READ(ICOM,1) RIEN
C
READ(ICOM,21) NO,NDIF,ISPHER,I_GR
C
IF(ISPHER.EQ.0) THEN
IDWSPH=0
NO=0
ENDIF
IF(NO.LT.0) NO=8
NUMAX(1)=NO/2
C
READ(ICOM,22) ISFLIP,IR_DIA,ITRTL,I_TEST
C
IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) I_TEST_A=I_TEST
IF(I_TEST.EQ.1) THEN
IF(INTERACT.EQ.'DIPOLAR') THEN
INITL=1
LI=0
IPOL=1
ELSEIF(INTERACT.EQ.'COULOMB') THEN
LI_C=0
LI_I=0
ENDIF
ENDIF
C
READ(ICOM,23) NEMET
C
BACKSPACE ICOM
NLG=INT((NEMET-0.0001)/3) +1
DO N=1,NLG
NRL=3*N
JD=3*(N-1)+1
IF(N.EQ.NLG) NRL=NEMET
READ(ICOM,24) NEMO,(IEMET(J), J=JD, NRL)
IF(N.EQ.1) NEMET1=NEMO
ENDDO
C
READ(ICOM,25) ISOM,NONVOL(JFICH),NPATHP,VINT
C
IF(I_TEST.EQ.2) THEN
IF(ABS(IPOL).EQ.1) THEN
THLUM=-90.
PHILUM=0.
ELSEIF(ABS(IPOL).EQ.2) THEN
THLUM=0.
PHILUM=0.
ENDIF
IMOD=0
VINT=0.
A=1.
ENDIF
C
IF((NFICHLEC.EQ.1).OR.(IBAS.EQ.1)) ISOM=0
C
READ(ICOM,26) IFWD,NTHOUT,I_NO,I_RA
C
IF(NTHOUT.EQ.NDIF-1) IFWD=0
C
IF(I_RA.EQ.1) NO=0
DO JAT=1,NAT
READ(ICOM,27) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT)
IF(I_RA.EQ.0) THEN
N_RA(JAT)=NO
NUMAX(JAT)=NO/2
ELSEIF(I_RA.EQ.1) THEN
NUMAX(JAT)=N_RA(JAT)/2
NO=MAX(N_RA(JAT),NO)
ENDIF
ENDDO
C
READ(ICOM,5) TESLEC
IF(TESLEC.EQ.'IPW,NCU') THEN
BACKSPACE ICOM
ELSE
IRET=8
GOTO 605
ENDIF
C
READ(ICOM,28) IPW,NCUT,PCTINT,IPP
READ(ICOM,29) ILENGTH,RLENGTH,UNLENGTH
READ(ICOM,30) IDWSPH,ISPEED,IATTS,IPRINT
C
IF(IDWSPH.EQ.0) ISPEED=1
C
READ(ICOM,31) IDCM,TD,T,RSJ
READ(ICOM,32) ILPM,XLPM0
C
IF((IDCM.GE.1).OR.(ILPM.EQ.1)) THEN
CALL ATDATA
ENDIF
NLEC=INT((NAT-0.0001)/4)+1
C
DO I=1,NLEC
NDEB=4*(I-1) + 1
NFIN=MIN0(4*I,NAT)
READ(ICOM,33) (UJ2(J),J=NDEB,NFIN)
ENDDO
C
DO JLINE=1,5
READ(ICOM,1) RIEN
ENDDO
READ(ICOM,5) TESLEC
IF(TESLEC.EQ.'DATA FI') THEN
BACKSPACE ICOM
ELSE
IRET=9
GOTO 605
ENDIF
C
READ(ICOM,34) INFILE1,IUI1
READ(ICOM,34) INFILE2,IUI2
READ(ICOM,34) INFILE3,IUI3
READ(ICOM,34) INFILE4,IUI4
READ(ICOM,34) INFILE5,IUI5
READ(ICOM,34) INFILE6,IUI6
C
IF(SPECTRO.NE.'APC') THEN
DO JLINE=1,9
READ(ICOM,1) RIEN
ENDDO
ELSE
DO JLINE=1,6
READ(ICOM,1) RIEN
ENDDO
READ(ICOM,34) INFILE7,IUI7
READ(ICOM,34) INFILE8,IUI8
READ(ICOM,34) INFILE9,IUI9
ENDIF
C
C Set up of the switch controlling external
C reading of the detector directions and
C averaging over them for an undetected electron
C
IF(SPECTRO.EQ.'APC') THEN
IF((I_EXT.EQ.-1).OR.(I_EXT_A.EQ.-1)) THEN
IF(I_EXT*I_EXT_A.EQ.0) THEN
WRITE(IUO1,523)
I_EXT=-1
I_EXT_A=-1
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI6,713) IDIR,NSET
READ(IUI9,713) IDIR_A,NSET_A
IF(IDIR.EQ.2) THEN
IF(NSET.NE.NSET_A) WRITE(IUO1,524) NSET,NSET_A
STOP
ENDIF
ENDIF
ENDIF
IF(I_INT.EQ.1) THEN
I_EXT=2
ELSEIF(I_INT.EQ.2) THEN
I_EXT_A=2
ELSEIF(I_INT.EQ.3) THEN
I_EXT=2
I_EXT_A=2
ENDIF
ENDIF
C
IF(I_EXT.EQ.-1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,701) IDIR,I_SET,N_POINTS
READ(IUI6,702) I_PH,N_FIXED,N_SCAN
DO JS=1,I_SET
READ(IUI6,703) TH_0(JS),PH_0(JS)
ENDDO
CLOSE(IUI6)
IF(IDIR.NE.2) IRET=12
IF(I_PH.NE.IPH_1) IPH_1=I_PH
IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN
IF(I_PH.EQ.0) THEN
NTHETA=N_FIXED
NPHI=N_SCAN
ELSE
NTHETA=N_SCAN
NPHI=N_FIXED
ENDIF
ICHKDIR=2
ENDIF
ENDIF
IF(I_EXT.GE.1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,701) IDIR,I_SET,N_POINTS
CLOSE(IUI6)
IF((IDIR.NE.1).AND.(I_EXT.EQ.2)) IRET=12
N_FIXED=N_POINTS
N_SCAN=1
NTHETA=N_POINTS
NPHI=1
ENDIF
IF(I_EXT_A.GE.1) THEN
IF(SPECTRO.EQ.'APC') THEN
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A
CLOSE(IUI9)
ELSE
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A
CLOSE(IUI6)
ENDIF
IF((IDIR_A.NE.1).AND.(I_EXT_A.EQ.2)) IRET=12
N_FIXED_A=N_POINTS_A
N_SCAN_A=1
NTHETA_A=N_POINTS_A
NPHI_A=1
ENDIF
C
IF(I_EXT_A.EQ.-1) THEN
IF(SPECTRO.EQ.'APC') THEN
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A
READ(IUI9,702) I_PH_A,N_FIXED_A,N_SCAN_A
CLOSE(IUI9)
ELSE
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A
READ(IUI6,702) I_PH_A,N_FIXED_A,N_SCAN_A
CLOSE(IUI6)
ENDIF
IF(IDIR_A.NE.2) IRET=12
IF(I_PH_A.EQ.0) THEN
NTHETA_A=N_FIXED_A
NPHI_A=N_SCAN_A
ELSE
NTHETA_A=N_SCAN_A
NPHI_A=N_FIXED_A
ENDIF
ICHKDIR_A=2
ENDIF
C
DO JLINE=1,5
READ(ICOM,1) RIEN
ENDDO
C
READ(ICOM,34) OUTFILE1,IUO1
READ(ICOM,34) OUTFILE2,IUO2
READ(ICOM,34) OUTFILE3,IUO3
READ(ICOM,34) OUTFILE4,IUO4
C
IUSCR=MAX0(ICOM,IUI2,IUI3,IUI4,IUI5,IUI6,IUI7,IUI8,IUI9,IUO1,IUO2,
&IUO3,IUO4)+1
IUSCR2=IUSCR+1
C
IF(IADS.GE.1) THEN
OPEN(UNIT=IUI5, FILE=INFILE5, STATUS='OLD')
READ(IUI5,1) RIEN
READ(IUI5,12) NATA,NADS1,NADS2,NADS3
IF(NATA.EQ.1) THEN
NADS2=0
NADS3=0
ELSEIF(NATA.EQ.2) THEN
NADS3=0
ENDIF
READ(IUI5,35) (NZAT(I),I=NAT+1,NAT+NATA)
READ(IUI5,36) (CHEM(I),I=NAT+1,NAT+NATA)
READ(IUI5,37) (UJ2(NAT+J),J=1,NATA)
READ(IUI5,38) NRELA,(PCRELA(I),I=1,NRELA)
IF(NRELA.EQ.0) THEN
DO JRELA=1,3
PCRELA(JRELA)=0.
ENDDO
ENDIF
NADS=NADS1+NADS2+NADS3
DO JADS=1,NADS
READ(IUI5,9) (ADS(I,JADS),I=1,3)
ENDDO
CLOSE(IUI5)
ELSE
NATA=0
NRELA=0
ENDIF
C
GOTO 601
C
605 REWIND ICOM
DO JLINE=1,500
READ(ICOM,5) TESLEC
IF(TESLEC.EQ.'CONTROL') THEN
BACKSPACE ICOM
READ(ICOM,34) OUTFILE1,IUO1
GOTO 601
ENDIF
ENDDO
C
601 IF((JFICH.EQ.1).OR.(ISOM.EQ.0)) THEN
c LINE REMOVED BY PYMSSPEC
ENDIF
IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN
WRITE(IUO1,105) INDATA(JFICH)
ENDIF
C
IF(IRET.EQ.1) RETURN 1
IF(IRET.EQ.3) RETURN 3
IF(IRET.EQ.4) RETURN 4
IF(IRET.EQ.5) RETURN 5
IF(IRET.EQ.6) RETURN 6
IF(IRET.EQ.7) RETURN 7
IF(IRET.EQ.8) RETURN 8
IF(IRET.EQ.9) RETURN 9
IF(IRET.EQ.10) RETURN 10
IF(IRET.EQ.11) RETURN 11
IF(IRET.EQ.12) RETURN 12
IF(IRET.EQ.13) RETURN 13
C
C
C.......... Writing of the input data in unit IUO1 ..........
C
C
WRITE(IUO1,100)
WRITE(IUO1,101)
WRITE(IUO1,101)
WRITE(IUO1,102) TEXTE1
WRITE(IUO1,101)
WRITE(IUO1,101)
WRITE(IUO1,203)
C
IF(I_TEST.NE.2) THEN
WRITE(IUO1,201) TEXTE2
ELSE
IF(ABS(IPOL).EQ.1) THEN
WRITE(IUO1,525)
ELSEIF(ABS(IPOL).EQ.2) THEN
WRITE(IUO1,526)
ENDIF
ENDIF
C
IF(NAT.GT.NATP_M) RETURN 2
IF(NE.GT.NE_M) RETURN 2
IF(NEMET.GT.NEMET_M) RETURN 2
C
IF(I_TEST.EQ.2) GOTO 606
IF(IBAS.EQ.0) THEN
WRITE(IUO1,204) A,IBAS
GOTO 604
ENDIF
WRITE(IUO1,103) CRIST,CENTR,IBAS,NAT
IF(NCRIST.EQ.1) THEN
BSURA=1.
CSURA=1.
WRITE(IUO1,304) A
ELSEIF((NCRIST.EQ.2).OR.(NCRIST.EQ.7).OR.(NCRIST.EQ.6)) THEN
BSURA=1.
WRITE(IUO1,404) A,CSURA
IF((NCRIST.EQ.6).AND.(CSURA.EQ.1.)) THEN
WRITE(IUO1,206) ALPHAD
ELSEIF(NCRIST.EQ.4) THEN
WRITE(IUO1,306) BETAD
ENDIF
ELSEIF((NCRIST.EQ.3).OR.(NCRIST.EQ.5).OR.(NCRIST.EQ.8)) THEN
WRITE(IUO1,104) A,BSURA,CSURA
IF(NCRIST.NE.3) THEN
WRITE(IUO1,106) ALPHAD,BETAD,GAMMAD
ENDIF
ENDIF
IF(NCRIST.EQ.7) THEN
WRITE(IUO1,107) IH,IK,II,IL
ELSE
WRITE(IUO1,207) IH,IK,IL
ENDIF
WRITE(IUO1,108) NIV,COUPUR,ITEST,IESURF
IF(NAT.GT.1) THEN
DO I=1,NAT
J=3*(I-1)
WRITE(IUO1,109) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(
&I)
ENDDO
ENDIF
IF(NCRIST.EQ.8) THEN
DO I=1,3
J=3*(I-1)
WRITE(IUO1,209) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J)
ENDDO
ENDIF
IF(IREL.GE.1) THEN
WRITE(IUO1,110) IREL,NREL,(PCREL(I),I=1,2)
IF(NREL.GT.2) THEN
NLIGNE=INT(FLOAT(NREL-2)/4.)+1
DO J=1,NLIGNE
WRITE(IUO1,210) (PCREL(I),I=1,4)
ENDDO
ENDIF
IF(NREL.GT.10) RETURN 4
WRITE(IUO1,112) OMEGAD1,OMEGAD2,IADS
ENDIF
IF((IREL.EQ.0).AND.(IADS.EQ.1)) WRITE(IUO1,212) IADS
IF(IADS.GE.1) THEN
WRITE(IUO1,501)
DO JADS=1,NADS
IF(JADS.LE.NADS1) THEN
IF(JADS.EQ.1) WRITE(IUO1,303) NAT+1
WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
ELSEIF((JADS.GT.NADS1).AND.(JADS.LE.(NADS1+NADS2))) THEN
IF(JADS.EQ.(NADS1+1)) WRITE(IUO1,303) NAT+2
WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
ELSEIF(JADS.GT.(NADS1+NADS2)) THEN
IF(JADS.EQ.(NADS2+1)) WRITE(IUO1,303) NAT+3
WRITE(IUO1,309) (ADS(I,JADS),I=1,3)
ENDIF
ENDDO
ENDIF
IF((IREL.GT.0).OR.(NRELA.GT.0)) WRITE(IUO1,502)
IF(NRELA.GT.0) THEN
WRITE(IUO1,311) (PCRELA(I),I=1,NRELA)
ENDIF
604 IF(IREL.GT.0) THEN
WRITE(IUO1,211) (PCREL(I),I=1,NREL)
ENDIF
C
606 IF(SPECTRO.EQ.'APC') WRITE(IUO1,517)
C
IF(SPECTRO.EQ.'PHD') THEN
C
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,503)
ELSE
WRITE(IUO1,527)
ENDIF
ENDIF
IF(IE.EQ.1) WRITE(IUO1,504)
IF(ITHETA.EQ.1) WRITE(IUO1,505)
IF(IFTHET.EQ.1) WRITE(IUO1,506)
IF(I_AMP.EQ.1) WRITE(IUO1,534)
C
WRITE(IUO1,201) TEXTE4
WRITE(IUO1,113) ISPIN,IDICHR,IPOL
WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO
WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
C
IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
WRITE(IUO1,508)
STOP
ENDIF
IF(ABS(THLUM).GT.90.0) THEN
WRITE(IUO1,509)
STOP
ENDIF
ENDIF
C
WRITE(IUO1,116) PHI0,THETA0,E0,R1
WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
WRITE(IUO1,117) THLUM,PHILUM,ELUM
WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
C
IF(IMOY.GT.3) IMOY=3
IF(IMOY.LT.0) IMOY=0
IF(IMOY.EQ.0) NDIR=1
IF(IMOY.EQ.1) NDIR=5
IF(IMOY.EQ.2) NDIR=13
IF(IMOY.EQ.3) NDIR=49
IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1
C
ELSEIF(SPECTRO.EQ.'LED') THEN
C
IF(IPHI.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,529)
ELSE
WRITE(IUO1,530)
ENDIF
ENDIF
IF(IE.EQ.1) WRITE(IUO1,531)
IF(ITHETA.EQ.1) WRITE(IUO1,532)
IF(IFTHET.EQ.1) WRITE(IUO1,506)
IF(I_AMP.EQ.1) WRITE(IUO1,534)
C
WRITE(IUO1,201) TEXTE4
WRITE(IUO1,141) ISPIN
WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
C
IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
WRITE(IUO1,508)
STOP
ENDIF
ENDIF
C
WRITE(IUO1,116) PHI0,THETA0,E0,R1
WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
WRITE(IUO1,142) TH_INI,PHI_INI
WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
C
IF(IMOY.GT.3) IMOY=3
IF(IMOY.LT.0) IMOY=0
IF(IMOY.EQ.0) NDIR=1
IF(IMOY.EQ.1) NDIR=5
IF(IMOY.EQ.2) NDIR=13
IF(IMOY.EQ.3) NDIR=49
C
ELSEIF(SPECTRO.EQ.'XAS') THEN
C
WRITE(IUO1,507)
IF(I_AMP.EQ.1) WRITE(IUO1,534)
WRITE(IUO1,201) TEXTE5
WRITE(IUO1,113) ISPIN,IDICHR,IPOL
WRITE(IUO1,134) EDGE,NEDGE,INITL,THLUM,PHILUM
WRITE(IUO1,119) NE_X,EK_INI,EK_FIN,EPH_INI
C
ELSEIF(SPECTRO.EQ.'AED') THEN
C
IF(IPHI_A.EQ.1) THEN
IF(STEREO.EQ.' NO') THEN
WRITE(IUO1,515)
ELSE
WRITE(IUO1,528)
ENDIF
ENDIF
IF(ITHETA_A.EQ.1) WRITE(IUO1,516)
IF(I_AMP.EQ.1) WRITE(IUO1,534)
WRITE(IUO1,201) TEXTE6
WRITE(IUO1,113) ISPIN,IDICHR,IPOL
WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
WRITE(IUO1,140) I_MULT,IM1,MULT,IM2
WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT
WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A
WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A
WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A
WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
C
IF(IMOY_A.GT.3) IMOY_A=3
IF(IMOY_A.LT.0) IMOY_A=0
IF(IMOY_A.EQ.0) NDIR_A=1
IF(IMOY_A.EQ.1) NDIR_A=5
IF(IMOY_A.EQ.2) NDIR_A=13
IF(IMOY_A.EQ.3) NDIR_A=49
C
ELSEIF(SPECTRO.EQ.'APC') THEN
C
WRITE(IUO1,518)
IF(IPHI.EQ.1) WRITE(IUO1,503)
IF(ITHETA.EQ.1) WRITE(IUO1,505)
IF(IFTHET.EQ.1) WRITE(IUO1,506)
IF(I_AMP.EQ.1) WRITE(IUO1,534)
C
WRITE(IUO1,201) TEXTE4
WRITE(IUO1,113) ISPIN,IDICHR,IPOL
WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO
WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET
WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET
C
IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN
IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN
WRITE(IUO1,508)
STOP
ENDIF
IF(ABS(THLUM).GT.90.0) THEN
WRITE(IUO1,509)
STOP
ENDIF
ENDIF
C
WRITE(IUO1,116) PHI0,THETA0,E0,R1
WRITE(IUO1,216) PHI1,THETA1,EFIN,R2
WRITE(IUO1,117) THLUM,PHILUM,ELUM
WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR
C
IF(IMOY.GT.3) IMOY=3
IF(IMOY.LT.0) IMOY=0
IF(IMOY.EQ.0) NDIR=1
IF(IMOY.EQ.1) NDIR=5
IF(IMOY.EQ.2) NDIR=13
IF(IMOY.EQ.3) NDIR=49
IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1
C
WRITE(IUO1,519)
IF(IPHI_A.EQ.1) WRITE(IUO1,515)
IF(ITHETA_A.EQ.1) WRITE(IUO1,516)
WRITE(IUO1,201) TEXTE6
WRITE(IUO1,113) ISPIN,IDICHR,IPOL
WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A
WRITE(IUO1,140) I_MULT,IM1,MULT,IM2
WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT
WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A
WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A
WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A
WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A
C
IF(IMOY_A.GT.3) IMOY_A=3
IF(IMOY_A.LT.0) IMOY_A=0
IF(IMOY_A.EQ.0) NDIR_A=1
IF(IMOY_A.EQ.1) NDIR_A=5
IF(IMOY_A.EQ.2) NDIR_A=13
IF(IMOY_A.EQ.3) NDIR_A=49
C
WRITE(IUO1,520)
C
ELSEIF(SPECTRO.EQ.'EIG') THEN
C
WRITE(IUO1,143) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP
DO JLINE=1,N_LINE_E-1
J=(JLINE-1)*4
WRITE(IUO1,145) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3
&),I_SPECTRUM(J+4)
ENDDO
J=4*(N_LINE_E-1)
WRITE(IUO1,145) (I_SPECTRUM(J+K),K=1,N_LAST)
C
WRITE(IUO1,146) I_PWM,METHOD,RACC,EXPO
WRITE(IUO1,147) N_MAX,N_ITER,N_TABLE,SHIFT
WRITE(IUO1,148) I_XN,I_VA,I_GN,I_WN
WRITE(IUO1,149) LEVIN,ALPHAR,BETAR
WRITE(IUO1,533)
C
ENDIF
C
WRITE(IUO1,201) TEXTE7
C
IF(SPECTRO.NE.'EIG') THEN
C
WRITE(IUO1,121) NO,NDIF,ISPHER,I_GR
C
IF(SPECTRO.EQ.'XAS') NDIF=NDIF+1
C
WRITE(IUO1,122) ISFLIP,IR_DIA,ITRTL,I_TEST
C
IF(ISFLIP.EQ.0) THEN
NSTEP=3
ELSE
NSTEP=1
ENDIF
DO N=1,NLG
NRL=3*N
JD=3*(N-1)+1
IF(N.EQ.NLG) NRL=NEMET
IF(N.EQ.1) NEMO=NEMET1
IF(N.LT.NLG) THEN
WRITE(IUO1,123) NEMO,(IEMET(J), J=JD, NRL)
ELSE
NTE=NEMET-JD+1
IF(NTE.EQ.1) WRITE(IUO1,223) NEMO,(IEMET(J),J=JD,NEMET)
IF(NTE.EQ.2) WRITE(IUO1,323) NEMO,(IEMET(J),J=JD,NEMET)
IF(NTE.EQ.3) WRITE(IUO1,123) NEMO,(IEMET(J),J=JD,NEMET)
ENDIF
ENDDO
ENDIF
IF(SPECTRO.NE.'EIG') THEN
WRITE(IUO1,124) ISOM,NONVOL(JFICH),NPATHP,VINT
WRITE(IUO1,125) IFWD,NTHOUT,I_NO,I_RA
DO JAT=1,NAT
WRITE(IUO1,126) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT)
RTHFWD(JAT)=THFWD(JAT)*PIS180
RTHBWD(JAT)=THBWD(JAT)*PIS180
ENDDO
WRITE(IUO1,127) IPW,NCUT,PCTINT,IPP
WRITE(IUO1,128) ILENGTH,RLENGTH,UNLENGTH
WRITE(IUO1,129) IDWSPH,ISPEED,IATTS,IPRINT
ELSE
WRITE(IUO1,144) VINT
ENDIF
WRITE(IUO1,130) IDCM,TD,T,RSJ
WRITE(IUO1,131) ILPM,XLPM0
DO I=1,NLEC
NDEB=4*(I-1) + 1
NFIN=4*I
IF(I.EQ.NLEC) NFIN=NAT
NUJ=NFIN-NDEB+1
IF(NUJ.EQ.1) WRITE(IUO1,132) (UJ2(J),J=NDEB,NFIN)
IF(NUJ.EQ.2) WRITE(IUO1,232) (UJ2(J),J=NDEB,NFIN)
IF(NUJ.EQ.3) WRITE(IUO1,332) (UJ2(J),J=NDEB,NFIN)
IF(NUJ.EQ.4) WRITE(IUO1,432) (UJ2(J),J=NDEB,NFIN)
ENDDO
IF(IADS.EQ.1) THEN
IF(NATA.EQ.1) WRITE(IUO1,133) (UJ2(J),J=NAT+1,NAT+NATA)
IF(NATA.EQ.2) WRITE(IUO1,233) (UJ2(J),J=NAT+1,NAT+NATA)
IF(NATA.EQ.3) WRITE(IUO1,333) (UJ2(J),J=NAT+1,NAT+NATA)
ENDIF
C
IF(UNLENGTH.EQ.'ATU') RLENGTH=RLENGTH*BOHR/A
IF(UNLENGTH.EQ.'ANG') RLENGTH=RLENGTH/A
IF(IBAS.GT.0) THEN
OMEGA1=OMEGAD1*PIS180
OMEGA2=OMEGAD2*PIS180
ENDIF
QD=0.
DO J=1,NATM
UJ2(J)=UJ2(J)/(A*A)
ENDDO
IF(E0.EQ.0.) E0=0.0001
NPOINT=NPHI*NE*NTHETA
ISORT1=0
IF(NPOINT.GT.250) THEN
ISORT1=1
WRITE(IUO1,510)
ENDIF
C
IF(IDWSPH.EQ.1) THEN
NFAC=N_GAUNT
ELSE
NFAC=4*NL_M
ENDIF
IF(SPECTRO.EQ.'EIG') THEN
C
C Switch for including vibrational damping into the MS matrix
C
C I_VIB = 0 : no vibrations included
C I_VIB = 1 : vibrations included
C
C and mean free path-like damping
C
C I_MFP = 0 : no Im(k) damping included
C I_MFP = 1 : Im(k) damping included
C
I_VIB=MOD(I_DAMP,2)
IF(I_VIB.EQ.1) THEN
IDWSPH=1
ELSE
IDWSPH=0
ENDIF
IF(I_DAMP.LE.1) THEN
I_MFP=0
ELSE
I_MFP=1
ENDIF
ENDIF
C
C Storage of the logarithm of the Gamma function GLD(N+1,N_INT)
C for integer (N_INT=1) and semi-integer (N_INT=2) values :
C
C GLD(N+1,1) = Log(N!) for N integer
C GLD(N+1/2,2) = Log(N!) for N semi-integer
C
IF((ISPHER.GE.0).OR.(I_MULT.EQ.1)) THEN
GLG(1)=0.0
GLD(1,1)=0.D0
GLD(1,2)=DLOG(SQPI/2.D0)
DO I=2,NFAC
J=I-1
GLG(I)=GLG(J)+ALOG(FLOAT(J))
GLD(I,1)=GLD(J,1)+DLOG(DFLOAT(J))
GLD(I,2)=GLD(J,2)+DLOG(DFLOAT(J) +0.5D0)
ENDDO
ELSEIF((IFTHET.EQ.1).AND.(ITEST.EQ.1)) THEN
GLG(1)=0.0
DO I=2,NFAC
J=I-1
GLG(I)=GLG(J)+ALOG(FLOAT(J))
ENDDO
ENDIF
EXPF(0,0)=1.
EXPR(0,0)=1.
FACT1L=0.D0
DO L=1,2*NL_M-2
XDEN=1./SQRT(FLOAT(L+L+1))
DXDEN=1.D0/DSQRT(DFLOAT(L+L+1))
FACT1L=FACT1L+DLOG(DFLOAT(L))
FACT2L=DLOG(DFLOAT(L+1))
DO M1=0,L
EXPF(M1,L)=EXP(0.5*(GLG(L+M1+1)-GLG(L-M1+1)))
DEXPF=DEXP(0.5D0*(GLD(L+M1+1,1)-GLD(L-M1+1,1)))
EXPR(M1,L)=EXP(0.5*(GLG(L+L+1)-GLG(L+M1+1)-GLG(L-M1+1)))
EXPF2(L,M1)=EXPF(M1,L)*XDEN
DEXPF2(L,M1)=DEXPF*DXDEN
IF(M1.GT.0) THEN
FACT2L=FACT2L+DLOG(DFLOAT(1+L+M1))
ENDIF
IF(L.LT.NL_M) THEN
DO M2=0,L
CF(L,M1,M2)=SQRT(FLOAT((L*L-M1*M1)*(L*L-M2*M2)))/FLOAT(L)
ENDDO
ENDIF
ENDDO
FSQ(L)=EXP(0.5*REAL(FACT2L-FACT1L))
DFSQ(L)=DEXP(0.5D0*(FACT2L-FACT1L))
ENDDO
C
IF((INITL.LT.-1).OR.(INITL.GT.2)) THEN
INITL=1
WRITE(IUO1,511)
ENDIF
NEPS=2-ABS(IPOL)
IF(IDICHR.GE.1) NEPS=1
ISTEP_LF=ABS(INITL)
IF(INITL.EQ.-1) THEN
LF1=LI-1
LF2=LF1
ELSEIF(INITL.EQ.1) THEN
LF1=LI+1
LF2=LF1
ELSEIF(INITL.EQ.2) THEN
LF1=LI-1
LF2=LI+1
ELSEIF(INITL.EQ.0) THEN
LF1=LI
LF2=LI
ISTEP_LF=1
ENDIF
C
C Initialization of the values of ji if spin-orbit is taken
C into account.
C
C Here : JI is the loop index going from JF1 to JF2 with :
C
C JI=1 : ji = li + 1/2
C JI=2 : ji = li - 1/2
C
IF(I_SO.EQ.0) THEN
JF1=1
JF2=2
ELSEIF(I_SO.EQ.1) THEN
IF(S_O.EQ.'1/2') THEN
IF(LI.EQ.0) THEN
JF1=1
JF2=1
ELSEIF(LI.EQ.1) THEN
JF1=2
JF2=2
ENDIF
ELSEIF(S_O.EQ.'3/2') THEN
IF(LI.EQ.1) THEN
JF1=1
JF2=1
ELSEIF(LI.EQ.2) THEN
JF1=2
JF2=2
ENDIF
ELSEIF(S_O.EQ.'5/2') THEN
IF(LI.EQ.2) THEN
JF1=1
JF2=1
ELSEIF(LI.EQ.3) THEN
JF1=2
JF2=2
ENDIF
ELSEIF(S_O.EQ.'7/2') THEN
IF(LI.EQ.3) THEN
JF1=1
JF2=1
ELSEIF(LI.EQ.4) THEN
JF1=2
JF2=2
ENDIF
ELSEIF(S_O.EQ.'9/2') THEN
IF(LI.EQ.4) THEN
JF1=1
JF2=1
ELSE
RETURN 7
ENDIF
ELSE
RETURN 7
ENDIF
ELSEIF(I_SO.EQ.2) THEN
JF1=1
JF2=2
ELSE
RETURN 7
ENDIF
C
IF(NI.LE.5) THEN
NNL=NI*(NI-1)/2 +LI+1
ELSEIF(NI.EQ.6) THEN
NNL=NI*(NI-1)/2 +LI
ELSEIF(NI.EQ.7) THEN
NNL=NI*(NI-1)/2 +LI-3
ENDIF
C
C Storage of the Clebsch-Gordan coefficients for the spin-orbit
C dependent coupling matrix elements in the array CG(MJI,JI,JSPIN).
C
C Here : JI=1 : ji = li + 1/2
C JI=2 : ji = li - 1/2
C MJI : mji + 1/2
C JSPIN=1 : msi = +1/2
C JSPIN=2 : msi = -1/2
C
C so that all indices remain integer
C
IF((I_SO.GT.0).OR.(ISPIN.EQ.1).OR.(SPECTRO.EQ.'APC')) THEN
DO JS=1,2
DO JI=1,2
DO MJI=-LI,LI+1
CG(MJI,JI,JS)=0.0
ENDDO
ENDDO
ENDDO
DO MJI=-LI,LI+1
CG(MJI,1,1)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1))
CG(MJI,1,2)=SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1))
IF((MJI.GT.-LI).AND.(MJI.LT.LI+1)) THEN
CG(MJI,2,1)=-SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1))
CG(MJI,2,2)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1))
ENDIF
ENDDO
ENDIF
C
C
C Storage of the Clebsch-Gordan coefficients for the Auger multiplet
C dependent coupling matrix elements in the array CGA(LJ1,MJ1,LJ2,MJ2,LJ).
C
C Here : LJ1 is an integer index related to J1 (LJ1=2*J1)
C LMJ1 is an integer index related to MJ1 (LMJ1=2*MJ1)
C LJ2 is an integer index related to J2 (LJ2=2*J2)
C LMJ2 is an integer index related to MJ2 (LMJ2=2*MJ2)
C LJ is an integer index related to J :
C J = FLOAT(LJ) for J integer
C J = FLOAT(LJ) + 0.5 for J half integer
C
C so that all indices remain integer
C
IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN
IF(I_MULT.EQ.1) THEN
N=3
MJ3=0.D0
LJ_MAX=2*(LI_I+LI_A+1)
DO LJ1=0,LJ_MAX
J1=DFLOAT(LJ1)/2.D0
DO LMJ1=-LJ1,LJ1,2
MJ1=DFLOAT(LMJ1)/2.D0
DO LJ2=0,LJ_MAX
J2=DFLOAT(LJ2)/2.D0
DO LMJ2=-LJ2,LJ2,2
MJ2=DFLOAT(LMJ2)/2.D0
CALL N_J(J1,MJ1,J2,MJ2,MJ3,NJ,I_INT,N)
C
JJ12=J1-J2
JL12=MJ1-MJ2
C
LJ12=INT(JJ12+SIGN(SMALL,JJ12))
LL12=INT(JL12+SIGN(SMALL,JL12))
C
JJ_MIN=ABS(LJ12)
JJ_MAX=J1+J2
LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN))
LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX))
C
DO LJJ=LJJ_MIN,LJJ_MAX,1
IF(I_INT.EQ.1) THEN
JJ=DFLOAT(LJJ)
ELSE
JJ=DFLOAT(LJJ)+0.5D0
ENDIF
L_EXP=INT(J1-J2+MJ1+MJ2)
IF(MOD(L_EXP,2).EQ.0) THEN
CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=NJ(LJJ)*SQRT(2.*REAL(JJ
&)+1.)
ELSE
CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=-NJ(LJJ)*SQRT(2.*REAL(J
&J)+1.)
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
C
C Storage of another of the spin Clebsch-Gordan used
C when the Auger line is multiplet-resolved. It
C originates from the coupling of SA and SC,
C the spins of the Auger electron of the original
C core electron (which is supposed to be the same
C as that of the photoelectron).
C
C CG_S(I,J,K) with : I = 1 ---> MSA = -1/2
C I = 2 ---> MSA = 1/2
C J = 1 ---> MSC = -1/2
C J = 2 ---> MSC = 1/2
C K = 1 ---> S = 0
C K = 2 ---> S = 1
C
C MS = MSA+MSC
C
IF(I_MULT.EQ.1) THEN
CG_S(1,1,1)=0.
CG_S(1,1,2)=1.
CG_S(1,2,1)=-0.707107
CG_S(1,2,2)= 0.707107
CG_S(2,1,1)= 0.707107
CG_S(2,1,2)= 0.707107
CG_S(2,2,1)= 0.
CG_S(2,2,2)= 1.
ENDIF
C
C Initialization of the variables used when only one multiplet
C is taken into account in the Auger peak
C
IF(I_MULT.EQ.1) THEN
MULTIPLET=CHAR(48+IM1)//MULT//CHAR(48+IM2)
IF(MOD(IM1,2).EQ.0) THEN
WRITE(IUO1,522) IM1
STOP
ENDIF
S_MUL=(IM1-1)/2
J_MUL=IM2
IF(MULT.EQ.'S') THEN
L_MUL=0
ELSEIF(MULT.EQ.'P') THEN
L_MUL=1
ELSEIF(MULT.EQ.'D') THEN
L_MUL=2
ELSEIF(MULT.EQ.'F') THEN
L_MUL=3
ELSEIF(MULT.EQ.'G') THEN
L_MUL=4
ELSEIF(MULT.EQ.'H') THEN
L_MUL=5
ELSEIF(MULT.EQ.'I') THEN
L_MUL=6
ELSEIF(MULT.EQ.'K') THEN
L_MUL=7
ELSEIF(MULT.EQ.'L') THEN
L_MUL=8
ELSEIF(MULT.EQ.'M') THEN
L_MUL=9
ELSE
WRITE(IUO1,521) MULTIPLET
STOP
ENDIF
ENDIF
C
C.......... Check of the dimensioning in the Gaussian case ..........
C
CALL STOP_EXT(I_EXT,I_EXT_A,SPECTRO)
C
C.................... Read FORMAT ....................
C
C
1 FORMAT(A7)
2 FORMAT(21X,10A4)
3 FORMAT(7X,A3,9X,A1,9X,I1,6X,I4)
4 FORMAT(8X,F6.3,4X,F6.3,4X,F6.3,3X,A3)
5 FORMAT(49X,A7)
6 FORMAT(7X,F6.2,4X,F6.2,4X,F6.2)
7 FORMAT(8X,I2,8X,I2,8X,I2,8X,I2)
8 FORMAT(8X,I2,8X,F6.3,3X,I3,9X,I1)
9 FORMAT(8X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2)
10 FORMAT(9X,I1,8X,I2,7X,F5.1,5X,F5.1)
11 FORMAT(7X,F5.1,3(5X,F5.1))
12 FORMAT(7X,F6.2,4X,F6.2,6X,I1)
13 FORMAT(7X,A3,9X,I1,9X,I1,8X,I2)
14 FORMAT(8X,I2,9X,I1,9X,I1,9X,I1,9X,I1)
15 FORMAT(7X,I3,7X,I3,7X,I3,7X,I3)
16 FORMAT(6X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3)
17 FORMAT(6X,F7.2,3X,F7.2,2X,F8.2)
18 FORMAT(9X,I1,9X,I1,8X,F5.2,6X,I1)
19 FORMAT(7X,I3,6X,F7.2,3X,F7.2,2X,F8.2)
20 FORMAT(8X,I1,A1,8X,A3,7X,I2,8X,I2)
21 FORMAT(8X,I2,8X,I2,9X,I1,9X,I1)
22 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
23 FORMAT(8X,I2)
24 FORMAT(8X,I2,3(8X,I2))
25 FORMAT(9X,I1,8X,I2,6X,I4,8X,F6.2)
26 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
27 FORMAT(9X,I1,6X,F6.2,7X,I1,7X,F6.2)
28 FORMAT(9X,I1,9X,I1,7X,F8.4,4X,I1)
29 FORMAT(9X,I1,7X,F6.2,4X,A3)
30 FORMAT(9X,I1,8X,I2,9X,I1,9X,I1)
31 FORMAT(9X,I1,6X,F8.3,2X,F8.3,5X,F4.2)
32 FORMAT(8X,I2,7X,F6.2)
33 FORMAT(8X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5)
34 FORMAT(9X,A24,5X,I2)
35 FORMAT(18X,I2,8X,I2,8X,I2)
36 FORMAT(18X,A2,8X,A2,8X,A2)
37 FORMAT(18X,F8.5,2X,F8.5,2X,F8.5)
38 FORMAT(9X,I1,7X,F5.1,5X,F5.1,5X,F5.1)
39 FORMAT(8X,A1,I1,8X,I2,6X,F7.2,3X,F7.2)
40 FORMAT(8X,A1,I1,8X,A1,I1,8X,A1,I1)
41 FORMAT(6X,F7.2,3X,F7.2,5X,F6.3)
42 FORMAT(9X,I1,8X,I1,A1,I1)
43 FORMAT(7X,I3,6X,F7.2,3X,F7.2,6X,I1)
44 FORMAT(9X,I1)
46 FORMAT(8X,I2,6X,A4,9X,F7.5,2X,F6.3)
47 FORMAT(5X,I5,6X,I4,6X,I4,8X,F6.3)
48 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1)
49 FORMAT(8X,I2,6X,F7.2,3X,F7.2)
C
C
C.................... Write FORMAT ....................
C
C
100 FORMAT(//////////,'******************************', '*************
&***************************************')
101 FORMAT('*********************',40X,'*********************')
102 FORMAT('*********************',10A4,'*********************')
103 FORMAT(10X,A3,9X,A1,9X,I1,6X,I4,9X,'CRIST,CENTR,IBAS,NAT')
104 FORMAT(11X,F6.3,4X,F6.3,4X,F6.3,15X,'A,BSURA,CSURA')
105 FORMAT(///,'ooooooooooooooooooooooooooooooooooooooooo','oooooooooo
&ooooooooooooooooooooooooooooooo',/,'oooooooooooooooo',50X,'ooooooo
&ooooooooo',/,'oooooooooooooooo INPUT DATA FILE : ',A24,' ooo
&ooooooooooooo',/,'oooooooooooooooo',50X,'oooooooooooooooo',/,'oooo
&oooooooooooooooooooooooo','ooooooooooooooooooooooooooooooooooooooo
&oooooooooo','ooooo',///)
106 FORMAT(10X,F6.2,4X,F6.2,4X,F6.2,16X,'ALPHAD,BETAD,GAMMAD')
107 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'H,K,I,L')
108 FORMAT(12X,I1,8X,F6.3,3X,I3,9X,I1,9X,'NIV,COUPUR,ITEST,IESURF')
109 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2,4X,'ATBAS,CHEM(NAT)','
&,NZAT(NAT)')
110 FORMAT(12X,I1,8X,I2,7X,F5.1,5X,F5.1,7X,'IREL,NREL,PCREL(NREL)')
112 FORMAT(10X,F6.2,4X,F6.2,6X,I1,19X,'OMEGA1,OMEGA2,IADS')
113 FORMAT(12X,I1,9X,I1,8X,I2,19X,'ISPIN,IDICHR,IPOL')
114 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI,ITHETA,IE,',
&'IFTHET')
115 FORMAT(10X,I3,7X,I3,7X,I3,7X,I3,9X,'NPHI,NTHETA,NE,NFTHET')
116 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI0,THETA0,E0,R0')
117 FORMAT(9X,F7.2,3X,F7.2,2X,F8.2,16X,'THLUM,PHILUM,ELUM')
118 FORMAT(12X,I1,9X,I1,8X,F5.2,6X,I1,9X,'IMOD,IMOY,ACCEPT,ICHKDIR')
119 FORMAT(10X,I3,6X,F7.2,3X,F7.2,2X,F8.2,6X,'NE,EK_INI,','EK_FIN,EPH_
&INI')
120 FORMAT(11X,I1,A1,8X,A3,7X,I2,8X,I2,9X,'LI,S-O,INITL,I_SO')
121 FORMAT(11X,I2,8X,I2,9X,I1,9X,I1,9X,'NO,NDIF,ISPHER,I_GR')
122 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'ISFLIP,IR_DIA,ITRTL,I_TEST')
123 FORMAT(11X,I2,3(8X,I2),9X,'NEMET,IEMET(NEMET)')
124 FORMAT(12X,I1,8X,I2,6X,I4,7X,F6.2,6X,'ISOM,NONVOL,NPATH,VINT')
125 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'IFWD,NTHOUT,I_NO,I_RA')
126 FORMAT(12X,I1,7X,F6.2,6X,I1,7X,F6.2,6X,'N_RA(NAT),THFWD(NAT)',',IB
&WD(NAT),THBWD(NAT)')
127 FORMAT(12X,I1,9X,I1,7X,F8.4,4X,I1,9X,'IPW,NCUT,PCTINT,IPP')
128 FORMAT(12X,I1,7X,F6.2,4X,A3,19X,'ILENGTH,RLENGTH,UNLENGTH')
129 FORMAT(12X,I1,8X,I2,9X,I1,9X,I1,9X,'IDWSPH,ISPEED,IATT,IPRINT')
130 FORMAT(12X,I1,6X,F8.3,2X,F8.3,5X,F4.2,6X,'IDCM,TD,T,RSJ')
131 FORMAT(11X,I2,7X,F6.2,26X,'ILPM,XLPM0')
132 FORMAT(11X,F8.5,33X,'UJ2(NAT) : ','SUBSTRATE')
133 FORMAT(11X,F8.5,33X,'UJ2(NATA) : ','ADSORBATES')
134 FORMAT(11X,A1,I1,8X,I2,6X,F7.2,3X,F7.2,6X,'EDGE,INITL,THLUM,','PHI
&LUM')
135 FORMAT(11X,A1,I1,8X,A1,I1,8X,A1,I1,19X,'EDGE_C,EDGE_I,','EDGE_A')
136 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI_A,ITHETA_A,','IFTHET_A,I_
&INT')
137 FORMAT(10X,I3,7X,I3,7X,I3,19X,'NPHI_A,NTHETA_A,NFTHET_A')
138 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI0_A,THETA0_A,R0_A')
139 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI1_A,THETA1_A,R1_A')
140 FORMAT(12X,I1,8X,I1,A1,I1,28X,'I_MULT,MULT')
141 FORMAT(12X,I1,39X,'ISPIN')
142 FORMAT(9X,F7.2,3X,F7.2,26X,'TH_INI,PHI_INI')
143 FORMAT(10X,I3,6X,F7.2,3X,F7.2,6X,I1,9X,'NE,EK_INI,EK_FIN,I_DAMP')
144 FORMAT(10X,F6.2,36X,'VINT')
145 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'I_SPECTRUM(NE)')
146 FORMAT(11X,I2,6X,A4,9X,F7.5,2X,F6.3,5X,'I_PWM,METHOD,ACC,EXPO')
147 FORMAT(8X,I5,6X,I4,6X,I4,8X,F6.3,5X,'N_MAX,N_ITER,N_TABLE,SHIFT')
148 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'I_XN,I_VA,I_GN,I_WN')
149 FORMAT(11X,I2,6X,F7.2,3X,F7.2,16X,'L,ALPHA,BETA')
C
201 FORMAT(///,21X,10A4,////)
203 FORMAT('**************************************************',
&'********************************',//////////)
204 FORMAT(11X,F6.3,5X,I1,29X,'A,IBAS')
206 FORMAT(10X,F6.2,36X,'ALPHAD')
207 FORMAT(11X,I2,8X,I2,8X,I2,19X,'H,K,L')
209 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'VECBAS')
210 FORMAT(10X,F5.1,3(5X,F5.1),7X,'PCREL(NREL)')
211 FORMAT(20X,'SUBSTRATE : ',10(F5.1,','))
212 FORMAT(32X,I1,19X,'IADS')
216 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI1,THETA1,EFIN,R1')
223 FORMAT(11X,I2,1(8X,I2),29X,'NEMET,IEMET(NEMET)')
232 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NAT) : ','SUBSTRATE')
233 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NATA) : ','ADSORBATES')
C
303 FORMAT(/,33X,'ATOMS OF TYPE ',I1,' :',/)
304 FORMAT(11X,F6.3,35X,'A')
306 FORMAT(10X,F6.2,36X,'BETAD')
309 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'XADS,YADS,ZADS')
311 FORMAT(20X,'ADSORBATE : ',3(F5.1,','))
323 FORMAT(11X,I2,2(8X,I2),19X,'NEMET,IEMET(NEMET)')
332 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NAT) : ','SUBSTRATE')
333 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NATA) : ','ADSORBATES')
C
404 FORMAT(11X,F6.3,4X,F6.3,25X,'A,CSURA')
432 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5,3X,'UJ2(NAT) : ','SUBSTRA
&TE')
C
501 FORMAT(//,30X,'POSITION OF THE ADSORBATES :')
502 FORMAT(///,25X,'VALUE OF THE RELAXATIONS :',/)
503 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL PHOTOELECTRON',' D
&IFFRACTION')
504 FORMAT(///,18X,'TYPE OF CALCULATION : FINE STRUCTURE ','OSCILLATIO
&NS')
505 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR PHOTOELECTRON',' DIFFR
&ACTION')
506 FORMAT(///,23X,'TYPE OF CALCULATION : SCATTERING FACTOR')
507 FORMAT(///,28X,'TYPE OF CALCULATION : EXAFS')
508 FORMAT(///,2X,' <<<<<<<<<< THE THETA VARIATION EXCEEDS THE ', 'P
&HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///)
509 FORMAT(///,2X,' <<<<<<<<<< THE THLUM VARIATION EXCEEDS THE ', 'P
&HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///)
510 FORMAT(///,4X,' <<<<<<<<<< AS THE CALCULATION HAS MORE THAN ','25
&0 POINTS, SOME OUTPUTS HAVE BEEN SUPRESSED >>>>>>>>>>',///)
511 FORMAT(///,4X,' <<<<<<<<<< INCORRECT VALUE OF INITL, THE ', 'C
&ALCULATION IS PERFORMED WITH INITL = 1 >>>>>>>>>>')
512 FORMAT(///,4X,' <<<<<<<<<< IMPOSSIBLE TO HAVE A SPIN RESOLVED ','
&EXAFS EXPERIMENT : DECREASE IDICHR >>>>>>>>>>')
513 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IPOL = 0 AND ','ID
&ICHR > 0 >>>>>>>>>>')
514 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IDICHR = 2 AND ','
&ISPIN = 0 >>>>>>>>>>')
515 FORMAT(///,12X,'TYPE OF CALCULATION : AZIMUTHAL AUGER ELECTRON','
&DIFFRACTION')
516 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR AUGER ELECTRON',' DIFF
&RACTION')
517 FORMAT(///,10X,'TYPE OF CALCULATION : AUGER PHOTOELECTRON ','COINC
&IDENCE SPECTROSCOPY')
518 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','-----
&-------------------')
519 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','-----
&-------------------')
520 FORMAT(///,9X,'----------------------------------------------','--
&--------------------')
521 FORMAT(///,4X,' <<<<<<<<<< ',A3,' IS NOT IMPLEMENTED IN THIS ','V
&ERSION >>>>>>>>>>')
522 FORMAT(///,4X,' <<<<<<<<<< WRONG NAME FOR THE MULTIPLET',' >>>>>
&>>>>>',/,4X,' <<<<<<<<<< ODD NUMBER ','EXPECTED INSTEAD OF',I2,'
& >>>>>>>>>>')
523 FORMAT(///,4X,' <<<<<<<<<< BOTH DETECTOR DIRECTIONS MUST BE ','EI
&THER INTERNAL OR EXTERNAL >>>>>>>>>>',/,8X,' -----> PROCEEDING WI
&TH EXTERNAL DIRECTIONS',/)
524 FORMAT(///,4X,' <<<<<<<<<< AVERAGING OVER ',I3,' DOMAINS ','FOR P
&HOTOELECTRON >>>>>>>>>>',/,4X,' <<<<<<<<<< AVERAGING OVER ',I3,
&' DOMAINS ','FOR AUGER ELECTRON >>>>>>>>>>',/,8X,' -----> IMPOSS
&IBLE : CHECK INPUT FILES !')
525 FORMAT(///,14X,'ATOMIC CALCULATION : Z AXIS ALONG POLARIZATION ','
&DIRECTION',/,' ',/,' ',/,' ')
526 FORMAT(///,18X,'ATOMIC CALCULATION : Z AXIS ALONG LIGHT ','DIRECTI
&ON',/,' ',/,' ',/,' ')
527 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' PHOTOELEC
&TRON DIFFRACTION')
528 FORMAT(///,10X,'TYPE OF CALCULATION : FULL HEMISPHERE',' AUGER ELE
&CTRON DIFFRACTION')
529 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL LEED',' VARIATIONS
&')
530 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' LEED')
531 FORMAT(///,18X,'TYPE OF CALCULATION : LEED ENERGY ','VARIATIONS')
532 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR LEED',' VARIATIONS')
533 FORMAT(///,17X,'TYPE OF CALCULATION : EIGENVALUE',' ANALYSIS')
534 FORMAT(///,22X,'THE AMPLITUDES WILL BE PRINTED SEPARATELY')
C
701 FORMAT(6X,I1,1X,I3,2X,I4)
702 FORMAT(6X,I1,1X,I3,3X,I3)
703 FORMAT(15X,F8.3,3X,F8.3)
713 FORMAT(6X,I1,1X,I3)
C
RETURN
C
END
C
C=======================================================================
C
FUNCTION SIG2(RJ,JTYP)
C
C This routine evaluates the mean square displacements.
C
USE DIM_MOD
C
USE DEBWAL_MOD , T => TEMP
USE MASSAT_MOD , XM => XMT
USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT
&, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT
C
REAL MJ
C
C
C
DATA COEF/145.52539/
DATA RZ2,RZ4,RZ6/1.644934,1.082323,1.017343/
C
A=TD/T
BJ=QD*RJ
U=BJ/A
MJ=XM(JTYP)
C=COEF/(2.*MJ*TD)
COMP=RZ2-U*U*RZ4+U*U*U*U*RZ6
X1=0.
X2=0.
X3=0.
X4=0.
DO 10 N=1,8
Z=FLOAT(N)
X1=X1+EXP(-Z*A)*((A/Z)+(1./(Z*Z)))
X2=X2+1./(Z**8+U*U*(Z**6))
X3=X3+EXP(-Z*A)*Z/(Z*Z+U*U)
X4=X4+EXP(-Z*A)/(Z*Z+U*U)
10 CONTINUE
P1=1.+4.*(RZ2-X1)/(A*A)
P2=-2.*(1.-COS(BJ))/(BJ*BJ)
P3=-4.*(COMP-(U**6)*X2)/(A*A)
P4=4.*SIN(BJ)*X3/(A*BJ)
P5=4.*COS(BJ)*X4/(A*A)
SIG2=C*(P1+P2+P3+P4+P5)/(A0*A0)
C
RETURN
C
END
C
C=======================================================================
C
DOUBLE PRECISION FUNCTION SIXJ_IN(J1,J2,L1,L2,L3)
C
C This function calculates the initial value {J1 J2 L1+L2}
C {L1 L2 L3 }
C
C A 6j symbol {J1 J2 J3} is non zero only if
C {J4 J5 J6}
C
C (J1,J2,J3),(J4,J5,J3),(J2,J4,J6) and (J1,J5,J6) satisfy the triangular inequality :
C
C (a,b,c) non zero if |a-b| <= c <= (a+b) . This means also that (a+b) and c must
C have the same nature (integer or half-integer).
C
C (J1,J2,J3) and (J4,J5,J3) are taken care of by the bounds of J3, JJ_MIN and JJ_MAX,
C as chosen in the N_J routine. Here we check the two last ones.
C
C Last modified : 8 Dec 2008
C
C
USE DIM_MOD
USE LOGAMAD_MOD
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL*8 J1,J2,L1,L2,L3
C
C
DATA SMALL /0.0001/
C
IZERO=0
C
C Check for unphysical values of L3
C
IF(DABS(J2-L1).GT.L3) IZERO=1
IF(J2+L1.LT.L3) IZERO=1
IF(IG(J2+L1).NE.IG(L3)) IZERO=1
IF(DABS(J1-L2).GT.L3) IZERO=1
IF(J1+L2.LT.L3) IZERO=1
IF(IG(J1+L2).NE.IG(L3)) IZERO=1
C
IF(IZERO.EQ.1) THEN
SIXJ_IN=0.D0
ELSE
C
C Storage indices of the angular momenta.
C
LJ1=INT(J1+SIGN(SMALL,J1))
LJ2=INT(J2+SIGN(SMALL,J2))
LL1=INT(L1+SIGN(SMALL,L1))
LL2=INT(L2+SIGN(SMALL,L2))
LL3=INT(L3+SIGN(SMALL,L3))
LL1_2=INT(L1+L1+SIGN(SMALL,L1))
LL2_2=INT(L2+L2+SIGN(SMALL,L2))
C
MSIGN=INT(J1+J2+L1+L2+SIGN(SMALL,J1+J2+L1+L2))
IF(MOD(MSIGN,2).EQ.0) THEN
SIGNE=1.D0
ELSE
SIGNE=-1.D0
ENDIF
C
D1=GLD(LL1_2+1,1) + GLD(LL2_2+1,1) - GLD(LL1_2+LL2_2+2,1)
D2=GLD(INT(J1+J2+L1+L2)+2,IG(J1+J2+L1+L2)) - GLD(INT(J1+J2-L1-L2
&)+1,IG(J1+J2-L1-L2))
D3=GLD(INT(J1-J2+L1+L2)+1,IG(J1-J2+L1+L2)) - GLD(INT(J1+L2-L3)+1
&,IG(J1+L2-L3))
D4=GLD(INT(J2-J1+L1+L2)+1,IG(J2-J1+L1+L2)) -GLD(INT(-J1+L2+L3)+1
&,IG(-J1+L2+L3))
D5=GLD(INT(J1-L2+L3)+1,IG(J1-L2+L3)) - GLD(INT(J1+L2+L3)+2,IG(J1
&+L2+L3))
D6=GLD(INT(J2+L3-L1)+1,IG(J2+L3-L1)) - GLD(INT(J2-L3+L1)+1,IG(J2
&-L3+L1))
D7=GLD(INT(L1+L3-J2)+1,IG(L1+L3-J2)) +GLD(INT(L1+J2+L3)+2,IG(L1+
&J2+L3))
C
SIXJ_IN=SIGNE*DSQRT(DEXP(D1+D2+D3+D4+D5+D6-D7))
C
ENDIF
C
END
C
C=======================================================================
C
SUBROUTINE SPH_HAR(NL,X,CF,YLM,NC)
C
C This routine computes the complex spherical harmonics using Condon and
C Shortley phase convention.
C
C If the angular direction R=(THETAR,PHIR) is given in cartesian
C coordinates by (XR,YR,ZR), the arguments of the subroutine are :
C
C X = ZR = cos(THETAR)
C CF = XR + i YR = sin(THETAR)*exp(i PHIR)
C
C NL is the dimensioning of the YLM array and NC is
C the maximum l value to be computed.
C
USE DIM_MOD
C
USE EXPFAC2_MOD
USE FACTSQ_MOD
C
COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF
C
DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/
C
C
YLM(0,0)=CMPLX(SQ4PI_INV)
YLM(1,0)=X*SQR3_INV
DO L=2,NC
Y=1./FLOAT(L)
YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L)
&-1.5))*YLM(L-2,0)
ENDDO
C
C2=-1.
C=-0.5*CF
C
C1=1.
COEF=(1.,0.)
DO M=1,NC
C1=C1*C2
COEF=COEF*C
YMM=SQ4PI_INV*COEF*FSQ(M)
YLM(M,M)=YMM
YLM(M,-M)=C1*CONJG(YMM)
YMMP=X*SQRT(FLOAT(M+M+3))*YMM
YLM(M+1,M)=YMMP
YLM(M+1,-M)=C1*CONJG(YMMP)
IF(M.LT.NC-1) THEN
DO L=M+2,NC
YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2(
&L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M))
YLM(L,-M)=C1*CONJG(YLM(L,M))
ENDDO
ENDIF
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE SPH_HAR2(NL,X,CF,YLM,NC)
C
C This routine computes the complex spherical harmonics using Condon and
C Shortley phase convention.
C
C If the angular direction R=(THETAR,PHIR) is given in cartesian
C coordinates by (XR,YR,ZR), the arguments of the subroutine are :
C
C X = ZR = cos(THETAR)
C CF = XR + i YR = sin(THETAR)*exp(i PHIR)
C
C NL is the dimensioning of the YLM array and NC is
C the maximum l value to be computed.
C
C This is the double precision version of sph_har.f
C
C
USE DIM_MOD
C
USE DEXPFAC2_MOD
USE DFACTSQ_MOD
C
C
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMPLEX*16 YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF
C
DATA SQ4PI_INV,SQR3_INV /0.282094791774D0,0.488602511903D0/
C
C
YLM(0,0)=DCMPLX(SQ4PI_INV)
YLM(1,0)=X*SQR3_INV
DO L=2,NC
Y=1.D0/DFLOAT(L)
YLM(L,0)=X*DSQRT(4.D0-Y*Y)*YLM(L-1,0) - (1.D0-Y)*DSQRT(1.D0+2.D0
&/(DFLOAT(L)-1.5D0))*YLM(L-2,0)
ENDDO
C
C2=-1.D0
C=-0.5D0*CF
C
C1=1.D0
COEF=(1.D0,0.D0)
DO M=1,NC
C1=C1*C2
COEF=COEF*C
YMM=SQ4PI_INV*COEF*DFSQ(M)
YLM(M,M)=YMM
YLM(M,-M)=C1*DCONJG(YMM)
YMMP=X*DSQRT(DFLOAT(M+M+3))*YMM
YLM(M+1,M)=YMMP
YLM(M+1,-M)=C1*DCONJG(YMMP)
IF(M.LT.NC-1) THEN
DO L=M+2,NC
YLM(L,M)=(X*DFLOAT(L+L-1)*DEXPF2(L-1,M)*YLM(L-1,M) - DFLOAT(
&L+M-1)*DEXPF2(L-2,M)*YLM(L-2,M))/(DEXPF2(L,M)*DFLOAT(L-M))
YLM(L,-M)=C1*DCONJG(YLM(L,M))
ENDDO
ENDIF
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE STOP_EXT(I_EXT,I_EXT_A,SPECTRO)
C
C This routine stops the code when the dimension N_TILT_M in the
C spec.inc file is insufficient for the number of values to
C Gaussian average over (as generated by the ext_dir.f code)
C
USE DIM_MOD
C
USE INFILES_MOD
USE INUNITS_MOD
USE OUTUNITS_MOD
C
C
C
CHARACTER*3 SPECTRO
C
NSET=1
NSET_A=1
C
IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN
IF(I_EXT.EQ.-1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,15) IDIR,NSET
CLOSE(IUI6)
ENDIF
IF(I_EXT_A.EQ.-1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,15) IDIR,NSET_A
CLOSE(IUI6)
ENDIF
ENDIF
IF(SPECTRO.EQ.'APC') THEN
IF(I_EXT.EQ.-1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,15) IDIR,NSET
CLOSE(IUI6)
ENDIF
IF(I_EXT_A.EQ.-1) THEN
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,15) IDIR,NSET_A
CLOSE(IUI9)
ENDIF
ENDIF
C
IF(MAX(NSET,NSET_A).GT.N_TILT_M) THEN
WRITE(IUO1,10) MAX(NSET,NSET_A)
STOP
ENDIF
C
10 FORMAT(///,16X,'<<<<<<<<<< N_TILT_M SHOULD BE AT LEAST ',I3,' >>
&>>>>>>>>')
15 FORMAT(6X,I1,1X,I3)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI
&,NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO)
C
C This subroutine stops the code before the long MS calculations
C when the dimensioning NDIM_M of the treatment routines
C (treat_aed,treat_apc,treat_phd,treat_xas) is insufficient.
C
C
C Last modified : 06 Oct 2006
C
USE DIM_MOD
USE OUTUNITS_MOD
C
CHARACTER*3 SPECTRO
C
C
IF(ISOM.EQ.0) THEN
C
C Photoelectron diffraction case
C
IF(SPECTRO.EQ.'PHD') THEN
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
NDP=NEMET*NTHETA*NPHI*NE
ELSEIF(I_EXT.EQ.-1) THEN
NDP=NEMET*NTHETA*NPHI*NE*2
ELSEIF(I_EXT.EQ.2) THEN
NDP=NEMET*NTHETA*NE
ENDIF
NTT=NPLAN*NDP
IF(NTT.GT.NDIM_M) GOTO 10
IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
C
C Auger electron diffraction case
C
ELSEIF(SPECTRO.EQ.'AED') THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NEMET*NTHETA_A*NPHI_A*NE
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NEMET*NTHETA_A*NPHI_A*NE*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NEMET*NTHETA_A*NE
ENDIF
NTT=NPLAN*NDP
IF(NTT.GT.NDIM_M) GOTO 20
IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
C
C X-ray absorption case
C
ELSEIF(SPECTRO.EQ.'XAS') THEN
NDP=NEMET*NE
NTT=NPLAN*NDP
IF(NTT.GT.NDIM_M) GOTO 30
C
C Auger Photoelectron coincidence spectroscopy case
C
ELSEIF(SPECTRO.EQ.'APC') THEN
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A
ENDIF
ELSEIF(I_EXT.EQ.-1) THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A
ENDIF
ELSEIF(I_EXT.EQ.2) THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NEMET*NTHETA*NE*NTHETA_A
ENDIF
ENDIF
NTT=NPLAN*NDP
IF(NTT.GT.NDIM_M) GOTO 40
IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
ENDIF
C
ELSE
C
C Photoelectron diffraction case
C
IF(SPECTRO.EQ.'PHD') THEN
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
NDP=NTHETA*NPHI*NE
ELSEIF(I_EXT.EQ.-1) THEN
NDP=NTHETA*NPHI*NE*2
ELSEIF(I_EXT.EQ.2) THEN
NDP=NTHETA*NE
ENDIF
NTT=NFICHLEC*NDP
IF(NTT.GT.NDIM_M) GOTO 10
IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
C
C Auger electron diffraction case
C
ELSEIF(SPECTRO.EQ.'AED') THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NTHETA_A*NPHI_A*NE
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NTHETA_A*NPHI_A*NE*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NTHETA_A*NE
ENDIF
NTT=NFICHLEC*NDP
IF(NTT.GT.NDIM_M) GOTO 20
IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
C
C X-ray absorption case
C
ELSEIF(SPECTRO.EQ.'XAS') THEN
NDP=NE
NTT=NFICHLEC*NDP
IF(NTT.GT.NDIM_M) GOTO 30
C
C Auger Photoelectron coincidence spectroscopy case
C
ELSEIF(SPECTRO.EQ.'APC') THEN
IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NTHETA*NPHI*NE*NTHETA_A
ENDIF
ELSEIF(I_EXT.EQ.-1) THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NTHETA*NPHI*NE*2*NTHETA_A
ENDIF
ELSEIF(I_EXT.EQ.2) THEN
IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN
NDP=NTHETA*NE*NTHETA_A*NPHI_A
ELSEIF(I_EXT_A.EQ.-1) THEN
NDP=NTHETA*NE*NTHETA_A*NPHI_A*2
ELSEIF(I_EXT_A.EQ.2) THEN
NDP=NTHETA*NE*NTHETA_A
ENDIF
ENDIF
NTT=NFICHLEC*NDP
IF(NTT.GT.NDIM_M) GOTO 40
IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50
IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50
ENDIF
ENDIF
C
GOTO 5
C
10 WRITE(IUO1,11) NTT
STOP
20 WRITE(IUO1,21) NTT
STOP
30 WRITE(IUO1,31) NTT
STOP
40 WRITE(IUO1,41) NTT
STOP
50 WRITE(IUO1,51) MAX(NTHETA,NPHI,NTHETA_A,NPHI_A)
STOP
C
11 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
&THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
&_PHD SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
&AT LEAST ',I8,' >>>>>>>>>>')
21 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
&THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
&_AED SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
&AT LEAST ',I8,' >>>>>>>>>>')
31 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
&THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
&_XAS SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
&AT LEAST ',I8,' >>>>>>>>>>')
41 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN
&THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT
&_APC SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE
&AT LEAST ',I8,' >>>>>>>>>>')
51 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL','
&IN THE INCLUDE FILE - SHOULD BE AT LEAST ',I6,' >>>>>>>>>>')
C
5 RETURN
C
END
C
C=======================================================================
C
SUBROUTINE SUP_ZEROS(TL,LMAX,NE,NAT,IUO1,ITRTL)
C
C This routine suppresses possible zeros in the TL arrays so that
C the code runs faster because of lower values of LMAX. Actually,
C the TL array is not modified, it is just the LMAX array that is
C altered. This is particularly useful for energy variations or
C for matrix inversion
C
USE DIM_MOD
C
COMPLEX TL_,TL(0:NT_M,4,NATM,NE_M)
C
INTEGER LMAX(NATM,NE_M)
C
IF(ITRTL.EQ.1) THEN
SMALL=0.1
ELSEIF(ITRTL.EQ.2) THEN
SMALL=0.01
ELSEIF(ITRTL.EQ.3) THEN
SMALL=0.001
ELSEIF(ITRTL.EQ.4) THEN
SMALL=0.0001
ELSEIF(ITRTL.EQ.5) THEN
SMALL=0.00001
ELSEIF(ITRTL.EQ.6) THEN
SMALL=0.000001
ELSEIF(ITRTL.EQ.7) THEN
SMALL=0.0000001
ELSEIF(ITRTL.EQ.8) THEN
SMALL=0.00000001
ELSE
ITRTL=9
SMALL=0.000000001
ENDIF
C
WRITE(IUO1,10)
WRITE(IUO1,15) ITRTL
C
DO JE=1,NE
WRITE(IUO1,20) JE
DO JAT=1,NAT
NONZERO=0
LM=LMAX(JAT,JE)
DO L=0,LM
TL_=TL(L,1,JAT,JE)
IF((ABS(REAL(TL_)).GE.SMALL).OR.(ABS(AIMAG(TL_)).GE.SMALL))
&THEN
NONZERO=NONZERO+1
ENDIF
ENDDO
LMAX(JAT,JE)=NONZERO-1
WRITE(IUO1,30) JAT,LM,NONZERO-1
ENDDO
ENDDO
C
WRITE(IUO1,40)
C
10 FORMAT(//,' ---> CHECK FOR ZEROS IN THE TL FILE TO REDUCE',' THE
& AMOUNT OF COMPUTING :',/)
15 FORMAT(/,' (ONLY THE MATRIX ELEMENTS NON ZERO ','TO THE FIRST ',I
&1,' DECIMAL DIGITS ARE KEPT)',/)
20 FORMAT(/,15X,'ENERGY POINT No ',I3,/)
30 FORMAT(8X,'PROTOTYPICAL ATOM No ',I5,' INITIAL LMAX = ',I2,' FI
&NAL LMAX = ',I2)
40 FORMAT(//)
C
RETURN
C
END
C
C=======================================================================
C
FUNCTION UJ_SQ(JTYP)
C
C This routine evaluates the mean square displacements UJ_SQ,
C first along une direction (x, y or z): UJ2 within the Debye model,
C using the Debye function formulation
C
C X1 is the Debye function phi_1
C UJ_SQ is given in unit of the square of the lattice parameter A0
C Temperatures are expressed in Kelvin
C
C The coefficient COEF equals:
C
C 3 hbar^{2} N_A 10^{3} / (4 k_B)
C
C where N_A is the Avogadro number, k_B is Boltzmann's constant
C and 10^3 arises from the fact that the atomic mass is
C expressed in grams
C
C Then UJ_SQ is obtained as UJ_SQ = (2 + RSJ) UJJ for surface atoms
C UJ_SQ = 3 UJJ for bulk atoms
C
C
C For empty spheres, two possibilities are provided. By construction,
C they are very light (their mass is taken as 1/1836 of the mass
C of a H atom) and so they will vibrate a lot (IDCM = 1). When
C setting IDCM = 2, their mean square displacement is set to a
C tiny value so that they hardly vibrate (frozen empty spheres)
C
C Last modified : 31 Jan 2017
C
USE DIM_MOD
C
USE DEBWAL_MOD , T => TEMP
USE MASSAT_MOD , XM => XMT
USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT
&, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT
USE VIBRAT_MOD
C
REAL MJ
C
C
C
DATA COEF /36.381551/ ! 3 hbar^{2} / (4 k_B) for MJ in grams
DATA RZ2 /1.644934/ ! Pi^2 / 6
DATA LITTLE /0.01/ ! lowest temperature for calculation of phi_1
C
N_MAX=20
C
C Computation of the 1D mean square displacement UJ2
C
A=TD/T
MJ=XM(JTYP)
C=COEF/(MJ*TD)
C
X1=0.
IF(T.GT.LITTLE) THEN
DO N=1,N_MAX
Z=FLOAT(N)
X1=X1+EXP(-Z*A)*(A+1./Z)/Z
ENDDO
ENDIF
C
P1=1.+4.*(RZ2-X1)/(A*A)
UJJ=C*P1/(A0*A0)
C
C 3D mean square displacement UJ_SQ
C
IF(IDCM.EQ.1) THEN
UJ_SQ=(3.+FLOAT(I_FREE(JTYP))*(RSJ-1.))*UJJ
ELSEIF(IDCM.EQ.2) THEN
UJ_SQ=1.0E-20
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE DIRAN(VINT,ECIN,J_EL)
C
C This subroutine calculates the direction(s) of the analyzer with
C or without an angular averaging.
C
C DIRANA is the internal direction
C ANADIR is the external direction
C
C J_EL is the type of electron : 1 ---> photoelectron
C 2 ---> Auger electron
C
C Last modified : 23/03/2006
C
C
USE DIRECT_MOD
USE DIRECT_A_MOD
USE MOYEN_MOD
USE MOYEN_A_MOD
USE OUTUNITS_MOD
USE TESTS_MOD , I1 => ITEST, I2 => ISORT1, N1 => NPATHP, I3 => ISO
&M
USE TYPCAL_MOD
USE TYPCAL_A_MOD
C
COMPLEX COEF,IC
DATA PI,PIS2,PIS180 /3.141593,1.570796,0.017453/
C
IC=(0.,1.)
C
IF(J_EL.EQ.1) THEN
ANADIR(1,1)=SIN(RTHEXT)*COS(RPHI)
ANADIR(2,1)=SIN(RTHEXT)*SIN(RPHI)
ANADIR(3,1)=COS(RTHEXT)
IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN
CALL REFRAC(VINT,ECIN,RTHEXT,RTHINT)
ELSE
RTHINT=RTHEXT
ENDIF
IF((IPRINT.GT.0).AND.(I_EXT.NE.2)) THEN
DTHEXT=RTHEXT/PIS180
DTHINT=RTHINT/PIS180
IF(I_TEST.NE.2) WRITE(IUO1,20) DTHEXT,DTHINT
ENDIF
DIRANA(1,1)=SIN(RTHINT)*COS(RPHI)
DIRANA(2,1)=SIN(RTHINT)*SIN(RPHI)
DIRANA(3,1)=COS(RTHINT)
THETAR(1)=RTHINT
PHIR(1)=RPHI
C
C The change in the definition below is necessary as RPHI is
C used to define the rotation axis of the direction of the detector
C when doing polar variations
C
IF(ITHETA.EQ.1) THEN
IF(RPHI.GT.PIS2) THEN
RTHEXT=-RTHEXT
RPHI=RPHI-PI
ELSEIF(RPHI.LT.-PIS2) THEN
RTHEXT=-RTHEXT
RPHI=RPHI+PI
ENDIF
ENDIF
C
IF(IMOY.GE.1) THEN
N=2**(IMOY-1)
S=SIN(ACCEPT*PI/180.)
RN=FLOAT(N)
J=1
DO K1=-N,N
RK1=FLOAT(K1)
DO K2=-N,N
RK2=FLOAT(K2)
D=SQRT(RK1*RK1+RK2*RK2)
IF((D-RN).GT.0.000001) GOTO 10
IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 10
C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S)
J=J+1
C
ANADIR(1,J)=(RK1*S*COS(RTHEXT)*COS(RPHI) -RK2*S*SIN(RPHI)+
&C*ANADIR(1,1))/RN
ANADIR(2,J)=(RK1*S*COS(RTHEXT)*SIN(RPHI) +RK2*S*COS(RPHI)+
&C*ANADIR(2,1))/RN
ANADIR(3,J)=(-RK1*S*SIN(RTHEXT) +C*ANADIR(3,1))/RN
THETA_R=ACOS(ANADIR(3,J))
COEF=ANADIR(1,J)+IC*ANADIR(2,J)
CALL ARCSIN(COEF,ANADIR(3,J),PHI_R)
IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN
CALL REFRAC(VINT,ECIN,THETA_R,THINT_R)
ELSE
THINT_R=THETA_R
ENDIF
C
DIRANA(1,J)=SIN(THINT_R)*COS(PHI_R)
DIRANA(2,J)=SIN(THINT_R)*SIN(PHI_R)
DIRANA(3,J)=COS(THINT_R)
C
THETAR(J)=THINT_R
PHIR(J)=PHI_R
10 CONTINUE
ENDDO
ENDDO
ENDIF
C
ELSEIF(J_EL.EQ.2) THEN
ANADIR_A(1,1)=SIN(RTHEXT_A)*COS(RPHI_A)
ANADIR_A(2,1)=SIN(RTHEXT_A)*SIN(RPHI_A)
ANADIR_A(3,1)=COS(RTHEXT_A)
IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN
CALL REFRAC(VINT,ECIN,RTHEXT_A,RTHINT_A)
ELSE
RTHINT_A=RTHEXT_A
ENDIF
IF((IPRINT.GT.0).AND.(I_EXT_A.NE.2)) THEN
DTHEXT_A=RTHEXT_A/PIS180
DTHINT_A=RTHINT_A/PIS180
IF(I_TEST_A.NE.2) WRITE(IUO1,21) DTHEXT_A,DTHINT_A
ENDIF
DIRANA_A(1,1)=SIN(RTHINT_A)*COS(RPHI_A)
DIRANA_A(2,1)=SIN(RTHINT_A)*SIN(RPHI_A)
DIRANA_A(3,1)=COS(RTHINT_A)
THETAR_A(1)=RTHINT_A
PHIR_A(1)=RPHI_A
C
C The change in the definition below is necessary as RPHI is
C used to define the rotation axis of the direction of the detector
C when doing polar variations
C
IF(ITHETA_A.EQ.1) THEN
IF(RPHI_A.GT.PIS2) THEN
RTHEXT_A=-RTHEXT_A
RPHI_A=RPHI_A-PI
ELSEIF(RPHI_A.LT.-PIS2) THEN
RTHEXT_A=-RTHEXT_A
RPHI_A=RPHI_A+PI
ENDIF
ENDIF
C
IF(IMOY_A.GE.1) THEN
N=2**(IMOY_A-1)
S=SIN(ACCEPT_A*PI/180.)
RN=FLOAT(N)
J=1
DO K1=-N,N
RK1=FLOAT(K1)
DO K2=-N,N
RK2=FLOAT(K2)
D=SQRT(RK1*RK1+RK2*RK2)
IF((D-RN).GT.0.000001) GOTO 15
IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 15
C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S)
J=J+1
C
ANADIR_A(1,J)=(RK1*S*COS(RTHEXT_A)*COS(RPHI_A) -RK2*S*SIN(
&RPHI_A)+C*ANADIR_A(1,1))/RN
ANADIR_A(2,J)=(RK1*S*COS(RTHEXT_A)*SIN(RPHI_A) +RK2*S*COS(
&RPHI_A)+C*ANADIR_A(2,1))/RN
ANADIR_A(3,J)=(-RK1*S*SIN(RTHEXT_A) +C*ANADIR_A(3,1))/RN
THETA_R_A=ACOS(ANADIR_A(3,J))
COEF=ANADIR_A(1,J)+IC*ANADIR_A(2,J)
CALL ARCSIN(COEF,ANADIR_A(3,J),PHI_R_A)
IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN
CALL REFRAC(VINT,ECIN,THETA_R_A,THINT_R_A)
ELSE
THINT_R_A=THETA_R_A
ENDIF
C
DIRANA_A(1,J)=SIN(THINT_R_A)*COS(PHI_R_A)
DIRANA_A(2,J)=SIN(THINT_R_A)*SIN(PHI_R_A)
DIRANA_A(3,J)=COS(THINT_R_A)
C
THETAR_A(J)=THINT_R_A
PHIR_A(J)=PHI_R_A
15 CONTINUE
ENDDO
ENDDO
ENDIF
C
ENDIF
C
20 FORMAT(/,10X,'PHOTOELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T
&HETA =', F7.2)
21 FORMAT(/,10X,'AUGER ELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T
&HETA =', F7.2)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE REFRAC(VINT,EKIN,RTHETA,RTHINT)
C
C This routine calculates the refraction of a plane wave beam induced
C by the surface potential barrier VINT. EKIN is the kinetic energy
C outside the crystal.
C
C Last modified : 3 Dec 2008
C
DATA PIS180,SMALL /0.017453,0.001/
C
IF(VINT.LT.0.) VINT=ABS(VINT)
IF(ABS(VINT).LT.SMALL) THEN
RTHINT=RTHETA
ELSE
U=VINT/(EKIN+VINT)
DTHETA=RTHETA/PIS180
REFRA=SIN(RTHETA)*SIN(RTHETA)*(1.-U)
RTHINT=ASIN(SQRT(REFRA))
IF(DTHETA.LT.0.) THEN
RTHINT=-RTHINT
ENDIF
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL)
C
C This subroutine performs a weighted sum of the results
C corresponding to different directions of the detector.
C The directions and weights are read from an external input file
C
C JEL is the electron undetected (i.e. for which the outgoing
C directions are integrated over the unit sphere). It is always
C 1 for one electron spectroscopies (PHD). For APECS, It can be
C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron
C detected)
C
C Last modified : 31 Jan 2007
C
USE DIM_MOD
USE INFILES_MOD
USE INUNITS_MOD
USE OUTUNITS_MOD
C
C
PARAMETER(N_MAX=5810,NPM=20)
C
REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M)
REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX)
REAL*4 SR_1,SF_1,SR_2,SF_2
REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX)
REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX)
C
CHARACTER*3 SPECTRO,SPECTRO2
CHARACTER*5 LIKE
CHARACTER*13 OUTDATA
C
C
C
C
DATA JVOL,JTOT/0,-1/
DATA LIKE /'-like'/
C
REWIND IUO2
C
READ(IUO2,15) SPECTRO,OUTDATA
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
SPECTRO2='XAS'
ELSE
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I
&THETA_A,IE_A
READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
READ(IUO2,8) NPHI_A,NTHETA_A
IF(JEL.EQ.1) THEN
SPECTRO2='AED'
ELSEIF(JEL.EQ.2) THEN
SPECTRO2='PHD'
ELSEIF(JEL.EQ.0) THEN
SPECTRO2='XAS'
ENDIF
ENDIF
C
IF(NPLAN.GT.NPM) THEN
WRITE(IUO1,4) NPLAN+2
STOP
ENDIF
C
C Reading the number of angular points
C
IF(SPECTRO.NE.'APC') THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
N_POINTS_A=1
ELSE
IF(JEL.EQ.1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
IF(I_EXT_A.EQ.0) THEN
N_POINTS_A=NTHETA_A*NPHI_A
ELSE
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,1) N_POINTS_A
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
ENDIF
NTHETA0=NTHETA_A
NPHI0=NPHI_A
ELSEIF(JEL.EQ.2) THEN
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,1) N_POINTS_A
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
IF(I_EXT.EQ.0) THEN
N_POINTS=NTHETA*NPHI
ELSE
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
ENDIF
NTHETA0=NTHETA
NPHI0=NPHI
ELSEIF(JEL.EQ.0) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI9,1) N_POINTS_A
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
ENDIF
ENDIF
C
IF(SPECTRO.NE.'APC') THEN
NANGLE=1
ELSE
IF(JEL.EQ.1) THEN
NANGLE=N_POINTS_A
ELSEIF(JEL.EQ.2) THEN
NANGLE=N_POINTS
ELSEIF(JEL.EQ.0) THEN
NANGLE=1
ENDIF
ENDIF
C
C Initialization of the arrays
C
DO JE=1,NE
DO JANGLE=1,NANGLE
DO JPLAN=1,NPLAN+2
SUMR_1(JPLAN,JE,JANGLE)=0.
SUMF_1(JPLAN,JE,JANGLE)=0.
IF(IDICHR.GT.0) THEN
SUMR_2(JPLAN,JE,JANGLE)=0.
SUMF_2(JPLAN,JE,JANGLE)=0.
ENDIF
ENDDO
ENDDO
ENDDO
C
C Reading of the data to be angle integrated
C
DO JE=1,NE
C
DO JANGLE=1,N_POINTS
IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE)
DO JANGLE_A=1,N_POINTS_A
IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN
READ(IUI9,2) THA,PHA,W_A(JANGLE_A)
ENDIF
C
DO JPLAN=1,NPLAN+2
C
IF(IDICHR.EQ.0) THEN
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE)
&,SR_1,SF_1
ELSE
READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1
ENDIF
ELSE
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),SR_1,SF_1,SR_2,SF_2
ELSE
READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2
ENDIF
ENDIF
C
IF(JEL.EQ.1) THEN
SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1
&*W(JANGLE)
SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1
&*W(JANGLE)
ELSEIF(JEL.EQ.2) THEN
SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A
&(JANGLE_A)
SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A
&(JANGLE_A)
ELSEIF(JEL.EQ.0) THEN
SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A
&(JANGLE_A)
SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A
&(JANGLE_A)
ENDIF
IF(IDICHR.GT.0) THEN
IF(JEL.EQ.1) THEN
SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR
&_2*W(JANGLE)
SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF
&_2*W(JANGLE)
ELSEIF(JEL.EQ.2) THEN
SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W
&_A(JANGLE_A)
SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W
&_A(JANGLE_A)
ELSEIF(JEL.EQ.0) THEN
SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W
&_A(JANGLE_A)
SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W
&_A(JANGLE_A)
ENDIF
ENDIF
C
ENDDO
C
ENDDO
IF(I_EXT_A.NE.0) THEN
REWIND IUI9
READ(IUI9,1) NDUM
READ(IUI9,1) NDUM
ENDIF
ENDDO
C
IF(I_EXT.NE.0) THEN
REWIND IUI6
READ(IUI6,1) NDUM
READ(IUI6,1) NDUM
ENDIF
ENDDO
C
CLOSE(IUI6)
CLOSE(IUI9)
REWIND IUO2
C
WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP
WRITE(IUO2,18) NE,NPLAN,ISOM
ELSEIF(JEL.EQ.1) THEN
WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A
&,ITHETA_A,IE_A
WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
ELSEIF(JEL.EQ.2) THEN
WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
ENDIF
C
DO JE=1,NE
DO JANGLE=1,NANGLE
IF(SPECTRO.EQ.'APC') THEN
IF(JEL.EQ.1) THEN
THETA=DTHETAA(JANGLE)
PHI=DPHIA(JANGLE)
ELSEIF(JEL.EQ.2) THEN
THETA=DTHETA(JANGLE)
PHI=DPHI(JANGLE)
ENDIF
ENDIF
C
DO JPLAN=1,NPLAN
IF(IDICHR.EQ.0) THEN
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
&MF_1(JPLAN,JE,JANGLE)
ELSE
WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
&JANGLE),SUMF_1(JPLAN,JE,JANGLE)
ENDIF
ELSE
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
&MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG
&LE)
ELSE
WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
&JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL
&AN,JE,JANGLE)
ENDIF
ENDIF
ENDDO
C
IF(IDICHR.EQ.0) THEN
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
&F_1(NPLAN+1,JE,JANGLE)
WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
&F_1(NPLAN+2,JE,JANGLE)
ELSE
WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
&ANGLE),SUMF_1(NPLAN+1,JE,JANGLE)
WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
&ANGLE),SUMF_1(NPLAN+2,JE,JANGLE)
ENDIF
ELSE
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
&F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE
&,JANGLE)
WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
&F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE
&,JANGLE)
ELSE
WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
&ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(
&NPLAN+1,JE,JANGLE)
WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
&ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(
&NPLAN+2,JE,JANGLE)
ENDIF
ENDIF
C
ENDDO
ENDDO
C
1 FORMAT(13X,I4)
2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6)
3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
&THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>')
5 FORMAT(6X,I1,1X,I3,3X,I3)
8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
9 FORMAT(9(2X,I1),2X,I2)
13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
&12.6)
15 FORMAT(2X,A3,11X,A13)
16 FORMAT(2X,A3,A5,1X,A3,2X,A13)
18 FORMAT(I4,2X,I3,2X,I1)
19 FORMAT(4(2X,I1))
20 FORMAT(8(2X,I1))
21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
&12.6,2X,E12.6,2X,E12.6)
33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6)
34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED)
C
C This routine recomputes the T-matrix elements taking into account the
C mean square displacements.
C
C When the argument X is tiny, no vibrations are taken into account
C
C Last modified : 25 Apr 2013
C
USE DIM_MOD
C
USE TRANS_MOD
C
DIMENSION GNT(0:N_GAUNT)
C
COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC
C
COMPLEX*16 FFL(0:2*NL_M)
C
DATA PI4,EPS /12.566371,1.0E-10/
C
ZEROC=(0.,0.)
C
IF(X.GT.EPS) THEN
C
C Standard case: vibrations
C
IF(ISPEED.LT.0) THEN
NSUM_LB=ABS(ISPEED)
ENDIF
C
COEF=PI4*EXP(-X)
NL2=2*LMAX(JTYP,JE)+2
IBESP=5
MG1=0
MG2=0
C
CALL BESPHE(NL2,IBESP,X,FFL)
C
DO L=0,LMAX(JTYP,JE)
XL=FLOAT(L+L+1)
SL1=ZEROC
C
DO L1=0,LMAX(JTYP,JE)
XL1=FLOAT(L1+L1+1)
CALL GAUNT(L,MG1,L1,MG2,GNT)
L2MIN=ABS(L1-L)
IF(ISPEED.GE.0) THEN
L2MAX=L1+L
ELSEIF(ISPEED.LT.0) THEN
L2MAX=L2MIN+2*(NSUM_LB-1)
ENDIF
SL2=0.
C
DO L2=L2MIN,L2MAX,2
XL2=FLOAT(L2+L2+1)
C=SQRT(XL1*XL2/(PI4*XL))
SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2)))
ENDDO
C
SL1=SL1+SL2*TL(L1,1,JTYP,JE)
ENDDO
C
TLT(L,1,JTYP,JE)=COEF*SL1
C
ENDDO
C
ELSE
C
C Argument X tiny: no vibrations
C
DO L=0,LMAX(JTYP,JE)
C
TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE)
C
ENDDO
C
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J
&E,*)
C
C This routine computes a spherical wave scattering factor
C
C Last modified : 03/04/2006
C
USE DIM_MOD
USE APPROX_MOD
USE EXPFAC_MOD
USE TRANS_MOD
USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I
&6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST
C
DIMENSION PLMM(0:100,0:100)
DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ
COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE
COMPLEX RHOJK
C
C
DATA PI/3.141593/
C
A=1.
INTER=0
IF(ITL.EQ.1) VKE=VK(JE)
RHOJ=VKE*RJ
RHOJK=VKE*RJK
HLM1=(1.,0.)
HLM2=(1.,0.)
HLM3=(1.,0.)
HLM4=(1.,0.)
IEM=1
CSTH=COS(BETA)
IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN
INTER=1
BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI))
ENDIF
CALL PLM(CSTH,PLMM,LMAX(JAT,JE))
IF(ISPHER.EQ.0) NO1=0
IF(ISPHER.EQ.1) THEN
IF(NO.EQ.8) THEN
NO1=LMAX(JAT,JE)+1
ELSE
NO1=NO
ENDIF
CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM)
IF(IEM.EQ.0) THEN
HLM4=HLM(0,L)
ENDIF
IF(RJK.GT.0.0001) THEN
NDUM=0
CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN)
ENDIF
CALL DJMN(THRJ,D,L)
A1=ABS(D(0,M,L))
IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1
&
ENDIF
MUMAX=MIN0(L,NO1)
SMU=(0.,0.)
DO 10 MU=0,MUMAX
IF(MOD(MU,2).EQ.0) THEN
B=1.
ELSE
B=-1.
IF(SIN(BETA).LT.0.) THEN
A=-1.
ENDIF
ENDIF
IF(ISPHER.LE.1) THEN
ALMU=(1.,0.)
C=1.
ENDIF
IF(ISPHER.EQ.0) GOTO 40
IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L))
IF(MU.GT.0) THEN
C=B*FLOAT(L+L+1)/EXPF(MU,L)
ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B*
* CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU
ELSE
C=1.
ALMU=CMPLX(D(M,0,L))/BLMU
ENDIF
40 SNU=(0.,0.)
NU1=INT(0.5*(NO1-MU)+0.0001)
NUMAX=MIN0(NU1,L-MU)
DO 20 NU=0,NUMAX
SLP=(0.,0.)
LPMIN=MAX0(MU,NU)
DO 30 LP=LPMIN,LMAX(JAT,JE)
IF(ISPHER.EQ.1) THEN
HLM1=HLM(NU,LP)
IF(RJK.GT.0.0001) HLM3=HLN(0,LP)
ENDIF
SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3
30 CONTINUE
IF(ISPHER.EQ.1) THEN
HLM2=HLM(MU+NU,L)
ENDIF
SNU=SNU+SLP*HLM2
20 CONTINUE
SMU=SMU+SNU*C*ALMU*A*B
10 CONTINUE
FSPH=SMU/(VKE*HLM4)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE FACDIF(COSTH,JAT,JE,FTHETA)
C
C This routine computes the plane wave scattering factor
C
USE DIM_MOD
C
USE TRANS_MOD
C
DIMENSION PL(0:100)
C
COMPLEX FTHETA
C
FTHETA=(0.,0.)
NL=LMAX(JAT,JE)+1
CALL POLLEG(NL,COSTH,PL)
DO 20 L=0,NL-1
FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L)
20 CONTINUE
FTHETA=FTHETA/VK(JE)
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE)
C
C This routine prepares the output for a plot of the scattering factor
C
USE DIM_MOD
C
USE APPROX_MOD
USE FDIF_MOD
USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 =>
& LF2, I10 => ISTEP_LF
USE INIT_J_MOD
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS
USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP
&, I13 => I_EXT, I14 => I_TEST
USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO
&L
USE VALFIN_MOD
C
C
C
DIMENSION LMX(NATM,NE_M)
C
COMPLEX FSPH,VKE
C
C
C
DATA PI,CONV/3.141593,0.512314/
C
OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
IF(ISPHER.EQ.0) THEN
L=0
LMAX=0
ELSE
LMAX=L
ENDIF
PHITOT=360.
THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
NPHI=(NFTHET+1)*IPHI+(1-IPHI)
NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
* (1-ITHETA)
NE=NFTHET*IE + (1-IE)
WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
DO 10 JT=1,NTHT
DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
RTHETA=DTHETA*PI/180.
TEST=SIN(RTHETA)
IF(TEST.GE.0.) THEN
POZ=PI
EPS=1.
ELSE
POZ=0.
EPS=-1.
ENDIF
BETA=RTHETA*EPS
IF(ABS(TEST).LT.0.0001) THEN
NPHIM=1
ELSE
NPHIM=NPHI
ENDIF
DO 20 JP=1,NPHIM
DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
RPHI=DPHI*PI/180.
GAMMA=POZ-RPHI
DO 30 JE=1,NE
IF(NE.EQ.1) THEN
ECIN=E0
ELSE
ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
ENDIF
IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
DO 40 JAT=1,NAT
IF(L.GT.LMX(JAT,JE)) GOTO 90
DO 50 M=-LMAX,LMAX
CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J
&AT,JE,*60)
GOTO 70
60 WRITE(IUO1,80)
STOP
70 REFTH=REAL(FSPH)
XIMFTH=AIMAG(FSPH)
WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN
50 CONTINUE
GOTO 40
90 WRITE(IUO1,100) JAT
STOP
40 CONTINUE
30 CONTINUE
20 CONTINUE
10 CONTINUE
CLOSE(IUO3)
1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X,
&F8.2)
80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z
&ERO >>>>>')
100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : '
&,I2,' >>>>>')
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE FINDPATHS(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIMI
&,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 16 May 2007
C
USE DIM_MOD
C
USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TRANS_MOD
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
C
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
&R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
&STHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
&BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
&REF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
&/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
&EN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
&.*COSTHIJK)
ELSE
CSKZ2J=1.
ENDIF
UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
ELSE
UJJ=UJ2(JTYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UJ2=VK2(JE)*UJJ
CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))
& IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
&IJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
&JK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS2(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
&IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE FINDPATHS2(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
&I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 16 May 2007
C
USE DIM_MOD
C
USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TRANS_MOD
USE TLDW_MOD
USE VARIA_MOD
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
C
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
&R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
&STHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
&BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
&REF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
&/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
&EN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
&.*COSTHIJK)
ELSE
CSKZ2J=1.
ENDIF
UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
ELSE
UJJ=UJ2(JTYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UJ2=VK2(JE)*UJJ
CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
&=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
&IJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
&JK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS3(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
&IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE FINDPATHS3(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
&I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 16 May 2007
C
USE DIM_MOD
C
USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TRANS_MOD
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
C
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
&R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
&STHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
&BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
&REF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
&/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
&EN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
&.*COSTHIJK)
ELSE
CSKZ2J=1.
ENDIF
UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
ELSE
UJJ=UJ2(JTYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UJ2=VK2(JE)*UJJ
CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
&=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
&IJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
&JK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS4(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
&IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE FINDPATHS4(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
&I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 16 May 2007
C
USE DIM_MOD
C
USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TRANS_MOD
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
C
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
&R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
&STHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
&BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
&REF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
&/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
&EN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
&.*COSTHIJK)
ELSE
CSKZ2J=1.
ENDIF
UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
ELSE
UJJ=UJ2(JTYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UJ2=VK2(JE)*UJJ
CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
&=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
&IJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
&JK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS5(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH
&IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE FINDPATHS5(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM
&I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
C
C This routine generates all the paths and filters them according to the
C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH).
C It corresponds to the spin-independent case from a non spin-orbit
C resolved initial core state LI
C
C Last modified : 16 May 2007
C
USE DIM_MOD
C
USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH
USE COOR_MOD
USE DEBWAL_MOD
USE INIT_L_MOD
USE PATH_MOD
USE ROT_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TRANS_MOD
USE TLDW_MOD
USE VARIA_MOD
C
DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),R(NDIF_M)
C
C
C
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
COMPLEX YLM1(0:NL_M,-NL_M:NL_M)
COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2
C
DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/
C
IC=(0.,1.)
IEULER=1
C
IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP))
IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP))
C
C I_CP = 0 : all open paths generated
C I_CP = 1 : only closed paths generated
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO JTYP=1,N_TYP
IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP))
IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP))
ND=ND+1
C
C I_ABS = 0 : the atom before the scatterer is not the absorber
C I_ABS = 1 : the atom before the scatterer is the absorber
C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only)
C
IF(ND.EQ.1) THEN
I_ABS=1
ELSE
I_ABS=0
ENDIF
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPJ=NATYP(JTYP)
ELSE
NBTYPJ=1
ENDIF
C
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
IF(JATL.EQ.IATL) GOTO 12
XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL)
YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL)
ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
JPOS(ND,1)=JTYP
JPOS(ND,2)=JNUM
JPOS(ND,3)=JATL
NPATH(ND)=NPATH(ND)+1.
IF(ND.GT.1) THEN
COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/(
&R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(ITYP).EQ.0) THEN
IF(COSTHMIJ.LT.COSFWDI) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(ITYP).EQ.1) THEN
IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42
RHOIJ=VK(JE)*R(ND)
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THIJ=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
CALL ARCSIN(COMPL1,CTROIS1,PHIIJ)
IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40
ZSURFI=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(ITYP)=SIG2(R(ND-1),ITYP)
ENDIF
IF(ABS(ZSURFI).LE.SMALL) THEN
IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN
CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO
&STHMIJ)
ELSE
CSKZ2I=1.
ENDIF
UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.))
ELSE
UII=UJ2(ITYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UI2=VK2(JE)*UII
CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED)
ENDIF
40 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ))
ENDIF
ENDIF
IF(ND.EQ.1) THEN
RHO01=RHOIJ
TH01=THIJ
PHI01=PHIIJ
CALL DJMN2(TH01,RLM01,LF2,2)
GOTO 30
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
LMJ=LMAX(ITYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42
CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ,
&BMIJ,CMIJ,RHOMI,RHOIJ)
30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F
&REF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 42
I_ABS=0
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN
N_TYP=N_PROT
ELSE
N_TYP=1
ENDIF
C
DO KTYP=1,N_TYP
ND=ND+1
IF(ND.GT.NDIF) GOTO 20
C
IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN
NBTYPK=NATYP(KTYP)
ELSE
NBTYPK=1
ENDIF
C
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.EQ.JATL) GOTO 22
JPOS(ND,1)=KTYP
JPOS(ND,2)=KNUM
JPOS(ND,3)=KATL
XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL)
YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL)
ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL)
R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND))
DIJ=DIJ+R(ND)
IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1
IF(IT(ND-1).EQ.1) GOTO 32
RHOJK=R(ND)*VK(JE)
NPATH(ND)=NPATH(ND)+1.
COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))
&/(R(ND)*R(ND-1))
IF(IFWD.EQ.1) THEN
IF(IBWD(JTYP).EQ.0) THEN
IF(COSTHIJK.LT.COSFWDJ) THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ELSEIF(IBWD(JTYP).EQ.1) THEN
IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH
&EN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN
NTHOF=NTHOF+1
IN(ND-1)=1
IF(NTHOF.GT.NTHOUT) THEN
IT(ND-1)=1
ENDIF
ENDIF
ENDIF
ENDIF
IF(IT(ND-1).EQ.1) GOTO 32
CTROIS1=ZR(ND)/R(ND)
IF(CTROIS1.GT.1) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
THJK=ACOS(CTROIS1)
COMPL1= XR(ND)+IC*YR(ND)
IF(ND-1.LT.NDIF) THEN
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50
ZSURFJ=ZSURF-ZR(ND-1)
IF(IDCM.EQ.1) THEN
UJ2(JTYP)=SIG2(R(ND-1),JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(COSTHIJK-1.).GT.SMALL) THEN
CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2
&.*COSTHIJK)
ELSE
CSKZ2J=1.
ENDIF
UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
ELSE
UJJ=UJ2(JTYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UJ2=VK2(JE)*UJJ
CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
50 IF(IDWSPH.EQ.1) THEN
DW(ND-1)=1.
ELSE
DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK))
ENDIF
ENDIF
IF(IPW.EQ.1) THEN
CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA)
PWI=FTHETA*DW(ND-1)/R(ND)
PW(ND)=PW(ND-1)*PWI
CTL2=PI4*PW(ND)*CEX(1)/VK(JE)
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
LMJ=LMAX(JTYP,JE)
IF(ND.GT.NCUT) THEN
IT(ND)=1
ELSE
IT(ND)=0
ENDIF
CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2)
CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ)
XMAXT=0.
DO LJ=0,LMJ
CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0)
DO LF=LF1,LF2,ISTEP_LF
PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE)
XMAXT=AMAX1(XMAXT,CABS(PW1))
ENDDO
ENDDO
IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)
&=0
ENDIF
IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32
IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN
CALL ARCSIN(COMPL1,CTROIS1,PHIJK)
ENDIF
CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER)
IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2
CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A
&IJK,BIJK,CIJK,RHOIJ,RHOJK)
CEX(ND)=CEXP(IC*RHOJK)/R(ND)
CEXDW(ND)=CEX(ND)*DW(ND-1)
IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN
IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN
CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI
&JK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
c CALL FINDPATHS(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
c 1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
32 DIJ=DIJ-R(ND)
22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDDO
20 CONTINUE
ND=ND-1
ENDDO
42 DIJ=DIJ-R(ND)
12 IF(ND.GT.1) THEN
IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1
IT(ND-1)=0
IN(ND-1)=0
ENDIF
ENDDO
ND=ND-1
ENDDO
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE MATDIF(NO,ND,LF,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A21,B2
&1,C21,RHO1,RHO2)
C
C This routine calculates the Rehr-Albers scattering matrix
C F_{LAMBDA1,LAMBDA2}. The result is stored in the COMMON block
C /SCATMAT/ as F21(NSPIN2_M,NLAMBDA_M,NLAMBDA_M,NDIF_M).
C
C Last modified : 3 Aug 2007
C
USE DIM_MOD
C
USE EXPFAC_MOD
USE LBD_MOD
USE LINLBD_MOD
USE RA_MOD
USE SCATMAT_MOD
USE TRANS_MOD
USE TLDW_MOD
C
REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX HLM1(0:NO_ST_M,0:NL_M-1),HLM2(0:NO_ST_M,0:NL_M-1)
COMPLEX SL,RHO1,RHO2,IC,ZEROC,ONEC,ONEOVK
COMPLEX SL_2_1,SL_2_2
COMPLEX EXP1,EXP2,PROD1,PROD2
C
DATA PI,SMALL /3.141593,0.0001/
C
IC=(0.,1.)
ZEROC=(0.,0.)
ONEC=(1.,0.)
ONEOVK=1./VK(JE)
IB=0
LMJ=LMAX(JTYP,JE)
IF(ABS(ABS(B21)-PI).LT.SMALL) IB=-1
IF(ABS(B21).LT.SMALL) IB=1
IF(NO.EQ.8) THEN
NN2=LMAX(JTYP,JE)+1
ELSE
NN2=NO
ENDIF
C
C NO is atom-dependent and is decreased with the rank of the scatterer
C in the path when I_NO > 0. Here LAMBDA1 depends on the scatterer JTYP
C while LAMBDA2 depends on the next atom (KTYP) in the path
C
IF(I_NO.EQ.0) THEN
NO1=N_RA(JTYP)
NO2=N_RA(KTYP)
ELSE
NO1=MAX(N_RA(JTYP)-(ND-1)/I_NO,0)
NO2=MAX(N_RA(KTYP)-ND/I_NO,0)
ENDIF
IF(I_ABS.EQ.0) THEN
NUMAX1=NO1/2
NUMAX2=NO2/2
ELSEIF(I_ABS.EQ.1) THEN
NUMAX1=MIN0(LF,NO1/2)
NUMAX2=NO2/2
ELSEIF(I_ABS.EQ.2) THEN
NUMAX1=NO1/2
NUMAX2=MIN0(LF,NO2/2)
ENDIF
LBDM(1,ND)=(NO1+1)*(NO1+2)/2
LBDM(2,ND)=(NO2+1)*(NO2+2)/2
C
EXP2=-EXP(-IC*A21)
EXP1=EXP(-IC*C21)
C
DO LAMBDA1=1,LBDMAX
DO LAMBDA2=1,LBDMAX
F21(1,LAMBDA2,LAMBDA1,ND)=ZEROC
ENDDO
ENDDO
C
IF(ABS(RHO1-RHO2).GT.SMALL) THEN
CALL POLHAN(ISPHER,NUMAX1,LMJ,RHO1,HLM1)
CALL POLHAN(ISPHER,NN2,LMJ,RHO2,HLM2)
NEQUAL=0
ELSE
CALL POLHAN(ISPHER,NN2,LMJ,RHO1,HLM1)
NEQUAL=1
ENDIF
C
C Calculation of the scattering matrix when the scattering angle
C is different from 0 and pi
C
IF(IB.EQ.0) THEN
CALL DJMN(B21,RLM,LMJ)
DO NU1=0,NUMAX1
MUMAX1=NO1-2*NU1
IF(I_ABS.EQ.1) MUMAX1=MIN(LF-NU1,MUMAX1)
DO NU2=0,NUMAX2
MUMAX2=NO2-2*NU2
C
C Case MU1 = 0
C
LAMBDA1=LBD(0,NU1)
C
C Case MU2 = 0
C
LAMBDA2=LBD(0,NU2)
LMIN=MAX(NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TL(L,1,JTYP,JE)*HLM1(NU1,L
&)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TLT(L,1,JTYP,JE)*HLM1(NU1,
&L)*HLM2(NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
C
C Case MU2 > 0
C
PROD2=ONEC
SIG2=1.
DO MU2=1,MUMAX2
LAMBDA2_1=LBD(MU2,NU2)
LAMBDA2_2=LBD(-MU2,NU2)
PROD2=PROD2*EXP2
SIG2=-SIG2
LMIN=MAX(NU1,MU2+NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
ENDIF
C1=EXPF(0,L)/EXPF(MU2,L)
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TL(L,1,JTYP,JE)*HLM
&1(NU1,L)*HLM2(MU2+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TLT(L,1,JTYP,JE)*HL
&M1(NU1,L)*HLM2(MU2+NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2_1,LAMBDA1,ND)=SL*PROD2*ONEOVK*SIG2
F21(1,LAMBDA2_2,LAMBDA1,ND)=SL*ONEOVK/PROD2
ENDDO
C
C Case MU1 > 0
C
PROD1=ONEC
SIG1=1.
DO MU1=1,MUMAX1
LAMBDA1_1=LBD(MU1,NU1)
LAMBDA1_2=LBD(-MU1,NU1)
PROD1=PROD1*EXP1
SIG1=-SIG1
C
C Case MU2 = 0
C
LAMBDA2=LBD(0,NU2)
LMIN=MAX(MU1,NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
C1=EXPF(MU1,L)/EXPF(0,L)
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TL(L,1,JTYP,JE)*HLM
&1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TLT(L,1,JTYP,JE)*HL
&M1(NU1,L)*HLM2(NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1_1,ND)=SL*PROD1*ONEOVK*SIG1
F21(1,LAMBDA2,LAMBDA1_2,ND)=SL*ONEOVK/PROD1
C
C Case MU2 > 0
C
PROD2=ONEC
SIG2=SIG1
DO MU2=1,MUMAX2
LAMBDA2_1=LBD(MU2,NU2)
LAMBDA2_2=LBD(-MU2,NU2)
PROD2=PROD2*EXP2
SIG2=-SIG2
LMIN=MAX(MU1,NU1,MU2+NU2)
SL_2_1=ZEROC
SL_2_2=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L)
ENDIF
C1=EXPF(MU1,L)/EXPF(MU2,L)
IF(ISPEED.EQ.1) THEN
SL=FLOAT(L+L+1)*C1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(
&MU2+NU2,L)
ELSE
SL=FLOAT(L+L+1)*C1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2
&(MU2+NU2,L)
ENDIF
SL_2_1=SL_2_1+SL*RLM(MU2,-MU1,L)
SL_2_2=SL_2_2+SL*RLM(MU2,MU1,L)
ENDDO
F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL_2_2*PROD1*PROD2*ONEOVK*
&SIG2
F21(1,LAMBDA2_2,LAMBDA1_1,ND)=SL_2_1*PROD1*ONEOVK/PROD2
F21(1,LAMBDA2_1,LAMBDA1_2,ND)=SL_2_1*ONEOVK*PROD2*SIG2/P
&ROD1
F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL_2_2*ONEOVK/(PROD1*PROD2
&)
ENDDO
ENDDO
ENDDO
ENDDO
C
C Calculation of the scattering matrix when the scattering angle
C is equal to 0 (forward scattering) or pi (backscattering)
C
ELSEIF(IB.EQ.1) THEN
DO NU1=0,NUMAX1
DO NU2=0,NUMAX2
MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
C
C Case MU = 0
C
LAMBDA1=LBD(0,NU1)
LAMBDA2=LBD(0,NU2)
LMIN=MAX(NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,
&L)
ELSE
SL=SL+FLOAT(L+L+1)*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2
&,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
C
C Case MU > 0
C
CST1=1.
DO MU=1,MUMAX1
LAMBDA1=LBD(MU,NU2)
LAMBDA2=LBD(-MU,NU2)
CST1=-CST1
LMIN=MAX(NU1,MU+NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*CST1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL
&M2(MU+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H
&LM2(MU+NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA1,LAMBDA1,ND)=SL*ONEOVK
F21(1,LAMBDA2,LAMBDA2,ND)=SL*ONEOVK
ENDDO
ENDDO
ENDDO
ELSEIF(IB.EQ.-1) THEN
DO NU1=0,NUMAX1
DO NU2=0,NUMAX2
MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2)
IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1)
C
C Case MU = 0
C
LAMBDA1=LBD(0,NU1)
LAMBDA2=LBD(0,NU2)
LMIN=MAX(NU1,NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(NU2,L)=HLM1(NU2,L)
ENDIF
IF(MOD(L,2).EQ.0) THEN
CST2=1.0
ELSE
CST2=-1.0
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2
&(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM
&2(NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK
C
C Case MU > 0
C
CST1=1.
DO MU=1,MUMAX1
MUP=-MU
LAMBDA1_1=LBD(MUP,NU1)
LAMBDA1_2=LBD(-MUP,NU1)
LAMBDA2_1=LBD(MU,NU2)
LAMBDA2_2=LBD(-MU,NU2)
CST1=-CST1
LMIN=MAX(NU1,MU+NU2)
SL=ZEROC
DO L=LMIN,LMJ
IF(NEQUAL.EQ.1) THEN
HLM2(MU+NU2,L)=HLM1(MU+NU2,L)
ENDIF
IF(MOD(L,2).EQ.0) THEN
CST2=CST1
ELSE
CST2=-CST1
ENDIF
IF(ISPEED.EQ.1) THEN
SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL
&M2(MU+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H
&LM2(MU+NU2,L)
ENDIF
ENDDO
F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL*ONEOVK
F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL*ONEOVK
ENDDO
ENDDO
ENDDO
ENDIF
C
RETURN
C
END
C
C=======================================================================
C
SUBROUTINE PATHOP(JPOS,JORDP,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,
&FREF,IJ,D,TAU)
C
C This subroutine calculates the contribution of a given path to
C the scattering path operator TAU.
C
C Last modified : 3 Aug 2007
C
USE DIM_MOD
C
USE APPROX_MOD
USE EXPFAC_MOD
USE EXTREM_MOD
USE INIT_L_MOD
USE INIT_J_MOD
USE LBD_MOD
USE LINLBD_MOD
USE OUTUNITS_MOD
USE PATH_MOD
USE PRINTP_MOD
USE RA_MOD
USE ROT_MOD
USE SCATMAT_MOD , F => F21
USE TESTS_MOD
USE TLDW_MOD
USE TRANS_MOD
USE VARIA_MOD
C
INTEGER JPOS(NDIF_M,3),AMU1
C
C
REAL RLMIJ(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
COMPLEX H(NLAMBDA_M,NLAMBDA_M)
COMPLEX G(NLAMBDA_M,NLAMBDA_M)
COMPLEX HLM01(0:NO_ST_M,0:NL_M-1),HLMIJ(0:NO_ST_M,0:NL_M-1)
COMPLEX SUM_NUJ_0,SUM_MUJ_0,SUM_NU1_0
COMPLEX SUM_NUJ_1,SUM_MUJ_1,SUM_NU1_1
COMPLEX SUM_NU1_2,SUM_NU1_3
COMPLEX RHO01,RHOIJ
COMPLEX RLMF_0,RLMF_1
COMPLEX CF,CJ,OVK
COMPLEX EXP_J,EXP_F,SUM_1
COMPLEX TL_J
COMPLEX COEF,ONEC,ZEROC
C
C
C
DATA PI,XCOMP /3.141593,1.E-10/
C
ZEROC=(0.,0.)
ONEC=(1.,0.)
C
OVK=(1.,0.)/VK(JE)
IF(NPATHP.GT.0) THEN
FM1=FMIN(JORDP)
XMAX=0.
ENDIF
EXP_J=CEXP((0.,-1.)*(PHIIJ-PI))
EXP_F=CEXP((0.,1.)*PHI01)
JTYP=JPOS(JORDP,1)
ITYP=JPOS(1,1)
JATL=JPOS(JORDP,3)
IF(I_CP.EQ.0) THEN
LMJ=LMAX(JTYP,JE)
ELSE
LMJ=LF2
ENDIF
IF(NO.EQ.8) THEN
NN2=LMJ+1
ELSE
NN2=NO
ENDIF
IF(NO.GT.LF2) THEN
NN=LF2
ELSE
NN=NO
ENDIF
C
C NO is atom-dependent and is decreased with the rank of the scatterer
C in the path when I_NO > 0 (except for the first scatterer ITYP for
C which there is no such decrease)
C
NO1=N_RA(ITYP)
IF(I_NO.EQ.0) THEN
IF(IJ.EQ.1) THEN
NOJ=N_RA(JTYP)
ELSE
NOJ=0
ENDIF
ELSE
IF(IJ.EQ.1) THEN
NOJ= MAX(N_RA(JTYP)-(JORDP-1)/I_NO,0)
ELSE
NOJ=0
ENDIF
ENDIF
NUMX=NO1/2
NUMAXJ=NOJ/2
C
C Calculation of the attenuation coefficients along the path
C
COEF=CEX(1)*OVK
DO JSC=2,JORDP
COEF=COEF*CEXDW(JSC)
ENDDO
C
C Call of the subroutines used for the R-A termination matrix
C This termination matrix is now merged into PATHOP
C
CALL DJMN2(-THIJ,RLMIJ,LMJ,1)
CALL POLHAN(ISPHER,NN,LF2,RHO01,HLM01)
CALL POLHAN(ISPHER,NN2,LMJ,RHOIJ,HLMIJ)
C
LBD1M1=LBDM(1,1)
LBD1M2=LBDM(2,1)
C
C Calculation of the L-independent part of TAU, called H
C
IF(JORDP.GE.3) THEN
DO JPAT=2,JORDP-1
LBD2M=LBDM(1,JPAT)
LBD3M=LBDM(2,JPAT)
DO LAMBDA1=1,LBD1M1
DO LAMBDA3=1,LBD3M
SUM_1=ZEROC
DO LAMBDA2=1,LBD2M
IF(JPAT.GT.2) THEN
SUM_1=SUM_1+H(LAMBDA2,LAMBDA1)*F(1,LAMBDA3,LAMBDA2,JPA
&T)
ELSE
SUM_1=SUM_1+F(1,LAMBDA2,LAMBDA1,1)*F(1,LAMBDA3,LAMBDA2
&,2)
ENDIF
ENDDO
G(LAMBDA3,LAMBDA1)=SUM_1
ENDDO
ENDDO
DO LAMBDA1=1,LBD1M1
DO LAMBDA2=1,LBD3M
H(LAMBDA2,LAMBDA1)=G(LAMBDA2,LAMBDA1)
ENDDO
ENDDO
ENDDO
ELSEIF(JORDP.EQ.2) THEN
DO LAMBDA1=1,LBD1M1
DO LAMBDA2=1,LBD1M2
H(LAMBDA2,LAMBDA1)=F(1,LAMBDA2,LAMBDA1,1)
ENDDO
ENDDO
ELSEIF(JORDP.EQ.1) THEN
DO LAMBDA1=1,LBD1M1
DO LAMBDA2=1,LBD1M1
H(LAMBDA2,LAMBDA1)=ONEC
ENDDO
ENDDO
ENDIF
C
C Calculation of the path operator TAU
C
DO LF=LF1,LF2,ISTEP_LF
ILF=LF*LF+LF+1
C
NU1MAX1=MIN(LF,NUMX)
C
C Case MF = 0
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
NUJMAX=MIN(LJ,NUMAXJ)
IF(JORDP.EQ.1) THEN
NU1MAX=MIN(NU1MAX1,LJ)
ELSE
NU1MAX=NU1MAX1
ENDIF
C
IF(ISPEED.EQ.1) THEN
TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
ELSE
TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
ENDIF
C
C Case MJ = 0
C
SUM_NU1_0=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
C
SUM_NUJ_0=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0,L
&J)
ENDDO
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
C
ENDDO
C
ENDDO
C
TAU(ILJ,ILF,JATL)=TAU(ILJ,ILF,JATL)+TL_J*SUM_NU1_0
C
IF(NPATHP.EQ.0) GOTO 35
C
FM2=FMAX(JORDP)
XINT=CABS(TL_J*SUM_NU1_0)
XMAX=AMAX1(XINT,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
35 CONTINUE
C
C Case MJ > 0
C
CJ=ONEC
DO MJ=1,LJ
INDJ=ILJ+MJ
INDJP=ILJ-MJ
CJ=CJ*EXP_J
C
SUM_NU1_0=ZEROC
SUM_NU1_1=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF)
C
SUM_NUJ_0=ZEROC
SUM_NUJ_1=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
SUM_MUJ_1=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,-
&MJ,LJ)
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,M
&J,LJ)
C
ENDDO
C
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
C
ENDDO
C
ENDDO
C
TAU(INDJP,ILF,JATL)=TAU(INDJP,ILF,JATL)+CONJG(CJ)*TL_J*SUM_N
&U1_1
TAU(INDJ,ILF,JATL)=TAU(INDJ,ILF,JATL)+CJ*TL_J*SUM_NU1_0
C
IF(NPATHP.EQ.0) GOTO 45
C
FM2=FMAX(JORDP)
XINT1=CABS(CJ*TL_J*SUM_NU1_0)
XINT2=CABS(CONJG(CJ)*TL_J*SUM_NU1_1)
XMAX=AMAX1(XINT1,XINT2,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
45 CONTINUE
ENDDO
ENDDO
C
C Case MF > 0
C
CF=ONEC
DO MF=1,LF
INDF=ILF+MF
INDFP=ILF-MF
CF=CF*EXP_F
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
NUJMAX=MIN(LJ,NUMAXJ)
IF(JORDP.EQ.1) THEN
NU1MAX=MIN(NU1MAX1,LJ)
ELSE
NU1MAX=NU1MAX1
ENDIF
C
IF(ISPEED.EQ.1) THEN
TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE)
ELSE
TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE)
ENDIF
C
C Case MJ = 0
C
SUM_NU1_0=ZEROC
SUM_NU1_1=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
C
SUM_NUJ_0=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0
&,LJ)
C
ENDDO
C
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
SUM_NU1_1=SUM_NU1_1+RLMF_1*SUM_NUJ_0
C
ENDDO
C
ENDDO
C
TAU(ILJ,INDF,JATL)=TAU(ILJ,INDF,JATL)+CF*TL_J*SUM_NU1_0
TAU(ILJ,INDFP,JATL)=TAU(ILJ,INDFP,JATL)+CONJG(CF)*TL_J*SUM_N
&U1_1
C
IF(NPATHP.EQ.0) GOTO 25
C
FM2=FMAX(JORDP)
XINT1=CABS(CF*TL_J*SUM_NU1_0)
XINT2=CABS(CONJG(CF)*TL_J*SUM_NU1_1)
XMAX=AMAX1(XINT1,XINT2,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
25 CONTINUE
C
C Case MJ > 0
C
CJ=ONEC
DO MJ=1,LJ
INDJ=ILJ+MJ
INDJP=ILJ-MJ
CJ=CJ*EXP_J
C
SUM_NU1_0=ZEROC
SUM_NU1_1=ZEROC
SUM_NU1_2=ZEROC
SUM_NU1_3=ZEROC
C
DO NU1=0,NU1MAX
IF(JORDP.GT.1) THEN
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1)
ELSE
MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ)
ENDIF
C
DO MU1=-MU1MAX,MU1MAX
LAMBDA1=LBD(MU1,NU1)
AMU1=ABS(MU1)
C
RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF)
RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF)
C
SUM_NUJ_0=ZEROC
SUM_NUJ_1=ZEROC
C
IF(JORDP.GT.1) THEN
DO NUJ=0,NUJMAX
MUJMAX=MIN(LJ,NOJ-NUJ-NUJ)
C
SUM_MUJ_0=ZEROC
SUM_MUJ_1=ZEROC
C
DO MUJ=-MUJMAX,MUJMAX
C
LAMBDAJ=LBD(MUJ,NUJ)
C
SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ
&,-MJ,LJ)
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ
&,MJ,LJ)
C
ENDDO
C
SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ)
SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ)
C
ENDDO
ELSE
SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ)
SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ)
ENDIF
C
SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0
SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1
SUM_NU1_2=SUM_NU1_2+RLMF_1*SUM_NUJ_0
SUM_NU1_3=SUM_NU1_3+RLMF_1*SUM_NUJ_1
C
ENDDO
C
ENDDO
C
TAU(INDJP,INDF,JATL)=TAU(INDJP,INDF,JATL)+CF*CONJG(CJ)*TL_
&J*SUM_NU1_1
TAU(INDJP,INDFP,JATL)=TAU(INDJP,INDFP,JATL)+CONJG(CF*CJ)*T
&L_J*SUM_NU1_3
TAU(INDJ,INDF,JATL)=TAU(INDJ,INDF,JATL)+CF*CJ*TL_J*SUM_NU1
&_0
TAU(INDJ,INDFP,JATL)=TAU(INDJ,INDFP,JATL)+CONJG(CF)*CJ*TL_
&J*SUM_NU1_2
C
IF(NPATHP.EQ.0) GOTO 15
C
FM2=FMAX(JORDP)
XINT1=CABS(CF*CJ*TL_J*SUM_NU1_0)
XINT2=CABS(CF*CONJG(CJ)*TL_J*SUM_NU1_1)
XINT3=CABS(CONJG(CF)*CJ*TL_J*SUM_NU1_2)
XINT4=CABS(CONJG(CF*CJ)*TL_J*SUM_NU1_3)
XMAX=AMAX1(XINT1,XINT2,XINT3,XINT4,XMAX)
FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2,XINT3,XINT4)
IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP)
IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN
FREF=FMAX(JORDP)
ENDIF
15 CONTINUE
ENDDO
ENDDO
ENDDO
ENDDO
C
IF(NPATHP.EQ.0) GOTO 16
FMIN(JORDP)=AMIN1(FM1,XMAX)
IF(XMAX.GT.FMN(NPATHP)) THEN
CALL LOCATE(FMN,NPATHP,XMAX,JMX)
DO KF=NPATHP,JMX+2,-1
FMN(KF)=FMN(KF-1)
JON(KF)=JON(KF-1)
PATH(KF)=PATH(KF-1)
DMN(KF)=DMN(KF-1)
DO KD=1,10
JPON(KF,KD)=JPON(KF-1,KD)
ENDDO
ENDDO
FMN(JMX+1)=XMAX
JON(JMX+1)=JORDP
PATH(JMX+1)=NPATH(JORDP)
DMN(JMX+1)=D
DO KD=1,JORDP
JPON(JMX+1,KD)=JPOS(KD,3)
ENDDO
ENDIF
IF((FMIN(JORDP)-FM1).LT.-XCOMP) NPMI(JORDP)=NPATH(JORDP)
IF((IPRINT.EQ.3).AND.(IJ.EQ.1)) THEN
WRITE(IUSCR,1) JORDP,NPATH(JORDP),XMAX,D,(JPOS(KD,3),KD=1,JORDP)
&
ENDIF
C
16 RETURN
C
1 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
C
END
C
C=======================================================================
C
SUBROUTINE COUMAT(ITL,MI,LF,MF,DELTA,RADIAL,MATRIX)
C
C This routine calculates the spin-independent PhD optical matrix
C elements for dipolar excitations. It is stored in
C MATRIX(JDIR,JPOL)
C
C Here, the conventions are :
C
C IPOL=1 : linearly polarized light
C IPOL=2 : circularly polarized light
C
C JPOL=1 : +/x polarization for circular/linear light
C JPOL=2 : -/y polarization for circular/linear light
C
C When IDICHR=0, JDIR = 1,2 and 3 correspond respectively to the x,y
C and z directions for the linear polarization. But for IDICHR=1,
C these basis directions are those of the position of the light.
C
C Last modified : 8 Dec 2008
C
USE DIM_MOD
C
USE INIT_L_MOD , L2 => NNL, L3 => LF1, L4 => LF2, L5 => ISTEP_LF
USE SPIN_MOD , I1 => ISPIN, N1 => NSPIN, N2 => NSPIN2, I2 => ISFLI
&P, I8 => IR_DIA, N3 => NSTEP
USE TYPCAL_MOD , I3 => IPHI, I4 => IE, I5 => ITHETA, I6 => IFTHET,
& I7 => IMOD, I9 => I_CP, I10 => I_EXT
C
COMPLEX MATRIX(3,2),SUM_1,SUM_2,DELTA,YLM(3,-1:1),RADIAL
COMPLEX ONEC,IC,IL,COEF,PROD
C
REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1),GNT(0:N_GAUNT)
REAL THETA(3),PHI(3)
C
DATA PI4S3,C_LIN,SQR2 /4.188790,1.447202,1.414214/
DATA PIS2 /1.570796/
C
ONEC=(1.,0.)
IC=(0.,1.)
C
IF(INITL.EQ.0) GOTO 2
C
M=MF-MI
C
IF(MOD(LF,4).EQ.0) THEN
IL=ONEC
ELSEIF(MOD(LF,4).EQ.1) THEN
IL=IC
ELSEIF(MOD(LF,4).EQ.2) THEN
IL=-ONEC
ELSEIF(MOD(LF,4).EQ.3) THEN
IL=-IC
ENDIF
C
CALL GAUNT(LI,MI,LF,MF,GNT)
C
IF(ITL.EQ.0) THEN
c COEF=CEXP(IC*DELTA)*CONJG(IL)
COEF=CEXP(IC*DELTA)*IL
ELSE
IF(IDICHR.EQ.0) THEN
c COEF=PI4S3*CONJG(IL)
COEF=PI4S3*IL
ELSE
c COEF=C_LIN*CONJG(IL)
COEF=C_LIN*IL
ENDIF
ENDIF
C
PROD=COEF*RADIAL*GNT(1)
C
IF(IDICHR.EQ.0) THEN
YLM(1,-1)=(0.345494,0.)
YLM(1,0)=(0.,0.)
YLM(1,1)=(-0.345494,0.)
YLM(2,-1)=(0.,-0.345494)
YLM(2,0)=(0.,0.)
YLM(2,1)=(0.,-0.345494)
YLM(3,-1)=(0.,0.)
YLM(3,0)=(0.488602,0.)
YLM(3,1)=(0.,0.)
C
DO JDIR=1,3
MATRIX(JDIR,1)=PROD*CONJG(YLM(JDIR,M))
ENDDO
C
ELSEIF(IDICHR.GE.1) THEN
C
THETA(1)=PIS2
PHI(1)=0.
THETA(2)=PIS2
PHI(2)=PIS2
THETA(3)=0.
PHI(3)=0.
C
DO JDIR=1,3
CALL DJMN(THETA(JDIR),RLM,1)
SUM_1=RLM(-1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
SUM_2=RLM(1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR))
IF(IPOL.EQ.2) THEN
MATRIX(JDIR,1)=SQR2*SUM_1
MATRIX(JDIR,2)=SQR2*SUM_2
ELSEIF(ABS(IPOL).EQ.1) THEN
MATRIX(JDIR,1)=(SUM_2-SUM_1)
MATRIX(JDIR,2)=(SUM_2+SUM_1)*IC
ENDIF
ENDDO
ENDIF
GOTO 1
C
2 DO JDIR=1,3
MATRIX(JDIR,1)=ONEC
MATRIX(JDIR,2)=ONEC
ENDDO
C
1 RETURN
C
END
C
C=======================================================================
C
SUBROUTINE PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,NATC
&LU,NFICHLEC,JFICH,NP)
C
C This subroutine computes the PhD formula in the spin-independent case
C from a non spin-orbit resolved initial core state LI.
C
C Alternatively, it can compute the PhD amplitude for the APECS process.
C
C The calculation is performed using a series expansion for the
C expression of the scattering path operator
C
C Last modified : 10 Jan 2016
C
USE DIM_MOD
C
USE ALGORITHM_MOD
USE AMPLI_MOD
USE APPROX_MOD
USE COOR_MOD , NTCLU => NATCLU, NTP => NATYP
USE DEBWAL_MOD
USE DIRECT_MOD , RTHETA => RTHEXT
USE EXTREM_MOD
USE FIXSCAN_MOD
USE INFILES_MOD
USE INUNITS_MOD
USE INIT_L_MOD
USE INIT_J_MOD
USE LIMAMA_MOD
USE LINLBD_MOD
USE MOYEN_MOD
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_MOD
USE PATH_MOD
USE PRINTP_MOD
USE RESEAU_MOD
USE SPIN_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TESTS_MOD
USE TRANS_MOD
USE TYPCAL_MOD
USE TYPEM_MOD
USE TYPEXP_MOD
USE VALIN_MOD , PHLUM => PHILUM
USE VALIN_AV_MOD
USE VALFIN_MOD
C
REAL NPATH1(0:NDIF_M),NOPA
REAL LUM(3),AXE(3),EPS(3),DIRLUM(3),E_PH(NE_M)
C
COMPLEX IC,ONEC,ZEROC,COEF,PW(0:NDIF_M),DELTA
COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI
COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M)
COMPLEX YLMR(0:NL_M,-NL_M:NL_M),MATRIX(3,2)
COMPLEX YLME(0:NL_M,-NL_M:NL_M)
COMPLEX R2,MLFLI(2,-LI_M:LI_M,3,2,3)
COMPLEX SJDIR_1,SJDIR_2,SJDIF_1,SJDIF_2
COMPLEX RHOK(NE_M,NATM,0:18,5,NSPIN2_M),RD
COMPLEX SLJDIF,ATT_M,MLIL0(2,-LI_M:LI_M,6),SLF_1,SLF_2
COMPLEX SL0DIF,SMJDIF
C
DIMENSION VAL(NATCLU_M),NATYP(NATM),DIRPOL(3,2)
DIMENSION EMET(3),R_L(9),COORD(3,NATCLU_M)
DIMENSION R(NDIF_M),XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M)
DIMENSION JPOS(NDIF_M,3),JPA(NDIF_M)
C
C
C
CHARACTER*7 STAT
CHARACTER*13 OUTDATA1,OUTDATA2
C
C
CHARACTER*24 OUTFILE
CHARACTER*24 AMPFILE
C
DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/
DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/
C
ALGO1='SE'
ALGO2=' '
ALGO3=' '
ALGO4=' '
C
I_DIR=0
NSET=1
JEL=1
OUTDATA1='CROSS-SECTION'
IF(I_AMP.EQ.1) THEN
I_MI=1
OUTDATA2='MS AMPLITUDES'
ELSE
I_MI=0
ENDIF
C
IF(SPECTRO.EQ.'PHD') THEN
IOUT=IUO2
OUTFILE=OUTFILE2
STAT='UNKNOWN'
IF(I_MI.EQ.1) THEN
IOUT2=IUSCR2+1
N_DOT=1
DO J_CHAR=1,24
IF(OUTFILE(J_CHAR:J_CHAR).EQ.'.') GOTO 888
N_DOT=N_DOT+1
ENDDO
888 CONTINUE
AMPFILE=OUTFILE(1:N_DOT)//'amp'
OPEN(UNIT=IOUT2, FILE=AMPFILE, STATUS=STAT)
ENDIF
ELSEIF(SPECTRO.EQ.'APC') THEN
IOUT=IUSCR2+1
OUTFILE='res/phot.amp'
STAT='UNKNOWN'
ENDIF
C
C Position of the light when the analyzer is along the z axis :
C (X_LUM_Z,Y_LUM_Z,Z_LUM_Z)
C
RTHLUM=THLUM*PIS180
RPHLUM=PHLUM*PIS180
X_LUM_Z=SIN(RTHLUM)*COS(RPHLUM)
Y_LUM_Z=SIN(RTHLUM)*SIN(RPHLUM)
Z_LUM_Z=COS(RTHLUM)
C
IF(IMOD.EQ.0) THEN
C
C The analyzer is rotated
C
DIRLUM(1)=X_LUM_Z
DIRLUM(2)=Y_LUM_Z
DIRLUM(3)=Z_LUM_Z
ELSE
C
C The sample is rotated ---> light and analyzer rotated
C
IF(I_EXT.EQ.0) THEN
RTH0=THETA0*PIS180
RPH0=PHI0*PIS180
RTH=RTH0
RPH=RPH0
C
C R_L is the rotation matrix from 0z to (THETA0,PHI0) expressed as
C a function of the Euler angles ALPHA=PHI0, BETA=THETA0, GAMMA=-PHI0
C It is stored as (1 2 3)
C (4 5 6)
C (7 8 9)
C
R_L(1)=COS(RTH0)*COS(RPH0)*COS(RPH0)+SIN(RPH0)*SIN(RPH0)
R_L(2)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
R_L(3)=SIN(RTH0)*COS(RPH0)
R_L(4)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0)
R_L(5)=COS(RTH0)*SIN(RPH0)*SIN(RPH0)+COS(RPH0)*COS(RPH0)
R_L(6)=SIN(RTH0)*SIN(RPH0)
R_L(7)=-SIN(RTH0)*COS(RPH0)
R_L(8)=-SIN(RTH0)*SIN(RPH0)
R_L(9)=COS(RTH0)
C
C Position of the light when the analyzer is along (THETA0,PHI0) : LUM(3)
C
LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
C
ENDIF
ENDIF
C
IC=(0.,1.)
ONEC=(1.,0.)
ZEROC=(0.,0.)
NSCAT=NATCLU-1
ATTSE=1.
ATTSJ=1.
NPATH2(0)=1.
NPATH(0)=1.
NPMA(0)=1.
NPMI(0)=1.
ZSURF=VAL(1)
C
IF((ISOM.EQ.0).OR.(JFICH.EQ.1)) THEN
OPEN(UNIT=IOUT, FILE=OUTFILE, STATUS=STAT)
ENDIF
C
C Writing the headers in the output file
C
CALL HEADERS(IOUT)
C
IF((ISOM.EQ.0).OR.((ISOM.GT.0).AND.(JFICH.EQ.1))) THEN
WRITE(IOUT,12) SPECTRO,OUTDATA1
WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IP
&H_1,I_EXT
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,12) SPECTRO,OUTDATA2
WRITE(IOUT2,12) STEREO
WRITE(IOUT2,19) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,I
&E,IPH_1,I_EXT
WRITE(IOUT2,20) PHI0,THETA0,PHI1,THETA1,NONVOL(1)
ENDIF
ENDIF
C
IF(ISOM.EQ.0) THEN
WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,79) NPLAN,NEMET,NTHETA,NPHI,NE
ENDIF
ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN
WRITE(IOUT,11) NTHETA,NPHI,NE
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,11) NTHETA,NPHI,NE
ENDIF
ENDIF
C
C Construction of the linear index LAMBDA=(MU,NU)
C
LAMBDA0=0
DO N_O=0,NO
NMX=N_O/2
DO NU=0,NMX
DO MU=-N_O,N_O
NMU=2*NU+ABS(MU)
IF(NMU.EQ.N_O) THEN
LAMBDA0=LAMBDA0+1
LBD(MU,NU)=LAMBDA0
ENDIF
ENDDO
ENDDO
ENDDO
LBDMAX=LAMBDA0
IJK=0
C
C Loop over the planes
C
DO JPLAN=1,NPLAN
Z=VAL(JPLAN)
IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN
DZZEM=ABS(Z-ZEM)
IF(DZZEM.LT.SMALL) GOTO 10
GOTO 1
ENDIF
10 CONTINUE
C
C Loop over the different absorbers in a given plane
C
DO JEMET=1,NEMET
CALL EMETT(JEMET,IEMET,Z,SYM_AT,NATYP,EMET,NTYPEM,JNEM,*4)
GO TO 2
4 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN
IF(I_TEST.NE.2) WRITE(IUO1,51) JPLAN,NTYPEM
ENDIF
GO TO 3
2 IF((ABS(EMET(3)).GT.COUPUR).AND.(IBAS.EQ.1)) GOTO 5
IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN
IF(I_TEST.NE.2) THEN
WRITE(IUO1,52) JPLAN,EMET(1),EMET(2),EMET(3),NTYPEM
ENDIF
ENDIF
IF(ISOM.EQ.1) NP=JPLAN
ZSURFE=VAL(1)-EMET(3)
C
C Loop over the energies
C
DO JE=1,NE
FMIN(0)=1.
FMAX(0)=1.
IF(NE.GT.1) THEN
ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
E_PH(JE)=ELUM+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
ELSEIF(NE.EQ.1) THEN
ECIN=E0
E_PH(JE)=ELUM
ENDIF
IF(I_TEST.NE.1) THEN
CFM=8.*PI*E_PH(JE)*FINSTRUC
ELSE
CFM=1.
ENDIF
CALL LPM(ECIN,XLPM,*6)
XLPM1=XLPM/A
IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1
IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN
IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR
ENDIF
IF(ITL.EQ.0) THEN
VK(JE)=SQRT(ECIN+VINT)*CONV*A*(1.,0.)
VK2(JE)=CABS(VK(JE)*VK(JE))
ENDIF
GAMMA=1./(2.*XLPM1)
IF(IPOTC.EQ.0) THEN
VK(JE)=VK(JE)+IC*GAMMA
ENDIF
IF(I_TEST.NE.1) THEN
VKR=REAL(VK(JE))
ELSE
VKR=1.
ENDIF
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,21) ECIN,VKR*CFM
ENDIF
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN
IF(IDCM.GE.1) WRITE(IUO1,22)
DO JAT=1,N_PROT
IF(IDCM.EQ.0) THEN
XK2UJ2=VK2(JE)*UJ2(JAT)
ELSE
XK2UJ2=VK2(JE)*UJ_SQ(JAT)
WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A
ENDIF
CALL DWSPH(JAT,JE,XK2UJ2,TLT,ISPEED)
DO LAT=0,LMAX(JAT,JE)
TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE)
ENDDO
ENDDO
ENDIF
IF(ABS(I_EXT).GE.1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,13) I_DIR,NSET,N_DUM1
READ(IUI6,14) I_DUM1,N_DUM2,N_DUM3
ENDIF
C
C Initialization of TAU(INDJ,LINFMAX,JTYP)
C
JATL=0
DO JTYP=1,N_PROT
NBTYP=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYP
JATL=JATL+1
DO LF=LF1,LF2,ISTEP_LF
ILF=LF*LF+LF+1
DO MF=-LF,LF
INDF=ILF+MF
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDF,JATL)=ZEROC
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C
C Storage of the coupling matrix elements MLFLI along the basis
C directions X,Y ET Z
C
C These basis directions refer to the polarization if IDICHR = 0
C but to the light when IDICHR = 1
C
C JBASE = 1 : X
C JBASE = 2 : Y
C JBASE = 3 : Z
C
DO MI=-LI,LI
DO LF=LF1,LF2,ISTEP_LF
LR=1+(1+LF-LI)/2
DELTA=DLT(JE,NTYPEM,NNL,LR)
RD=RHOK(JE,NTYPEM,NNL,LR,1)
DO MF=-LF,LF
IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 333
IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 333
MR=2+MF-MI
CALL COUMAT(ITL,MI,LF,MF,DELTA,RD,MATRIX)
DO JBASE=1,3
MLFLI(1,MI,MR,LR,JBASE)=MATRIX(JBASE,1)
IF(IDICHR.GE.1) THEN
MLFLI(2,MI,MR,LR,JBASE)=MATRIX(JBASE,2)
ENDIF
ENDDO
333 CONTINUE
ENDDO
ENDDO
ENDDO
C
C Calculation of the scattering path operator TAU
C
IF(I_TEST.EQ.2) GOTO 666
PW(0)=ONEC
PW(1)=ONEC
ND=0
TH01=0.
PHI01=0.
RHO01=ZEROC
THMI=0.
PHMI=0.
RHOMI=ZEROC
JATLEM=JNEM
IF(NTYPEM.GT.1) THEN
DO JAEM=NTYPEM-1,1,-1
JATLEM=JATLEM+NATYP(JAEM)
ENDDO
ENDIF
DO JD=1,NDIF
NPATH2(JD)=0.
NPATH(JD)=0.
IT(JD)=0
IN(JD)=0
FMIN(JD)=1.E+20
FMAX(JD)=0.
ENDDO
NTHOF=0
C
C Calculation of the maximal intensity for the paths of order NCUT
C (plane waves). This will be taken as a reference for the IPW filter.
C
IF(IPW.EQ.1) THEN
NDIFOLD=NDIF
NOOLD=NO
ISPHEROLD=ISPHER
NDIF=NCUT
NO=0
ISPHER=0
IREF=1
IPW=0
IJ=0
DIJ=0.
FREF=0.
CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PH
&MI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
NDIF=NDIFOLD
NO=NOOLD
ISPHER=ISPHEROLD
PW(0)=ONEC
PW(1)=ONEC
IPW=1
ND=0
TH01=0.
PHI01=0.
RHO01=ZEROC
THMI=0.
PHMI=0.
RHOMI=ZEROC
JATLEM=JNEM
IF(NTYPEM.GT.1) THEN
DO JAEM=NTYPEM-1,1,-1
JATLEM=JATLEM+NATYP(JAEM)
ENDDO
ENDIF
DO JD=1,NDIF
NPATH2(JD)=0.
NPATH(JD)=0.
IT(JD)=0
IN(JD)=0
FMIN(JD)=1.E+20
FMAX(JD)=0.
ENDDO
NTHOF=0
C
C New initialization of TAU(INDJ,INDF,JATL) after the PW calculation
C
JATL=0
DO JTYP=1,N_PROT
NBTYP=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYP
JATL=JATL+1
DO LF=LF1,LF2,ISTEP_LF
ILF=LF*LF+LF+1
DO MF=-LF,LF
INDF=ILF+MF
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDF,JATL)=ZEROC
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDIF
C
C Generation and print-out of the paths
C
IF (NPATHP.GT.0) THEN
DO JP=1,NPATHP-1
FMN(JP)=0.
PATH(JP)=0.
JON(JP)=0
ENDDO
FMN(NPATHP)=-1.
PATH(NPATHP)=0.
JON(NPATHP)=0
ENDIF
IREF=0
IJ=1
IF(IPRINT.EQ.3) THEN
OPEN(UNIT=IUSCR, STATUS='SCRATCH')
ENDIF
DIJ=0.
CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHMI
&,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU)
IF(NPATHP.EQ.0) GOTO 15
IF(NSCAT.GT.1) THEN
XPATOT=REAL((DFLOAT(NSCAT)**DFLOAT(NDIF+1) -1.D0)/DFLOAT(NSCA
&T-1))
ELSE
XPATOT=FLOAT(NDIF+1)
ENDIF
IF(XPATOT.LT.2.14748E+09) THEN
NPATOT=INT(XPATOT)
IF(NPATOT.LT.NPATHP) NPATHP=NPATOT-1
ENDIF
WRITE(IUO1,84) NPATHP
WRITE(IUO1,81)
DO JPT=1,NPATHP
IF(PATH(NPATHP).GT.2.14E+09) THEN
WRITE(IUO1,82) JPT,JON(JPT),PATH(JPT),FMN(JPT),DMN(JPT),JNE
&M,(JPON(JPT,KD),KD=1,JON(JPT))
ELSE
WRITE(IUO1,83) JPT,JON(JPT),INT(PATH(JPT)),FMN(JPT),DMN(JPT
&),JNEM,(JPON(JPT,KD),KD=1,JON(JPT))
ENDIF
ENDDO
IF(IPRINT.EQ.3) THEN
IF(XPATOT.GT.2.14748E+09) GOTO 172
WRITE(IUO1,85)
WRITE(IUO1,71)
NPATOT=INT(XPATOT)
DO JOP=0,NDIF
IF(JOP.EQ.0) THEN
XINT0=FMAX(0)
DIST0=0.
WRITE(IUO1,70) JOP,JOP+1,XINT0,DIST0,JNEM
GOTO 75
ENDIF
WRITE(IUO1,77)
DO JLINE=1,NPATOT-1
READ(IUSCR,69,ERR=75,END=75) JOPA,NOPA,XMAX,DIST0,(JPA(KD
&),KD=1,JOPA)
IF(JOPA.EQ.JOP) THEN
IF(NOPA.GT.2.14E+09) THEN
WRITE(IUO1,76) JOPA,NOPA,XMAX,DIST0,JNEM,(JPA(KD),KD=1
&,JOPA)
ELSE
WRITE(IUO1,70) JOPA,INT(NOPA),XMAX,DIST0,JNEM,(JPA(KD)
&,KD=1,JOPA)
ENDIF
ENDIF
ENDDO
IF(JOP.EQ.NDIF) WRITE(IUO1,80)
75 REWIND IUSCR
ENDDO
GOTO 73
172 WRITE(IUO1,74)
CLOSE(IUSCR,STATUS='DELETE')
73 ENDIF
DO JD=0,NDIF
NPATH1(JD)=REAL(DFLOAT(NSCAT)**DFLOAT(JD))
IF(NPATH1(JD).GT.2.14E+09) THEN
IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
WRITE(IUO1,53) JD,NPATH1(JD),NPATH2(JD),FMIN(JD),NPMI(JD),F
&MAX(JD),NPMA(JD)
IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
ELSE
IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0.
WRITE(IUO1,58) JD,INT(NPATH1(JD)+0.1),INT(NPATH2(JD)+0.1),F
&MIN(JD),INT(NPMI(JD)+0.1),FMAX(JD),INT(NPMA(JD)+0.1)
IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT
ENDIF
ENDDO
666 CONTINUE
C
C Calculation of the Photoelectron Diffraction formula
C
C
C Loop over the 'fixed' angle
C
15 DO J_FIXED=1,N_FIXED
IF(N_FIXED.GT.1) THEN
IF(I_EXT.EQ.0) THEN
FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1)
XINCRF=FLOAT(J_FIXED-1)*FIX_STEP
ELSE
XINCRF=0.
ENDIF
ELSEIF(N_FIXED.EQ.1) THEN
XINCRF=0.
ENDIF
IF(ABS(I_EXT).GE.1) THEN
READ(IUI6,86) JSET,JLINE,THD,PHD
IF(I_EXT.EQ.-1) BACKSPACE IUI6
THETA0=THD
PHI0=PHD
ENDIF
IF(IPH_1.EQ.1) THEN
IF(I_EXT.EQ.0) THEN
DPHI=PHI0+XINCRF
ELSE
DPHI=PHD
ENDIF
RPHI=DPHI*PIS180
IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
ELSE
ISAUT=0
IF(I_EXT.EQ.0) THEN
DTHETA=THETA0+XINCRF
ELSE
DTHETA=THD
ENDIF
RTHETA=DTHETA*PIS180
IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
IF(I_EXT.GE.1) ISAUT=0
IF(I_TEST.EQ.2) ISAUT=0
IF(ISAUT.GT.0) GOTO 8
IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
C
C THETA-dependent number of PHI points for stereographic
C representation (to obtain a uniform sampling density).
C (Courtesy of J. Osterwalder - University of Zurich)
C
IF(STEREO.EQ.'YES') THEN
N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+SMALL)+1
ENDIF
C
ENDIF
IF((N_FIXED.GT.1).AND.(IMOD.EQ.1)) THEN
C
C When there are several sets of scans (N_FIXED > 1),
C the initial position LUM of the light is recalculated
C for each initial position (RTH,RPH) of the analyzer
C
IF(IPH_1.EQ.1) THEN
RTH=THETA0*PIS180
RPH=RPHI
ELSE
RTH=RTHETA
RPH=PHI0*PIS180
ENDIF
C
R_L(1)=COS(RTH)*COS(RPH)
R_L(2)=-SIN(RPH)
R_L(3)=SIN(RTH)*COS(RPH)
R_L(4)=COS(RTH)*SIN(RPH)
R_L(5)=COS(RPH)
R_L(6)=SIN(RTH)*SIN(RPH)
R_L(7)=-SIN(RTH)
R_L(8)=0.
R_L(9)=COS(RTH)
C
LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
ENDIF
C
C Loop over the scanned angle
C
DO J_SCAN=1,N_SCAN
IF(N_SCAN.GT.1) THEN
XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1)
ELSEIF(N_SCAN.EQ.1) THEN
XINCRS=0.
ENDIF
IF(I_EXT.EQ.-1) THEN
READ(IUI6,86) JSET,JLINE,THD,PHD
BACKSPACE IUI6
ENDIF
IF(IPH_1.EQ.1) THEN
ISAUT=0
IF(I_EXT.EQ.0) THEN
DTHETA=THETA0+XINCRS
ELSE
DTHETA=THD
ENDIF
RTHETA=DTHETA*PIS180
IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1
IF(I_EXT.GE.1) ISAUT=0
IF(I_TEST.EQ.2) ISAUT=0
IF(ISAUT.GT.0) GOTO 8
IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA
IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59)
IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60)
ELSE
IF(I_EXT.EQ.0) THEN
DPHI=PHI0+XINCRS
ELSE
DPHI=PHD
ENDIF
RPHI=DPHI*PIS180
IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI
ENDIF
C
C Loop over the sets of directions to average over (for gaussian average)
C
C
SSETDIR_1=0.
SSETDIF_1=0.
SSETDIR_2=0.
SSETDIF_2=0.
C
SSET2DIR_1=0.
SSET2DIF_1=0.
SSET2DIR_2=0.
SSET2DIF_2=0.
C
IF(I_EXT.EQ.-1) THEN
JREF=INT(NSET)/2+1
ELSE
JREF=1
ENDIF
C
DO J_SET=1,NSET
IF(I_EXT.EQ.-1) THEN
READ(IUI6,86) JSET,JLINE,THD,PHD,W
DTHETA=THD
DPHI=PHD
RTHETA=DTHETA*PIS180
RPHI=DPHI*PIS180
C
C Here, there are several sets of scans (NSET > 1), so
C the initial position LUM of the light must be
C recalculated for each initial position of the analyzer
C
RTH=TH_0(J_SET)*PIS180
RPH=PH_0(J_SET)*PIS180
C
IF(IMOD.EQ.1) THEN
R_L(1)=COS(RTH)*COS(RPH)
R_L(2)=-SIN(RPH)
R_L(3)=SIN(RTH)*COS(RPH)
R_L(4)=COS(RTH)*SIN(RPH)
R_L(5)=COS(RPH)
R_L(6)=SIN(RTH)*SIN(RPH)
R_L(7)=-SIN(RTH)
R_L(8)=0.
R_L(9)=COS(RTH)
C
LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3)
LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6)
LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9)
C
ENDIF
ELSE
W=1.
ENDIF
C
IF(I_EXT.EQ.-1) PRINT 89
C
CALL DIRAN(VINT,ECIN,JEL)
C
IF(J_SET.EQ.JREF) THEN
DTHETAP=DTHETA
DPHIP=DPHI
ENDIF
C
IF(I_EXT.EQ.-1) THEN
WRITE(IUO1,88) DTHETA,DPHI
ENDIF
C
C .......... Case IMOD=1 only ..........
C
C Calculation of the position of the light when the analyzer is at
C (THETA,PHI). DIRLUM is the direction of the light and its initial
C value (at (THETA0,PHI0)) is LUM. AXE is the direction of the theta
C rotation axis and EPS is defined so that (AXE,DIRLUM,EPS) is a
C direct orthonormal basis. The transform of a vector R by a rotation
C of OMEGA about AXE is then given by
C
C R' = R COS(OMEGA) + (AXE.R)(1-COS(OMEGA)) AXE + (AXE^R) SIN(OMEGA)
C
C Here, DIRANA is the internal direction of the analyzer and ANADIR
C its external position
C
C Note that when the initial position of the analyzer is (RTH,RPH)
C which coincides with (RTH0,RPH0) only for the first fixed angle
C
IF(IMOD.EQ.1) THEN
IF(ITHETA.EQ.1) THEN
AXE(1)=-SIN(RPH)
AXE(2)=COS(RPH)
AXE(3)=0.
RANGLE=RTHETA-RTH
ELSEIF(IPHI.EQ.1) THEN
AXE(1)=0.
AXE(2)=0.
AXE(3)=1.
RANGLE=RPHI-RPH
ENDIF
CALL PRVECT(AXE,LUM,EPS,CVECT)
PRS=PRSCAL(AXE,LUM)
IF(J_SCAN.EQ.1) THEN
DIRLUM(1)=LUM(1)
DIRLUM(2)=LUM(2)
DIRLUM(3)=LUM(3)
ELSE
DIRLUM(1)=LUM(1)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(1)+
&SIN(RANGLE)*EPS(1)
DIRLUM(2)=LUM(2)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(2)+
&SIN(RANGLE)*EPS(2)
DIRLUM(3)=LUM(3)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(3)+
&SIN(RANGLE)*EPS(3)
ENDIF
ENDIF
IF(DIRLUM(3).GT.1.) DIRLUM(3)=1.
IF(DIRLUM(3).LT.-1.) DIRLUM(3)=-1.
THETALUM=ACOS(DIRLUM(3))
IF(I_TEST.EQ.2) THETALUM=-THETALUM
COEF=DIRLUM(1)+IC*DIRLUM(2)
CALL ARCSIN(COEF,DIRLUM(3),PHILUM)
ANALUM=ANADIR(1,1)*DIRLUM(1) + ANADIR(2,1)*DIRLUM(2) +ANADIR(
&3,1)*DIRLUM(3)
C
SEPSDIR_1=0.
SEPSDIF_1=0.
SEPSDIR_2=0.
SEPSDIF_2=0.
C
C Loop over the directions of polarization
C
DO JEPS=1,NEPS
IF((JEPS.EQ.1).AND.(IPOL.GE.0)) THEN
DIRPOL(1,JEPS)=COS(THETALUM)*COS(PHILUM)
DIRPOL(2,JEPS)=COS(THETALUM)*SIN(PHILUM)
DIRPOL(3,JEPS)=-SIN(THETALUM)
ELSE
DIRPOL(1,JEPS)=-SIN(PHILUM)
DIRPOL(2,JEPS)=COS(PHILUM)
DIRPOL(3,JEPS)=0.
ENDIF
IF(ABS(IPOL).EQ.1) THEN
IF(IPRINT.GT.0) THEN
WRITE(IUO1,61) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),
& (DIRPOL(K,1),K=1,3),ANALUM
ENDIF
ELSE
IF((JEPS.EQ.1).AND.(IPRINT.GT.0)) THEN
WRITE(IUO1,63) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),ANA
&LUM
ENDIF
ENDIF
IF((JEPS.EQ.1).AND.(I_EXT.EQ.-1)) PRINT 89
C
C Calculation of the coupling matrix MLIL0
C
DO MI=-LI,LI
DO LF=LF1,LF2,ISTEP_LF
LR=1+(1+LF-LI)/2
LRR=3*(LR-1)
DO MF=-LF,LF
MR=2+MF-MI
IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 777
IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 777
LMR=LRR+MR
IF(IDICHR.EQ.0) THEN
IF(I_TEST.NE.1) THEN
MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRPOL(1,JEPS)
& +MLFLI(1,MI,MR,LR,2)*DIRPOL(2,JEPS) +MLFLI(1,MI,MR,LR,3)*DIRPOL(3
&,JEPS)
ELSE
MLIL0(1,MI,LMR)=ONEC
ENDIF
ELSEIF(IDICHR.GE.1) THEN
IF(I_TEST.NE.1) THEN
MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRLUM(1) +MLF
&LI(1,MI,MR,LR,2)*DIRLUM(2) +MLFLI(1,MI,MR,LR,3)*DIRLUM(3)
MLIL0(2,MI,LMR)=MLFLI(2,MI,MR,LR,1)*DIRLUM(1) +MLF
&LI(2,MI,MR,LR,2)*DIRLUM(2) +MLFLI(2,MI,MR,LR,3)*DIRLUM(3)
ELSE
MLIL0(1,MI,LMR)=ONEC
ENDIF
ENDIF
777 CONTINUE
ENDDO
ENDDO
ENDDO
C
SRDIF_1=0.
SRDIR_1=0.
SRDIF_2=0.
SRDIR_2=0.
C
C Loop over the different directions of the analyzer contained in a cone
C
DO JDIR=1,NDIR
IF(IATTS.EQ.1) THEN
ATTSE=EXP(-ZSURFE*GAMMA/DIRANA(3,JDIR))
ENDIF
C
SMIDIR_1=0.
SMIDIF_1=0.
SMIDIR_2=0.
SMIDIF_2=0.
C
C Loop over the equiprobable azimuthal quantum numbers MI corresponding
C to the initial state LI
C
LME=LMAX(1,JE)
CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME)
DO MI=-LI,LI
SJDIR_1=ZEROC
SJDIF_1=ZEROC
SJDIR_2=ZEROC
SJDIF_2=ZEROC
C
C Calculation of the direct emission (used a a reference for the
C output), which is not contained in the calculation of TAU
C
DO LF=LF1,LF2,ISTEP_LF
LR=1+(1+LF-LI)/2
LRR=3*(LR-1)
ILF=LF*LF+LF+1
IF(ISPEED.EQ.1) THEN
R2=TL(LF,1,1,JE)
ELSE
R2=TLT(LF,1,1,JE)
ENDIF
DO MF=-LF,LF
MR=2+MF-MI
LMR=LRR+MR
INDF=ILF+MF
IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 444
IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 444
SJDIR_1=SJDIR_1+YLME(LF,MF)*ATTSE*MLIL0(1,MI,LMR)*R2
IF(IDICHR.GE.1) THEN
SJDIR_2=SJDIR_2+YLME(LF,MF)*ATTSE*MLIL0(2,MI,LMR)*R2
&
ENDIF
C
C Contribution of the absorber to TAU (initialization of SJDIF)
C
IF(I_TEST.EQ.2) GOTO 444
SL0DIF=ZEROC
DO L0=0,LME
IL0=L0*L0+L0+1
SL0DIF=SL0DIF+YLME(L0,0)*TAU(IL0,INDF,1)
DO M0=1,L0
IND01=IL0+M0
IND02=IL0-M0
SL0DIF=SL0DIF+(YLME(L0,M0)*TAU(IND01,INDF,1)+YLME(L
&0,-M0)*TAU(IND02,INDF,1))
ENDDO
ENDDO
SJDIF_1=SJDIF_1+SL0DIF*MLIL0(1,MI,LMR)
IF(IDICHR.GE.1) THEN
SJDIF_2=SJDIF_2+SL0DIF*MLIL0(2,MI,LMR)
ENDIF
444 CONTINUE
ENDDO
ENDDO
SJDIF_1=SJDIF_1*ATTSE
IF(IDICHR.GE.1) THEN
SJDIF_2=SJDIF_2*ATTSE
ENDIF
C
C Loop over the last atom J encountered by the photoelectron
C before escaping the solid
C
IF(I_TEST.EQ.2) GOTO 111
DO JTYP=2,N_PROT
NBTYP=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYP
JATL=NCORR(JNUM,JTYP)
XOJ=SYM_AT(1,JATL)-EMET(1)
YOJ=SYM_AT(2,JATL)-EMET(2)
ZOJ=SYM_AT(3,JATL)-EMET(3)
ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ)
ZSURFJ=VAL(1)-SYM_AT(3,JATL)
CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLMR,LMJ)
IF(IATTS.EQ.1) THEN
ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR))
ENDIF
CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+ZOJ*DIRANA
&(3,JDIR))/ROJ
IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78
CTROIS1=ZOJ/ROJ
IF(CTROIS1.GT.1.) THEN
CTROIS1=1.
ELSEIF(CTROIS1.LT.-1.) THEN
CTROIS1=-1.
ENDIF
IF(IDCM.GE.1) THEN
UJ2(JTYP)=UJ_SQ(JTYP)
ENDIF
IF(ABS(ZSURFJ).LE.SMALL) THEN
IF(ABS(CSTHJR-1.).GT.SMALL) THEN
CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)*(DIRANA(3,JDIR)-CTRO
&IS1)/(2.-2.*CSTHJR)
ELSE
CSKZ2J=1.
ENDIF
UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.))
ELSE
UJJ=UJ2(JTYP)
ENDIF
IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN
XK2UJ2=VK2(JE)*UJJ
CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED)
ENDIF
78 IF(IDWSPH.EQ.1) THEN
DWTER=1.
ELSE
DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR))
ENDIF
IF(JATL.EQ.JATLEM) THEN
ATT_M=ATTSE*DWTER
ELSE
ATT_M=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*CSTHJR)
ENDIF
C
SLF_1=ZEROC
SLF_2=ZEROC
DO LF=LF1,LF2,ISTEP_LF
LR=1+(1+LF-LI)/2
LRR=3*(LR-1)
ILF=LF*LF+LF+1
DO MF=-LF,LF
MR=2+MF-MI
INDF=ILF+MF
IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 555
IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 555
LMR=LRR+MR
SLJDIF=ZEROC
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDF,JATL)
IF(LJ.GT.0) THEN
DO MJ=1,LJ
INDJ1=ILJ+MJ
INDJ2=ILJ-MJ
SMJDIF=SMJDIF+(YLMR(LJ,MJ)*TAU(INDJ1,INDF,JATL)+YL
&MR(LJ,-MJ)*TAU(INDJ2,INDF,JATL))
ENDDO
ENDIF
SLJDIF=SLJDIF+SMJDIF
ENDDO
SLF_1=SLF_1+SLJDIF*MLIL0(1,MI,LMR)
IF(IDICHR.GE.1) THEN
SLF_2=SLF_2+SLJDIF*MLIL0(2,MI,LMR)
ENDIF
555 CONTINUE
ENDDO
ENDDO
SJDIF_1=SJDIF_1+SLF_1*ATT_M
IF(IDICHR.GE.1) THEN
SJDIF_2=SJDIF_2+SLF_2*ATT_M
ENDIF
C
C End of the loops over the last atom J
C
ENDDO
ENDDO
C
C Writing the amplitudes in file IOUT for APECS, or
C in file IOUT2 for PhD (orientated orbitals' case)
C
111 IF(SPECTRO.EQ.'APC') THEN
WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEPS,
&JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1
IF(IDICHR.GE.1) THEN
WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEP
&S,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2
ENDIF
ELSE
IF(I_MI.EQ.1) THEN
WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JE
&PS,JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1
IF(IDICHR.GE.1) THEN
WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,
&JEPS,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2
ENDIF
ENDIF
C
C Computing the square modulus
C
SMIDIF_1=SMIDIF_1+CABS(SJDIR_1+SJDIF_1)*CABS(SJDIR_1+SJD
&IF_1)
SMIDIR_1=SMIDIR_1+CABS(SJDIR_1)*CABS(SJDIR_1)
IF(IDICHR.GE.1) THEN
SMIDIF_2=SMIDIF_2+CABS(SJDIR_2+SJDIF_2)*CABS(SJDIR_2+S
&JDIF_2)
SMIDIR_2=SMIDIR_2+CABS(SJDIR_2)*CABS(SJDIR_2)
ENDIF
ENDIF
C
C End of the loop over MI
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 220
SRDIR_1=SRDIR_1+SMIDIR_1
SRDIF_1=SRDIF_1+SMIDIF_1
IF(IDICHR.GE.1) THEN
SRDIR_2=SRDIR_2+SMIDIR_2
SRDIF_2=SRDIF_2+SMIDIF_2
ENDIF
220 CONTINUE
C
C End of the loop on the directions of the analyzer
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 221
SEPSDIF_1=SEPSDIF_1+SRDIF_1*VKR*CFM/NDIR
SEPSDIR_1=SEPSDIR_1+SRDIR_1*VKR*CFM/NDIR
IF(IDICHR.GE.1) THEN
SEPSDIF_2=SEPSDIF_2+SRDIF_2*VKR*CFM/NDIR
SEPSDIR_2=SEPSDIR_2+SRDIR_2*VKR*CFM/NDIR
ENDIF
221 CONTINUE
C
C End of the loop on the polarization
C
ENDDO
C
SSETDIR_1=SSETDIR_1+SEPSDIR_1*W
SSETDIF_1=SSETDIF_1+SEPSDIF_1*W
IF(ICHKDIR.EQ.2) THEN
IF(JSET.EQ.JREF) THEN
SSET2DIR_1=SEPSDIR_1
SSET2DIF_1=SEPSDIF_1
ENDIF
ENDIF
IF(IDICHR.GE.1) THEN
SSETDIR_2=SSETDIR_2+SEPSDIR_2*W
SSETDIF_2=SSETDIF_2+SEPSDIF_2*W
IF(ICHKDIR.EQ.2) THEN
IF(JSET.EQ.JREF) THEN
SSET2DIR_2=SEPSDIR_2
SSET2DIF_2=SEPSDIF_2
ENDIF
ENDIF
ENDIF
C
C End of the loop on the set averaging
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 222
IF(IDICHR.EQ.0) THEN
IF(ISOM.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
&ETDIF_1
IF(ICHKDIR.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
&SSET2DIF_1
ENDIF
ELSE
WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
&ETDIF_1
IF(ICHKDIR.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
&SSET2DIF_1
ENDIF
ENDIF
ELSE
IF(ISOM.EQ.2) THEN
WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
&ETDIF_1,SSETDIR_2,SSETDIF_2
IF(ICHKDIR.EQ.2) THEN
WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
&SSET2DIF_1,SSET2DIR_2,SSET2DIF_2
ENDIF
ELSE
WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS
&ETDIF_1,SSETDIR_2,SSETDIF_2
IF(ICHKDIR.EQ.2) THEN
WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1,
&SSET2DIF_1,SSET2DIR_2,SSET2DIF_2
ENDIF
ENDIF
ENDIF
222 CONTINUE
C
C End of the loop on the scanned angle
C
ENDDO
C
8 CONTINUE
C
C End of the loop on the fixed angle
C
ENDDO
C
C End of the loop on the energy
C
CLOSE(IUI6)
ENDDO
C
3 CONTINUE
C
C End of the loop on the emitters
C
ENDDO
C
GO TO 1
5 IPLAN=JPLAN-1
IJK=IJK+1
IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN
IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN
ENDIF
1 CONTINUE
C
C End of the loop on the planes
C
ENDDO
C
IF(ABS(I_EXT).GE.1) CLOSE(IUI6)
IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*)
IF(SPECTRO.EQ.'APC') CLOSE(IOUT)
IF(SPECTRO.EQ.'APC') GOTO 7
c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN
IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN
NP=0
CALL TREAT_PHD(ISOM,NFICHLEC,JFICH,NP)
ENDIF
IF(I_EXT.EQ.2) THEN
CALL WEIGHT_SUM(ISOM,I_EXT,0,1)
ENDIF
GOTO 7
6 WRITE(IUO1,55)
C
9 FORMAT(9(2X,I1),2X,I2)
11 FORMAT(I4,2X,I4,2X,I4)
12 FORMAT(2X,A3,11X,A13)
13 FORMAT(6X,I1,1X,I3,2X,I4)
14 FORMAT(6X,I1,1X,I3,3X,I3)
19 FORMAT(2(2X,I1),1X,I2,6(2X,I1),2X,I2)
20 FORMAT(2(5X,F6.2,2X,F6.2),2X,I1)
21 FORMAT(10X,E12.6,3X,E12.6)
22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,2
&5X,' BY DEBYE UNCORRELATED MODEL:',/)
23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2')
51 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' DOES NOT CONTAIN ',
*'ANY ABSORBER OF TYPE ',I2,' *******')
52 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' POSITION OF ','THE AB
&SORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X,'******* ',19X
&,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******')
53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1,/,
&10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1,/,10X,' MINIMAL INTENS
&ITY : ',E12.6,2X,'No OF THE PATH : ',F15.1,
& /,10X,' MAXIMAL INTENSITY : ',E12.6,2X,'No OF T
&HE PATH : ',F15.1)
54 FORMAT(//,7X,'DUE TO THE SIZE OF THE CLUSTER, THE SUMMATION',
*' HAS BEEN TRUNCATED TO THE ',I2,' TH PLANE')
55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT',
*'AVAILABLE >>>>>>>>>>')
56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X,
*'MEAN FREE PATH = ',F6.3,' * A',//)
57 FORMAT(25X,'CLUSTER RADIUS = ',F6.3,' *A')
58 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',I10,/,10
&X,' EFFECTIVE NUMBER OF PATHS : ',I10, /,10X,' MI
&NIMAL INTENSITY : ',E12.6,2X,'No OF THE PATH : ',I10,
& /,10X,' MAXIMAL INTENSITY : ',E12.6,
& 2X,'No OF THE PATH : ',I10)
59 FORMAT(//,15X,'THE SCATTERING DIRECTION IS GIVEN INSIDE ',
*'THE CRYSTAL')
60 FORMAT(7X,'THE POSITIONS OF THE ATOMS ARE GIVEN WITH RESPECT ',
*'TO THE ABSORBER')
61 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6.
&3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI
&GHT ', ' : (',F6.3,',',F6.3,',',F6.3,
& ')',/,16X,'DIRECTION OF THE POLARIZATION : (
&', F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZER.LIGHT ','
& : ',F7.4)
63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6.
&3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI
&GHT ', ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZE
&R.LIGHT : ',F7.4)
65 FORMAT(////,3X,'++++++++++++++++++',9X,
*'THETA = ',F6.2,' DEGREES',9X,'++++++++',
*'++++++++++',///)
66 FORMAT(////,3X,'++++++++++++++++++',9X,
*'PHI = ',F6.2,' DEGREES',9X,'++++++++++',
*'++++++++++',///)
67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
68 FORMAT(10X,' CUT-OFF INTENSITY : ',E12.6)
69 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X))
70 FORMAT(2X,I2,2X,I10,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
71 FORMAT(//,1X,'JDIF',4X,'No OF THE PATH',2X,'INTENSITY',3X,'LENGTH'
&,4X,'ABSORBER',2X,'ORDER OF THE SCATTERERS',/)
72 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1
&2.6,2X,E12.6)
74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ','=====
&>')
76 FORMAT(2X,I2,2X,E12.6,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X))
77 FORMAT(' ')
79 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4)
80 FORMAT(///)
81 FORMAT(//,1X,'RANK',1X,'ORDER',4X,'No PATH',3X,'INTENSITY',3X,'LEN
&GTH',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
Reference in New Issue View Git Blame Copy Permalink