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

Added AED with series expansion.
epsi-builds/msspec_python3/pipeline/head There was a failure building this commit Details 

WIP
This commit is contained in:
Sylvain Tricot 2021-11-30 16:54:04 +01:00
parent 8983368e97
commit e17a4525cc
21 changed files with 7064 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,6 @@
.PHONY: all phd_se phd_mi eig_mi eig_pw comp_curve clean
.PHONY: all phd_se phd_mi aed_se aed_mi eig_mi eig_pw comp_curve clean
all: phd_se phd_mi aed_mi eig_mi eig_pw comp_curve
all: phd_se phd_mi aed_se aed_mi eig_mi eig_pw comp_curve
phd_se:
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk all
@ -8,6 +8,9 @@ phd_se:
phd_mi:
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk all
aed_se:
@+$(MAKE) -f aed_se_mu_noso_nosp_nosym.mk all
aed_mi:
@+$(MAKE) -f aed_mi_mu_noso_nosp_nosym.mk all
@ -23,6 +26,7 @@ comp_curve:
clean::
@+$(MAKE) -f phd_se_noso_nosp_nosym.mk $@
@+$(MAKE) -f phd_mi_noso_nosp_nosym.mk $@
@+$(MAKE) -f aed_se_mu_noso_nosp_nosym.mk $@
@+$(MAKE) -f aed_mi_mu_noso_nosp_nosym.mk $@
@+$(MAKE) -f eig_mi.mk $@
@+$(MAKE) -f eig_pw.mk $@

2
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f
View File

@ -1300,7 +1300,7 @@ C
CST IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1)
IF(ISOM.NE.0) CLOSE(IUO2)
CST STOP
GOTO 999
GOTO 999
C
1 WRITE(IUO1,60)
STOP

11
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym.mk Normal file
View File

@ -0,0 +1,11 @@
memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/allocation.f
cluster_gen_src := $(wildcard cluster_gen/*.f)
common_sub_src := $(wildcard common_sub/*.f)
renormalization_src := $(wildcard renormalization/*.f)
aed_se_mu_noso_nosp_nosym_src := $(wildcard aed_se_mu_noso_nosp_nosym/*.f)
SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(aed_se_mu_noso_nosp_nosym_src)
MAIN_F = aed_se_mu_noso_nosp_nosym/main.f
SO = _aed_se_mu_noso_nosp_nosym.so
include ../../../options.mk

998
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/aeddif_se_mu.f Normal file
View File

@ -0,0 +1,998 @@
C
C=======================================================================
C
SUBROUTINE AEDDIF_SE_MU(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,
1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX)
C
C This subroutine computes the AED formula in the spin-independent case
C from a multiplet resolved initial core state L1. The
C intermediate state that gives its energy is L2 while the
C core hole that is filled in the process is noted LC. The
C multiplet is characterized by the integer angular momentum
C variables (L_MUL,S_MUL,J_MUL)
C
C Alternatively, it can compute the AED 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 : 26 Apr 2013
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_A_MOD, DIRANA => DIRANA_A, ANADIR => ANADIR_A,
& RTHETA => RTHEXT_A, RPHI => RPHI_A,
& THETAR => THETAR_A, PHIR => PHIR_A
USE EXTREM_MOD
USE FIXSCAN_A_MOD, N_FIXED => N_FIXED_A, N_SCAN => N_SCAN_A,
& IPH_1 => IPH_1_A, FIX0 => FIX0_A,
& FIX1 => FIX1_A, SCAN0 => SCAN0_A,
& SCAN1 => SCAN1_A
USE INFILES_MOD
USE INUNITS_MOD
USE INIT_J_MOD
USE INIT_L_MOD
USE INIT_M_MOD
USE LIMAMA_MOD
USE LINLBD_MOD
USE MOYEN_A_MOD, IMOY => IMOY_A, NDIR => NDIR_A,
& ACCEPT => ACCEPT_A, ICHKDIR => ICHKDIR_A
USE OUTFILES_MOD
USE OUTUNITS_MOD
USE PARCAL_A_MOD, NPHI => NPHI_A, NE => NE_A,
& NTHETA => NTHETA_A, NFTHET => NFTHET_A
USE PATH_MOD
USE PRINTP_MOD
USE RESEAU_MOD
USE SPIN_MOD
USE TESTPA_MOD
USE TESTPB_MOD
USE TESTS_MOD
USE TL_AED_MOD, DLT = > DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A,
& IFTHET => IFTHET_A, IMOD => IMOD_A,
& I_CP => I_CP_A, I_EXT => I_EXT_A,
& I_TEST => I_TEST_A
USE TYPEM_MOD
USE TYPEXP_MOD
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
USE VALIN_MOD, P0 => PHI0, T0 => THETA0, TM => THLUM,
& PM => PHILUM, EM => ELUM
C
REAL NPATH1(0:NDIF_M),NOPA
C
COMPLEX IC,ONEC,ZEROC,PW(0:NDIF_M)
COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
COMPLEX YLMR(0:NL_M,-NL_M:NL_M)
COMPLEX YLME(0:NL_M,-NL_M:NL_M)
COMPLEX R2,M_COUL(0:NL_M,-NL_M:NL_M,2,-LI_M:LI_M,2)
COMPLEX SJDIR_1,SJDIF_1
COMPLEX RHOK(0:NT_M,NATM,0:40,2,NSPIN2_M),COU
COMPLEX SLJDIF,ATT_M,SLE_1
COMPLEX SL0DIF,SMJDIF
C
DIMENSION VAL(NATCLU_M),NATYP(NATM)
DIMENSION EMET(3),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
CHARACTER*7 STAT
CHARACTER*24 INFILE
CHARACTER*24 OUTFILE
C
DATA PIS180 /0.017453/
DATA EV,SMALL /13.60583,0.0001/
DATA BOHR /0.529177/
C
ALGO1=' '
ALGO2='SE'
ALGO3=' '
ALGO4=' '
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
I_DIR=0
NSET=1
JEL=2
C
IF(SPECTRO.EQ.'AED') THEN
IOUT=IUO2
OUTFILE=OUTFILE2
STAT='UNKNOWN'
IF(ABS(I_EXT).GE.1) THEN
ISET=IUI6
INFILE=INFILE6
ENDIF
ELSEIF(SPECTRO.EQ.'APC') THEN
IOUT=IUSCR2
OUTFILE='res/auger.amp'
STAT='UNKNOWN'
IF(ABS(I_EXT).GE.1) THEN
ISET=IUI9
INFILE=INFILE9
ENDIF
ENDIF
C
LF1=LE_MIN
LF2=LE_MAX
ISTEP_LF=2
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
WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,
1 IPH_1,I_EXT
ENDIF
C
IF(ISOM.EQ.0) THEN
WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE
ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN
WRITE(IOUT,11) NTHETA,NPHI,NE
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,
1 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)
JTE=IEMET(JEMET)
C
C Loop over the energies
C
DO JE=1,NE
FMIN(0)=1.
FMAX(0)=1.
IF(I_TEST.NE.1) THEN
VKR=REAL(VK(JE))
ELSE
VKR=1.
ENDIF
ECIN=VKR*VKR*BOHR*BOHR*EV/(A*A)+VINT
IF(I_TEST.NE.1) THEN
CFM=2.*VKR
ELSE
CFM=1.
ENDIF
CALL LPM(ECIN,XLPM,*6)
XLPM1=XLPM/A
GAMMA=1./(2.*XLPM1)
IF(IPOTC.EQ.0) THEN
VK(JE)=VK(JE)+IC*GAMMA
ENDIF
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((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_A(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=ISET, FILE=INFILE, STATUS='OLD')
READ(ISET,13) I_DIR,NSET,N_DUM1
READ(ISET,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 LE=LE_MIN,LE_MAX,2
ILE=LE*LE+LE+1
DO ME=-LE,LE
INDE=ILE+ME
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDE,JATL)=ZEROC
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
C
C Storage of the coupling matrix elements M_COUL
C
DO MC=-LI,LI
DO ISC=1,2
SC=FLOAT(ISC)-1.5
DO LA=LE_MIN,LE_MAX,2
DO MA=-LA,LA
DO ISA=1,2
SA=FLOAT(ISA)-1.5
CALL COUMAT_AM(LA,MA,SA,MC,SC,JTE,RHOK,COU)
M_COUL(LA,MA,ISA,MC,ISC)=COU
ENDDO
ENDDO
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_A(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,
1 THMI,PHMI,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 LE=LE_MIN,LE_MAX,2
ILE=LE*LE+LE+1
DO ME=-LE,LE
INDE=ILE+ME
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
TAU(INDJ,INDE,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_A(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,
1 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)/
1 DFLOAT(NSCAT-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),
1 JNEM,(JPON(JPT,KD),KD=1,JON(JPT))
ELSE
WRITE(IUO1,83) JPT,JON(JPT),INT(PATH(JPT)),FMN(JPT),
1 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,
1 (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,
1 (JPA(KD),KD=1,JOPA)
ELSE
WRITE(IUO1,70) JOPA,INT(NOPA),XMAX,DIST0,JNEM,
1 (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),
1 FMAX(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),
1 INT(NPATH2(JD)+0.1),FMIN(JD),
2 INT(NPMI(JD)+0.1),FMAX(JD),
3 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 Auger Electron 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(ISET,86) JSET,JLINE,THD,PHD
IF(I_EXT.EQ.-1) BACKSPACE ISET
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
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(ISET,86) JSET,JLINE,THD,PHD
BACKSPACE ISET
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.
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(ISET,86) JSET,JLINE,THD,PHD,W
DTHETA=THD
DPHI=PHD
RTHETA=DTHETA*PIS180
RPHI=DPHI*PIS180
ELSE
W=1.
ENDIF
C
IF(I_EXT.EQ.-1) PRINT 89
C
CALL DIRAN(VINT,ECIN,JEL)
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
WRITE(IUO1,61) (DIRANA(J,1),J=1,3)
C
SRDIF_1=0.
SRDIR_1=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
SSCDIR_1=0.
SSCDIF_1=0.
C
C Loop over the equiprobable quantum numbers MC,SC and SA
C corresponding respectively to the core hole (MC and spin SC)
C and to the outgoing Auger electron (SA). The sum over the
C equiprobable azimuthal quantum number MJ of the multiplet
C configuration is suppressed here as, because of the selection
C rules, one has MJ = MA + MC + SA + SC
C
LME=LMAX(1,JE)
CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME)
C
DO ISC=1,2
SC=FLOAT(ISC)-1.5
C
SMCDIR_1=0.
SMCDIF_1=0.
C
DO MC=-LI,LI
C
SSADIR_1=0.
SSADIF_1=0.
C
DO ISA=1,2
SA=FLOAT(ISA)-1.5
C
SMJMDIR_1=0.
SMJMDIF_1=0.
C
DO MJM=-J_MUL,J_MUL
C
SJDIR_1=ZEROC
SJDIF_1=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 L_E=LE_MIN,LE_MAX,2
ILE=L_E*L_E+L_E+1
IF(ISPEED.EQ.1) THEN
R2=TL(L_E,1,1,JE)
ELSE
R2=TLT(L_E,1,1,JE)
ENDIF
M_E=MJM-MC-ISA-ISC+3
IF(ABS(M_E).GT.L_E) GOTO 444
INDE=ILE+M_E
SJDIR_1=SJDIR_1+YLME(L_E,M_E)*ATTSE*
1 M_COUL(L_E,M_E,ISA,MC,ISC)*R2
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,INDE,1)
DO M0=1,L0
IND01=IL0+M0
IND02=IL0-M0
SL0DIF=SL0DIF+(YLME(L0,M0)*
1 TAU(IND01,INDE,1)+
2 YLME(L0,-M0)*
3 TAU(IND02,INDE,1))
ENDDO
ENDDO
SJDIF_1=SJDIF_1+SL0DIF*M_COUL(L_E,M_E,ISA,MC,ISC)
444 CONTINUE
ENDDO
SJDIF_1=SJDIF_1*ATTSE
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,
1 LMJ)
IF(IATTS.EQ.1) THEN
ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR))
ENDIF
CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+
1 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)*
1 (DIRANA(3,JDIR)-CTROIS1)/(2.
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_A(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
SLE_1=ZEROC
DO L_E=LE_MIN,LE_MAX,2
ILE=L_E*L_E+L_E+1
M_E=MJM-MC-ISA-ISC+3
IF(ABS(M_E).GT.L_E) GOTO 555
INDE=ILE+M_E
SLJDIF=ZEROC
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDE,JATL)
IF(LJ.GT.0) THEN
DO MJ=1,LJ
INDJ1=ILJ+MJ
INDJ2=ILJ-MJ
SMJDIF=SMJDIF+(YLMR(LJ,MJ)*
1 TAU(INDJ1,INDE,JATL)+
2 YLMR(LJ,-MJ)*
3 TAU(INDJ2,INDE,JATL))
ENDDO
ENDIF
SLJDIF=SLJDIF+SMJDIF
ENDDO
SLE_1=SLE_1+SLJDIF*M_COUL(L_E,M_E,ISA,MC,ISC)
555 CONTINUE
ENDDO
SJDIF_1=SJDIF_1+SLE_1*ATT_M
C
C End of the loops over the last atom J
C
ENDDO
ENDDO
C
C Writing the amplitudes in file IOUT for APECS
C
111 IF(SPECTRO.EQ.'APC') THEN
WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,
1 JDIR,ISC,MC,ISA,MJM,SJDIR_1,
2 SJDIR_1+SJDIF_1
ELSE
C
C Computing the square modulus
C
SSADIF_1=SSADIF_1+CABS(SJDIR_1+SJDIF_1)*
1 CABS(SJDIR_1+SJDIF_1)
SSADIR_1=SSADIR_1+CABS(SJDIR_1)*CABS(SJDIR_1)
C
ENDIF
C
C End of the loop over MJM
C
ENDDO
C
SMJMDIF_1=SMJMDIF_1+SSADIF_1
SMJMDIR_1=SMJMDIR_1+SSADIR_1
C
C End of the loop over SA
C
ENDDO
C
SMCDIF_1=SMCDIF_1+SMJMDIF_1
SMCDIR_1=SMCDIR_1+SMJMDIR_1
C
C End of the loop over MC
C
ENDDO
C
SSCDIF_1=SSCDIF_1+SMCDIF_1
SSCDIR_1=SSCDIR_1+SMCDIR_1
C
C End of the loop over SC
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 220
SRDIR_1=SRDIR_1+SSCDIR_1*VKR*CFM/NDIR
SRDIF_1=SRDIF_1+SSCDIF_1*VKR*CFM/NDIR
220 CONTINUE
C
C End of the loop on the directions of the analyzer
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 221
SSETDIR_1=SSETDIR_1+SRDIR_1*W
SSETDIF_1=SSETDIF_1+SRDIF_1*W
IF(ICHKDIR.EQ.2) THEN
IF(JSET.EQ.JREF) THEN
SSET2DIR_1=SRDIR_1
SSET2DIF_1=SRDIF_1
ENDIF
ENDIF
221 CONTINUE
C
C End of the loop on the set averaging
C
ENDDO
C
IF(SPECTRO.EQ.'APC') GOTO 222
IF(ISOM.EQ.2) THEN
WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,
1 SSETDIR_1,SSETDIF_1
IF(ICHKDIR.EQ.2) THEN
WRITE(IUO2,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,
1 SSET2DIR_1,SSET2DIF_1
ENDIF
ELSE
WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,
1 SSETDIR_1,SSETDIF_1
IF(ICHKDIR.EQ.2) THEN
WRITE(IUO2,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,
1 SSET2DIR_1,SSET2DIF_1
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(ISET)
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(ISET)
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_AED(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)
13 FORMAT(6X,I1,1X,I3,2X,I4)
14 FORMAT(6X,I1,1X,I3,3X,I3)
22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,
1 25X,' 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 ',
1'THE ABSORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X,
2'******* ',19X,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******')
53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1,
1 /,10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1,
2 /,10X,' MINIMAL INTENSITY : ',E12.6,
3 2X,'No OF THE PATH : ',F15.1,
4 /,10X,' MAXIMAL INTENSITY : ',E12.6,
5 2X,'No OF THE 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,
1 /,10X,' EFFECTIVE NUMBER OF PATHS : ',I10,
2 /,10X,' MINIMAL INTENSITY : ',E12.6,
3 2X,'No OF THE PATH : ',I10,
4 /,10X,' MAXIMAL INTENSITY : ',E12.6,
5 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 : (',
1 F6.3,',',F6.3,',',F6.3,') ..........')
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,
1 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,
1 'INTENSITY',3X,'LENGTH',4X,'ABSORBER',2X,
2 'ORDER OF THE SCATTERERS',/)
74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ',
1 '=====>')
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,
1 'INTENSITY',3X,'LENGTH',4X,'ABS',3X,
2 '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',
1 ' ORDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ',
2 'OF A)')
85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ',
1 /,24X,'(THE LENGTH 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,I2,2X,I2,2X,I2,
1 2X,I2,2X,I2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =',
1 F6.2)
89 FORMAT(/,4X,'..........................................',
1 '.....................................')
C
7 RETURN
C
END

140
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/coumat_am.f Normal file
View File

@ -0,0 +1,140 @@
C
C=======================================================================
C
SUBROUTINE COUMAT_AM(LA,MA,SA,MC,SC,JE,RHOK_A,MATRIX_AM)
C
C This routine calculates the multiplet-resolved spin-independent
C Coulomb matrix elements occuring in the Auger process. They
C are stored in MATRIX_AM. The multiplet component is characterized
C by the quantum numbers (L,S,J) which are read from the input
C data file.
C
C Here, the conventions are (direct process D):
C
C (LC,MC) : core hole filled by intermediate electron
C (L1,M1) : Auger electron before excitation
C (L2,M2) : intermediate electron that fills the core hole
C (LA,MA) : Auger electron after excitation
C
C In the exchange process E, the roles of (L1,M1) and (L2,M2)
C are interchanged.
C
C Note that the Clebsch-Gordan corresponding to the spin-orbit
C resolved core state is not included in the formula here. This
C is because in APECS, it appears also in the dipole matrix
C element and it is therefore useless to calculate it twice.
C Therefore, it must be implemented into the cross-section
C subroutine.
C
C The factor i**LA comes from the particular normalization used
C in the phagen code
C
C Last modified : 8 Dec 2008
C
USE DIM_MOD
C
USE C_G_M_MOD
USE INIT_A_MOD, LC => LI_C, L2 => LI_I, L1 => LI_A
USE TYPCAL_A_MOD, I1 => IPHI_A, I2 => IE_A, I3 => ITHETA_A,
1 I4 => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A,
2 I7 => I_EXT_A, I_TEST => I_TEST_A
USE INIT_M_MOD
C
COMPLEX RHOK_A(0:NT_M,NATM,0:40,2,NSPIN2_M)
COMPLEX ZEROC,ONEC,MATRIX_AM
COMPLEX SUM_LB,SUM_M1,IC,IL
C
REAL*4 CG1(0:N_GAUNT),CG2(0:N_GAUNT)
REAL*4 GNT1(0:N_GAUNT),GNT2(0:N_GAUNT),GNT3(0:N_GAUNT)
REAL*4 GNT4(0:N_GAUNT)
C
REAL*8 ZEROD
C
DATA PI4,ONEOSQ2,HALF /12.566371,0.707107,0.5/
C
ZEROC=(0.,0.)
ONEC=(1.,0.)
IC=(0.,1.)
ZEROD=0.D0
C
IF(I_TEST.EQ.1) GOTO 2
C
IF(MOD(LA,4).EQ.0) THEN
IL=ONEC
ELSEIF(MOD(LA,4).EQ.1) THEN
IL=IC
ELSEIF(MOD(LA,4).EQ.2) THEN
IL=-ONEC
ELSEIF(MOD(LA,4).EQ.3) THEN
IL=-IC
ENDIF
C
IF(I_SHELL.EQ.0) THEN
COEF1=ONEOSQ2*PI4
ELSEIF(I_SHELL.EQ.1) THEN
COEF1=HALF*PI4
ENDIF
C
IF(MOD(S_MUL,2).EQ.0) THEN
SIGN1=1.
ELSE
SIGN1=-1.
ENDIF
C
C Values of MJ, ML and MS given by the Clebsch-Gordan
C
ML=MA+MC
MS=INT(SA+SC+0.0001)
MJ=ML+MS
C
C Storage indices for the spin Clebsch-Gordan :
C
C ISA(C) = 1 for -1/2 and 2 for 1/2
C IS = 1 for S_MUL=0 and 2 for S_MUL=1
C
IS=S_MUL+1
ISA=INT(SA+1.5001)
ISC=INT(SC+1.5001)
C
C Bounds of the sum over LB
C
LB_MAX_D=MIN(L1+LA,L2+LC)
LB_MIN_D=MAX(ABS(L1-LA),ABS(L2-LC))
LB_MAX_E=MIN(L2+LA,L1+LC)
LB_MIN_E=MAX(ABS(L2-LA),ABS(L1-LC))
LB_MIN=MIN(LB_MIN_D,LB_MIN_E)
LB_MAX=MAX(LB_MAX_D,LB_MAX_E)
C
N_CG=2
CALL N_J(DFLOAT(L_MUL),DFLOAT(ML),DFLOAT(S_MUL),DFLOAT(MS),
1 ZEROD,CG1,I_INT1,N_CG)
C
SUM_M1=ZEROC
DO M1=-L1,L1
M2=ML-M1
C
CALL N_J(DFLOAT(L1),DFLOAT(M1),DFLOAT(L2),DFLOAT(ML-M1),
1 ZEROD,CG2,I_INT2,N_CG)
CALL GAUNT(L1,M1,LA,MA,GNT1)
CALL GAUNT(LC,MC,L2,M2,GNT2)
CALL GAUNT(L2,M2,LA,MA,GNT3)
CALL GAUNT(LC,MC,L1,M1,GNT4)
C
SUM_LB=ZEROC
DO LB=LB_MIN,LB_MAX
SUM_LB=SUM_LB+(RHOK_A(LA,JE,LB,1,1)*GNT1(LB)*GNT2(LB)+
1 RHOK_A(LA,JE,LB,2,1)*GNT3(LB)*GNT4(LB)*
2 SIGN1)/FLOAT(LB+LB+1)
ENDDO
SUM_M1=SUM_M1+SUM_LB*CG2(L_MUL)
ENDDO
C
MATRIX_AM=SUM_M1*CG1(J_MUL)*CG_S(ISA,ISC,IS)*COEF1*IL
C
GOTO 1
C
2 MATRIX_AM=ONEC
C
1 RETURN
C
END

88
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/dwsph_a.f Normal file
View File

@ -0,0 +1,88 @@
C
C=======================================================================
C
SUBROUTINE DWSPH_A(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 TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, VK2 =>
& VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
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

115
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif1_a.f Normal file
View File

@ -0,0 +1,115 @@
C
C=======================================================================
C
SUBROUTINE FACDIF1_A(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,
1 FSPH,JAT,JE,*)
C
C This routine computes a spherical wave scattering factor
C
C Last modified : 03/04/2006
C
USE DIM_MOD
C
USE APPROX_MOD
USE EXPFAC_MOD
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE TYPCAL_A_MOD, I2 => IPHI_A, I3 => IE_A, I4 => ITHETA_A,
& IFTHET => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A,
& I7 => I_EXT_A, I8 => I_TEST_A
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
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

28
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif_a.f Normal file
View File

@ -0,0 +1,28 @@
C
C=======================================================================
C
SUBROUTINE FACDIF_A(COSTH,JAT,JE,FTHETA)
C
C This routine computes the plane wave scattering factor
C
USE DIM_MOD
C
USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
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

369
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths1_a.f Normal file
View File

@ -0,0 +1,369 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 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 : 31 Jul 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 TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
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
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,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)+
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.
1 (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.
1 -2.*COSTHMIJ)
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_A(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_A(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))
1 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_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,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)+
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.
1 (COSTHIJK.LT.-SMALL)) THEN
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.))
1 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.
1 -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_A(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_A(COSTHIJK,JPOS(ND-1,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))
1 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_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS2_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths2_a.f Normal file
View File

@ -0,0 +1,370 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS2_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 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 : 31 Jul 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 TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
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
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,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)+
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.
1 (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.
1 -2.*COSTHMIJ)
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_A(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_A(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))
1 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_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,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)+
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.
1 (COSTHIJK.LT.-SMALL)) THEN
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.))
1 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.
1 -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_A(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_A(COSTHIJK,JPOS(ND-1,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))
1 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_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS3_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths3_a.f Normal file
View File

@ -0,0 +1,370 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS3_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 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 : 31 Jul 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 TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
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
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,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)+
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.
1 (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.
1 -2.*COSTHMIJ)
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_A(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_A(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))
1 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_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,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)+
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.
1 (COSTHIJK.LT.-SMALL)) THEN
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.))
1 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.
1 -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_A(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_A(COSTHIJK,JPOS(ND-1,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))
1 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_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS4_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths4_a.f Normal file
View File

@ -0,0 +1,370 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS4_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 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 : 31 Jul 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 TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
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
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,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)+
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.
1 (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.
1 -2.*COSTHMIJ)
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_A(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_A(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))
1 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_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,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)+
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.
1 (COSTHIJK.LT.-SMALL)) THEN
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.))
1 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.
1 -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_A(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_A(COSTHIJK,JPOS(ND-1,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))
1 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_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
CALL FINDPATHS5_A(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,
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

370
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths5_a.f Normal file
View File

@ -0,0 +1,370 @@
C
C=======================================================================
C
SUBROUTINE FINDPATHS5_A(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,
1 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 : 31 Jul 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 TL_AED_MOD, DLT => DLT_A,TL => TL_A, VK => VK_A, VK2 => VK2_A,
& IPOTC => IPOTC_A, ITL => ITL_A, LMAX => LMAX_A
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
COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK
COMPLEX IC,COMPL1,PW(0:NDIF_M)
COMPLEX TAU(LINMAXA,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)+
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.
1 (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.
1 -2.*COSTHMIJ)
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_A(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_A(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))
1 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_A(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,
1 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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,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)+
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.
1 (COSTHIJK.LT.-SMALL)) THEN
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.))
1 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.
1 -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_A(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_A(COSTHIJK,JPOS(ND-1,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))
1 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_A(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,
1 ISPHER,AIJK,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_A(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,
1 THJK,PHIJK,FREF,IJ,DIJ,TAU)
NPATH2(ND)=NPATH2(ND)+1.
ENDIF
ENDIF
IF(ND.EQ.NDIF) GOTO 32
c CALL FINDPATHS_A(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

21
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main.f Normal file
View File

@ -0,0 +1,21 @@
SUBROUTINE RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
& NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
& NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
& N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
USE DIM_MOD
IMPLICIT INTEGER (A-Z)
CF2PY INTEGER, INTENT(IN,COPY) :: NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_
CF2PY INTEGER, INTENT(IN,COPY) :: NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_
CF2PY INTEGER, INTENT(IN,COPY) :: NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_
CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_
CALL ALLOCATION(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_,
& NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_,
& NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_,
& N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_)
CALL MAIN_AED_MU_SE()
CALL CLOSE_ALL_FILES()
END SUBROUTINE RUN

1669
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main_aed_mu_se.f Normal file
View File

File diff suppressed because it is too large Load Diff

349
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/matdif_a.f Normal file
View File

@ -0,0 +1,349 @@
C
C=======================================================================
C
SUBROUTINE MATDIF_A(NO,ND,LF,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,
1 A21,B21,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). It is more
C specifically designed for the Auger electron.
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 TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
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)*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(0,0,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 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*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU2+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*
1 TLT(L,1,JTYP,JE)*HLM1(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*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*
1 TLT(L,1,JTYP,JE)*HLM1(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)*
1 HLM1(NU1,L)*HLM2(MU2+NU2,L)
ELSE
SL=FLOAT(L+L+1)*C1*TLT(L,1,JTYP,JE)*
1 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*
1 ONEOVK*SIG2
F21(1,LAMBDA2_2,LAMBDA1_1,ND)=SL_2_1*PROD1
1 *ONEOVK/PROD2
F21(1,LAMBDA2_1,LAMBDA1_2,ND)=SL_2_1*ONEOVK*PROD2*SIG2/
1 PROD1
F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL_2_2*ONEOVK/
1 (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)*
1 TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*
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
1 *TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST1
1 *TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(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
1 *TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST2
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
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
1 *TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(MU+NU2,L)
ELSE
SL=SL+FLOAT(L+L+1)*CST2
1 *TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(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

551
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/pathop_a.f Normal file
View File

@ -0,0 +1,551 @@
C
C=======================================================================
C
SUBROUTINE PATHOP_A(JPOS,JORDP,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,
1 PHIIJ,FREF,IJ,D,TAU)
C
C This subroutine calculates the contribution of a given path to
C the scattering path operator TAU. It is designed for the Auger
C electron
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 TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A,
& VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A,
& LMAX => LMAX_A
USE VARIA_MOD
C
INTEGER JPOS(NDIF_M,3),AMU1
C
REAL RLMIJ(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1)
C
COMPLEX TAU(LINMAXA,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
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)*
1 F(1,LAMBDA3,LAMBDA2,JPAT)
ELSE
SUM_1=SUM_1+F(1,LAMBDA2,LAMBDA1,1)*
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)*
1 RLMIJ(MUJ,0,LJ)
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
C
ENDDO
C
ENDDO
C
TAU(ILJ,ILF,JATL)=TAU(ILJ,ILF,JATL)+
1 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)=
1 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)*
1 RLMIJ(MUJ,-MJ,LJ)
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*
1 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
C
ENDDO
C
ENDDO
C
TAU(INDJP,ILF,JATL)=TAU(INDJP,ILF,JATL)+
1 CONJG(CJ)*TL_J*SUM_NU1_1
TAU(INDJ,ILF,JATL)=TAU(INDJ,ILF,JATL)+
1 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)=
1 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)*
1 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)+
1 CF*TL_J*
2 SUM_NU1_0
TAU(ILJ,INDFP,JATL)=TAU(ILJ,INDFP,JATL)+
1 CONJG(CF)*TL_J*
2 SUM_NU1_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)=
1 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)*
1 RLMIJ(MUJ,-MJ,LJ)
SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*
1 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)+
1 CF*CONJG(CJ)*TL_J*SUM_NU1_1
TAU(INDJP,INDFP,JATL)=TAU(INDJP,INDFP,JATL)+
1 CONJG(CF*CJ)*TL_J*SUM_NU1_3
TAU(INDJ,INDF,JATL)=TAU(INDJ,INDF,JATL)+
1 CF*CJ*TL_J*SUM_NU1_0
TAU(INDJ,INDFP,JATL)=TAU(INDJ,INDFP,JATL)+
1 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)=
1 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

106
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/plotfd_a.f Normal file
View File

@ -0,0 +1,106 @@
C
C=======================================================================
C
SUBROUTINE PLOTFD_A(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 PARCAL_A_MOD, N3 => NPHI_A, N4 => NE_A, N5 => NTHETA_A,
& NFTHET => NFTHET_A
USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A,
& IFTHET => IFTHET_A, IMOD => IMOD_A,
& I_CP => I_CP_A, I_EXT => I_EXT_A,
& I_TEST => I_TEST_A
USE VALIN_MOD, PHI00 => PHI0, THETA00 => THETA0, U1 => THLUM,
& U2 => PHILUM, U3 => ELUM, N7 => NONVOL
USE VALFIN_MOD, PHI11 => PHI1, THETA11 => THETA1
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
C
DIMENSION LMX(NATM,NE_M)
C
COMPLEX FSPH,VKE
C
DATA PI,CONV/3.141593,0.512314/
C
OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN')
IF(ISPHER.EQ.0) THEN
L=0
LMAX=0
ELSE
LMAX=L
ENDIF
PHITOT=360.
THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI
NPHI=(NFTHET+1)*IPHI+(1-IPHI)
NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+
* (1-ITHETA)
NE=NFTHET*IE + (1-IE)
WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN
DO 10 JT=1,NTHT
DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1))
RTHETA=DTHETA*PI/180.
TEST=SIN(RTHETA)
IF(TEST.GE.0.) THEN
POZ=PI
EPS=1.
ELSE
POZ=0.
EPS=-1.
ENDIF
BETA=RTHETA*EPS
IF(ABS(TEST).LT.0.0001) THEN
NPHIM=1
ELSE
NPHIM=NPHI
ENDIF
DO 20 JP=1,NPHIM
DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1))
RPHI=DPHI*PI/180.
GAMMA=POZ-RPHI
DO 30 JE=1,NE
IF(NE.EQ.1) THEN
ECIN=E0
ELSE
ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1)
ENDIF
IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.)
DO 40 JAT=1,NAT
IF(L.GT.LMX(JAT,JE)) GOTO 90
DO 50 M=-LMAX,LMAX
CALL FACDIF1_A(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,
1 FSPH,JAT,JE,*60)
GOTO 70
60 WRITE(IUO1,80)
STOP
70 REFTH=REAL(FSPH)
XIMFTH=AIMAG(FSPH)
WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN
50 CONTINUE
GOTO 40
90 WRITE(IUO1,100) JAT
STOP
40 CONTINUE
30 CONTINUE
20 CONTINUE
10 CONTINUE
CLOSE(IUO3)
1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2)
5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,
1 1X,F6.2,1X,F8.2)
80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ',
1 'IS ZERO >>>>>')
100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',
1 ' : ',I2,' >>>>>')
C
RETURN
C
END

791
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/treat_aed.f Normal file
View File

@ -0,0 +1,791 @@
C
C=======================================================================
C
SUBROUTINE TREAT_AED(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
C
USE OUTUNITS_MOD
USE TYPEXP_MOD, DUMMY => SPECTRO
USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A,
& PHI1 => PHI1_A, THETA1 => THETA1_A
USE VALIN_MOD, P0 => PHI0, T0 => THETA0
USE VALFIN_MOD, P1 => PHI1, T1 => THETA1
C
PARAMETER(N_HEAD=5000,N_FILES=1000)
C
CHARACTER*3 SPECTRO
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
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,
1 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)/
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)*
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 +
1 (JEMET-1)*NE*N_FIXED*N_SCAN +
2 (JE-1)*N_FIXED*N_SCAN +
3 (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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
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),
1 ECIN(JE),TAB(JLIN2,1),TAB(JLIN2,2),
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 +
1 (JEMET-1)*NE*NTHETA*NPHI +
2 (JE-1)*NTHETA*NPHI +
3 (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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 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),
1 VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR2_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)/
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)*
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 +
1 (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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
2 TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
1 DPHI(JPHI2),ECIN(JE),
2 TAB(JLIN2,1),TAB(JLIN2,2),
3 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),
1 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),
1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2),
2 TAB(JLIN,3),TAB(JLIN,4)
IF(I_EXT.EQ.-1) THEN
JLIN2=NTT+JLIN
READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),
1 DPHI(JPHI2),ECIN(JE),
2 TAB(JLIN2,1),TAB(JLIN2,2),
3 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 +
1 (JTHETA-1)*NPHI + JPHI
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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 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),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),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),
1 VOLDIR_1,VOLDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),VOLDIR2_1,VOLDIF2_1
ENDIF
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),TOTDIR2_1,TOTDIF2_1
ENDIF
ELSE
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),VOLDIR2_1,VOLDIF2_1,
3 VOLDIR2_2,VOLDIF2_2
ENDIF
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),
1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),TOTDIR2_1,TOTDIF2_1,
3 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 +
1 (JTHETA-1)*NPHI + JPHI
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),
1 ECIN(JE),SR_1,SF_1
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR2_1,SF2_1
ENDIF
ELSE
WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),SR_1,SF_1,SR_2,SF_2
IF(I_EXT.EQ.-1) THEN
WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),
1 ECIN(JE),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,
1 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 ',
1 'IN THE TREAT_AED SUBROUTINE - INCREASE NDIM_M ',
2 '>>>>>>>>>>')
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,
1 2X,E12.6,2X,E12.6,2X,E12.6)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,
1 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 ',
1 'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,
2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6,
3 ' >>>>>>>>>>')
38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ',
1 'IN THE INCLUDE FILE >>>>>>>>>>',/,8X,
2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6,
3 ' >>>>>>>>>>')
888 FORMAT(A72)
C
6 RETURN
C
END

335
src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/weight_sum.f Normal file
View File

@ -0,0 +1,335 @@
C
C=======================================================================
C
SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL)
C
C This subroutine performs a weighted sum of the results
C corresponding to different directions of the detector.
C The directions and weights are read from an external input file
C
C JEL is the electron undetected (i.e. for which the outgoing
C directions are integrated over the unit sphere). It is always
C 1 for one electron spectroscopies (PHD). For APECS, It can be
C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron
C detected)
C
C Last modified : 31 Jan 2007
C
USE DIM_MOD
USE INFILES_MOD
USE INUNITS_MOD
USE OUTUNITS_MOD
C
C
PARAMETER(N_MAX=5810,NPM=20)
C
REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M)
REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX)
REAL*4 SR_1,SF_1,SR_2,SF_2
REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX)
REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX)
C
CHARACTER*3 SPECTRO,SPECTRO2
CHARACTER*5 LIKE
CHARACTER*13 OUTDATA
C
C
C
C
DATA JVOL,JTOT/0,-1/
DATA LIKE /'-like'/
C
REWIND IUO2
C
READ(IUO2,15) SPECTRO,OUTDATA
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
SPECTRO2='XAS'
ELSE
READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I
&THETA_A,IE_A
READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM
READ(IUO2,8) NPHI_A,NTHETA_A
IF(JEL.EQ.1) THEN
SPECTRO2='AED'
ELSEIF(JEL.EQ.2) THEN
SPECTRO2='PHD'
ELSEIF(JEL.EQ.0) THEN
SPECTRO2='XAS'
ENDIF
ENDIF
C
IF(NPLAN.GT.NPM) THEN
WRITE(IUO1,4) NPLAN+2
STOP
ENDIF
C
C Reading the number of angular points
C
IF(SPECTRO.NE.'APC') THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
N_POINTS_A=1
ELSE
IF(JEL.EQ.1) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
IF(I_EXT_A.EQ.0) THEN
N_POINTS_A=NTHETA_A*NPHI_A
ELSE
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,1) N_POINTS_A
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
ENDIF
NTHETA0=NTHETA_A
NPHI0=NPHI_A
ELSEIF(JEL.EQ.2) THEN
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI9,1) N_POINTS_A
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
IF(I_EXT.EQ.0) THEN
N_POINTS=NTHETA*NPHI
ELSE
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
ENDIF
NTHETA0=NTHETA
NPHI0=NPHI
ELSEIF(JEL.EQ.0) THEN
OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD')
OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD')
READ(IUI6,1) N_POINTS
READ(IUI9,1) N_POINTS_A
READ(IUI6,5) I_DIM,N_DUM1,N_DUM2
READ(IUI9,5) I_DIM,N_DUM1,N_DUM2
ENDIF
ENDIF
C
IF(SPECTRO.NE.'APC') THEN
NANGLE=1
ELSE
IF(JEL.EQ.1) THEN
NANGLE=N_POINTS_A
ELSEIF(JEL.EQ.2) THEN
NANGLE=N_POINTS
ELSEIF(JEL.EQ.0) THEN
NANGLE=1
ENDIF
ENDIF
C
C Initialization of the arrays
C
DO JE=1,NE
DO JANGLE=1,NANGLE
DO JPLAN=1,NPLAN+2
SUMR_1(JPLAN,JE,JANGLE)=0.
SUMF_1(JPLAN,JE,JANGLE)=0.
IF(IDICHR.GT.0) THEN
SUMR_2(JPLAN,JE,JANGLE)=0.
SUMF_2(JPLAN,JE,JANGLE)=0.
ENDIF
ENDDO
ENDDO
ENDDO
C
C Reading of the data to be angle integrated
C
DO JE=1,NE
C
DO JANGLE=1,N_POINTS
IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE)
DO JANGLE_A=1,N_POINTS_A
IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN
READ(IUI9,2) THA,PHA,W_A(JANGLE_A)
ENDIF
C
DO JPLAN=1,NPLAN+2
C
IF(IDICHR.EQ.0) THEN
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE)
&,SR_1,SF_1
ELSE
READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1
ENDIF
ELSE
IF(SPECTRO.NE.'APC') THEN
READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),SR_1,SF_1,SR_2,SF_2
ELSE
READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE
&),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2
ENDIF
ENDIF
C
IF(JEL.EQ.1) THEN
SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1
&*W(JANGLE)
SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1
&*W(JANGLE)
ELSEIF(JEL.EQ.2) THEN
SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A
&(JANGLE_A)
SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A
&(JANGLE_A)
ELSEIF(JEL.EQ.0) THEN
SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A
&(JANGLE_A)
SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A
&(JANGLE_A)
ENDIF
IF(IDICHR.GT.0) THEN
IF(JEL.EQ.1) THEN
SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR
&_2*W(JANGLE)
SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF
&_2*W(JANGLE)
ELSEIF(JEL.EQ.2) THEN
SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W
&_A(JANGLE_A)
SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W
&_A(JANGLE_A)
ELSEIF(JEL.EQ.0) THEN
SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W
&_A(JANGLE_A)
SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W
&_A(JANGLE_A)
ENDIF
ENDIF
C
ENDDO
C
ENDDO
IF(I_EXT_A.NE.0) THEN
REWIND IUI9
READ(IUI9,1) NDUM
READ(IUI9,1) NDUM
ENDIF
ENDDO
C
IF(I_EXT.NE.0) THEN
REWIND IUI6
READ(IUI6,1) NDUM
READ(IUI6,1) NDUM
ENDIF
ENDDO
C
CLOSE(IUI6)
CLOSE(IUI9)
REWIND IUO2
C
WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP
WRITE(IUO2,18) NE,NPLAN,ISOM
ELSEIF(JEL.EQ.1) THEN
WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A
&,ITHETA_A,IE_A
WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
ELSEIF(JEL.EQ.2) THEN
WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE
WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM
ENDIF
C
DO JE=1,NE
DO JANGLE=1,NANGLE
IF(SPECTRO.EQ.'APC') THEN
IF(JEL.EQ.1) THEN
THETA=DTHETAA(JANGLE)
PHI=DPHIA(JANGLE)
ELSEIF(JEL.EQ.2) THEN
THETA=DTHETA(JANGLE)
PHI=DPHI(JANGLE)
ENDIF
ENDIF
C
DO JPLAN=1,NPLAN
IF(IDICHR.EQ.0) THEN
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
&MF_1(JPLAN,JE,JANGLE)
ELSE
WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
&JANGLE),SUMF_1(JPLAN,JE,JANGLE)
ENDIF
ELSE
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU
&MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG
&LE)
ELSE
WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE,
&JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL
&AN,JE,JANGLE)
ENDIF
ENDIF
ENDDO
C
IF(IDICHR.EQ.0) THEN
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
&F_1(NPLAN+1,JE,JANGLE)
WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
&F_1(NPLAN+2,JE,JANGLE)
ELSE
WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
&ANGLE),SUMF_1(NPLAN+1,JE,JANGLE)
WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
&ANGLE),SUMF_1(NPLAN+2,JE,JANGLE)
ENDIF
ELSE
IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN
WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM
&F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE
&,JANGLE)
WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM
&F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE
&,JANGLE)
ELSE
WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J
&ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(
&NPLAN+1,JE,JANGLE)
WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J
&ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(
&NPLAN+2,JE,JANGLE)
ENDIF
ENDIF
C
ENDDO
ENDDO
C
1 FORMAT(13X,I4)
2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6)
3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN
&THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>')
5 FORMAT(6X,I1,1X,I3,3X,I3)
8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
9 FORMAT(9(2X,I1),2X,I2)
13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
&12.6)
15 FORMAT(2X,A3,11X,A13)
16 FORMAT(2X,A3,A5,1X,A3,2X,A13)
18 FORMAT(I4,2X,I3,2X,I1)
19 FORMAT(4(2X,I1))
20 FORMAT(8(2X,I1))
21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1)
23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E
&12.6,2X,E12.6,2X,E12.6)
33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6)
34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6)
43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6)
44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X
&,E12.6)
C
RETURN
C
END

12
tests/aed/test.py
View File

@ -14,7 +14,7 @@ do_ped = False
# Define a Rocksalt Factory class (to tetragonalize the unit cell)
class RocksaltFactory(SimpleTetragonalFactory):
bravais_basis = [[0, 0, 0], [0.5, 0.5, 0], [0.5, 0, 0.5], [0, 0.5, 0.5],
bravais_basis = [[0, 0, 0], [0.5, 0.5, 0], [0.5, 0, 0.5], [0, 0.5, 0.5],
[0, 0, 0.5], [0.5, 0, 0], [0, 0.5, 0], [0.5, 0.5, 0.5]]
element_basis = (0, 0, 0, 0, 1, 1, 1, 1)
Rocksalt = RocksaltFactory()
@ -22,8 +22,8 @@ Rocksalt = RocksaltFactory()
a0 = 4.09
a_perp = 4.25
MgO = Rocksalt(('Mg', 'O'),
latticeconstant={'a': a0, 'c/a': a_perp/a0},
MgO = Rocksalt(('Mg', 'O'),
latticeconstant={'a': a0, 'c/a': a_perp/a0},
size=(1,1,1))
@ -58,7 +58,7 @@ calc.tmatrix_parameters.lmax_mode = 'true_ke'
calc.source_parameters.energy = XRaySource.AL_KALPHA
calc.source_parameters.theta = -55.
calc.source_parameters.phi = -55.
calc.source_parameters.phi = 0
calc.detector_parameters.angular_acceptance = 2.
calc.detector_parameters.average_sampling = 'high'
@ -72,11 +72,11 @@ calc.calculation_parameters.vibration_scaling = 3.
if do_ped:
calc.muffintin_parameters.interstitial_potential = 14
data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5),
data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5),
level='2p',
kinetic_energy=1200)
else:
data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5),
data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5),
edge='KL2L2', multiplet='1D2',
kinetic_energy=1200)