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

Added AED support with Matrix Inversion and test script for AED
epsi-builds/msspec_python3/pipeline/head This commit looks good Details

This commit is contained in:
Sylvain Tricot 2021-10-27 09:38:15 +02:00
parent 369e743197
commit 9f6306675f
14 changed files with 9502 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym.mk Normal file
View File

@ -0,0 +1,12 @@
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_mi_mu_noso_nosp_nosym_src := $(wildcard aed_mi_mu_noso_nosp_nosym/*.f)
aed_mi_mu_noso_nosp_nosym_src := $(filter-out aed_mi_mu_noso_nosp_nosym/lapack_axb.f, $(wildcard aed_mi_mu_noso_nosp_nosym/*.f))
SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(aed_mi_mu_noso_nosp_nosym_src)
MAIN_F = aed_mi_mu_noso_nosp_nosym/main.f
SO = _aed_mi_mu_noso_nosp_nosym.so
include ../../../options.mk

789
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/aeddif_mi_mu.f Normal file
View File

@ -0,0 +1,789 @@
C
C=======================================================================
C
SUBROUTINE AEDDIF_MI_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 matrix inversion for the
C expression of the scattering path operator
C
C The matrix inversion is performed using the LAPACK inversion
C routines for a general complex matrix
C
C Last modified : 26 Apr 2013
C
USE DIM_MOD
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 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 RESEAU_MOD
USE SPIN_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
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='MI'
ALGO3=' '
ALGO4=' '
C
IC=(0.,1.)
ONEC=(1.,0.)
ZEROC=(0.,0.)
NSCAT=NATCLU-1
ATTSE=1.
ATTSJ=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
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)
JATLEM=JNEM
C
C Loop over the energies
C
DO JE=1,NE
FMIN(0)=1.
FMAX(0)=1.
IF(I_TEST.NE.1) THEN
CST VKR=REAL(VK(JE))
VKR=ABS(VK(JE))
ELSE
VKR=1.
ENDIF
CST ECIN=VKR*VKR*BOHR*BOHR*EV/(A*A)+VINT
ECIN=E0_A/(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 Matrix inversion for the calculation of TAU
C
IF(I_TEST.EQ.2) GOTO 666
CALL INV_MAT_MS_A(JE,TAU)
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 output)
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
IF(I_TEST.EQ.2) SJDIF_1=SJDIR_1
WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,
1 JDIR,ISC,MC,ISA,MJM,SJDIR_1,SJDIF_1
ELSE
C
C Computing the square modulus
C
SSADIF_1=SSADIF_1+CABS(SJDIF_1)*CABS(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

198
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/axb_mat_ms_la_a.f Normal file
View File

@ -0,0 +1,198 @@
C
C=======================================================================
C
SUBROUTINE INV_MAT_MS_A(JE,TAU)
C
C This subroutine stores the multiple scattering matrix and computes
C the scattering path operator TAU^{j 0} exactly, without explicitely
C using the inverse matrix.
C
C (Auger electron case)
C
C Last modified : 31 Jul 2007
C
USE DIM_MOD
C
USE COOR_MOD
USE INIT_L_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
C
C PARAMETER(NLTWO=2*NL_M)
C
COMPLEX*16 HL1(0:2*NL_M),SM(LINMAXA*NATCLU_M,LINMAXA*NATCLU_M)
COMPLEX*16 IN(LINMAXA*NATCLU_M,LINMAXA)
COMPLEX*16 SUM_L,ONEC,IC,ZEROC
COMPLEX*16 YLM(0:2*NL_M,-2*NL_M:2*NL_M),TLJ,TLK,EXPKJ
C
COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M)
C
REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ
C
INTEGER IPIV(LINMAXA*NATCLU_M)
C
CHARACTER*1 CH
C
DATA PI /3.1415926535898D0/
C
ONEC=(1.D0,0.D0)
IC=(0.D0,1.D0)
ZEROC=(0.D0,0.D0)
IBESS=3
CH='N'
C
C Construction of the multiple scattering matrix MS = (I-GoT).
C Elements are stored using a linear index LINJ representing
C (J,LJ)
C
JLIN=0
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
XJ=SYM_AT(1,JATL)
YJ=SYM_AT(2,JATL)
ZJ=SYM_AT(3,JATL)
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
TLJ=DCMPLX(TL(LJ,1,JTYP,JE))
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
JLIN=JLIN+1
C
KLIN=0
DO KTYP=1,N_PROT
NBTYPK=NATYP(KTYP)
LMK=LMAX(KTYP,JE)
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
IF(KATL.NE.JATL) THEN
XKJ=DBLE(SYM_AT(1,KATL)-XJ)
YKJ=DBLE(SYM_AT(2,KATL)-YJ)
ZKJ=DBLE(SYM_AT(3,KATL)-ZJ)
RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ)
KRKJ=DBLE(VK(JE))*RKJ
ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*RKJ)
EXPKJ=(XKJ+IC*YKJ)/RKJ
ZDKJ=ZKJ/RKJ
CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,LMJ+LMK)
CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,HL1)
ENDIF
C
DO LK=0,LMK
ILK=LK*LK+LK+1
L_MIN=ABS(LK-LJ)
L_MAX=LK+LJ
TLK=DCMPLX(TL(LK,1,KTYP,JE))
DO MK=-LK,LK
INDK=ILK+MK
KLIN=KLIN+1
SM(KLIN,JLIN)=ZEROC
SUM_L=ZEROC
IF(KATL.NE.JATL) THEN
CALL GAUNT2(LK,MK,LJ,MJ,GNT)
C
DO L=L_MIN,L_MAX,2
M=MJ-MK
IF(ABS(M).LE.L) THEN
SUM_L=SUM_L+(IC**L)*HL1(L)*
1 YLM(L,M)*GNT(L)
ENDIF
ENDDO
SUM_L=SUM_L*ATTKJ*4.D0*PI*IC
ELSE
SUM_L=ZEROC
ENDIF
C
IF(KLIN.EQ.JLIN) THEN
SM(KLIN,JLIN)=ONEC-TLK*SUM_L
IF(JTYP.EQ.1) THEN
IN(KLIN,JLIN)=ONEC
ENDIF
ELSE
SM(KLIN,JLIN)=-TLK*SUM_L
IF(JTYP.EQ.1) THEN
IN(KLIN,JLIN)=ZEROC
ENDIF
ENDIF
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
LW2=(LMAX(1,JE)+1)*(LMAX(1,JE)+1)
C
C Partial inversion of the multiple scattering matrix MS and
C multiplication by T : the LAPACK subroutine performing
C
C A * x = b
C
C is used where b is the block column corresponding to
C the absorber 0 in the identity matrix. x is then TAU^{j 0}.
C
CALL ZGETRF(JLIN,JLIN,SM,LINMAXA*NATCLU_M,IPIV,INFO1)
IF(INFO1.NE.0) THEN
WRITE(6,*) ' ---> INFO1 =',INFO1
ELSE
CALL ZGETRS(CH,JLIN,LW2,SM,LINMAXA*NATCLU_M,IPIV,
1 IN,LINMAXA*NATCLU_M,INFO)
ENDIF
C
C Storage of the Tau matrix
C
JLIN=0
DO JTYP=1,N_PROT
NBTYPJ=NATYP(JTYP)
LMJ=LMAX(JTYP,JE)
DO JNUM=1,NBTYPJ
JATL=NCORR(JNUM,JTYP)
C
DO LJ=0,LMJ
ILJ=LJ*LJ+LJ+1
TLJ=DCMPLX(TL(LJ,1,JTYP,JE))
DO MJ=-LJ,LJ
INDJ=ILJ+MJ
JLIN=JLIN+1
C
KLIN=0
DO KTYP=1,N_PROT
NBTYPK=NATYP(KTYP)
LMK=LMAX(KTYP,JE)
DO KNUM=1,NBTYPK
KATL=NCORR(KNUM,KTYP)
C
DO LK=0,LMK
ILK=LK*LK+LK+1
DO MK=-LK,LK
INDK=ILK+MK
KLIN=KLIN+1
IF((JATL.EQ.1).AND.(LJ.LE.LF2)) THEN
TAU(INDK,INDJ,KATL)=CMPLX(IN(KLIN,JLIN)*TLJ)
ENDIF
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
ENDDO
ENDDO
C
RETURN
C
END

140
src/msspec/spec/fortran/aed_mi_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_mi_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_mi_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_mi_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

5123
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/lapack_axb.f Normal file
View File

File diff suppressed because it is too large Load Diff

21
src/msspec/spec/fortran/aed_mi_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_MI()
CALL CLOSE_ALL_FILES()
END SUBROUTINE RUN

1673
src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f Normal file
View File

File diff suppressed because it is too large Load Diff

106
src/msspec/spec/fortran/aed_mi_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_mi_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_mi_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

83
tests/aed/test.py Normal file
View File

@ -0,0 +1,83 @@
# coding: utf8
import numpy as np
from ase.build import bulk
from ase.lattice.tetragonal import SimpleTetragonalFactory
from msspec.calculator import MSSPEC, XRaySource
from msspec.utils import hemispherical_cluster, get_atom_index
import logging
logging.basicConfig(level=logging.INFO)
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],
[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()
a0 = 4.09
a_perp = 4.25
MgO = Rocksalt(('Mg', 'O'),
latticeconstant={'a': a0, 'c/a': a_perp/a0},
size=(1,1,1))
for atom in MgO:
atom.set('mean_square_vibration', 0.01)
atom.set('forward_angle', 20.)
if atom.symbol == 'Mg':
atom.tag = 1
atom.set('mt_radius', 0.63)
else:
atom.tag = 2
atom.set('mt_radius', 1.415)
#cluster = hemispherical_cluster(MgO, emitter_tag=1, emitter_plane=1, planes=4, diameter=4.5*a0)
cluster = hemispherical_cluster(MgO, emitter_tag=1, emitter_plane=1, planes=2)
cluster.absorber = get_atom_index(cluster, 0, 0, 0)
#cluster.edit()
#exit()
if do_ped:
calc = MSSPEC(spectroscopy='PED', algorithm='inversion')
else:
calc = MSSPEC(spectroscopy='AED', algorithm='inversion')
calc.set_atoms(cluster)
calc.muffintin_parameters.ionicity = {'Mg': 0.1, 'O': -0.1}
calc.tmatrix_parameters.exchange_correlation = 'hedin_lundqvist_complex'
calc.tmatrix_parameters.lmax_mode = 'true_ke'
#calc.tmatrix_parameters.tl_threshold = 1e-6
calc.source_parameters.energy = XRaySource.AL_KALPHA
calc.source_parameters.theta = -55.
calc.source_parameters.phi = -55.
calc.detector_parameters.angular_acceptance = 2.
calc.detector_parameters.average_sampling = 'high'
calc.calculation_parameters.scattering_order = 4
calc.calculation_parameters.RA_cutoff = 2
calc.calculation_parameters.path_filtering = 'forward_scattering'
calc.calculation_parameters.off_cone_events = 1
calc.calculation_parameters.vibrational_damping = 'averaged_tl'
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),
level='2p',
kinetic_energy=1200)
else:
data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5),
edge='KL2L2', multiplet='1D2',
kinetic_energy=1200)
data.save('results.hdf5')