From e17a4525cc734cbde6ec5d63cec40038ac2de930 Mon Sep 17 00:00:00 2001 From: Sylvain Tricot Date: Tue, 30 Nov 2021 16:54:04 +0100 Subject: [PATCH] Added AED with series expansion. WIP --- src/msspec/spec/fortran/Makefile | 8 +- .../main_aed_mu_mi.f | 2 +- .../spec/fortran/aed_se_mu_noso_nosp_nosym.mk | 11 + .../aed_se_mu_noso_nosp_nosym/aeddif_se_mu.f | 998 ++++++++++ .../aed_se_mu_noso_nosp_nosym/coumat_am.f | 140 ++ .../aed_se_mu_noso_nosp_nosym/dwsph_a.f | 88 + .../aed_se_mu_noso_nosp_nosym/facdif1_a.f | 115 ++ .../aed_se_mu_noso_nosp_nosym/facdif_a.f | 28 + .../aed_se_mu_noso_nosp_nosym/findpaths1_a.f | 369 ++++ .../aed_se_mu_noso_nosp_nosym/findpaths2_a.f | 370 ++++ .../aed_se_mu_noso_nosp_nosym/findpaths3_a.f | 370 ++++ .../aed_se_mu_noso_nosp_nosym/findpaths4_a.f | 370 ++++ .../aed_se_mu_noso_nosp_nosym/findpaths5_a.f | 370 ++++ .../fortran/aed_se_mu_noso_nosp_nosym/main.f | 21 + .../main_aed_mu_se.f | 1669 +++++++++++++++++ .../aed_se_mu_noso_nosp_nosym/matdif_a.f | 349 ++++ .../aed_se_mu_noso_nosp_nosym/pathop_a.f | 551 ++++++ .../aed_se_mu_noso_nosp_nosym/plotfd_a.f | 106 ++ .../aed_se_mu_noso_nosp_nosym/treat_aed.f | 791 ++++++++ .../aed_se_mu_noso_nosp_nosym/weight_sum.f | 335 ++++ tests/aed/test.py | 12 +- 21 files changed, 7064 insertions(+), 9 deletions(-) create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym.mk create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/aeddif_se_mu.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/coumat_am.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/dwsph_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif1_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths1_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths2_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths3_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths4_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths5_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main_aed_mu_se.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/matdif_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/pathop_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/plotfd_a.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/treat_aed.f create mode 100644 src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/weight_sum.f diff --git a/src/msspec/spec/fortran/Makefile b/src/msspec/spec/fortran/Makefile index 58e1f29..2d0079b 100644 --- a/src/msspec/spec/fortran/Makefile +++ b/src/msspec/spec/fortran/Makefile @@ -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 $@ diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f index 5bde10b..ab8fad6 100644 --- a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym.mk b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym.mk new file mode 100644 index 0000000..dca1f6a --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym.mk @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/aeddif_se_mu.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/aeddif_se_mu.f new file mode 100644 index 0000000..71ede85 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/aeddif_se_mu.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/coumat_am.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/coumat_am.f new file mode 100644 index 0000000..59d0cb9 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/coumat_am.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/dwsph_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/dwsph_a.f new file mode 100644 index 0000000..eaa8118 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/dwsph_a.f @@ -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 + diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif1_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif1_a.f new file mode 100644 index 0000000..174cdce --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif1_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif_a.f new file mode 100644 index 0000000..4f38377 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/facdif_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths1_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths1_a.f new file mode 100644 index 0000000..baa632e --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths1_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths2_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths2_a.f new file mode 100644 index 0000000..c4e4af2 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths2_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths3_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths3_a.f new file mode 100644 index 0000000..77a4aee --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths3_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths4_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths4_a.f new file mode 100644 index 0000000..0867934 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths4_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths5_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths5_a.f new file mode 100644 index 0000000..8f7ce9d --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/findpaths5_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main.f new file mode 100644 index 0000000..e5993ba --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main_aed_mu_se.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main_aed_mu_se.f new file mode 100644 index 0000000..e521506 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/main_aed_mu_se.f @@ -0,0 +1,1669 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * AUGER ELECTRON DIFFRACTION CODE * * +C * * BASED ON SERIES EXPANSION * * +C * * * * +C * ******************************************************** * +C ************************************************************ +C +C +C +C +C Written by D. Sebilleau, Groupe Theorie, +C Departement Materiaux-Nanosciences, +C Institut de Physique de Rennes, +C UMR CNRS-Universite 6251, +C Universite de Rennes-1, +C 35042 Rennes-Cedex, +C France +C +C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada +C +C----------------------------------------------------------------------- +C +C As a general rule in this code, although there might be a few +C exceptions (...), a variable whose name starts with a 'I' is a +C switch, with a 'J' is a loop index and with a 'N' is a number. +C +C The main subroutines are : +C +C * PHDDIF : computes the photoelectron diffraction +C formula +C +C * LEDDIF : computes the low-energy electron +C diffraction formula +C +C * XASDIF : computes the EXAFS or XANES formula +C depending on the energy +C +C * AEDDIF : computes the Auger electron diffraction +C formula +C +C * FINDPATHS : generates the multiple scattering +C paths the electron will follow +C +C * PATHOP : calculates the contribution of a given +C path to the scattering path operator +C +C * MATDIF : computes the Rehr-Albers scattering +C matrices +C +C A subroutine called NAME_A is the Auger equivalent of subroutine +C NAME. The essentail difference between NAME and NAME_A is that +C they do not contain the same arrays. +C +C Always remember, when changing the input data file, to keep the +C format. The rule here is that the last digit of any integer or +C character data must correspond to the tab (+) while for real data, +C the tab precedes the point. +C +C Do not forget, before submitting a calculation, to check the +C consistency of the input data with the corresponding maximal +C values in the include file. +C +C----------------------------------------------------------------------- +C +C Please report any bug or problem to me at : +C +C didier.sebilleau@univ-rennes1.fr +C +C +C +C Last modified : 10 Jan 2016 +C +C======================================================================= +C + SUBROUTINE MAIN_AED_MU_SE() +C +C This routine reads the various input files and calls the subroutine +C performing the requested calculation +C + USE DIM_MOD +C + USE ADSORB_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE CLUSLIM_MOD + USE COOR_MOD + USE DEBWAL_MOD + USE INDAT_MOD + USE INIT_A_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE INIT_M_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE LIMAMA_MOD + USE LPMOY_MOD + USE MASSAT_MOD + USE MILLER_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TL_AED_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE XMRHO_MOD +C + DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3) + DIMENSION ROT(3,3),EMET(3) + DIMENSION VAL2(NATCLU_M) + DIMENSION IRE(NATCLU_M,2) + DIMENSION REL(NATCLU_M),RHOT(NATM) + DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M) + DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM) + DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M) + DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M) + DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM) +C + COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR +C + INTEGER INV(2) +C + CHARACTER RIEN + CHARACTER*1 B + CHARACTER*2 R + CHARACTER*30 TUNIT,DUMMY +C + DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/ + DATA INV /0,0/ +C + LE_MAX=0 +C +CST READ(*,776) NFICHLEC +CST READ(*,776) ICOM +CST DO JF=1,NFICHLEC +CST READ(*,777) INDATA(JF) +CST ENDDO +C +C.......... Loop on the data files .......... +C + NFICHLEC=1 + ICOM=5 + DO JFICH=1,NFICHLEC +CST OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD') + OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD') + CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504, + 1 *520,*540,*550,*570,*580,*590,*630) +C +C.......... Atomic case index .......... +C + I_AT=0 + IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1 + IF(SPECTRO.EQ.'APC') THEN + IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1 + ENDIF +C + IF(IBAS.EQ.1) THEN + IF(ITEST.EQ.0) THEN + NEQ=(2*NIV+1)**3 + ELSE + NEQ=(2*NIV+3)**3 + ENDIF + IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518 + ENDIF +C + IF(SPECTRO.EQ.'APC') THEN + N_EL=2 + ELSE + N_EL=1 + ENDIF + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN +c IF(I_MULT.EQ.0) THEN + LE_MIN=ABS(LI_C-ABS(LI_I-LI_A)) + LE_MAX=LI_C+LI_A+LI_I +c ELSE +c LE_MIN=ABS(LI_C-L_MUL) +c LE_MAX=LI_C+L_MUL +c ENDIF + ENDIF +C +C.......... Test of the dimensions against the input values .......... +C + IF(NO.GT.NO_ST_M) GOTO 600 + IF(LE_MAX.GT.LI_M) GOTO 620 +C + OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD') + OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD') + IF(INTERACT.EQ.'DIPCOUL') THEN + OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD') + OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD') + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (dipolar excitation or no excitation case) .......... +C + IF(INTERACT.NE.'COULOMB') THEN + IF(SPECTRO.EQ.'APC') WRITE(IUO1,418) + READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE + IF(ISPIN.EQ.0) THEN + IF(NAT1.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1 + ENDIF + ENDIF + IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IUI2,530) E_MIN,E_MAX,DE + ENDIF + IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN + NLG=INT(NAT1-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1 + READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX. Waiting for a version of PHAGEN +C with LMAX dependent on the energy +C + DO JE=1,NE + DO JAT=1,NAT1 + LMAX(JAT,JE)=LMAX(JAT,1) + ENDDO + ENDDO +C + NL1=1 + DO JAT=1,NAT1 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + ENDIF + IF(ITL.EQ.0) READ(IUI3,101) NATR,NER + IF(ISPIN.EQ.1) THEN + READ(IUI3,106) L_IN,NATR,NER + IF(LI.NE.L_IN) GOTO 606 + ENDIF + NAT2=NAT+NATA + IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180 + IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL.EQ.0) THEN + DO JAT=1,NAT2 + IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + ENDIF + DO JE=1,NE + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121 + READ(IUI3,103) ENERGIE + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + 121 CONTINUE + DO L=0,LMAX(JAT,JE) + READ(IUI2,7) VK(JE),TL(L,1,JAT,JE) + TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,1.)* + 1 TL(L,1,JAT,JE)) + ENDDO + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5 + DO LL=1,18 + READ(IUI3,104) RH1,RH2,DEF1,DEF2 + RHOR(JE,JAT,LL,1,1)=CMPLX(RH1) + RHOR(JE,JAT,LL,2,1)=CMPLX(RH2) + DLT(JE,JAT,LL,1)=CMPLX(DEF1) + DLT(JE,JAT,LL,2)=CMPLX(DEF2) + ENDDO + 5 CONTINUE + ENDDO + ENDDO + ELSE +C +C.......... TL and RHOR calculated by PHAGEN .......... +C + DO JE=1,NE + NLG=INT(NAT2-0.0001)/4 +1 + IF(NE.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2 + READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL) + ENDDO + NL1=1 + DO JAT=1,NAT2 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + DO JAT=1,NAT2 + READ(IUI2,*) DUMMY + DO L=0,LMAX(JAT,JE) + IF(LMAX_MODE.EQ.0) THEN + READ(IUI2,9) VK(JE),TLSTAR + ELSE + READ(IUI2,9) VK(JE),TLSTAR + ENDIF + TL(L,1,JAT,JE)=CONJG(TLSTAR) + VK(JE)=CONJG(VK(JE)) + ENDDO + ENDDO +C + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333 + IF(JE.EQ.1) THEN + DO JDUM=1,7 + READ(IUI3,102) RIEN + ENDDO + ENDIF + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + ENDDO + 333 VK(JE)=VK(JE)*A + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDDO + ENDIF +C + CLOSE(IUI2) + CLOSE(IUI3) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN + CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL) + ENDIF + + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (Coulomb excitation case) .......... +C + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN + IERR=0 + IF(INTERACT.EQ.'COULOMB') THEN + IRD1=IUI2 + IRD2=IUI3 + ELSEIF(INTERACT.EQ.'DIPCOUL') THEN + IRD1=IUI7 + IRD2=IUI8 + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,419) + READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A + IF(ISPIN.EQ.0) THEN + IF(NAT1_A.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1_A + ENDIF + ENDIF + IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A + ENDIF + IF(ITL_A.EQ.1) THEN + READ(IRD2,107) LI_C2,LI_I2,LI_A2 + READ(IRD2,117) LE_MIN1,N_CHANNEL + LE_MAX1=LE_MIN1+N_CHANNEL-1 + IF(I_TEST_A.NE.1) THEN + IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO 610 + ELSE + LI_C2=0 + LI_I2=1 + LI_A2=0 + LE_MIN1=1 + N_CHANNEL=1 + ENDIF + ENDIF + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN + NLG=INT(NAT1_A-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1_A + READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX_A. Waiting for a version of PHAGEN +C with LMAX_A dependent on the energy +C + DO JE=1,NE1_A + DO JAT=1,NAT1_A + LMAX_A(JAT,JE)=LMAX_A(JAT,1) + ENDDO + ENDDO +C + NL1_A=1 + DO JAT=1,NAT1_A + NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1) + ENDDO + IF(NL1_A.GT.NL_M) GOTO 184 + ENDIF + IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A + IF(ISPIN.EQ.1) THEN + READ(IRD2,106) L_IN_A,NATR_A,NER_A + IF(LI_C.NE.L_IN_A) GOTO 606 + ENDIF + NAT2_A=NAT+NATA + NAT2=NAT2_A + IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180 + IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) + 1 GOTO 182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL_A.EQ.0) THEN + CONTINUE + ELSE +C +C.......... TL_A and RHOR_A calculated by PHAGEN .......... +C + DO JE=1,NE_A + NLG=INT(NAT2_A-0.0001)/4 +1 + IF(NE_A.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2_A + READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL) + ENDDO + DO JAT=1,NAT2_A + READ(IRD1,*) DUMMY + DO L=0,LMAX_A(JAT,JE) + IF(LMAX_MODE_A.EQ.0) THEN + READ(IRD1,9) VK_A(JE),TLSTAR + ELSE +CST READ(IRD1,7) VK_A(JE),TLSTAR + READ(IRD1,9) VK_A(JE),TLSTAR + ENDIF + TL_A(L,1,JAT,JE)=CONJG(TLSTAR) + VK_A(JE)=CONJG(VK_A(JE)) + ENDDO + ENDDO +C + IF(IFTHET_A.EQ.1) GOTO 331 + DO LE=LE_MIN,LE_MAX + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IRD2,109) L_E,LB_MIN,LB_MAX + IF(I_TEST_A.EQ.1) THEN + L_E=1 + LB_MIN=0 + LB_MAX=1 + ENDIF + IF(LE.NE.L_E) IERR=1 + L_BOUNDS(L_E,1)=LB_MIN + L_BOUNDS(L_E,2)=LB_MAX + DO LB=LB_MIN,LB_MAX + READ(IRD2,108) L_A,RAD_D,RAD_E + RHOR_A(LE,JM,L_A,1,1)=RAD_D + RHOR_A(LE,JM,L_A,2,1)=RAD_E + IF(I_TEST_A.EQ.1) THEN + IF(LB.EQ.LB_MIN) THEN + RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0) + ELSEIF(LB.EQ.LB_MAX) THEN + RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + 331 VK_A(JE)=VK_A(JE)*A + VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE)) + ENDDO + ENDIF +C + CLOSE(IRD1) + CLOSE(IRD2) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN + CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL) + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,420) +C + ENDIF +C +C.......... Check of the consistency of the two TL and radial .......... +C.......... matrix elements for APECS .......... +C + IF(SPECTRO.EQ.'APC') THEN +C + I_TL_FILE=0 + I_RD_FILE=0 +C + IF(NAT1.NE.NAT1_A) I_TL_FILE=1 + IF(NE1.NE.NE1_A) I_TL_FILE=1 + IF(ITL.NE.ITL_A) I_TL_FILE=1 + IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1 +C + IF(LI_C.NE.LI_C2) I_RD_FILE=1 + IF(LI_I.NE.LI_I2) I_RD_FILE=1 + IF(LI_A.NE.LI_A2) I_RD_FILE=1 +C + IF(I_TL_FILE.EQ.1) GOTO 608 + IF(I_RD_FILE.EQ.1) GOTO 610 + IF(IERR.EQ.1) GOTO 610 +C + ENDIF +C +C.......... Calculation of the scattering factor (only) .......... +C + IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8 + IF(IFTHET.EQ.1) THEN +c CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE) + ELSEIF(IFTHET_A.EQ.1) THEN + CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A) + ENDIF + WRITE(IUO1,57) +CST STOP + GOTO 999 +C + 8 IF(IBAS.EQ.0) THEN +C +C............... Reading of an external cluster ............... +C +C +C Cluster originating from CLUSTER_NEW.F : IPHA=0 +C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems) +C Other cluster : the first line must be text; then +C free format : Atomic number,X,Y,Z,number +C of the corresponding prototypical atom ; +C All atoms corresponding to the same +C prototypical atom must follow each other. +C Moreover, the blocks of equivalent atoms +C must be ordered by increasing number of +C prototypical atom. +C + VALZ_MIN=1000.0 + VALZ_MAX=-1000.0 +C + OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD') + READ(IUI4,778,ERR=892) IPHA + GOTO 893 + 892 IPHA=3 + IF(UNIT.EQ.'ANG') THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + ELSEIF(UNIT.EQ.'LPU') THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(UNIT.EQ.'ATU') THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + ELSE + GOTO 890 + ENDIF + 893 NATCLU=0 + DO JAT=1,NAT2 + NATYP(JAT)=0 + ENDDO + IF(IPHA.EQ.0) THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(IPHA.EQ.1) THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + IEMET(1)=1 + ELSEIF(IPHA.EQ.2) THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + IEMET(1)=1 + ENDIF + IF(IPRINT.EQ.2) THEN + IF(I_AT.NE.1) THEN + WRITE(IUO1,558) IUI4,TUNIT + IF(IPHA.EQ.3) WRITE(IUO1,549) + ENDIF + ENDIF + JATM=0 + DO JLINE=1,10000 + IF(IPHA.EQ.0) THEN + READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.1) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.2) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.3) THEN + READ(IUI4,*,END=780) NN,X,Y,Z,JAT + ENDIF + JATM=MAX0(JAT,JATM) + NATCLU=NATCLU+1 + IF(IPHA.NE.3) THEN + CHEM(JAT)=R + ELSE + CHEM(JAT)='XX' + ENDIF + NZAT(JAT)=NN + NATYP(JAT)=NATYP(JAT)+1 + COORD(1,NATCLU)=X*CUNIT + COORD(2,NATCLU)=Y*CUNIT + COORD(3,NATCLU)=Z*CUNIT + VALZ(NATCLU)=Z*CUNIT + IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,NATCLU), + 1 COORD(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT) + ENDIF + ENDDO + 780 NBZ=NATCLU + IF(JATM.NE.NAT) GOTO 514 + CLOSE(IUI4) +C + IF(NATCLU.GT.NATCLU_M) GOTO 510 + DO JA1=1,NATCLU + DO JA2=1,NATCLU + DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2 + 1 +(COORD(2,JA1)-COORD(2,JA2))**2 + 2 +(COORD(3,JA1)-COORD(3,JA2))**2) + IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO 895 + ENDDO + ENDDO +C + D_UP=VALZ_MAX-VALZ(1) + D_DO=VALZ(1)-VALZ_MIN + IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN + I_INV=1 + ELSE + I_INV=0 + ENDIF + ELSE +C +C............... Construction of an internal cluster ............... +C + CALL BASE + CALL ROTBAS(ROT) + IF(IVG0.EQ.2) THEN + NMAX=NIV+1 + ELSE + NMAX=(2*NIV+1)**3 + ENDIF + IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN + WRITE(IUO1,37) + WRITE(IUO1,38) NIV + DO NUM=1,NMAX + CALL NUMAT(NUM,NIV,IA,IB,IC) + WRITE(IUO1,17) NUM,IA,IB,IC + ENDDO + WRITE(IUO1,39) + ENDIF + CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT, + 1 IRE,NATYP,NBZ,NAT2,NCOUCH,NMAX) + IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN + CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL, + 1 NCOUCH) + IF(IREL.EQ.1) THEN + DO JP=1,NPLAN + VAL(JP)=VAL2(JP) + ENDDO + ENDIF + ENDIF + ENDIF +C +C Storage of the extremal values of x and y for each plane. They define +C the exterior of the cluster when a new cluster has to be build to +C support a point-group +C + IF(I_GR.GE.1) THEN + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + WRITE(IUO1,29) K,VAL(K) + X_MAX(K)=0. + X_MIN(K)=0. + Y_MAX(K)=0. + Y_MIN(K)=0. + ENDDO + ENDIF + DO JAT=1,NATCLU + X=COORD(1,JAT) + Y=COORD(2,JAT) + Z=COORD(3,JAT) + DO JPLAN=1,NPLAN + IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN + X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN)) + X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN)) + Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN)) + Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN)) + ENDIF + ENDDO + ENDDO + ENDIF +C +C Instead of the symmetrization of the cluster (this version only) +C + N_PROT=NAT + NAT_ST=0 + DO JTYP=1,JATM + NB_AT=NATYP(JTYP) + IF(NB_AT.GT.NAT_EQ_M) GOTO 614 + DO JA=1,NB_AT + NAT_ST=NAT_ST+1 + NCORR(JA,JTYP)=NAT_ST + ENDDO + ENDDO + DO JC=1,3 + DO JA=1,NATCLU + SYM_AT(JC,JA)=COORD(JC,JA) + ENDDO + ENDDO +C +C Checking surface-like atoms for mean square displacements +C calculations +C + CALL CHECK_VIB(NAT2) +C +C.......... Set up of the variables used for an internal .......... +C.......... calculation of the mean free path and/or of .......... +C.......... the mean square displacements .......... +C + IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN + DO JTYP=1,NAT2 + XMT(JTYP)=XMAT(NZAT(JTYP)) + RHOT(JTYP)=RHOAT(NZAT(JTYP)) + ENDDO + XMTA=XMT(1) + RHOTA=RHOT(1) + NZA=NZAT(1) + ENDIF + IF(IDCM.GT.0) THEN + CALL CHNOT(3,VECBAS,VEC) + DO J=1,3 + VB1(J)=VEC(J,1) + VB2(J)=VEC(J,2) + VB3(J)=VEC(J,3) + ENDDO + CPR=1. + CALL PRVECT(VB2,VB3,VBS,CPR) + VM=PRSCAL(VB1,VBS) + QD=(6.*PI*PI*NAT/VM)**(1./3.) + ENDIF +C +C.......... Writing of the contents of the cluster, .......... +C.......... of the position of the different planes .......... +C.......... and of their respective absorbers in .......... +C.......... the control file IUO1 .......... +C + IF(I_AT.EQ.1) GOTO 153 + IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN + WRITE(IUO1,40) + NCA=0 + DO J=1,NAT + DO I=1,NMAX + NCA=NCA+1 + WRITE(IUO1,20) J,I + WRITE(IUO1,21) (ATOME(L,NCA),L=1,3) + K=IRE(NCA,1) + IF(K.EQ.0) THEN + WRITE(IUO1,22) + ELSE + WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2) + ENDIF + ENDDO + ENDDO + WRITE(IUO1,41) + ENDIF + IF(IBAS.EQ.1) THEN + WRITE(IUO1,24) + NATCLU=0 + DO I=1,NAT + NN=NATYP(I) + NATCLU=NATCLU+NATYP(I) + WRITE(IUO1,26) NN,I + ENDDO + IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3 + WRITE(IUO1,782) NATCLU + IF(NATCLU.GT.NATCLU_M) GOTO 516 + IF(IPRINT.EQ.3) WRITE(IUO1,559) + IF(IPRINT.EQ.3) THEN + NBTA=0 + DO JT=1,NAT2 + NBJT=NATYP(JT) + DO JN=1,NBJT + NBTA=NBTA+1 + WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA), + 1 COORD(3,NBTA),JT,JN,CHEM(JT) + ENDDO + ENDDO + ENDIF + ENDIF + 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN + CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) + ENDIF + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) + ENDDO + ENDIF +C + IF(I_AT.EQ.0) WRITE(IUO1,30) + IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,31) (IEMET(J),J=1,NEMET) + ENDIF + ZEM=1.E+20 + DO L=1,NPLAN + Z=VAL(L) + DO JEMED=1,NEMET + CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93) + IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET(3) + IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3) + GO TO 33 + 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM + 33 CONTINUE + ENDDO + ENDDO +C +C.......... Loop on the electrons involved in the .......... +C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... +C.......... LEED or AED and N_EL = 2 for APC .......... +C + DO J_EL=1,N_EL +C +C.......... Writing the information on the spectroscopies .......... +C.......... in the control file IUO1 .......... +C + IF(SPECTRO.EQ.'XAS') GOTO 566 + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,236) + ELSE + WRITE(IUO1,248) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,245) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF +C +C---------- Photoelectron diffraction case (PHD) ---------- +C + IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,35) + ELSE + WRITE(IUO1,246) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,44) + IF(IE.EQ.1) WRITE(IUO1,58) + IF(INITL.EQ.0) WRITE(IUO1,118) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + WRITE(IUO1,418) + WRITE(IUO1,18) + ENDIF + IF(J_EL.EQ.2) GOTO 222 + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + IF(INITL.NE.0) THEN + WRITE(IUO1,337) + WRITE(IUO1,91) + IF(IPOL.EQ.0) THEN + WRITE(IUO1,88) + ELSEIF(ABS(IPOL).EQ.1) THEN + WRITE(IUO1,87) + ELSEIF(IPOL.EQ.2) THEN + WRITE(IUO1,89) + ENDIF + WRITE(IUO1,91) + IF(IDICHR.GT.0) THEN + WRITE(IUO1,338) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,90) + WRITE(IUO1,43) THLUM,PHILUM + IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF + ENDIF +C + IF(INITL.EQ.2) THEN + WRITE(IUO1,79) LI,LI-1,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,1,1), + 1 RHOR(JE,JTE,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1), + 1 DLT(JE,JTE,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.-1) THEN + WRITE(IUO1,82) LI,LI-1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,1,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,1) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.1) THEN + WRITE(IUO1,82) LI,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + 222 CONTINUE + ENDIF +C +C---------- LEED case (LED) ---------- +C + IF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,252) + ELSE + WRITE(IUO1,258) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,254) + IF(IE.EQ.1) WRITE(IUO1,256) + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,260) + WRITE(IUO1,261) THLUM,PHILUM + IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF +C +C---------- Auger diffraction case (AED) ---------- +C + IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,235) + ELSE + WRITE(IUO1,247) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,244) + IF(I_TEST_A.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN + WRITE(IUO1,419) + WRITE(IUO1,18) + ENDIF + IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC_A.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,95) AUGER + CALL AUGER_MULT + IF(I_MULT.EQ.0) THEN + WRITE(IUO1,154) + ELSE + WRITE(IUO1,155) MULTIPLET + ENDIF +C + DO JEM=1,NEMET + JTE=IEMET(JEM) + WRITE(IUO1,112) JTE + DO LE=LE_MIN,LE_MAX + WRITE(IUO1,119) LE + LA_MIN=L_BOUNDS(LE,1) + LA_MAX=L_BOUNDS(LE,2) + DO LA=LA_MIN,LA_MAX + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,115) LA,RHOR_A(LE,JTE,LA,1,1), + 1 RHOR_A(LE,JTE,LA,2,1) + ENDIF + ENDDO + ENDDO + ENDDO +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF + ENDIF +C +C.......... Check of the dimensioning of the treatment routine .......... +C + CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A, + 1 NPHI,NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C.......... Call of the subroutine performing either .......... +C.......... the PhD, LEED, AED, EXAFS or APECS calculation .......... +C + 566 IF(ISPIN.EQ.0) THEN + IF(SPECTRO.EQ.'PHD') THEN +c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'LED') THEN +c CALL LEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'AED') THEN + CALL AEDDIF_SE_MU(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP, + 1 RHOR_A,NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) + ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'APC') THEN +c IF(J_EL.EQ.1) THEN +c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(J_EL.EQ.2) THEN +c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, +c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) +c ENDIF + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF(SPECTRO.EQ.'PHD') THEN +c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(SPECTRO.EQ.'AED') THEN +c CALL AEDDIF_SP +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_SP +c ENDIF + continue + ENDIF +C +C.......... End of the MS calculation : .......... +C.......... direct exit or treatment of the results .......... +C +C +C.......... End of the loop on the electrons .......... +C + ENDDO +C + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,52) + ELSE + WRITE(IUO1,249) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,49) + IF(IE.EQ.1) WRITE(IUO1,59) + ELSEIF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,253) + ELSE + WRITE(IUO1,259) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,255) + IF(IE.EQ.1) WRITE(IUO1,257) + ELSEIF(SPECTRO.EQ.'XAS') THEN + WRITE(IUO1,51) + ELSEIF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,237) + ELSE + WRITE(IUO1,250) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,238) + ELSEIF(SPECTRO.EQ.'APC') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,239) + ELSE + WRITE(IUO1,251) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,240) + ENDIF +C + CLOSE(ICOM) + IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN + WRITE(IUO1,562) + ENDIF + IF(ISOM.EQ.0) CLOSE(IUO2) +CST IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1) +C +C.......... End of the loop on the data files .......... +C + ENDDO +C + IF(ISOM.NE.0) THEN + JFF=1 + IF(ISPIN.EQ.0) THEN + IF(SPECTRO.NE.'XAS') THEN + CALL TREAT_AED(ISOM,NFICHLEC,JFF,NP) + ELSE +c CALL TREAT_XAS(ISOM,NFICHLEC,NP) + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP) +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP) +c ENDIF + continue + ENDIF + ENDIF +C +CST IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) +CST STOP + GOTO 999 +C + 1 WRITE(IUO1,60) + STOP + 2 WRITE(IUO1,61) + STOP + 55 WRITE(IUO1,65) + STOP + 56 WRITE(IUO1,64) + STOP + 74 WRITE(IUO1,75) + STOP + 99 WRITE(IUO1,100) + STOP + 180 WRITE(IUO1,181) + STOP + 182 WRITE(IUO1,183) + STOP + 184 WRITE(IUO1,185) + STOP + 504 WRITE(IUO1,505) + STOP + 510 WRITE(IUO1,511) IUI4 + STOP + 514 WRITE(IUO1,515) + STOP + 516 WRITE(IUO1,517) + STOP + 518 WRITE(IUO1,519) + WRITE(IUO1,889) + STOP + 520 WRITE(IUO1,521) + STOP + 540 WRITE(IUO1,541) + STOP + 550 WRITE(IUO1,551) + STOP + 570 WRITE(IUO1,571) + STOP + 580 WRITE(IUO1,581) + STOP + 590 WRITE(IUO1,591) + STOP + 600 WRITE(IUO1,601) + STOP + 602 WRITE(IUO1,603) + STOP + 604 WRITE(IUO1,605) + STOP + 606 WRITE(IUO1,607) + STOP + 608 WRITE(IUO1,609) + STOP + 610 WRITE(IUO1,611) + STOP + 614 WRITE(IUO1,615) NB_AT + STOP + 620 WRITE(IUO1,621) LE_MAX + STOP + 630 WRITE(IUO1,631) + STOP + 890 WRITE(IUO1,891) + STOP + 895 WRITE(IUO1,896) JA1,JA2 +C + 3 FORMAT(5(5X,I4)) + 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) +CST 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) + 9 FORMAT(3X,F9.4,1X,F9.4,E18.6,E18.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ', + 1': (',I3,',',I3,',',I3,')') + 18 FORMAT(' ',/) + 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5) + 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',', + 1 F7.3,',',F7.3,')') + 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER') + 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',', + 1 F7.3,',',F7.3,')',5X,'NEW NUMBER : ',I4) + 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/) + 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2) + 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3) + 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/) + 31 FORMAT(38X,10(I2,3X),//) + 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', + 1I2,' IS POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', + 1'OF THE EXAFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', + 1' NUMBERING OF THE ATOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + 1'++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', + 1' CONTENTS OF THE REDUCED CLUSTER ======================', + 2 ///) + 41 FORMAT(///,'====================================================', + 1'============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ', + 1 F6.2,' DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', + 1'OF THE POLAR PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ', + 1 'THE NORMAL TO THE SURFACE)') + 49 FORMAT(/////,'########## END OF THE ', + 1'POLAR PHOTOELECTRON DIFFRACTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', + 1'EXAFS CALCULATION ##########') + 52 FORMAT(/////,'########## END OF THE ', + 1'AZIMUTHAL PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####') + 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE') + 58 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FINE STRUCTURE OSCILLATIONS CALCULATION #####', + 2'#####',/////) + 59 FORMAT(/////,'########## END OF THE ', + 1'FINE STRUCTURE OSCILLATIONS CALCULATION #####', + 2'#####') + 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,', + 1 'NEMET_M) - CHECK THE DIMENSIONING >>>>>>>>>>') + 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', + 1' >>>>>>>>>>') + 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ', + 1'CLUSTER HAS NOT CONVERGED YET >>>>>>>>>>') + 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ', + 1'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>') + 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ', + 1'IN MAIN ET READ_DATA >>>>>>>>>>') + 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ', + 1I1,',',I1,/) + 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ', + 1 A3,')',//) + 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)') + 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1) + 83 FORMAT(//,32X,'(SPHERICAL WAVES)') + 84 FORMAT(//,34X,'(PLANE WAVES)') + 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)') + 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)') + 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +') + 88 FORMAT(24X,'+ NON POLARIZED LIGHT +') + 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +') + 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/) + 91 FORMAT(24X,'+',35X,'+') + 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++') + 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, + 1' IS PRESENT IN THIS PLANE') + 95 FORMAT(////,31X,'AUGER LINE :',A6,//) + 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1, + 1 ')') + 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ', + 1 I1,')') + 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE', + 1 ' >>>>>>>>>>') + 101 FORMAT(24X,I3,24X,I3) + 102 FORMAT(A1) + 103 FORMAT(31X,F7.2) + 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5) + 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5, + 1 2X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) + 106 FORMAT(12X,I3,12X,I3,12X,I3) + 107 FORMAT(5X,I2,5X,I2,5X,I2) + 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 109 FORMAT(5X,I2,12X,I2,11X,I2) + 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + 1 ' :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//) + 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ', + 1 I2,' : (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')') + 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ', + 1 I2,' : ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER', + 2 ' ELECTRON)',/, + 2 8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//) + 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ', + * 'TYPE ',I2,' : (',F8.5,',',F8.5,')') + 114 FORMAT(/) + 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X, + 1 '(',F8.5,',',F8.5,')') + 117 FORMAT(12X,I2,5X,I2) + 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/) + 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X, + 1 'EXCHANGE INTEGRAL') + 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ', + 1 'INVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ', + 1 'INVERSION)') + 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4) + 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE', + 1 ' ',/,' ',/,' ') + 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ', + 1 'LINE',' ',/,' ',/,' ') + 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + 1 'AND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + 1 'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ', + 1 'FILE >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ', + 1 'MATRIX ELEMENTS TAKEN INTO ACCOUNT <-----',///) + 235 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 236 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 237 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 238 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 239 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 240 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE PHOTOELECTRON DIFFRACTION CALCULATION ', + 2'##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE AUGER DIFFRACTION CALCULATION ', + 2'##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE APECS DIFFRACTION CALCULATION ', + 2'##########',/////) + 249 FORMAT(/////,'########## END OF THE ', + 1'FULL ANGLE PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####') + 250 FORMAT(/////,'########## END ', + 1'OF THE FULL ANGLE AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 251 FORMAT(/////,'########## END ', + 1'OF THE FULL ANGLE APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL LEED CALCULATION #####', + 2'#####',/////) + 253 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL LEED CALCULATION #####', + 2'#####',/////) + 254 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR LEED CALCULATION #####', + 2'#####',/////) + 255 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR LEED CALCULATION #####', + 2'#####',/////) + 256 FORMAT(/////,5X,'########## BEGINNING ', + 1'OF THE ENERGY LEED CALCULATION #####', + 2'#####',/////) + 257 FORMAT(/////,5X,'########## END ', + 1'OF THE ENERGY LEED CALCULATION #####', + 2'#####',/////) + 258 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE LEED CALCULATION ', + 2'##########',/////) + 259 FORMAT(/////,'########## END OF THE ', + 1'FULL ANGLE LEED CALCULATION #####', + 2'#####') + 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/) + 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ', + 1 F6.2,' DEGREES') + 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +') + 335 FORMAT(24X,'+ STANDARD +') + 336 FORMAT(24X,'+ SPIN-POLARIZED +') + 337 FORMAT(24X,'+ WITH +') + 338 FORMAT(24X,'+ IN DICHROIC MODE +') + 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +') + 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ', + 1 '------------------------') + 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ', + 1 '------------------------') + 420 FORMAT(///,9X,'----------------------------------------------', + 1 '----------------------') + 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ', + 1 '(',F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')') + 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (', + 1 F8.5,',',F8.5,')') + 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ', + 1 'CHECK THE DIMENSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ', + 1 'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2, + 2 ' >>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ', + 1 'NAT IN THE DATA AND CLUSTER FILES >>>>>>>>>>') + 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ', + 1 'IBWD >>>>>>>>>>') + 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT', + 1 ' CONSISTENT WITH THE NUMBER OF ATOMS GENERATED BY THE ', + 2 'CODE >>>>>>>>>>') + 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH', + 1 ' THE VALUE OF LI >>>>>>>>>>') + 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4) + 535 FORMAT(29X,F8.5,1X,F8.5) + 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 543 FORMAT(5X,F12.9,5X,F12.9) + 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X, + 2 'SNo',2X,'SYM',/) + 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 555 FORMAT(4(7X,I2)) + 556 FORMAT(28X,4(I2,5X)) + 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4, + 1 3X,A2) + 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ', + 1 I2,' : ',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)', + 2 10X,'CLASS',1X,'ATOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//, + 1 14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3, + 1 ' PROTOTYPICAL ATOMS : ',//) + 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ', + 1 'PROTOTYPICAL ATOM : ',//) + 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE', + 1 13X,'oooooooooooooooo',///) + 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/) + 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ', + 1 'PHD AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ', + 1 'NOT CONSISTENT WITH THE INPUT DATA FILE >>>>>>>>>>') + 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ', + 1 '>>>>>>>>>>',//) + 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ', + 1 '.inc FILE >>>>>>>>>>',//) + 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ', + 1 '>>>>>>>>>>',//) + 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ', + 1 'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ', + 2 'ELEMENTS FILE >>>>>>>>>>',//) + 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ', + 1 '>>>>>>>>>>',//) + 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ', + 1 'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/, + 2 3X,'<<<<<<<<<< ',17X,'WITH THE INPUT DATA FILE ', + 3 16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ', + 1 ' BE IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ', + 2 'FOR BOTH ELECTRONS IN CLUSTER ROTATION MODE', + 3 ' >>>>>>>>>>',//) + 776 FORMAT(I2) + 777 FORMAT(A24) + 778 FORMAT(30X,I1) + 779 FORMAT(11X,A2,5X,I2,3F10.4,I5) + 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4, + 1 ' ATOMS') + 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE', + 1 ' NATCLU_M >>>>>>>>>>') + 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''', + 1 'UNITS >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE', + 1 ' ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4, + 2 ' AND ',I4,' ARE IDENTICAL >>>>>>>>>>') +C + 999 END diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/matdif_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/matdif_a.f new file mode 100644 index 0000000..65c8398 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/matdif_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/pathop_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/pathop_a.f new file mode 100644 index 0000000..1f3663c --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/pathop_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/plotfd_a.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/plotfd_a.f new file mode 100644 index 0000000..86812f0 --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/plotfd_a.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/treat_aed.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/treat_aed.f new file mode 100644 index 0000000..ec7820e --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/treat_aed.f @@ -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 diff --git a/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/weight_sum.f b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/weight_sum.f new file mode 100644 index 0000000..0db9ffc --- /dev/null +++ b/src/msspec/spec/fortran/aed_se_mu_noso_nosp_nosym/weight_sum.f @@ -0,0 +1,335 @@ +C +C======================================================================= +C + SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL) +C +C This subroutine performs a weighted sum of the results +C corresponding to different directions of the detector. +C The directions and weights are read from an external input file +C +C JEL is the electron undetected (i.e. for which the outgoing +C directions are integrated over the unit sphere). It is always +C 1 for one electron spectroscopies (PHD). For APECS, It can be +C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron +C detected) +C +C Last modified : 31 Jan 2007 +C + USE DIM_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE OUTUNITS_MOD +C +C + PARAMETER(N_MAX=5810,NPM=20) +C + REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M) + REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX) + REAL*4 SR_1,SF_1,SR_2,SF_2 + REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX) + REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX) +C + CHARACTER*3 SPECTRO,SPECTRO2 + CHARACTER*5 LIKE + CHARACTER*13 OUTDATA +C +C +C +C + DATA JVOL,JTOT/0,-1/ + DATA LIKE /'-like'/ +C + REWIND IUO2 +C + READ(IUO2,15) SPECTRO,OUTDATA + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + SPECTRO2='XAS' + ELSE + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I + &THETA_A,IE_A + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + READ(IUO2,8) NPHI_A,NTHETA_A + IF(JEL.EQ.1) THEN + SPECTRO2='AED' + ELSEIF(JEL.EQ.2) THEN + SPECTRO2='PHD' + ELSEIF(JEL.EQ.0) THEN + SPECTRO2='XAS' + ENDIF + ENDIF +C + IF(NPLAN.GT.NPM) THEN + WRITE(IUO1,4) NPLAN+2 + STOP + ENDIF +C +C Reading the number of angular points +C + IF(SPECTRO.NE.'APC') THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + N_POINTS_A=1 + ELSE + IF(JEL.EQ.1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT_A.EQ.0) THEN + N_POINTS_A=NTHETA_A*NPHI_A + ELSE + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA_A + NPHI0=NPHI_A + ELSEIF(JEL.EQ.2) THEN + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT.EQ.0) THEN + N_POINTS=NTHETA*NPHI + ELSE + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA + NPHI0=NPHI + ELSEIF(JEL.EQ.0) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI9,1) N_POINTS_A + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + ENDIF +C + IF(SPECTRO.NE.'APC') THEN + NANGLE=1 + ELSE + IF(JEL.EQ.1) THEN + NANGLE=N_POINTS_A + ELSEIF(JEL.EQ.2) THEN + NANGLE=N_POINTS + ELSEIF(JEL.EQ.0) THEN + NANGLE=1 + ENDIF + ENDIF +C +C Initialization of the arrays +C + DO JE=1,NE + DO JANGLE=1,NANGLE + DO JPLAN=1,NPLAN+2 + SUMR_1(JPLAN,JE,JANGLE)=0. + SUMF_1(JPLAN,JE,JANGLE)=0. + IF(IDICHR.GT.0) THEN + SUMR_2(JPLAN,JE,JANGLE)=0. + SUMF_2(JPLAN,JE,JANGLE)=0. + ENDIF + ENDDO + ENDDO + ENDDO +C +C Reading of the data to be angle integrated +C + DO JE=1,NE +C + DO JANGLE=1,N_POINTS + IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE) + DO JANGLE_A=1,N_POINTS_A + IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN + READ(IUI9,2) THA,PHA,W_A(JANGLE_A) + ENDIF +C + DO JPLAN=1,NPLAN+2 +C + IF(IDICHR.EQ.0) THEN + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE) + &,SR_1,SF_1 + ELSE + READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1 + ENDIF + ELSE + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),SR_1,SF_1,SR_2,SF_2 + ELSE + READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2 + ENDIF + ENDIF +C + IF(JEL.EQ.1) THEN + SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1 + &*W(JANGLE) + SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1 + &*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A + &(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A + &(JANGLE_A) + ENDIF + IF(IDICHR.GT.0) THEN + IF(JEL.EQ.1) THEN + SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR + &_2*W(JANGLE) + SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF + &_2*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W + &_A(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W + &_A(JANGLE_A) + ENDIF + ENDIF +C + ENDDO +C + ENDDO + IF(I_EXT_A.NE.0) THEN + REWIND IUI9 + READ(IUI9,1) NDUM + READ(IUI9,1) NDUM + ENDIF + ENDDO +C + IF(I_EXT.NE.0) THEN + REWIND IUI6 + READ(IUI6,1) NDUM + READ(IUI6,1) NDUM + ENDIF + ENDDO +C + CLOSE(IUI6) + CLOSE(IUI9) + REWIND IUO2 +C + WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP + WRITE(IUO2,18) NE,NPLAN,ISOM + ELSEIF(JEL.EQ.1) THEN + WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A + &,ITHETA_A,IE_A + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ELSEIF(JEL.EQ.2) THEN + WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ENDIF +C + DO JE=1,NE + DO JANGLE=1,NANGLE + IF(SPECTRO.EQ.'APC') THEN + IF(JEL.EQ.1) THEN + THETA=DTHETAA(JANGLE) + PHI=DPHIA(JANGLE) + ELSEIF(JEL.EQ.2) THEN + THETA=DTHETA(JANGLE) + PHI=DPHI(JANGLE) + ENDIF + ENDIF +C + DO JPLAN=1,NPLAN + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE) + ELSE + WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG + &LE) + ELSE + WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL + &AN,JE,JANGLE) + ENDIF + ENDIF + ENDDO +C + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE) + ELSE + WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE + &,JANGLE) + WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE + &,JANGLE) + ELSE + WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2( + &NPLAN+1,JE,JANGLE) + WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2( + &NPLAN+2,JE,JANGLE) + ENDIF + ENDIF +C + ENDDO + ENDDO +C + 1 FORMAT(13X,I4) + 2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6) + 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN + &THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>') + 5 FORMAT(6X,I1,1X,I3,3X,I3) + 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 9 FORMAT(9(2X,I1),2X,I2) + 13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6) + 15 FORMAT(2X,A3,11X,A13) + 16 FORMAT(2X,A3,A5,1X,A3,2X,A13) + 18 FORMAT(I4,2X,I3,2X,I1) + 19 FORMAT(4(2X,I1)) + 20 FORMAT(8(2X,I1)) + 21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) + 24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6,2X,E12.6,2X,E12.6) + 33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6) + 34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6) + 44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) +C + RETURN +C + END diff --git a/tests/aed/test.py b/tests/aed/test.py index ed6a679..641a7fe 100644 --- a/tests/aed/test.py +++ b/tests/aed/test.py @@ -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)