C C C ************************************************************ C * ******************************************************** * C * * * * C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * C * * PHOTOELECTRON DIFFRACTION CODE * * C * * BASED ON SERIES EXPANSION * * C * * * * C * ******************************************************** * C ************************************************************ C C C C C Written by D. Sebilleau, Groupe Theorie, C Departement Materiaux-Nanosciences, C Institut de Physique de Rennes, C UMR CNRS-Universite 6251, C Universite de Rennes-1, C 35042 Rennes-Cedex, C France C C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada C C----------------------------------------------------------------------- C C As a general rule in this code, although there might be a few C exceptions (...), a variable whose name starts with a 'I' is a C switch, with a 'J' is a loop index and with a 'N' is a number. C C The main subroutines are : C C * PHDDIF : computes the photoelectron diffraction C formula C C * LEDDIF : computes the low-energy electron C diffraction formula C C * XASDIF : computes the EXAFS or XANES formula C depending on the energy C C * AEDDIF : computes the Auger electron diffraction C formula C C * FINDPATHS : generates the multiple scattering C paths the electron will follow C C * PATHOP : calculates the contribution of a given C path to the scattering path operator C C * MATDIF : computes the Rehr-Albers scattering C matrices C C A subroutine called NAME_A is the Auger equivalent of subroutine C NAME. The essentail difference between NAME and NAME_A is that C they do not contain the same arrays. C C Always remember, when changing the input data file, to keep the C format. The rule here is that the last digit of any integer or C character data must correspond to the tab (+) while for real data, C the tab precedes the point. C C Do not forget, before submitting a calculation, to check the C consistency of the input data with the corresponding maximal C values in the include file. C C----------------------------------------------------------------------- C C Please report any bug or problem to me at : C C didier.sebilleau@univ-rennes1.fr C C C C Last modified : 10 Jan 2016 C C======================================================================= C SUBROUTINE DO_MAIN() C C This routine reads the various input files and calls the subroutine C performing the requested calculation C USE DIM_MOD C USE ADSORB_MOD USE APPROX_MOD USE ATOMS_MOD USE AUGER_MOD USE BASES_MOD USE CLUSLIM_MOD USE COOR_MOD USE DEBWAL_MOD USE INDAT_MOD USE INIT_A_MOD USE INIT_L_MOD USE INIT_J_MOD USE INIT_M_MOD USE INFILES_MOD USE INUNITS_MOD USE LIMAMA_MOD USE LPMOY_MOD USE MASSAT_MOD USE MILLER_MOD USE OUTUNITS_MOD USE PARCAL_MOD USE PARCAL_A_MOD USE RELADS_MOD USE RELAX_MOD USE RESEAU_MOD USE SPIN_MOD USE TESTS_MOD USE TRANS_MOD USE TL_AED_MOD USE TYPCAL_MOD USE TYPCAL_A_MOD USE TYPEM_MOD USE TYPEXP_MOD USE VALIN_MOD USE XMRHO_MOD C DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3) DIMENSION ROT(3,3),EMET(3) DIMENSION VAL2(NATCLU_M) DIMENSION IRE(NATCLU_M,2) DIMENSION REL(NATCLU_M),RHOT(NATM) DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M) DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM) DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M) DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M) DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM) C COMPLEX TLSTAR COMPLEX RHOR(NE_M,NATM,0:18,5,NSPIN2_M) COMPLEX TLSTAR_A COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E COMPLEX RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHOR5STAR C INTEGER INV(2) C CHARACTER RIEN CHARACTER*1 B CHARACTER*2 R C C C C C C CHARACTER*30 TUNIT,DUMMY C DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/ DATA INV /0,0/ C LE_MAX=0 C C! READ(*,776) NFICHLEC C! READ(*,776) ICOM C! DO JF=1,NFICHLEC C! READ(*,777) INDATA(JF) C! ENDDO C C.......... Loop on the data files .......... C NFICHLEC=1 ICOM = 5 DO JFICH=1,NFICHLEC C! OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD') OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD') CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504,*5 &20,*540,*550,*570,*580,*590,*630) C C.......... Atomic case index .......... C I_AT=0 IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1 IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1 IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1 IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1 IF(SPECTRO.EQ.'APC') THEN IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1 ENDIF C IF(IBAS.EQ.1) THEN IF(ITEST.EQ.0) THEN NEQ=(2*NIV+1)**3 ELSE NEQ=(2*NIV+3)**3 ENDIF IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518 ENDIF C IF(SPECTRO.EQ.'APC') THEN N_EL=2 ELSE N_EL=1 ENDIF IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN IF(I_MULT.EQ.0) THEN LE_MIN=ABS(LI_C-ABS(LI_I-LI_A)) LE_MAX=LI_C+LI_A+LI_I ELSE LE_MIN=ABS(LI_C-L_MUL) LE_MAX=LI_C+L_MUL ENDIF ENDIF C C.......... Test of the dimensions against the input values .......... C IF(NO.GT.NO_ST_M) GOTO 600 IF(LE_MAX.GT.LI_M) GOTO 620 C OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD') OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD') IF(INTERACT.EQ.'DIPCOUL') THEN OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD') OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD') ENDIF C C.......... Reading of the TL and radial matrix elements files .......... C.......... (dipolar excitation or no excitation case) .......... C IF(INTERACT.NE.'COULOMB') THEN IF(SPECTRO.EQ.'APC') WRITE(IUO1,418) READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE IF(ISPIN.EQ.0) THEN IF(NAT1.EQ.1) THEN WRITE(IUO1,561) ELSE WRITE(IUO1,560) NAT1 ENDIF ENDIF IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN READ(IUI2,530) E_MIN,E_MAX,DE ENDIF IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN NLG=INT(NAT1-0.0001)/4 +1 DO NN=1,NLG NRL=4*NN JD=4*(NN-1)+1 IF(NN.EQ.NLG) NRL=NAT1 READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL) WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL) ENDDO C C Temporary storage of LMAX. Waiting for a version of PHAGEN C with LMAX dependent on the energy C DO JE=1,NE DO JAT=1,NAT1 LMAX(JAT,JE)=LMAX(JAT,1) ENDDO ENDDO C NL1=1 DO JAT=1,NAT1 NL1=MAX0(NL1,LMAX(JAT,1)+1) ENDDO IF(NL1.GT.NL_M) GOTO 184 ENDIF IF(ITL.EQ.0) READ(IUI3,101) NATR,NER IF(ISPIN.EQ.1) THEN READ(IUI3,106) L_IN,NATR,NER IF(LI.NE.L_IN) GOTO 606 ENDIF NAT2=NAT+NATA IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180 IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182 C C.......... DL generated by MUFPOT and RHOR given .......... C.......... by S. M. Goldberg, C. S. Fadley .......... C.......... and S. Kono, J. Electron Spectr. .......... C.......... Relat. Phenom. 21, 285 (1981) .......... C IF(ITL.EQ.0) THEN DO JAT=1,NAT2 IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN READ(IUI3,102) RIEN READ(IUI3,102) RIEN READ(IUI3,102) RIEN ENDIF DO JE=1,NE IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121 READ(IUI3,103) ENERGIE READ(IUI3,102) RIEN READ(IUI3,102) RIEN READ(IUI3,102) RIEN 121 CONTINUE DO L=0,LMAX(JAT,JE) READ(IUI2,7) VK(JE),TL(L,1,JAT,JE) TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,1.)*TL(L,1, &JAT,JE)) ENDDO IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5 DO LL=1,18 READ(IUI3,104) RH1,RH2,DEF1,DEF2 RHOR(JE,JAT,LL,1,1)=CMPLX(RH1) RHOR(JE,JAT,LL,2,1)=CMPLX(RH2) DLT(JE,JAT,LL,1)=CMPLX(DEF1) DLT(JE,JAT,LL,2)=CMPLX(DEF2) ENDDO 5 CONTINUE ENDDO ENDDO ELSE C C.......... TL and RHOR calculated by PHAGEN .......... C DO JE=1,NE NLG=INT(NAT2-0.0001)/4 +1 IF(NE.GT.1) WRITE(IUO1,563) JE DO NN=1,NLG NRL=4*NN JD=4*(NN-1)+1 IF(NN.EQ.NLG) NRL=NAT2 READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL) WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL) ENDDO NL1=1 DO JAT=1,NAT2 NL1=MAX0(NL1,LMAX(JAT,1)+1) ENDDO IF(NL1.GT.NL_M) GOTO 184 DO JAT=1,NAT2 READ(IUI2,*) DUMMY DO L=0,LMAX(JAT,JE) IF(LMAX_MODE.EQ.0) THEN READ(IUI2,9) VK(JE),TLSTAR ELSE READ(IUI2,9) VK(JE),TLSTAR ENDIF TL(L,1,JAT,JE)=CONJG(TLSTAR) VK(JE)=CONJG(VK(JE)) ENDDO ENDDO C IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333 IF(JE.EQ.1) THEN DO JDUM=1,7 READ(IUI3,102) RIEN ENDDO ENDIF C C Reading or regular (RHOR) and irregular (RHOI) radial integrals C C 1-2 : dipole terms C 3-5 : quadrupole terms C DO JEMET=1,NEMET C JM=IEMET(JEMET) READ(IUI3,105) RHOR1STAR,RHOR2STAR,RHOR3STAR,RHOR4STAR,RHO &R5STAR RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) RHOR(JE,JM,NNL,3,1)=CONJG(RHOR3STAR) RHOR(JE,JM,NNL,4,1)=CONJG(RHOR4STAR) RHOR(JE,JM,NNL,5,1)=CONJG(RHOR5STAR) C ENDDO C 333 VK(JE)=VK(JE)*A VK2(JE)=CABS(VK(JE)*VK(JE)) ENDDO ENDIF C CLOSE(IUI2) CLOSE(IUI3) C C.......... Suppression of possible zeros in the TL array .......... C.......... (in case of the use of matrix inversion and .......... C.......... for energy variations) .......... C IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL) ENDIF ENDIF C C.......... Reading of the TL and radial matrix elements files .......... C.......... (Coulomb excitation case) .......... C IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN IERR=0 IF(INTERACT.EQ.'COULOMB') THEN IRD1=IUI2 IRD2=IUI3 ELSEIF(INTERACT.EQ.'DIPCOUL') THEN IRD1=IUI7 IRD2=IUI8 ENDIF IF(SPECTRO.EQ.'APC') WRITE(IUO1,419) READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A IF(ISPIN.EQ.0) THEN IF(NAT1_A.EQ.1) THEN WRITE(IUO1,561) ELSE WRITE(IUO1,560) NAT1_A ENDIF ENDIF IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A ENDIF IF(ITL_A.EQ.1) THEN READ(IRD2,107) LI_C2,LI_I2,LI_A2 READ(IRD2,117) LE_MIN1,N_CHANNEL LE_MAX1=LE_MIN1+N_CHANNEL-1 IF(I_TEST_A.NE.1) THEN IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO 610 ELSE LI_C2=0 LI_I2=1 LI_A2=0 LE_MIN1=1 N_CHANNEL=1 ENDIF ENDIF IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN NLG=INT(NAT1_A-0.0001)/4 +1 DO NN=1,NLG NRL=4*NN JD=4*(NN-1)+1 IF(NN.EQ.NLG) NRL=NAT1_A READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL) WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL) ENDDO C C Temporary storage of LMAX_A. Waiting for a version of PHAGEN C with LMAX_A dependent on the energy C DO JE=1,NE1_A DO JAT=1,NAT1_A LMAX_A(JAT,JE)=LMAX_A(JAT,1) ENDDO ENDDO C NL1_A=1 DO JAT=1,NAT1_A NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1) ENDDO IF(NL1_A.GT.NL_M) GOTO 184 ENDIF IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A IF(ISPIN.EQ.1) THEN READ(IRD2,106) L_IN_A,NATR_A,NER_A IF(LI_C.NE.L_IN_A) GOTO 606 ENDIF NAT2_A=NAT+NATA NAT2=NAT2_A IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180 IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) GOTO &182 C C.......... DL generated by MUFPOT and RHOR given .......... C.......... by S. M. Goldberg, C. S. Fadley .......... C.......... and S. Kono, J. Electron Spectr. .......... C.......... Relat. Phenom. 21, 285 (1981) .......... C IF(ITL_A.EQ.0) THEN CONTINUE ELSE C C.......... TL_A and RHOR_A calculated by PHAGEN .......... C DO JE=1,NE_A NLG=INT(NAT2_A-0.0001)/4 +1 IF(NE_A.GT.1) WRITE(IUO1,563) JE DO NN=1,NLG NRL=4*NN JD=4*(NN-1)+1 IF(NN.EQ.NLG) NRL=NAT2_A READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL) WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL) ENDDO DO JAT=1,NAT2_A READ(IRD1,*) DUMMY DO L=0,LMAX_A(JAT,JE) IF(LMAX_MODE_A.EQ.0) THEN READ(IRD1,9) VK_A(JE),TLSTAR ELSE READ(IRD1,7) VK_A(JE),TLSTAR ENDIF TL_A(L,1,JAT,JE)=CONJG(TLSTAR) VK_A(JE)=CONJG(VK_A(JE)) ENDDO ENDDO C IF(IFTHET_A.EQ.1) GOTO 331 DO LE=LE_MIN,LE_MAX DO JEMET=1,NEMET JM=IEMET(JEMET) READ(IRD2,109) L_E,LB_MIN,LB_MAX IF(I_TEST_A.EQ.1) THEN L_E=1 LB_MIN=0 LB_MAX=1 ENDIF IF(LE.NE.L_E) IERR=1 L_BOUNDS(L_E,1)=LB_MIN L_BOUNDS(L_E,2)=LB_MAX DO LB=LB_MIN,LB_MAX READ(IRD2,108) L_A,RAD_D,RAD_E RHOR_A(LE,JM,L_A,1,1)=RAD_D RHOR_A(LE,JM,L_A,2,1)=RAD_E IF(I_TEST_A.EQ.1) THEN IF(LB.EQ.LB_MIN) THEN RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0) RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0) ELSEIF(LB.EQ.LB_MAX) THEN RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0) RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0) ENDIF ENDIF ENDDO ENDDO ENDDO 331 VK_A(JE)=VK_A(JE)*A VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE)) ENDDO ENDIF C CLOSE(IRD1) CLOSE(IRD2) C C.......... Suppression of possible zeros in the TL array .......... C.......... (in case of the use of matrix inversion and .......... C.......... for energy variations) .......... C IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL) ENDIF IF(SPECTRO.EQ.'APC') WRITE(IUO1,420) C ENDIF C C.......... Check of the consistency of the two TL and radial .......... C.......... matrix elements for APECS .......... C IF(SPECTRO.EQ.'APC') THEN C I_TL_FILE=0 I_RD_FILE=0 C IF(NAT1.NE.NAT1_A) I_TL_FILE=1 IF(NE1.NE.NE1_A) I_TL_FILE=1 IF(ITL.NE.ITL_A) I_TL_FILE=1 IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1 C IF(LI_C.NE.LI_C2) I_RD_FILE=1 IF(LI_I.NE.LI_I2) I_RD_FILE=1 IF(LI_A.NE.LI_A2) I_RD_FILE=1 C IF(I_TL_FILE.EQ.1) GOTO 608 IF(I_RD_FILE.EQ.1) GOTO 610 IF(IERR.EQ.1) GOTO 610 C ENDIF C C.......... Calculation of the scattering factor (only) .......... C IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8 IF(IFTHET.EQ.1) THEN CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE) ELSEIF(IFTHET_A.EQ.1) THEN c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A) ENDIF WRITE(IUO1,57) STOP C 8 IF(IBAS.EQ.0) THEN C C............... Reading of an external cluster ............... C C C Cluster originating from CLUSTER_NEW.F : IPHA=0 C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems) C Other cluster : the first line must be text; then C free format : Atomic number,X,Y,Z,number C of the corresponding prototypical atom ; C All atoms corresponding to the same C prototypical atom must follow each other. C Moreover, the blocks of equivalent atoms C must be ordered by increasing number of C prototypical atom. C VALZ_MIN=1000.0 VALZ_MAX=-1000.0 C OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD') READ(IUI4,778,ERR=892) IPHA GOTO 893 892 IPHA=3 IF(UNIT.EQ.'ANG') THEN CUNIT=1./A TUNIT='ANGSTROEMS' ELSEIF(UNIT.EQ.'LPU') THEN CUNIT=1. TUNIT='UNITS OF THE LATTICE PARAMETER' ELSEIF(UNIT.EQ.'ATU') THEN CUNIT=BOHR/A TUNIT='ATOMIC UNITS' ELSE GOTO 890 ENDIF 893 NATCLU=0 DO JAT=1,NAT2 NATYP(JAT)=0 ENDDO IF(IPHA.EQ.0) THEN CUNIT=1. TUNIT='UNITS OF THE LATTICE PARAMETER' ELSEIF(IPHA.EQ.1) THEN CUNIT=BOHR/A TUNIT='ATOMIC UNITS' IEMET(1)=1 ELSEIF(IPHA.EQ.2) THEN CUNIT=1./A TUNIT='ANGSTROEMS' IEMET(1)=1 ENDIF IF(IPRINT.EQ.2) THEN IF(I_AT.NE.1) THEN WRITE(IUO1,558) IUI4,TUNIT IF(IPHA.EQ.3) WRITE(IUO1,549) ENDIF ENDIF JATM=0 DO JLINE=1,10000 IF(IPHA.EQ.0) THEN READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT ELSEIF(IPHA.EQ.1) THEN READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT ELSEIF(IPHA.EQ.2) THEN READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT ELSEIF(IPHA.EQ.3) THEN READ(IUI4,*,END=780) NN,X,Y,Z,JAT ENDIF JATM=MAX0(JAT,JATM) NATCLU=NATCLU+1 IF(IPHA.NE.3) THEN CHEM(JAT)=R ELSE CHEM(JAT)='XX' ENDIF NZAT(JAT)=NN NATYP(JAT)=NATYP(JAT)+1 COORD(1,NATCLU)=X*CUNIT COORD(2,NATCLU)=Y*CUNIT COORD(3,NATCLU)=Z*CUNIT VALZ(NATCLU)=Z*CUNIT IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,NATCLU),COORD &(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT) ENDIF ENDDO 780 NBZ=NATCLU IF(JATM.NE.NAT) GOTO 514 CLOSE(IUI4) C IF(NATCLU.GT.NATCLU_M) GOTO 510 DO JA1=1,NATCLU DO JA2=1,NATCLU DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2+(COORD(2 &,JA1)-COORD(2,JA2))**2+(COORD(3,JA1)-COORD(3,JA2))**2) IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO 895 ENDDO ENDDO C D_UP=VALZ_MAX-VALZ(1) D_DO=VALZ(1)-VALZ_MIN IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN I_INV=1 ELSE I_INV=0 ENDIF ELSE C C............... Construction of an internal cluster ............... C CALL BASE CALL ROTBAS(ROT) IF(IVG0.EQ.2) THEN NMAX=NIV+1 ELSE NMAX=(2*NIV+1)**3 ENDIF IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN WRITE(IUO1,37) WRITE(IUO1,38) NIV DO NUM=1,NMAX CALL NUMAT(NUM,NIV,IA,IB,IC) WRITE(IUO1,17) NUM,IA,IB,IC ENDDO WRITE(IUO1,39) ENDIF CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT,IRE,NATYP,NBZ,N &AT2,NCOUCH,NMAX) IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL,NCOUCH) & IF(IREL.EQ.1) THEN DO JP=1,NPLAN VAL(JP)=VAL2(JP) ENDDO ENDIF ENDIF ENDIF C C Storage of the extremal values of x and y for each plane. They define C the exterior of the cluster when a new cluster has to be build to C support a point-group C IF(I_GR.GE.1) THEN IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN CALL ORDRE(NBZ,VALZ,NPLAN,VAL) WRITE(IUO1,50) NPLAN DO K=1,NPLAN WRITE(IUO1,29) K,VAL(K) X_MAX(K)=0. X_MIN(K)=0. Y_MAX(K)=0. Y_MIN(K)=0. ENDDO ENDIF DO JAT=1,NATCLU X=COORD(1,JAT) Y=COORD(2,JAT) Z=COORD(3,JAT) DO JPLAN=1,NPLAN IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN)) X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN)) Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN)) Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN)) ENDIF ENDDO ENDDO ENDIF C C Instead of the symmetrization of the cluster (this version only) C N_PROT=NAT NAT_ST=0 DO JTYP=1,JATM NB_AT=NATYP(JTYP) IF(NB_AT.GT.NAT_EQ_M) GOTO 614 DO JA=1,NB_AT NAT_ST=NAT_ST+1 NCORR(JA,JTYP)=NAT_ST ENDDO ENDDO DO JC=1,3 DO JA=1,NATCLU SYM_AT(JC,JA)=COORD(JC,JA) ENDDO ENDDO C C Checking surface-like atoms for mean square displacements C calculations C CALL CHECK_VIB(NAT2) C C.......... Set up of the variables used for an internal .......... C.......... calculation of the mean free path and/or of .......... C.......... the mean square displacements .......... C IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN DO JTYP=1,NAT2 XMT(JTYP)=XMAT(NZAT(JTYP)) RHOT(JTYP)=RHOAT(NZAT(JTYP)) ENDDO XMTA=XMT(1) RHOTA=RHOT(1) NZA=NZAT(1) ENDIF IF(IDCM.GT.0) THEN CALL CHNOT(3,VECBAS,VEC) DO J=1,3 VB1(J)=VEC(J,1) VB2(J)=VEC(J,2) VB3(J)=VEC(J,3) ENDDO CPR=1. CALL PRVECT(VB2,VB3,VBS,CPR) VM=PRSCAL(VB1,VBS) QD=(6.*PI*PI*NAT/VM)**(1./3.) ENDIF C C.......... Writing of the contents of the cluster, .......... C.......... of the position of the different planes .......... C.......... and of their respective absorbers in .......... C.......... the control file IUO1 .......... C IF(I_AT.EQ.1) GOTO 153 IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN WRITE(IUO1,40) NCA=0 DO J=1,NAT DO I=1,NMAX NCA=NCA+1 WRITE(IUO1,20) J,I WRITE(IUO1,21) (ATOME(L,NCA),L=1,3) K=IRE(NCA,1) IF(K.EQ.0) THEN WRITE(IUO1,22) ELSE WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2) ENDIF ENDDO ENDDO WRITE(IUO1,41) ENDIF IF(IBAS.EQ.1) THEN WRITE(IUO1,24) NATCLU=0 DO I=1,NAT NN=NATYP(I) NATCLU=NATCLU+NATYP(I) WRITE(IUO1,26) NN,I ENDDO IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3 WRITE(IUO1,782) NATCLU IF(NATCLU.GT.NATCLU_M) GOTO 516 IF(IPRINT.EQ.3) WRITE(IUO1,559) IF(IPRINT.EQ.3) THEN NBTA=0 DO JT=1,NAT2 NBJT=NATYP(JT) DO JN=1,NBJT NBTA=NBTA+1 WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA),COORD(3,N &BTA),JT,JN,CHEM(JT) ENDDO ENDDO ENDIF ENDIF 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) ENDIF IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN CALL ORDRE(NBZ,VALZ,NPLAN,VAL) IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN DO K=1,NPLAN IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) ENDDO ENDIF C IF(I_AT.EQ.0) WRITE(IUO1,30) IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN WRITE(IUO1,31) (IEMET(J),J=1,NEMET) ENDIF ZEM=1.E+20 DO L=1,NPLAN Z=VAL(L) DO JEMED=1,NEMET CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93) IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET(3) IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3) GO TO 33 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM 33 CONTINUE ENDDO ENDDO C C.......... Loop on the electrons involved in the .......... C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... C.......... LEED or AED and N_EL = 2 for APC .......... C DO J_EL=1,N_EL C C.......... Writing the information on the spectroscopies .......... C.......... in the control file IUO1 .......... C IF(SPECTRO.EQ.'XAS') GOTO 566 IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,236) ELSE WRITE(IUO1,248) ENDIF ENDIF IF(ITHETA.EQ.1) WRITE(IUO1,245) IF(I_TEST.EQ.1) WRITE(IUO1,234) ENDIF C C---------- Photoelectron diffraction case (PHD) ---------- C IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN IF(SPECTRO.EQ.'PHD') THEN IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,35) ELSE WRITE(IUO1,246) ENDIF ENDIF IF(ITHETA.EQ.1) WRITE(IUO1,44) IF(IE.EQ.1) WRITE(IUO1,58) IF(INITL.EQ.0) WRITE(IUO1,118) IF(I_TEST.EQ.1) WRITE(IUO1,234) ENDIF IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN WRITE(IUO1,418) WRITE(IUO1,18) ENDIF IF(J_EL.EQ.2) GOTO 222 IF(IPRINT.GT.0) THEN WRITE(IUO1,92) WRITE(IUO1,91) IF(ISPIN.EQ.0) THEN WRITE(IUO1,335) ELSE WRITE(IUO1,336) ENDIF WRITE(IUO1,91) IF(IPOTC.EQ.0) THEN WRITE(IUO1,339) ELSE WRITE(IUO1,334) ENDIF WRITE(IUO1,91) IF(INITL.NE.0) THEN WRITE(IUO1,337) WRITE(IUO1,91) IF(IPOL.EQ.0) THEN WRITE(IUO1,88) ELSEIF(ABS(IPOL).EQ.1) THEN WRITE(IUO1,87) ELSEIF(IPOL.EQ.2) THEN WRITE(IUO1,89) ENDIF WRITE(IUO1,91) IF(IDICHR.GT.0) THEN WRITE(IUO1,338) ENDIF WRITE(IUO1,91) WRITE(IUO1,92) WRITE(IUO1,90) WRITE(IUO1,43) THLUM,PHILUM IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN WRITE(IUO1,45) ENDIF ENDIF C IF(INITL.EQ.2) THEN WRITE(IUO1,79) LI,LI-1,LI+1 IF(I_SO.EQ.1) THEN WRITE(IUO1,80) S_O ENDIF DO JE=1,NE DO JEM=1,NEMET JTE=IEMET(JEM) IF(ISPIN.EQ.0) THEN WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,1,1),RHOR(JE,JTE &,NNL,2,1) IF(ITL.EQ.0) THEN WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1),DLT(JE,JTE,N &NL,2) ENDIF ENDIF ENDDO ENDDO ELSEIF(INITL.EQ.-1) THEN WRITE(IUO1,82) LI,LI-1 IF(I_SO.EQ.1) THEN WRITE(IUO1,80) S_O ENDIF DO JE=1,NE DO JEM=1,NEMET JTE=IEMET(JEM) IF(ISPIN.EQ.0) THEN WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,1,1) IF(ITL.EQ.0) THEN WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,1) ENDIF ENDIF ENDDO ENDDO ELSEIF(INITL.EQ.1) THEN WRITE(IUO1,82) LI,LI+1 IF(I_SO.EQ.1) THEN WRITE(IUO1,80) S_O ENDIF DO JE=1,NE DO JEM=1,NEMET JTE=IEMET(JEM) IF(ISPIN.EQ.0) THEN WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,2,1) IF(ITL.EQ.0) THEN WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,2) ENDIF ENDIF ENDDO ENDDO ENDIF C IF(I_AT.EQ.0) THEN IF(INV(J_EL).EQ.0) THEN IF(NDIF.EQ.1) THEN IF(ISPHER.EQ.1) THEN WRITE(IUO1,83) ELSEIF(ISPHER.EQ.0) THEN WRITE(IUO1,84) ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,97) NDIF ELSE WRITE(IUO1,98) NDIF ENDIF ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,122) ELSE WRITE(IUO1,120) ENDIF ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,85) ELSE WRITE(IUO1,86) ENDIF ENDIF C ENDIF 222 CONTINUE ENDIF C C---------- LEED case (LED) ---------- C IF(SPECTRO.EQ.'LED') THEN IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,252) ELSE WRITE(IUO1,258) ENDIF ENDIF IF(ITHETA.EQ.1) WRITE(IUO1,254) IF(IE.EQ.1) WRITE(IUO1,256) IF(IPRINT.GT.0) THEN WRITE(IUO1,92) WRITE(IUO1,91) IF(ISPIN.EQ.0) THEN WRITE(IUO1,335) ELSE WRITE(IUO1,336) ENDIF WRITE(IUO1,91) IF(IPOTC.EQ.0) THEN WRITE(IUO1,339) ELSE WRITE(IUO1,334) ENDIF WRITE(IUO1,91) WRITE(IUO1,92) WRITE(IUO1,260) WRITE(IUO1,261) THLUM,PHILUM IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN WRITE(IUO1,45) ENDIF C IF(I_AT.EQ.0) THEN IF(INV(J_EL).EQ.0) THEN IF(NDIF.EQ.1) THEN IF(ISPHER.EQ.1) THEN WRITE(IUO1,83) ELSEIF(ISPHER.EQ.0) THEN WRITE(IUO1,84) ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,97) NDIF ELSE WRITE(IUO1,98) NDIF ENDIF ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,122) ELSE WRITE(IUO1,120) ENDIF ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,85) ELSE WRITE(IUO1,86) ENDIF ENDIF C ENDIF ENDIF C C---------- Auger diffraction case (AED) ---------- C IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN IF(SPECTRO.EQ.'AED') THEN IF(IPHI_A.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,235) ELSE WRITE(IUO1,247) ENDIF ENDIF IF(ITHETA_A.EQ.1) WRITE(IUO1,244) IF(I_TEST_A.EQ.1) WRITE(IUO1,234) ENDIF IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN WRITE(IUO1,419) WRITE(IUO1,18) ENDIF IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN IF(IPRINT.GT.0) THEN WRITE(IUO1,92) WRITE(IUO1,91) IF(ISPIN.EQ.0) THEN WRITE(IUO1,335) ELSE WRITE(IUO1,336) ENDIF WRITE(IUO1,91) IF(IPOTC_A.EQ.0) THEN WRITE(IUO1,339) ELSE WRITE(IUO1,334) ENDIF WRITE(IUO1,91) WRITE(IUO1,92) WRITE(IUO1,95) AUGER CALL AUGER_MULT IF(I_MULT.EQ.0) THEN WRITE(IUO1,154) ELSE WRITE(IUO1,155) MULTIPLET ENDIF C DO JEM=1,NEMET JTE=IEMET(JEM) WRITE(IUO1,112) JTE DO LE=LE_MIN,LE_MAX WRITE(IUO1,119) LE LA_MIN=L_BOUNDS(LE,1) LA_MAX=L_BOUNDS(LE,2) DO LA=LA_MIN,LA_MAX IF(ISPIN.EQ.0) THEN WRITE(IUO1,115) LA,RHOR_A(LE,JTE,LA,1,1),RHOR_A(LE &,JTE,LA,2,1) ENDIF ENDDO ENDDO ENDDO C IF(I_AT.EQ.0) THEN IF(INV(J_EL).EQ.0) THEN IF(NDIF.EQ.1) THEN IF(ISPHER.EQ.1) THEN WRITE(IUO1,83) ELSEIF(ISPHER.EQ.0) THEN WRITE(IUO1,84) ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,97) NDIF ELSE WRITE(IUO1,98) NDIF ENDIF ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,122) ELSE WRITE(IUO1,120) ENDIF ENDIF ELSE IF(ISPHER.EQ.0) THEN WRITE(IUO1,85) ELSE WRITE(IUO1,86) ENDIF ENDIF C ENDIF ENDIF ENDIF C C.......... Check of the dimensioning of the treatment routine .......... C CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI,NPH &I_A,ISOM,I_EXT,I_EXT_A,SPECTRO) C C.......... Call of the subroutine performing either .......... C.......... the PhD, LEED, AED, EXAFS or APECS calculation .......... C 566 IF(ISPIN.EQ.0) THEN IF(SPECTRO.EQ.'PHD') THEN CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR,NATC &LU,NFICHLEC,JFICH,NP) ELSEIF(SPECTRO.EQ.'LED') THEN c CALL LEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, c 1 NATCLU,NFICHLEC,JFICH,NP) ELSEIF(SPECTRO.EQ.'AED') THEN c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) ELSEIF(SPECTRO.EQ.'XAS') THEN c CALL XASDIF_SE(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP) ELSEIF(SPECTRO.EQ.'APC') THEN c IF(J_EL.EQ.1) THEN c CALL PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, c 1 NATCLU,NFICHLEC,JFICH,NP) c ELSEIF(J_EL.EQ.2) THEN c CALL AEDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) c ENDIF ENDIF ELSEIF(ISPIN.EQ.1) THEN c IF(SPECTRO.EQ.'PHD') THEN c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, c 1 NATCLU,NFICHLEC,JFICH,NP) c ELSEIF(SPECTRO.EQ.'AED') THEN c CALL AEDDIF_SP c ELSEIF(SPECTRO.EQ.'XAS') THEN c CALL XASDIF_SP c ENDIF continue ENDIF C C.......... End of the MS calculation : .......... C.......... direct exit or treatment of the results .......... C C C.......... End of the loop on the electrons .......... C ENDDO C IF(SPECTRO.EQ.'PHD') THEN IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,52) ELSE WRITE(IUO1,249) ENDIF ENDIF IF(ITHETA.EQ.1) WRITE(IUO1,49) IF(IE.EQ.1) WRITE(IUO1,59) ELSEIF(SPECTRO.EQ.'LED') THEN IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,253) ELSE WRITE(IUO1,259) ENDIF ENDIF IF(ITHETA.EQ.1) WRITE(IUO1,255) IF(IE.EQ.1) WRITE(IUO1,257) ELSEIF(SPECTRO.EQ.'XAS') THEN WRITE(IUO1,51) ELSEIF(SPECTRO.EQ.'AED') THEN IF(IPHI_A.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,237) ELSE WRITE(IUO1,250) ENDIF ENDIF IF(ITHETA_A.EQ.1) WRITE(IUO1,238) ELSEIF(SPECTRO.EQ.'APC') THEN IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,239) ELSE WRITE(IUO1,251) ENDIF ENDIF IF(ITHETA.EQ.1) WRITE(IUO1,240) ENDIF C CLOSE(ICOM) IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN WRITE(IUO1,562) ENDIF IF(ISOM.EQ.0) CLOSE(IUO2) IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1) C C.......... End of the loop on the data files .......... C ENDDO C IF(ISOM.NE.0) THEN JFF=1 IF(ISPIN.EQ.0) THEN IF(SPECTRO.NE.'XAS') THEN CALL TREAT_PHD(ISOM,NFICHLEC,JFF,NP) ELSE c CALL TREAT_XAS(ISOM,NFICHLEC,NP) ENDIF ELSEIF(ISPIN.EQ.1) THEN c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP) c ELSEIF(SPECTRO.EQ.'XAS') THEN c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP) c ENDIF continue ENDIF ENDIF C IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) IF(ISOM.NE.0) CLOSE(IUO2) C STOP GOTO 999 C 1 WRITE(IUO1,60) STOP 2 WRITE(IUO1,61) STOP 55 WRITE(IUO1,65) STOP 56 WRITE(IUO1,64) STOP 74 WRITE(IUO1,75) STOP 99 WRITE(IUO1,100) STOP 180 WRITE(IUO1,181) STOP 182 WRITE(IUO1,183) STOP 184 WRITE(IUO1,185) STOP 504 WRITE(IUO1,505) STOP 510 WRITE(IUO1,511) IUI4 STOP 514 WRITE(IUO1,515) STOP 516 WRITE(IUO1,517) STOP 518 WRITE(IUO1,519) WRITE(IUO1,889) STOP 520 WRITE(IUO1,521) STOP 540 WRITE(IUO1,541) STOP 550 WRITE(IUO1,551) STOP 570 WRITE(IUO1,571) STOP 580 WRITE(IUO1,581) STOP 590 WRITE(IUO1,591) STOP 600 WRITE(IUO1,601) STOP 602 WRITE(IUO1,603) STOP 604 WRITE(IUO1,605) STOP 606 WRITE(IUO1,607) STOP 608 WRITE(IUO1,609) STOP 610 WRITE(IUO1,611) STOP 614 WRITE(IUO1,615) NB_AT STOP 620 WRITE(IUO1,621) LE_MAX STOP 630 WRITE(IUO1,631) STOP 890 WRITE(IUO1,891) STOP 895 WRITE(IUO1,896) JA1,JA2 C 3 FORMAT(5(5X,I4)) 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ',': &(',I3,',',I3,',',I3,')') 18 FORMAT(' ',/) 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5) 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',',F7.3,', &',F7.3,')') 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER') 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',',F7.3,' &,',F7.3,')',5X,'NEW NUMBER : ',I4) 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/) 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2) 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3) 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/) 31 FORMAT(38X,10(I2,3X),//) 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', I2,' IS P &OSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') 35 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL PHOTO &ELECTRON DIFFRACTION CALCULATION #####', '#####',/////) 36 FORMAT(/////,'########## BEGINNING ', 'OF THE EX &AFS CALCULATION ##########',/////) 37 FORMAT(/////,'++++++++++++++++++++', ' NUMBERING OF THE A &TOMS GENERATED +++++++++++++++++++') 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', &'++++++++++++++++++++++++++++++++',/////) 40 FORMAT(/////,'======================', ' CONTENTS OF THE RE &DUCED CLUSTER ======================',///) 41 FORMAT(///,'====================================================', &'============================',/////) 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ',F6.2,' &DEGREES') 44 FORMAT(/////,'########## BEGINNING ', 'OF THE POLAR PHOTOELECTR &ON DIFFRACTION CALCULATION #####', '#####',/////) 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ','THE NORMAL TO THE SURF &ACE)') 49 FORMAT(/////,'########## END OF THE ', 'POLAR PHOTOELECTRON DIFFRA &CTION CALCULATION ##########') 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') 51 FORMAT(/////,'########## END OF THE ', 'EXAFS CALCU &LATION ##########') 52 FORMAT(/////,'########## END OF THE ', 'AZIMUTHAL PHOTOELECTRON DI &FFRACTION CALCULATION #####','#####') 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE') 58 FORMAT(/////,'########## BEGINNING ', 'OF THE FINE STRUCTURE & OSCILLATIONS CALCULATION #####', '#####',/////) 59 FORMAT(/////,'########## END OF THE ', 'FINE STRUCTURE OSCILLATI &ONS CALCULATION #####','#####') 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,','NEMET_M) &- CHECK THE DIMENSIONING >>>>>>>>>>') 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', ' & >>>>>>>>>>') 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ','CLUST &ER HAS NOT CONVERGED YET >>>>>>>>>>') 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ', &'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>') 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ', & 'IN MAIN ET READ_DATA >>>>>>>>>>') 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ', & I1,',',I1,/) 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ',A3 &,')',//) 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)') 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1) 83 FORMAT(//,32X,'(SPHERICAL WAVES)') 84 FORMAT(//,34X,'(PLANE WAVES)') 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)') 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)') 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +') 88 FORMAT(24X,'+ NON POLARIZED LIGHT +') 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +') 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/) 91 FORMAT(24X,'+',35X,'+') 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++') 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, ' IS PR &ESENT IN THIS PLANE') 95 FORMAT(////,31X,'AUGER LINE :',A6,//) 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1,')') & 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ',I1, &')') 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE',' >> &>>>>>>>>') 101 FORMAT(24X,I3,24X,I3) 102 FORMAT(A1) 103 FORMAT(31X,F7.2) 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5) 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5,2X,E1 &2.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) 106 FORMAT(12X,I3,12X,I3,12X,I3) 107 FORMAT(5X,I2,5X,I2,5X,I2) 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) 109 FORMAT(5X,I2,12X,I2,11X,I2) 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,' & :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//) 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,' &: (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')') 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2,' &: ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER',' ELECTRON)',/, &8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//) 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ', * 'TYPE ',I2,' : (',F8.5,',',F8.5,')') 114 FORMAT(/) 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X,'(',F8.5,',',F8.5 &,')') 117 FORMAT(12X,I2,5X,I2) 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/) 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X,'EXCHANGE INTEGRAL' &) 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ','I &NVERSION)') 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ','INVER &SION)') 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4) 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE',' ',/,' &',/,' ') 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ','LINE' &,' ',/,' ',/,' ') 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A &ND PHASE SHIFTS FILES >>>>>>>>>>') 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ','A &ND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ','FILE & >>>>>>>>>>') 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ','MATRIX ELEME &NTS TAKEN INTO ACCOUNT <-----',///) 235 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL AUGER & DIFFRACTION CALCULATION #####', '#####',/////) 236 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL APECS & DIFFRACTION CALCULATION #####', '#####',/////) 237 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL AUGER DIFFR &ACTION CALCULATION #####', '#####',/////) 238 FORMAT(/////,6X,'########## END ', 'OF THE POLAR AUGER DIFFRACT &ION CALCULATION #####', '#####',/////) 239 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL APECS DIFFR &ACTION CALCULATION #####', '#####',/////) 240 FORMAT(/////,6X,'########## END ', 'OF THE POLAR APECS DIFFRACT &ION CALCULATION #####', '#####',/////) 244 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR AUGER DI &FFRACTION CALCULATION #####', '#####',/////) 245 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR APECS DI &FFRACTION CALCULATION #####', '#####',/////) 246 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE PHOT &OELECTRON DIFFRACTION CALCULATION ','##########',/////) 247 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE AUGE &R DIFFRACTION CALCULATION ', '##########',/////) 248 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE APEC &S DIFFRACTION CALCULATION ', '##########',/////) 249 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE PHOTOELECTRON D &IFFRACTION CALCULATION #####','#####') 250 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE AUGER DIFF &RACTION CALCULATION #####', '#####',/////) 251 FORMAT(/////,'########## END ', 'OF THE FULL ANGLE APECS DIFF &RACTION CALCULATION #####', '#####',/////) 252 FORMAT(/////,'########## BEGINNING ', 'OF THE AZIMUTHAL LEED &CALCULATION #####', '#####',/////) 253 FORMAT(/////,'########## END ', 'OF THE AZIMUTHAL LEED CALCUL &ATION #####', '#####',/////) 254 FORMAT(/////,6X,'########## BEGINNING ', 'OF THE POLAR LEED CAL &CULATION #####', '#####',/////) 255 FORMAT(/////,6X,'########## END ', 'OF THE POLAR LEED CALCULATI &ON #####', '#####',/////) 256 FORMAT(/////,5X,'########## BEGINNING ', 'OF THE ENERGY LEED CA &LCULATION #####', '#####',/////) 257 FORMAT(/////,5X,'########## END ', 'OF THE ENERGY LEED CALCULAT &ION #####', '#####',/////) 258 FORMAT(/////,'########## BEGINNING ', 'OF THE FULL ANGLE LEED & CALCULATION ', '##########',/////) 259 FORMAT(/////,'########## END OF THE ', 'FULL ANGLE LEED CALCULATIO &N #####','#####') 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/) 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ',F6.2,' DE &GREES') 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +') 335 FORMAT(24X,'+ STANDARD +') 336 FORMAT(24X,'+ SPIN-POLARIZED +') 337 FORMAT(24X,'+ WITH +') 338 FORMAT(24X,'+ IN DICHROIC MODE +') 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +') 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','----- &-------------------') 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','----- &-------------------') 420 FORMAT(///,9X,'----------------------------------------------','-- &--------------------') 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ','(', &F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')') 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (',F8.5 &,',',F8.5,')') 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ','CHECK THE DIME &NSIONING >>>>>>>>>>') 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ','CONSIS &TENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2,' >>>>>>>>>>') 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ','N &AT IN THE DATA AND CLUSTER FILES >>>>>>>>>>') 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ',' &IBWD >>>>>>>>>>') 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT',' CONSIS &TENT WITH THE NUMBER OF ATOMS GENERATED BY THE ','CODE >>>>>>>>>> &') 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH', &' THE VALUE OF LI >>>>>>>>>>') 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4) 535 FORMAT(29X,F8.5,1X,F8.5) 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ','CORR &ESPOND TO NAT >>>>>>>>>>') 543 FORMAT(5X,F12.9,5X,F12.9) 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM' &,/) 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ','CORRES &POND TO NAT >>>>>>>>>>') 555 FORMAT(4(7X,I2)) 556 FORMAT(28X,4(I2,5X)) 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4,3X,A2) & 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ',I2,' : &',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)',10X,'CLASS',1X,'A &TOM',/) 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//,14X,' N &o ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3,' PROTOTYPICAL A &TOMS : ',//) 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ','PROTOTYPICAL ATOM : & ',//) 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE',13X &,'oooooooooooooooo',///) 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/) 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ','CORR &ESPOND TO NAT >>>>>>>>>>') 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ','PHD A &ND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ','NOT CON &SISTENT WITH THE INPUT DATA FILE >>>>>>>>>>') 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ','> &>>>>>>>>>',//) 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ', &'.inc FILE >>>>>>>>>>',//) 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ','>>>> &>>>>>>',//) 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ', &'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ','ELEMENTS FILE & >>>>>>>>>>',//) 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ','>>> &>>>>>>>',//) 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ','ELECTR &ON IS NOT COMPATIBLE >>>>>>>>>>',/,3X,'<<<<<<<<<< ',17X,'WITH T &HE INPUT DATA FILE ',16X,'>>>>>>>>>>',//) 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ','TH &E DIMENSIONNING FILE >>>>>>>>>>',//) 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ',' &THE DIMENSIONNING FILE >>>>>>>>>>',//) 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ','THE &DIMENSIONNING FILE >>>>>>>>>>',//) 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ',' BE IDE &NTICAL >>>>>>>>>>',/,'<<<<<<<<<< ','FOR BOTH ELECTRONS IN & CLUSTER ROTATION MODE',' >>>>>>>>>>',//) 776 FORMAT(I2) 777 FORMAT(A24) 778 FORMAT(30X,I1) 779 FORMAT(11X,A2,5X,I2,3F10.4,I5) 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4,' ATOMS &') 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE',' NATCLU_M >> &>>>>>>>>') 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''','UNIT &S >>>>>>>>>>') 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE',' AT &OMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4,' AND ',I4,' ARE & IDENTICAL >>>>>>>>>>') C 999 END C C======================================================================= C SUBROUTINE AMAS(NIV,ATOME,COORD,VALZ,ISURF,COUPUR,ROT,IRE,NATYP,NB &Z,NAT2,NCOUCH,NMAX) C C This routine generates a cluster from the knowledge of its C lattice vectors C USE DIM_MOD C USE ADSORB_MOD , NCOUCH1 => NCOUCH USE BASES_MOD USE MILLER_MOD , IM1 => IH, IM2 => IK, IM3 => II, IM4 => IL USE OUTUNITS_MOD USE RESEAU_MOD C DIMENSION VALZ(NATCLU_M) DIMENSION ROT(3,3),IRE(NATCLU_M,2),NATYP(NATM),ITA(NATCLU_M) DIMENSION ATOME(3,NATCLU_M),ATRSU(3,NATCLU_M),COORD(3,NATCLU_M) DIMENSION ROTINV(3,3),XINIT(3,1),XFIN(3,1) C C C NCOUCH=0 WRITE(IUO1,10) ISURF 10 FORMAT(//,18X,'ATOM (0,0,0) ON THE SURFACE PLANE IS OF TYPE ',I2) NBZ=0 CALL INVMAT(ROT,ROTINV) IF(IVG0.EQ.0) THEN CALL CHBASE(NATP_M,ATBAS) ENDIF NB1=0 NB2=0 DO NTYP=1,NAT NBAT=0 DO NUM=1,NMAX NB1=NB1+1 IRE(NB1,1)=0 IRE(NB1,2)=0 IF(IVG0.LE.1) THEN CALL NUMAT(NUM,NIV,IA,IB,IC) ELSE BSURA=1. CSURA=1. ENDIF IF(IVG0.LE.1) THEN XA=FLOAT(IA) XB=FLOAT(IB) XC=FLOAT(IC) ELSEIF(IVG0.EQ.2) THEN XA=FLOAT(NUM-1) XB=FLOAT(NUM-1) XC=FLOAT(NUM-1) ENDIF IF(IVG0.EQ.1) THEN IF(IVN(1).EQ.0) THEN ITA(NUM)=IA ELSEIF(IVN(2).EQ.0) THEN ITA(NUM)=IB ELSEIF(IVN(3).EQ.0) THEN ITA(NUM)=IC ENDIF IF((ITA(NUM).EQ.ITA(NUM-1)).AND.(NUM.GT.1)) GOTO 30 ENDIF DO J=1,3 K=J+3*(NTYP-1) O=ATBAS(K) ATOME(J,NB1)=O+XA*VECBAS(J)+XB*VECBAS(J+3)+XC*VECBAS(J+6) ENDDO DO I=1,3 M=I+3*(ISURF-1) XINIT(I,1)=ATOME(I,NB1)-ATBAS(M) ENDDO CALL MULMAT(ROTINV,3,3,XINIT,3,1,XFIN) DO I=1,3 ATRSU(I,NB1)=XFIN(I,1) ENDDO CALL TEST1(COUPUR,NB1,NB2,ATRSU,COORD,VALZ,NBAT,IRE,NBZ) 30 CONTINUE ENDDO NATYP(NTYP)=NBAT ENDDO IF(IADS.GE.1) THEN N0=NBZ DO JADS=1,NADS1 NB1=NB1+1 DO I=1,3 COORD(I,NB1)=ADS(I,JADS) ENDDO N1=0 DO N=1,N0 D=ABS(COORD(3,NB1)-VALZ(N)) IF(D.LT.0.0001) N1=N1+1 ENDDO IF(N1.EQ.0) THEN N0=N0+1 VALZ(N0)=COORD(3,NB1) ENDIF ENDDO NANEW1=NADS1+NADS2 NATYP(NAT+1)=NADS1 IF(NANEW1.EQ.NADS1) GOTO 99 DO JADS=NADS1+1,NANEW1 NB1=NB1+1 DO I=1,3 COORD(I,NB1)=ADS(I,JADS) ENDDO N1=0 DO N=1,N0 D=ABS(COORD(3,NB1)-VALZ(N)) IF(D.LT.0.0001) N1=N1+1 ENDDO IF(N1.EQ.0) THEN N0=N0+1 VALZ(N0)=COORD(3,NB1) ENDIF ENDDO NATYP(NAT+2)=NADS2 NANEW2=NANEW1+NADS3 IF(NANEW2.EQ.NANEW1) GOTO 99 DO JADS=NANEW1+1,NANEW2 NB1=NB1+1 DO I=1,3 COORD(I,NB1)=ADS(I,JADS) ENDDO N1=0 DO N=1,N0 D=ABS(COORD(3,NB1)-VALZ(N)) IF(D.LT.0.0001) N1=N1+1 ENDDO IF(N1.EQ.0) THEN N0=N0+1 VALZ(N0)=COORD(3,NB1) ENDIF ENDDO NATYP(NAT+3)=NADS3 99 CONTINUE NCOUCH=N0-NBZ NBZ=N0 ENDIF C RETURN C END C C======================================================================= C SUBROUTINE BASE C C This routine generates the lattice basis vectors for a given Bravais C lattice NCRIST centered according to NCENTR C USE DIM_MOD USE BASES_MOD USE CRANGL_MOD USE OUTUNITS_MOD USE RESEAU_MOD USE VECSYS_MOD C CHARACTER*15 BRAV(8),CENT(7) CHARACTER*31 RESEAU C C DIMENSION CUB(9),MNC(9),TCN(9),TRG(9),HEX(9) C C C DATA CUB /1.,0.,0., 0.,1.,0., 0.,0.,1./ DATA MNC /1.,0.,1., 0.,1.,0., 0.,0.,1./ DATA TCN /1.,0.,1., 1.,1.,1., 0.,0.,1./ DATA TRG /0.,1.,1., -0.866025,-0.5,1., 0.866025,-0.5,1./ DATA HEX /1.,0.,0., -0.5,0.866025,0., 0.,0.,1./ DATA PIS180 /0.017453/ DATA BRAV /' CUBIQUE',' TETRAGONAL',' ORTHORHOMBIQUE',' & MONOCLINIQUE',' TRICLINIQUE',' TRIGONAL',' HEXAGO &NAL',' EXTERNE'/ DATA CENT /' ','CENTRE',' FACES CENTREES','(RHOMBOEDRIQUE)',' FACE & A CENTREE',' FACE B CENTREE',' FACE C CENTREE'/ C ALPHAR=ALPHAD*PIS180 BETAR=BETAD*PIS180 GAMMAR=GAMMAD*PIS180 NAT3=NAT*3 GO TO (1,1,1,2,3,4,5,6) NCRIST C 1 DO I=1,9 VECBAS(I)=CUB(I) ENDDO IF(NCRIST.NE.1) THEN VECBAS(9)=CSURA IF(NCRIST.EQ.3) THEN VECBAS(5)=BSURA ENDIF ENDIF GO TO 6 C 2 DO I=1,9 VECBAS(I)=MNC(I) ENDDO VECBAS(1)=SIN(BETAR) VECBAS(3)=COS(BETAR) VECBAS(5)=BSURA VECBAS(9)=CSURA GO TO 6 C 3 DO I=1,9 VECBAS(I)=TCN(I) ENDDO VECBAS(1)=SIN(BETAR) VECBAS(3)=COS(BETAR) A2Y=(COS(GAMMAR)-COS(ALPHAR)*COS(BETAR))/SIN(BETAR) VECBAS(4)=BSURA*A2Y VECBAS(5)=BSURA*SQRT(SIN(ALPHAR)*SIN(ALPHAR)-A2Y*A2Y) VECBAS(6)=BSURA*COS(ALPHAR) VECBAS(9)=CSURA GO TO 6 C 4 IF(((NCENTR.EQ.4).AND.(CSURA.NE.1.)).OR.(NCENTR.EQ.1)) GO TO 5 ETA=-2.*SIN(ALPHAR/2.)/SQRT(3.) DZETA=SQRT(1.-ETA*ETA) DO I=1,3 J=I+2*(I-1) J1=J+1 J2=J+2 VECBAS(J)=TRG(J)*ETA VECBAS(J1)=TRG(J1)*ETA VECBAS(J2)=TRG(J2)*DZETA ENDDO GO TO 6 C 5 DO I=1,9 VECBAS(I)=HEX(I) ENDDO VECBAS(9)=CSURA C 6 DO I=1,3 ASYS(I)=VECBAS(I) BSYS(I)=VECBAS(I+3) CSYS(I)=VECBAS(I+6) ENDDO DCA=ABS(CSURA-1.) IF((NCRIST.EQ.6).AND.(DCA.LT.0.0001)) GO TO 8 IF(NCRIST.EQ.8) GO TO 8 IF(NCENTR.GT.1) THEN CALL CENTRE(VECBAS) IF(NCENTR.EQ.4) THEN DO I=1,9 VECBAS(I)=VECBAS(I)*SQRT((1.-CSURA*CSURA)*3.) ENDDO DO I=1,3 ASYS(I)=VECBAS(I) BSYS(I)=VECBAS(I+3) CSYS(I)=VECBAS(I+6) ENDDO ENDIF ENDIF C 8 RESEAU=BRAV(NCRIST)//' '//CENT(NCENTR) WRITE(IUO1,80) RESEAU,NAT WRITE(IUO1,81) (VECBAS(I),I=1,9) WRITE(IUO1,82) WRITE(IUO1,83) (ATBAS(I),I=1,NAT3) C 80 FORMAT(////,10X,'RESEAU CRISTALLIN DE TYPE : ',A29,/,16X, * 'CONTENANT',I3,' ATOMES DANS LA MAILLE ELEMENTAIRE',//) 81 FORMAT(28X,'VECTEURS GENERATEURS :',//,26X,'A1 = (',F6.3,',', *F6.3,',',F6.3,')',/,26X,'A2 = (',F6.3,',',F6.3,',',F6.3,')',/, *26X,'A3 = (',F6.3,',',F6.3,',',F6.3,')') 82 FORMAT(/,21X,'POSITIONS DES ATOMES DANS LA MAILLE :',/) 83 FORMAT(29X,'(',F6.3,',',F6.3,',',F6.3,')') C RETURN C END C C======================================================================= C SUBROUTINE CENTRE(VECBAS) C C This routine modifies the Bravais lattice basis vectors according to C the way the lattice is centered C USE RESEAU_MOD C DIMENSION VECBAS(9),V1(9) C C C DO I=1,9 V1(I)=VECBAS(I) ENDDO N1=NCENTR-1 GO TO (2,3,4,5,6,7) N1 C 2 DO I=1,3 VECBAS(I)=-0.5*V1(I)+0.5*V1(I+3)+0.5*V1(I+6) VECBAS(I+3)=0.5*V1(I)-0.5*V1(I+3)+0.5*V1(I+6) VECBAS(I+6)=0.5*V1(I)+0.5*V1(I+3)-0.5*V1(I+6) ENDDO GO TO 8 C 3 DO I=1,3 VECBAS(I)=0.5*(V1(I+3)+V1(I+6)) VECBAS(I+3)=0.5*(V1(I)+V1(I+6)) VECBAS(I+6)=0.5*(V1(I)+V1(I+3)) ENDDO GO TO 8 C 4 DO I=1,3 VECBAS(I)=(2./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6) VECBAS(I+3)=(-1./3.)*V1(I)+(1./3.)*V1(I+3)+(1./3.)*V1(I+6) VECBAS(I+6)=(-1./3.)*V1(I)-(2./3.)*V1(I+3)+(1./3.)*V1(I+6) ENDDO DO I=1,3 VECBAS(3*I)=VECBAS(3*I)*SQRT(3./(1.-CSURA*CSURA)) ENDDO GO TO 8 C 5 DO I=1,3 VECBAS(I+6)=0.5*(V1(I+3)+V1(I+6)) ENDDO GO TO 8 C 6 DO I=1,3 VECBAS(I+6)=0.5*(V1(I)+V1(I+6)) ENDDO GO TO 8 C 7 DO I=1,3 VECBAS(I+3)=0.5*(V1(I)+V1(I+3)) ENDDO C 8 RETURN C END C C======================================================================= C SUBROUTINE CHBASE(NAT,ATBAS) C USE VECSYS_MOD C DIMENSION ATBAS(3*NAT),BASVEC(3,3),BAS1(1,3),BAS2(1,3) C DO J=1,3 BASVEC(1,J)=ASYS(J) BASVEC(2,J)=BSYS(J) BASVEC(3,J)=CSYS(J) ENDDO C DO JAT=1,NAT DO J=1,3 K=J+3*(JAT-1) BAS1(1,J)=ATBAS(K) ENDDO CALL MULMAT(BAS1,1,3,BASVEC,3,3,BAS2) DO J=1,3 K=J+3*(JAT-1) ATBAS(K)=BAS2(1,J) ENDDO ENDDO C RETURN C END C C======================================================================= C SUBROUTINE CHNOT(NVEC,VEC1,VEC2) C C This routine linearizes the storage of a two index array C DIMENSION VEC1(3*NVEC),VEC2(3,NVEC) C DO J=1,NVEC DO I=1,3 VEC2(I,J)=VEC1(I+3*(J-1)) ENDDO ENDDO C RETURN C END C C======================================================================= C SUBROUTINE INVMAT(B,BINV) C USE OUTUNITS_MOD DIMENSION B(3,3),BINV(3,3) C C A1=B(1,1)*B(2,2)*B(3,3) A2=B(2,1)*B(3,2)*B(1,3) A3=B(3,1)*B(1,2)*B(2,3) A4=B(1,1)*B(3,2)*B(2,3) A5=B(2,1)*B(1,2)*B(3,3) A6=B(3,1)*B(2,2)*B(1,3) DET=A1+A2+A3-A4-A5-A6 C IF(ABS(DET).LT.0.0001) GO TO 10 C DO I=1,3 DO J=1,3 DO K=1,3 L=(I-J)*(I-K)*(J-K) IF(L.NE.0) THEN XNUM1=B(J,J)*B(K,K)-B(J,K)*B(K,J) XNUM2=B(I,K)*B(K,J)-B(K,K)*B(I,J) BINV(I,I)=XNUM1/DET BINV(I,J)=XNUM2/DET ENDIF ENDDO ENDDO ENDDO GO TO 50 C 10 WRITE(IUO1,60) C 60 FORMAT(5X,'NON INVERTIBLE MATRIX') C 50 CONTINUE C RETURN C END C C======================================================================= C SUBROUTINE MULMAT(A1,IL1,IC1,A2,IL2,IC2,A3) C C This routine performs the matrix multiplication of A1(IL1,IC1) by C A2(IL2,IC2) with the result stored in A3(IL1,IC2) C USE OUTUNITS_MOD DIMENSION A1(IL1,IC1),A2(IL2,IC2),A3(IL1,IC2) C C IF(IC1.NE.IL2) THEN WRITE(IUO1,10) ELSE DO I=1,IL1 DO J=1,IC2 A3(I,J)=0. DO K=1,IC1 A3(I,J)=A3(I,J)+A1(I,K)*A2(K,J) ENDDO ENDDO ENDDO ENDIF C 10 FORMAT(5X,'THESE MATRICES CANNOT BE MULTIPLIED') C RETURN C END C C======================================================================= C SUBROUTINE NUMAT(NUM,NIVA,IL,IM,IN) C USE OUTUNITS_MOD DIMENSION I(100) C C L=2*NIVA+1 IF(L.GT.100) THEN WRITE(IUO1,5) STOP ENDIF L1=NIVA+1 C DO K=1,L IF(K.LE.L1) THEN I(K)=K-1 ELSE I(K)=L1-K ENDIF ENDDO C Q1=FLOAT(NUM)/FLOAT(L*L) JR1=NUM-L*L*INT(Q1+0.0001) JS1=INT(Q1+0.9999) Q2=FLOAT(JR1)/FLOAT(L) JS2=INT(Q2+0.9999) IF(JR1.EQ.0) JS2=L Q3=FLOAT(NUM)/FLOAT(L) JR3=INT(Q3+0.0001) JS3=NUM-L*JR3 IF(JS3.EQ.0) JS3=L IL=I(JS1) IM=I(JS2) IN=I(JS3) C 5 FORMAT(///,'<<<<<<<<<< INCREASE THE SIZE OF I IN',' THE NUMAT SU &BROUTINE >>>>>>>>>>') C RETURN C END C C======================================================================= C SUBROUTINE RELA(NINI,NFIN,NAT,VALINI,VALFIN,VALFIN2,COORD,NTYP,REL &,L) C USE DIM_MOD C USE ADSORB_MOD , I1 => IADS, N1 => NADS1, N2 => NADS2, N3 => NADS3 & USE OUTUNITS_MOD USE RELADS_MOD USE RELAX_MOD C DIMENSION VALINI(NATCLU_M),VALFIN(NATCLU_M),REL(NATCLU_M) DIMENSION NTYP(NATM),COORD(3,NATCLU_M),LSP(2),DZA(2),DZB(2) DIMENSION DYA(2),DYB(2),VALFIN2(NATCLU_M),KZ(1000) C DATA SMALL /0.0001/ C IF((IREL.EQ.1).OR.((IREL.EQ.0).AND.(NRELA.GT.0))) THEN C CALL ORDRE(NINI,VALINI,NFIN,VALFIN) WRITE(IUO1,70) NFIN DO JPLAN=1,NFIN IF(JPLAN.LE.NRELA) THEN X1=1. X2=0. PCADS=PCRELA(JPLAN) ELSEIF((JPLAN.GT.NRELA).AND.(JPLAN.LE.L)) THEN X1=0. X2=0. ELSE X1=0. X2=1. PCSUBS=PCREL(JPLAN-L) ENDIF REL(JPLAN)=0. IF(JPLAN.GT.NREL+L) GO TO 20 IF(JPLAN.EQ.NFIN) GO TO 20 DPLAN=VALFIN(JPLAN)-VALFIN(JPLAN+1) REL(JPLAN)=DPLAN*(X1*PCADS+X2*PCSUBS)/100. 20 DREL=VALFIN(JPLAN)+REL(JPLAN) WRITE(IUO1,30) JPLAN,VALFIN(JPLAN),DREL ENDDO C NBR=0 DO JTYP=1,NAT NBAT=NTYP(JTYP) DO NUM=1,NBAT NBR=NBR+1 DO JPLAN=1,NFIN DIF=ABS(COORD(3,NBR)-VALFIN(JPLAN)) IF(DIF.LT.SMALL) THEN COORD(3,NBR)=COORD(3,NBR)+REL(JPLAN) ENDIF ENDDO ENDDO ENDDO C DO JPLAN=1,NFIN VALFIN(JPLAN)=VALFIN(JPLAN)+REL(JPLAN) ENDDO C ELSEIF(IREL.GE.2) THEN C IP=0 LSP(2)=0 OMEGA=OMEGA1 97 XN1=1. XN2=0. IP=IP+1 CALL ORDRE(NINI,VALINI,NFIN,VALFIN) ZP=VALFIN(IP) CALL RZB110(OMEGA,DY1,DY2,DZ1,DZ2) DZA(IP)=DZ1 DZB(IP)=DZ2 DYA(IP)=DY1 DYB(IP)=DY2 IF(ABS(OMEGA).LT.SMALL) THEN LSP(IP)=1 ELSE LSP(IP)=2 ENDIF IF(LSP(IP).EQ.1) GOTO 95 NBR=0 C DO JTYP=1,NAT-NATA NBAT=NTYP(JTYP) XN1=XN1+1.-FLOAT(JTYP) XN2=XN2-1.+FLOAT(JTYP) DO JNUM=1,NBAT NBR=NBR+1 ZAT=COORD(3,NBR)-ZP IF(ABS(ZAT).LT.SMALL) THEN YAT=COORD(2,NBR) COORD(2,NBR)=YAT-XN1*DYA(IP)-XN2*DYB(IP) COORD(3,NBR)=ZAT+ZP+XN1*DZA(IP)+XN2*DZB(IP) ENDIF ENDDO ENDDO C 95 OMEGA=OMEGA2 IF((IREL.EQ.3).AND.(IP.EQ.1)) GOTO 97 LS=0 DO I=1,IP LS=LS+LSP(I) ENDDO NBZ1=NFIN+LS-IP DO K=1,IP IF(LSP(K).EQ.2) THEN IF((K.EQ.2).AND.(LS.EQ.3)) THEN KN=K-1 ELSE KN=K ENDIF VALINI(NBZ1-KN+1)=VALFIN(L+K)+DZB(K) REL(NBZ1-KN+1)=DZB(K) ELSE VALINI(NBZ1-K+1)=VALFIN(L+K) REL(NBZ1-K+1)=0. ENDIF ENDDO C IL=0 IR=0 DO J=1,NFIN IS=0 IF(J.LE.NRELA) THEN X1=1. X2=0. X3=0. PCADS=PCRELA(J) IS=1 ELSEIF((J.GT.NRELA).AND.(J.LE.L)) THEN X1=0. X2=0. X3=0. ELSEIF((J.GT.L).AND.(J.LE.(L+IP))) THEN IR=IR+1 IF(LSP(IR).EQ.1) THEN IF((IR.EQ.1).AND.(LSP(2).EQ.2)) GOTO 31 X1=0. X2=1. X3=0. LT=MAX0(LSP(1),LSP(2))-1 PCSUBS=PCREL(J-L-LT) IL=1 IS=1 31 CONTINUE ELSE X1=0. X2=0. X3=1. ENDIF ELSEIF((J.GT.(L+IP)).AND.(J.LE.(L+IP+NREL))) THEN X1=0. X2=1. X3=0. LT=MAX0(LSP(1),LSP(2))+IP-1 PCSUBS=PCREL(J-L-LT+IL+1) IS=1 ELSE X1=0. X2=0. X3=0. ENDIF DPLAN=VALFIN(J)-VALFIN(J+1) REL(J)=X3*DZA(IR)+DPLAN*(X1*PCADS+X2*PCSUBS)/100. VALINI(J)=VALFIN(J)+REL(J) IF(IS.EQ.1) THEN NBR=0 DO JTYP=1,NAT NBAT=NTYP(JTYP) DO NUM=1,NBAT NBR=NBR+1 DIF=ABS(COORD(3,NBR)-VALFIN(J)) IF(DIF.LT.SMALL) THEN COORD(3,NBR)=VALINI(J) ENDIF ENDDO ENDDO ENDIF ENDDO C CALL ORDRE(NBZ1,VALINI,NFIN,VALFIN2) WRITE(IUO1,65) NFIN KZ(1)=0 KZ(2)=LSP(1) KZ(3)=MAX0(LSP(1),LSP(2)) DO KK=4,NFIN KZ(KK)=LS ENDDO DO JPLAN=1,NFIN IF(JPLAN.LE.L) THEN WRITE(IUO1,55) JPLAN,VALFIN(JPLAN),VALFIN2(JPLAN) VALINI(JPLAN)=VALFIN(JPLAN) ELSEIF((JPLAN.GT.L).AND.(JPLAN.LE.(L+LS))) THEN K=KZ(JPLAN-L) - INT((JPLAN-L)/2) IPLAN=JPLAN-K WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN) VALINI(JPLAN)=VALFIN(IPLAN) ELSEIF(JPLAN.GT.(L+LS)) THEN IPLAN=JPLAN-LS+IP WRITE(IUO1,55) JPLAN,VALFIN(IPLAN),VALFIN2(JPLAN) VALINI(JPLAN)=VALFIN(IPLAN) ENDIF ENDDO ENDIF C 30 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3, * ' BEFORE RELAXATION AND : ',F6.3,' AFTER') 55 FORMAT(/,26X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3, * ' BEFORE RELAXATION AND : ',F6.3,' AFTER') 65 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ') 70 FORMAT(//,44X,'THE SUMMATION IS PERFORMED OVER ',I2,' PLANES : ') C RETURN C END C C======================================================================= C SUBROUTINE ROTBAS(ROT) C C This routine calculates the basis vectors related to a surface C characterized by its Miller indices (IH,IK,II,IL) C USE MILLER_MOD USE OUTUNITS_MOD USE RESEAU_MOD USE VECSYS_MOD , A1 => ASYS, A2 => BSYS, A3 => CSYS C DIMENSION ROT(3,3),VECT(3,3),A1STAR(3),A2STAR(3),A3STAR(3),B1(3) DIMENSION VECT1(3),XNORM(3),CHBASE(3,3),VECT2(3,3) C C C DATA PI /3.141593/ C IF((NCRIST.EQ.8).AND.(IVG0.GE.1)) GOTO 7 XH=FLOAT(IH) XK=FLOAT(IK) XI=FLOAT(II) XL=FLOAT(IL) XI1=-XH-XK II1=INT(XI1) IF((NCRIST.EQ.7).AND.(XI.NE.XI1)) WRITE(IUO1,5) IH,IK,II1,IL 5 FORMAT(5X,'THE SURFACE INDICES ARE NOT CORRECT,',/,5X, 'FOR THE RE &ST OF THE CALCULATION, THEY ARE TAKEN AS ','(',I2,1X,I2,1X,I2,1X,I &2,')') CPR=1. CALL PRVECT(A2,A3,B1,CPR) OMEGA=PRSCAL(A1,B1)/(2.*PI) CALL PRVECT(A2,A3,A1STAR,OMEGA) CALL PRVECT(A3,A1,A2STAR,OMEGA) CALL PRVECT(A1,A2,A3STAR,OMEGA) DO 10 I=1,3 VECT1(I)=XH*A1STAR(I)+XK*A2STAR(I)+XL*A3STAR(I) 10 CONTINUE DO 15 I=1,3 ROT(I,3)=VECT1(I)/SQRT(PRSCAL(VECT1,VECT1)) 15 CONTINUE DO 20 I=1,3 CHBASE(I,1)=A1(I) CHBASE(I,2)=A2(I) CHBASE(I,3)=A3(I) DO 25 J=1,3 VECT(I,J)=0. 25 CONTINUE 20 CONTINUE XHKL=XH*XK*XL XHK=XH*XK XHL=XH*XL XKL=XK*XL IF(XHKL.NE.0.) THEN VECT(1,1)=-1./XH VECT(2,1)=1./XK VECT(1,2)=-1./XH VECT(3,2)=1./XL VECT(2,3)=-1./XK VECT(3,3)=1./XL ELSEIF(XHK.NE.0.) THEN VECT(1,1)=-1./XH VECT(2,1)=1./XK ELSEIF(XHL.NE.0.) THEN VECT(1,2)=-1./XH VECT(3,2)=1./XL ELSEIF(XKL.NE.0.) THEN VECT(2,3)=-1./XK VECT(3,3)=1./XL ELSEIF(XH.NE.0.) THEN VECT(2,2)=1./XH ELSEIF(XK.NE.0.) THEN VECT(3,3)=1./XK ELSEIF(XL.NE.0.) THEN VECT(1,1)=1./XL ENDIF CALL MULMAT(CHBASE,3,3,VECT,3,3,VECT2) DO 35 I=1,3 XNORM(I)=SQRT(VECT2(1,I)**2+VECT2(2,I)**2+VECT2(3,I)**2) 35 CONTINUE XMIN=AMIN1(XNORM(1),XNORM(2),XNORM(3)) XMAX=AMAX1(XNORM(1),XNORM(2),XNORM(3)) DO 40 I=1,3 IF(XHKL.NE.0.) THEN IF(ABS(XMIN-XNORM(I)).LT.0.0001) THEN DO 45 J=1,3 ROT(J,1)=VECT2(J,I)/XNORM(I) 45 CONTINUE ENDIF ELSE IF(ABS(XMAX-XNORM(I)).LT.0.0001) THEN DO 50 J=1,3 ROT(J,1)=VECT2(J,I)/XNORM(I) 50 CONTINUE ENDIF ENDIF 40 CONTINUE ROT(1,2)=ROT(2,3)*ROT(3,1)-ROT(3,3)*ROT(2,1) ROT(2,2)=ROT(3,3)*ROT(1,1)-ROT(3,1)*ROT(1,3) ROT(3,2)=ROT(1,3)*ROT(2,1)-ROT(2,3)*ROT(1,1) IF(NCRIST.EQ.7) THEN WRITE(IUO1,85) IH,IK,II1,IL ELSE WRITE(IUO1,80) IH,IK,IL ENDIF WRITE(IUO1,65) ROT(1,1),ROT(2,1),ROT(3,1) WRITE(IUO1,70) ROT(1,2),ROT(2,2),ROT(3,2) WRITE(IUO1,75) ROT(1,3),ROT(2,3),ROT(3,3) GOTO 37 7 DO 17 I=1,3 DO 27 J=1,3 ROT(I,J)=0. IF(I.EQ.J) ROT(I,J)=1. 27 CONTINUE 17 CONTINUE IF(IVG0.EQ.1) WRITE(IUO1,48) IF(IVG0.EQ.2) WRITE(IUO1,47) 47 FORMAT(//,25X,'LINEAR CHAIN STUDY ') 48 FORMAT(//,35X,'PLANE STUDY') 65 FORMAT(26X,'ISURF = (',F6.3,',',F6.3,',',F6.3,')') 70 FORMAT(26X,'JSURF = (',F6.3,',',F6.3,',',F6.3,')') 75 FORMAT(26X,'KSURF = (',F6.3,',',F6.3,',',F6.3,')') 80 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X, *I2,') :',/) 85 FORMAT(//,18X,'BASIS VECTORS FOR THE SURFACE (',I2,1X,I2,1X, *I2,1X,I2,') :',/) C 37 RETURN C END C C======================================================================= C SUBROUTINE RZB110(OMEGA,DY1,DY2,DZ1,DZ2) C A1=COS(OMEGA) ALPHA=SIN(OMEGA) BETA=A1-3. GAMMA=SQRT(3.)*(5./3.-A1) DELTA=SQRT(SQRT(3.)*(1./3.+A1)/GAMMA) CSA=SQRT(3.)*(-BETA-ALPHA*DELTA)/6. SNA=SQRT(1.-CSA*CSA) CSB=-SQRT(3.)*BETA/3. -CSA SNB=-SQRT(3.)*ALPHA/3. +SNA DY1=(SQRT(3.)*CSB-1.)/4. DY2=(1.-SQRT(3.)*CSA)/4. DZ1=(SQRT(3.)*SNB-SQRT(2.))/4. DZ2=(SQRT(3.)*SNA-SQRT(2.))/4. C RETURN C END C C======================================================================= C SUBROUTINE TEST1(COUPUR,NB1,NB2,ATOME,COORD,VAL,NBAT,IRE,NBZ) C USE DIM_MOD C DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M),VAL(NATCLU_M) DIMENSION IRE(NATCLU_M,2) C DIST2=0. DO 10 I=1,3 DIST2=DIST2+ATOME(I,NB1)*ATOME(I,NB1) 10 CONTINUE DIST=SQRT(DIST2) V=0.0001 IF((ATOME(3,NB1).LE.V).AND.(DIST.LE.COUPUR)) THEN NBAT=NBAT+1 NB2=NB2+1 IRE(NB1,1)=NB2 IRE(NB1,2)=NBAT DO 20 I=1,3 COORD(I,NB2)=ATOME(I,NB1) 20 CONTINUE IF(NBZ.EQ.0) THEN NBZ=NBZ+1 VAL(NBZ)=COORD(3,NB2) ELSE N1=0 DO N=1,NBZ D=ABS(COORD(3,NB2)-VAL(N)) IF(D.LT.0.0001) N1=N1+1 ENDDO IF(N1.EQ.0) THEN NBZ=NBZ+1 VAL(NBZ)=COORD(3,NB2) ENDIF ENDIF ENDIF C RETURN C END C C======================================================================= C SUBROUTINE TEST(NIV,ROT,NATYP,NBZ,NAT2,ISURF,COUP,*) C USE DIM_MOD C DIMENSION ATOME1(3,NATCLU_M),COORD1(3,NATCLU_M) DIMENSION IRE1(NATCLU_M,2),NATYP(NATM) DIMENSION NATYP1(NATM),VALZ1(NATCLU_M),ROT(3,3) C NMAX1=(2*NIV+3)**3 NV1=NIV+1 CALL AMAS(NV1,ATOME1,COORD1,VALZ1,ISURF,COUP,ROT,IRE1,NATYP1,NBZ,N &AT2,NCOUCH,NMAX1) DO 10 I=1,NAT2 IF(NATYP(I).NE.NATYP1(I)) RETURN 1 10 CONTINUE C RETURN C END C C======================================================================= C SUBROUTINE ARCSIN(U,CST,RANGLE) C C For a given complex number U, this subroutine calculates its phase C Warning : it is implicitely assumed that U = sin(theta) exp(i*phi) C with theta > or = to 0 which is always the case when theta is obtained C from the coordinates of a given vector r by the ACOS intrinsic function. C C When sin(theta) = 0, then phi = 0 if cos(theta) = 1 and pi if C cos(theta) = -1. Cos(theta) is the variable CST. C COMPLEX U,CANGLE C IF(CABS(U).LT.0.0001) THEN IF(CST.GT.0.) THEN RANGLE=0. ELSEIF(CST.LT.0.) THEN RANGLE=3.141593 ENDIF ELSE CANGLE=(0.,-1.)*CLOG(U/CABS(U)) RANGLE=REAL(CANGLE) ENDIF RETURN C END C C======================================================================= C SUBROUTINE ATDATA C C This routine contains the atomic mass and the density of all the C elements,and the equivalence between their atomic number and C chemical symbol. C C Value Z = 0 added for empty spheres. The values entered in this C case are arbitrary and set to the corresponding Z = 1 value C divided by 1836 (the ratio of the mass of the proton and electron). C C Last modified : 25 Apr 2013 C USE XMRHO_MOD , XM_AT => XMAT, RHO_AT => RHOAT REAL XMAT(0:99),RHOAT(0:99) C C DATA XMAT/0.00055,1.00794,4.00260,6.941,9.01218,10.81,12.011,14.00 &67,15.9994,18.998403,20.179,22.98977,24.305,26.98154,28.0855,30.97 &376,32.06,35.453,39.948,39.0983,40.08,44.9559,47.88,50.9415,51.996 &,54.9380,55.847,58.9332,58.69,63.546,65.38,69.72,72.59,74.9216,78. &96,79.904,83.80,85.4678,87.62,88.9059,91.22,92.9064,95.94,98.,101. &07,102.9055,106.42,107.8682,112.41,114.82,118.69,121.75,127.60,126 &.9045,131.29,132.9054,137.33,138.9055,140.12,140.9077,144.24,145., & * 150.36,151.96,157.25,158.9254,162.50,164.9304, * 167.26,168.9342,173.04,174.967,178.49,180.9479, * 183.85,186.207,190.2,192.22,195.08,196.9665, * 200.59,204.383,207.2,208.9804,209.,210.,222., * 223.,226.0254,227.0278,232.0381,231.0359, * 238.0289,237.0482,244.,243.,247.,247.,251.,252./ C DATA RHOAT/0.0007,0.0708,0.122,0.533,1.845,2.34,2.26,0.81,1.14,1.1 &08,1.207,0.969,1.735,2.6941,2.32,1.82,2.07,1.56,1.40,0.860,1.55,2. &980,4.53,6.10,7.18,7.43,7.860,8.9,8.876,8.94,7.112,5.877,5.307,5.7 &2,4.78,3.11,2.6,1.529,2.54,4.456,6.494,8.55,10.20,11.48,12.39,12.3 &9,12.00,10.48,8.63,7.30,7.30,6.679,6.23,4.92,3.52,1.870,3.5,6.127, &6.637,6.761,6.994,7.20,7.51,5.228,7.8772,8.214,8.525,8.769,9.039,9 &.294,6.953,9.811,13.29,16.624,19.3,20.98,22.53,22.39,21.41,18.85,1 &3.522,11.83,11.33, * 9.730,9.30,0.0,4.4,0.0,5.,10.05,11.70,15.34, * 18.92,20.21,19.80,13.64,13.49,14.,0.0,0.0/ C DO J=0,99 XM_AT(J)=XMAT(J) RHO_AT(J)=RHOAT(J) ENDDO C END C C======================================================================= C SUBROUTINE AUGER_MULT C C This subroutine computes all the possible multiplets that are C contained in a given Auger transition line. It assumes that C the atom has closed shells only. C C Last modified : 9 March 2006 C USE INIT_A_MOD , LI => LI_C, L2 => LI_I, L1 => LI_A USE OUTUNITS_MOD C CHARACTER*1 SC(0:1),LC(0:6),JC(0:7) CHARACTER*3 MULTIPLET(112) C DATA SC /'1','3'/ DATA LC /'S','P','D','F','G','H','I'/ DATA JC /'0','1','2','3','4','5','6','7'/ C WRITE(IUO1,10) N_MULT=0 DO NS=0,1 DO L=ABS(L1-L2),L1+L2 DO J=ABS(L-NS),L+NS N_MULT=N_MULT+1 MULTIPLET(N_MULT)=SC(NS)//LC(L)//JC(J) WRITE(IUO1,20) MULTIPLET(N_MULT) ENDDO ENDDO ENDDO C 10 FORMAT(///,26X,'THE POSSIBLE MULTIPLETS ARE :',/,' ') 20 FORMAT(58X,A3) C RETURN C END C C======================================================================= C SUBROUTINE BESPHE(NL,IBES,X1,FL) C C This routine computes the spherical Bessel functions for C a real argument X1. C C IBES=1 : Bessel function C IBES=2 : Neumann function C IBES=3 : Hankel function of the first kind C IBES=4 : Hankel function of the second kind C IBES=5 : Modified Bessel function C IBES=6 : Modified Neumann function C IBES=7 : Modified Hankel function C C Last modified : 8 Nov 2006 C C USE DIM_MOD USE OUTUNITS_MOD C IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2 COMPLEX*16 ZERO,CNORM C DOUBLE PRECISION SCALN(0:N_BESS) C REAL X1 C C ECH=37.D0 COMP=1.D37 COMM=1.D-37 X=DBLE(X1) NX=INT(X1) NREC=5*MAX0(NL-1,NX) IF(NREC.GT.N_BESS) GOTO 16 ITEST=0 ZERO=(0.D0,0.D0) UN=(1.D0,0.D0) C1=UN I=(0.D0,1.D0) C2=I DEB=1.D0 IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN IBES1=1 IF(IBES.EQ.4) C2=-I ELSEIF(IBES.EQ.7) THEN IBES1=5 C2=-UN ELSE IBES1=IBES ENDIF C C Case where the argument is zero C IF(DABS(X).LT.0.000001D0) THEN IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN FL(0)=UN DO 10 L=1,NL-1 FL(L)=ZERO 10 CONTINUE ITEST=1 ELSE ITEST=-1 ENDIF ENDIF IF(ITEST) 11,12,13 11 WRITE(IUO1,14) STOP 16 WRITE(IUO1,17) NREC STOP 15 IBES1=IBES1+1 C C Initial values C 12 A=-1.D0 B=1.D0 IF(IBES1.EQ.1) THEN FL(0)=UN*DSIN(X)/X FLNN(NREC)=ZERO SCALN(NREC)=0.D0 FLNN(NREC-1)=UN*DEB SCALN(NREC-1)=0.D0 ELSEIF(IBES1.EQ.2) THEN GL(0)=-UN*DCOS(X)/X GL(1)=GL(0)/X -DSIN(X)/X ELSEIF(IBES1.EQ.5) THEN A=1.D0 B=-1.D0 FL(0)=UN*DSINH(X)/X FLNN(NREC)=ZERO SCALN(NREC)=0.D0 FLNN(NREC-1)=UN*DEB SCALN(NREC-1)=0.D0 ELSEIF(IBES1.EQ.6) THEN A=1.D0 B=-1.D0 GL(0)=UN*DCOSH(X)/X GL(1)=(DSINH(X)-GL(0))/X ENDIF C C Downward reccurence for the spherical Bessel function C IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN DO 30 L=NREC-1,1,-1 ECHEL=0.D0 SCALN(L-1)=SCALN(L) REN=DEXP(SCALN(L)-SCALN(L+1)) FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X) IF(CDABS(FLNN(L-1)).GT.COMP) THEN ECHEL=-ECH ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN ECHEL=ECH ENDIF IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1) FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL) 30 CONTINUE CNORM=FL(0)/FLNN(0) DO 40 L=1,NL-1 FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L)) 40 CONTINUE ELSE C C Upward recurrence for the spherical Neumann function C DO 20 L=1,NL-1 IF(IBES.EQ.7) C1=(-UN)**(L+2) GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X IF(IBES1.NE.IBES) THEN C C Calculation of the spherical Hankel function C FL(L+1)=C1*(FL(L+1)+C2*GL(L+1)) ELSE FL(L+1)=GL(L+1) ENDIF 20 CONTINUE IF(IBES1.EQ.IBES) THEN FL(0)=GL(0) FL(1)=GL(1) ELSE FL(0)=C1*(FL(0)+C2*GL(0)) FL(1)=C1*(FL(1)+C2*GL(1)) ENDIF IBES1=IBES ENDIF IF(IBES.NE.IBES1) GOTO 15 C 13 RETURN C 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION &S IS NUL >>>>>>>>>>') 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL &D BE AT LEAST : ',I5,' >>>>>>>>>>') C END C C======================================================================= C SUBROUTINE BESPHE2(NL,IBES,X,FL) C C This routine computes the spherical Bessel functions for C a real argument X1. C C IBES=1 : Bessel function C IBES=2 : Neumann function C IBES=3 : Hankel function of the first kind C IBES=4 : Hankel function of the second kind C IBES=5 : Modified Bessel function C IBES=6 : Modified Neumann function C IBES=7 : Modified Hankel function C C Last modified : 8 Nov 2006 C C USE DIM_MOD USE OUTUNITS_MOD C IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMPLEX*16 FL(0:2*NL_M),FLNN(0:N_BESS),GL(0:N_BESS),UN,I,C1,C2 COMPLEX*16 ZERO,CNORM C DOUBLE PRECISION SCALN(0:N_BESS) C C ECH=37.D0 COMP=1.D37 COMM=1.D-37 NX=INT(X) NREC=5*MAX0(NL-1,NX) IF(NREC.GT.N_BESS) GOTO 16 ITEST=0 ZERO=(0.D0,0.D0) UN=(1.D0,0.D0) C1=UN I=(0.D0,1.D0) C2=I DEB=1.D0 IF((IBES.EQ.3).OR.(IBES.EQ.4)) THEN IBES1=1 IF(IBES.EQ.4) C2=-I ELSEIF(IBES.EQ.7) THEN IBES1=5 C2=-UN ELSE IBES1=IBES ENDIF C C Case where the argument is zero C IF(DABS(X).LT.0.000001D0) THEN IF((IBES.EQ.1).OR.(IBES.EQ.5)) THEN FL(0)=UN DO 10 L=1,NL-1 FL(L)=ZERO 10 CONTINUE ITEST=1 ELSE ITEST=-1 ENDIF ENDIF IF(ITEST) 11,12,13 11 WRITE(IUO1,14) STOP 16 WRITE(IUO1,17) NREC STOP 15 IBES1=IBES1+1 C C Initial values C 12 A=-1.D0 B=1.D0 IF(IBES1.EQ.1) THEN FL(0)=UN*DSIN(X)/X FLNN(NREC)=ZERO SCALN(NREC)=0.D0 FLNN(NREC-1)=UN*DEB SCALN(NREC-1)=0.D0 ELSEIF(IBES1.EQ.2) THEN GL(0)=-UN*DCOS(X)/X GL(1)=GL(0)/X -DSIN(X)/X ELSEIF(IBES1.EQ.5) THEN A=1.D0 B=-1.D0 FL(0)=UN*DSINH(X)/X FLNN(NREC)=ZERO SCALN(NREC)=0.D0 FLNN(NREC-1)=UN*DEB SCALN(NREC-1)=0.D0 ELSEIF(IBES1.EQ.6) THEN A=1.D0 B=-1.D0 GL(0)=UN*DCOSH(X)/X GL(1)=(DSINH(X)-GL(0))/X ENDIF C C Downward reccurence for the spherical Bessel function C IF((IBES1.EQ.1).OR.(IBES1.EQ.5)) THEN DO 30 L=NREC-1,1,-1 ECHEL=0.D0 SCALN(L-1)=SCALN(L) REN=DEXP(SCALN(L)-SCALN(L+1)) FLNN(L-1)=A*(REN*FLNN(L+1)-B*DFLOAT(2*L+1)*FLNN(L)/X) IF(CDABS(FLNN(L-1)).GT.COMP) THEN ECHEL=-ECH ELSEIF(CDABS(FLNN(L-1)).LT.COMM) THEN ECHEL=ECH ENDIF IF(ECHEL.NE.0.D0 ) SCALN(L-1)=ECHEL+SCALN(L-1) FLNN(L-1)=FLNN(L-1)*DEXP(ECHEL) 30 CONTINUE CNORM=FL(0)/FLNN(0) DO 40 L=1,NL-1 FL(L)=CNORM*FLNN(L)*DEXP(SCALN(0)-SCALN(L)) 40 CONTINUE ELSE C C Upward recurrence for the spherical Neumann function C DO 20 L=1,NL-1 IF(IBES.EQ.7) C1=(-UN)**(L+2) GL(L+1)=A*GL(L-1)+B*DFLOAT(2*L+1)*GL(L)/X IF(IBES1.NE.IBES) THEN C C Calculation of the spherical Hankel function C FL(L+1)=C1*(FL(L+1)+C2*GL(L+1)) ELSE FL(L+1)=GL(L+1) ENDIF 20 CONTINUE IF(IBES1.EQ.IBES) THEN FL(0)=GL(0) FL(1)=GL(1) ELSE FL(0)=C1*(FL(0)+C2*GL(0)) FL(1)=C1*(FL(1)+C2*GL(1)) ENDIF IBES1=IBES ENDIF IF(IBES.NE.IBES1) GOTO 15 C 13 RETURN C 14 FORMAT(/////,3X,'<<<<<<<<<< THE ARGUMENT OF THE BESSEL ','FUNCTION &S IS NUL >>>>>>>>>>') 17 FORMAT(/////,3X,'<<<<<<<<<< THE DIMENSIONNING N_BESS ','IS NOT COR &RECT FOR SUBROUTINE BESPHE >>>>>>>>>>',//,15X,'<<<<<<<<<< IT SHOUL &D BE AT LEAST : ',I5,' >>>>>>>>>>') C END C C======================================================================= C SUBROUTINE CHECK_VIB(NAT2) C C This subroutines checks the geometrical environment of each atom C to identify those which can move "freely" in one direction, in C order to see whether the mean square displacement in this C direction is of bulk type or surface type C C An atom is considered to move freely in one direction if no other C atom is present in the tetragonal cell of height ALENGTH * A C and base edge 2 * A, whose base is centered on the atom considered C C Only prototypical atoms are considered as all equivalent atoms are C in the same geometrical environment C C Surface-like atoms are then identified as having I_FREE = 1 C C Last modified : 24 Apr 2013 C USE DIM_MOD C USE COOR_MOD , COORD => SYM_AT USE OUTUNITS_MOD USE VIBRAT_MOD C INTEGER NSUR(NATP_M) C DATA SMALL /0.0001/ C ALENGTH=4. C C.................... Checking the z direction .................... C WRITE(IUO1,11) N_SUR=0 C C Loop on the prototypical atoms C DO JTYP=1,N_PROT C I_FREE(JTYP)=0 JAT0=NCORR(1,JTYP) XA=COORD(1,JAT0) YA=COORD(2,JAT0) ZA=COORD(3,JAT0) C C Loop on the surrounding atoms C I_ACC=0 C DO JAT=1,NAT2 C IF(JAT.EQ.JAT0) GOTO 10 C X=COORD(1,JAT) Y=COORD(2,JAT) Z=COORD(3,JAT) C C Considering only atoms with Z > ZA C IF(Z.LT.(ZA+SMALL)) GOTO 10 C C Lateral and vertical distances between the two atoms C D_LAT=(X-XA)*(X-XA)+(Y-YA)*(Y-YA) D_VER=(Z-ZA)*(Z-ZA) C IF(D_VER.LT.(ALENGTH+SMALL)) THEN IF(D_LAT.LT.(1.+SMALL)) THEN I_ACC=I_ACC+1 ENDIF ENDIF C IF(I_ACC.GE.1) GOTO 10 C 10 CONTINUE C ENDDO C IF(I_ACC.EQ.0) THEN I_FREE(JTYP)=1 N_SUR=N_SUR+1 NSUR(N_SUR)=JTYP ENDIF C ENDDO C WRITE(IUO1,12) (NSUR(J),J=1,N_SUR) C 11 FORMAT(//,18X,'SURFACE-LIKE ATOMS FOR MSD CALCULATIONS: ',/) 12 FORMAT(20X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5,2X,I5) C RETURN C END C C======================================================================= C SUBROUTINE DJMN(RBETA,R,LMAX) C C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to C order LMAX, following Messiah's convention. C They are stored as R(M2,M1,L). C C Last modified : 20 Oct 2006 C USE DIM_MOD C USE COEFRLM_MOD USE EXPROT_MOD C INTEGER EPS0 C DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) C DATA SMALL,SQR2 /0.001,1.4142136/ C C=COS(RBETA)*0.5 S=SIN(RBETA)*0.5 CC=C+C CMUL=-1. IF(ABS(S).LT.SMALL) THEN IF(C.GT.0.) EPS0=1 IF(C.LT.0.) EPS0=-1 DO L=0,LMAX DO M1=-L,L DO M2=-L,L IF(M1.NE.M2*EPS0) THEN R(M2,M1,L)=0. ELSE IF(EPS0.EQ.1) THEN R(M2,M1,L)=1. ELSE IF(MOD(L+M1,2).EQ.0) THEN R(M2,M1,L)=1. ELSE R(M2,M1,L)=-1. ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO ELSE S1=S*SQR2 C1=0.5+C R(0,0,0)=1.0 R(-1,-1,1)=C1 R(0,-1,1)=S1 R(1,-1,1)=1.-C1 R(-1,0,1)=-S1 R(0,0,1)=CC R(1,0,1)=S1 R(-1,1,1)=1.-C1 R(0,1,1)=-S1 R(1,1,1)=C1 C PRODL=-S COEF=-S/C1 CL=-1. DO L=2,LMAX CL=-CL L1=L-1 FLL1=CC*FLOAT(L+L1) FLL2=1./(FLOAT(L*L1)*CC) PRODL=-PRODL*S C C Case M = 0 C R_1=EXPR(0,L)*PRODL R(-L,0,L)=R_1 C R(L,0,L)=R_1*CL R(0,-L,L)=R_1*CL C R(0,L,L)=R_1 C CM2=CL DO M2=-L1,-1 CM2=CM2*CMUL CF1=CF(L1,0,-M2)/FLL1 CF2=FLL1/CF(L,0,-M2) IF(-M2.LT.L1) THEN R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1) ELSE R_A=CF2*R(M2,0,L1) ENDIF C R(M2,0,L)=R_A C R(-M2,0,L)=R_A*CM2 R(0,M2,L)=R_A*CM2 C R(0,-M2,L)=R_A C ENDDO C R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0 &,0) C C Case M > 0 C PRODM=1. CM=CL FLLM=0. DO M=1,L1 CM=-CM PRODM=PRODM*COEF FLLM=FLLM+FLL2 C R_1=EXPR(M,L)*PRODL*PRODM R_2=R_1/(PRODM*PRODM) C R(-L,M,L)=R_1 R(-L,-M,L)=R_2 C R(L,-M,L)=R_1*CM R(M,-L,L)=R_1*CM R(L,M,L)=R_2*CM R(-M,-L,L)=R_2*CM C R(-M,L,L)=R_1 R(M,L,L)=R_2 C CM2=CM DO M2=-L1,-M CM2=-CM2 D0=FLOAT(M2)*FLLM CF1=CF(L1,M,-M2)/FLL1 CF2=FLL1/CF(L,M,-M2) IF((M.LT.L1).AND.(-M2.LT.L1)) THEN R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1) R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1) ELSE R_A=CF2*(1.-D0)*R(M2,M,L1) R_B=CF2*(1.+D0)*R(M2,-M,L1) ENDIF C R(M2,M,L)=R_A R(M2,-M,L)=R_B C R(-M2,-M,L)=R_A*CM2 R(M,M2,L)=R_A*CM2 R(-M,M2,L)=R_B*CM2 R(-M2,M,L)=R_B*CM2 C R(-M,-M2,L)=R_A R(M,-M2,L)=R_B C ENDDO ENDDO C PRODM=PRODM*COEF R_1=PRODL*PRODM R_2=PRODL/PRODM R(-L,L,L)=R_1 R(L,-L,L)=R_1 R(L,L,L)=R_2 R(-L,-L,L)=R_2 C ENDDO ENDIF C RETURN C END C C======================================================================= C SUBROUTINE DJMN2(RBETA,R,LMAX,ISWITCH) C C This routine calculates Wigner rotation matrices R^{L}_{M1 M2} up to C order LMAX, following Messiah's convention. C They are stored as R(M2,M1,L) and multiplied (ISWITCH=1) or divided C by EXPF. C C Last modified : 20 Oct 2006 C USE DIM_MOD C USE COEFRLM_MOD USE EXPFAC_MOD USE EXPROT_MOD C INTEGER EPS0 C DIMENSION R(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) C DATA SMALL,SQR2 /0.001,1.4142136/ C C=COS(RBETA)*0.5 S=SIN(RBETA)*0.5 CC=C+C CMUL=-1. IF(ABS(S).LT.SMALL) THEN IF(C.GT.0.) EPS0=1 IF(C.LT.0.) EPS0=-1 DO L=0,LMAX DO M1=-L,L DO M2=-L,L IF(M1.NE.M2*EPS0) THEN R(M2,M1,L)=0. ELSE IF(EPS0.EQ.1) THEN R(M2,M1,L)=1. ELSE IF(MOD(L+M1,2).EQ.0) THEN R(M2,M1,L)=1. ELSE R(M2,M1,L)=-1. ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO ELSE S1=S*SQR2 C1=0.5+C R(0,0,0)=1.0 R(-1,-1,1)=C1 R(0,-1,1)=S1 R(1,-1,1)=1.-C1 R(-1,0,1)=-S1 R(0,0,1)=CC R(1,0,1)=S1 R(-1,1,1)=1.-C1 R(0,1,1)=-S1 R(1,1,1)=C1 C PRODL=-S COEF=-S/C1 CL=-1. DO L=2,LMAX CL=-CL L1=L-1 FLL1=CC*FLOAT(L+L1) FLL2=1./(FLOAT(L*L1)*CC) PRODL=-PRODL*S C C Case M = 0 C R_1=EXPR(0,L)*PRODL R(-L,0,L)=R_1 C R(L,0,L)=R_1*CL R(0,-L,L)=R_1*CL C R(0,L,L)=R_1 C CM2=CL DO M2=-L1,-1 CM2=CM2*CMUL CF1=CF(L1,0,-M2)/FLL1 CF2=FLL1/CF(L,0,-M2) IF(-M2.LT.L1) THEN R_A=CF2*(R(M2,0,L1)-R(M2,0,L-2)*CF1) ELSE R_A=CF2*R(M2,0,L1) ENDIF C R(M2,0,L)=R_A C R(-M2,0,L)=R_A*CM2 R(0,M2,L)=R_A*CM2 C R(0,-M2,L)=R_A C ENDDO C R(0,0,L)=FLL1*R(0,0,L1)/CF(L,0,0)-R(0,0,L-2)*CF(L1,0,0)/CF(L,0 &,0) C C Case M > 0 C PRODM=1. CM=CL FLLM=0. DO M=1,L1 CM=-CM PRODM=PRODM*COEF FLLM=FLLM+FLL2 C R_1=EXPR(M,L)*PRODL*PRODM R_2=R_1/(PRODM*PRODM) C R(-L,M,L)=R_1 R(-L,-M,L)=R_2 C R(L,-M,L)=R_1*CM R(M,-L,L)=R_1*CM R(L,M,L)=R_2*CM R(-M,-L,L)=R_2*CM C R(-M,L,L)=R_1 R(M,L,L)=R_2 C CM2=CM DO M2=-L1,-M CM2=-CM2 D0=FLOAT(M2)*FLLM CF1=CF(L1,M,-M2)/FLL1 CF2=FLL1/CF(L,M,-M2) IF((M.LT.L1).AND.(-M2.LT.L1)) THEN R_A=CF2*((1.-D0)*R(M2,M,L1)-R(M2,M,L-2)*CF1) R_B=CF2*((1.+D0)*R(M2,-M,L1)-R(M2,-M,L-2)*CF1) ELSE R_A=CF2*(1.-D0)*R(M2,M,L1) R_B=CF2*(1.+D0)*R(M2,-M,L1) ENDIF C R(M2,M,L)=R_A R(M2,-M,L)=R_B C R(-M2,-M,L)=R_A*CM2 R(M,M2,L)=R_A*CM2 R(-M,M2,L)=R_B*CM2 R(-M2,M,L)=R_B*CM2 C R(-M,-M2,L)=R_A R(M,-M2,L)=R_B C ENDDO ENDDO C PRODM=PRODM*COEF R_1=PRODL*PRODM R_2=PRODL/PRODM R(-L,L,L)=R_1 R(L,-L,L)=R_1 R(L,L,L)=R_2 R(-L,-L,L)=R_2 C ENDDO ENDIF C IF(ISWITCH.EQ.1) THEN DO L=0,LMAX DO M1=-L,L DO M2=-L,L R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)*EXPF(ABS(M2),L) ENDDO ENDDO ENDDO ELSEIF(ISWITCH.EQ.2) THEN DO L=0,LMAX DO M1=-L,L DO M2=-L,L R(M2,M1,L)=SQRT(FLOAT(L+L+1))*R(M2,M1,L)/EXPF(ABS(M2),L) ENDDO ENDDO ENDDO ENDIF C RETURN C END C C======================================================================= C SUBROUTINE EMETT(JEM,IEMET,Z,COORD,NATYP,EMET,NM,JNEM,*) C C This routine looks for the position of an absorber of type IEMET(JEM) C situated in the plane at Z. The result is stored in EMET(3) C USE DIM_MOD C DIMENSION IEMET(NEMET_M) DIMENSION EMET(3),DIST(NATCLU_M),COORD(3,NATCLU_M),NATYP(NATM) C KEMET=0 JNT=0 IEM=IEMET(JEM) IF(IEM.GT.1) THEN DO JTP=1,IEM-1 JNT=JNT+NATYP(JTP) ENDDO ENDIF NB=NATYP(IEM) XMIN=1000000. C DO J=1,NB JN=J+JNT DELTAZ=ABS(COORD(3,JN)-Z) IF(DELTAZ.LT.0.0001) THEN XX=COORD(1,JN) XY=COORD(2,JN) XZ=COORD(3,JN) DIST(J)=SQRT(XX*XX+XY*XY+XZ*XZ) IF(DIST(J).LT.XMIN) THEN XMIN=DIST(J) NM=IEM JNEM=J DO I=1,3 EMET(I)=COORD(I,JN) ENDDO ENDIF KEMET=KEMET+1 ENDIF ENDDO C IF(KEMET.EQ.0) THEN NM=IEM RETURN 1 ENDIF C RETURN C END C C======================================================================= C SUBROUTINE EULER(RTHETA1,RPHI1,RTHETA2,RPHI2,RALPHA,RBETA,RGAMMA,I &ROT) C C This routine calculates the Euler angles RALPHA,RBETA,RGAMMA corresponding C to the rotation r1(RTHETA1,RPHI1) ----> r2(RTHETA2,RPHI2) C C IROT=1 : r ---> z represented by (0,RTHETA,PI-RPHI) C IROT=0 : r ---> z represented by (0,-RTHETA,-RPHI) C C COMPLEX U1,U2 C DATA PI /3.141593/ C IF(IROT.EQ.1) THEN EPS=1 ELSE EPS=-1 ENDIF DPHI=RPHI2-RPHI1 A1=SIN(RTHETA1)*COS(RTHETA2) A2=COS(RTHETA1)*SIN(RTHETA2) A3=COS(RTHETA1)*COS(RTHETA2) A4=SIN(RTHETA1)*SIN(RTHETA2) U1=A1-A2*COS(DPHI)-(0.,1.)*SIN(RTHETA2)*SIN(DPHI) U2=A1*COS(DPHI)-A2+(0.,1.)*SIN(RTHETA1)*SIN(DPHI) U3=A3+A4*COS(DPHI) IF(U3.GT.1.) U3=1. IF(U3.LT.-1.) U3=-1. RBETA=ACOS(U3) IF(ABS(SIN(RBETA)).GT.0.0001) THEN U1=EPS*U1/SIN(RBETA) U2=EPS*U2/SIN(RBETA) CALL ARCSIN(U1,U3,RALPHA) CALL ARCSIN(U2,U3,RGAMMA) ELSE RALPHA=0. IF(ABS(U3-1.0).LT.0.0001) THEN RGAMMA=0. ELSE RGAMMA=PI ENDIF ENDIF C RETURN C END C C======================================================================= C SUBROUTINE GAUNT(L2,M2,L1,M1,GNT) C C This subroutine calculates the Gaunt coefficient G(L2,L3|L1) C using a downward recursion scheme due to Schulten and Gordon C for the Wigner's 3j symbols. The result is stored as GNT(L3), C making use of the selection rule M3 = M1 - M2. C C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975) C C Last modified : 8 Dec 2008 C C USE DIM_MOD USE LOGAMAD_MOD C IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL GNT(0:N_GAUNT) C DOUBLE PRECISION F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT) DOUBLE PRECISION A1(0:N_GAUNT),B(0:N_GAUNT) C C DATA PI4/12.566370614359D0/ C L12=L1+L2 K12=L1-L2 C DO J=1,N_GAUNT GNT(J)=0. ENDDO C IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10 C M3=M1-M2 LM1=L1+M1 LM2=L2+M2 KM1=L1-M1 KM2=L2-M2 C IF(MOD(M1,2).EQ.0) THEN COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) ELSE COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) ENDIF C F(L12+1)=0.D0 G(L12+1)=0.D0 A(L12+1)=0.D0 A1(L12+1)=0.D0 D1=GLD(2*L2+1,1)-GLD(2*L12+2,1) D2=GLD(2*L1+1,1)-GLD(LM2+1,1) D3=GLD(L12+M3+1,1)-GLD(KM2+1,1) D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1) C IF(MOD(KM1-KM2,2).EQ.0) THEN F(L12)=DSQRT(DEXP(D1+D2+D3+D4)) ELSE F(L12)=-DSQRT(DEXP(D1+D2+D3+D4)) ENDIF C D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1)) D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1) C IF(MOD(K12,2).EQ.0) THEN G(L12)=DEXP(D5+D6) ELSE G(L12)=-DEXP(D5+D6) ENDIF C A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3))) B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1) &)) A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12))) C IF(ABS(M3).LE.L12) THEN GNT(L12)=SNGL(COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1))) ELSE GNT(L12)=0. ENDIF C JMIN=MAX0(ABS(K12),ABS(M3)) C DO J=L12-1,JMIN,-1 J1=J+1 J2=J+2 A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL &OAT(J*J-M3*M3)) B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1))) A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J) &)) F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1)) G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1)) GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1)) C IF(ABS(M3).LE.J) THEN GNT(J)=SNGL(GND) ELSE GNT(J)=0. ENDIF C ENDDO C 10 RETURN C END C C======================================================================= C SUBROUTINE GAUNT2(L2,M2,L1,M1,GNT) C C This subroutine calculates the Gaunt coefficient G(L2,L3|L1) C using a downward recursion scheme due to Schulten and Gordon C for the Wigner's 3j symbols. The result is stored as GNT(L3), C making use of the selection rule M3 = M1 - M2. C C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975) C C Last modified : 8 Dec 2008 C This is the double precision version C C C USE DIM_MOD USE LOGAMAD_MOD C IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL*8 F(0:N_GAUNT),G(0:N_GAUNT),A(0:N_GAUNT),A1(0:N_GAUNT) REAL*8 B(0:N_GAUNT),GNT(0:N_GAUNT) C C DATA PI4/12.566370614359D0/ C L12=L1+L2 K12=L1-L2 C DO J=1,N_GAUNT GNT(J)=0.D0 ENDDO C IF((ABS(M1).GT.L1).OR.(ABS(M2).GT.L2)) GOTO 10 C M3=M1-M2 LM1=L1+M1 LM2=L2+M2 KM1=L1-M1 KM2=L2-M2 C IF(MOD(M1,2).EQ.0) THEN COEF=DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) ELSE COEF=-DSQRT(DFLOAT((2*L1+1)*(2*L2+1))/PI4) ENDIF C F(L12+1)=0.D0 G(L12+1)=0.D0 A(L12+1)=0.D0 A1(L12+1)=0.D0 D1=GLD(2*L2+1,1)-GLD(2*L12+2,1) D2=GLD(2*L1+1,1)-GLD(LM2+1,1) D3=GLD(L12+M3+1,1)-GLD(KM2+1,1) D4=GLD(L12-M3+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1) C IF(MOD(KM1-KM2,2).EQ.0) THEN F(L12)=DSQRT(DEXP(D1+D2+D3+D4)) ELSE F(L12)=-DSQRT(DEXP(D1+D2+D3+D4)) ENDIF C D5=0.5D0*(GLD(2*L1+1,1)+GLD(2*L2+1,1)-GLD(2*L12+2,1)) D6=GLD(L12+1,1)-GLD(L1+1,1)-GLD(L2+1,1) C IF(MOD(K12,2).EQ.0) THEN G(L12)=DEXP(D5+D6) ELSE G(L12)=-DEXP(D5+D6) ENDIF C A(L12)=2.D0*DSQRT(DFLOAT(L1*L2*(1+2*L12)*(L12*L12-M3*M3))) B(L12)=-DFLOAT((2*L12+1)*((L2*L2-L1*L1-K12)*M3+L12*(L12+1)*(M2+M1) &)) A1(L12)=2.D0*DFLOAT(L12)*DSQRT(DFLOAT(L1*L2*(1+2*L12))) C IF(ABS(M3).LE.L12) THEN GNT(L12)=COEF*F(L12)*G(L12)*DSQRT(DFLOAT(2*L12+1)) ELSE GNT(L12)=0.D0 ENDIF C JMIN=MAX0(ABS(K12),ABS(M3)) C DO J=L12-1,JMIN,-1 J1=J+1 J2=J+2 A(J)=DSQRT(DFLOAT((J*J-K12*K12))*DFLOAT((L12+1)*(L12+1)-J*J)*DFL &OAT(J*J-M3*M3)) B(J)=-DFLOAT((2*J+1)*(L2*(L2+1)*M3-L1*(L1+1)*M3+J*J1*(M2+M1))) A1(J)=DFLOAT(J)*DSQRT(DFLOAT((J*J-K12*K12)*((L12+1)*(L12+1)-J*J) &)) F(J)=-(DFLOAT(J1)*A(J2)*F(J2)+B(J1)*F(J1))/(DFLOAT(J2)*A(J1)) G(J)=-(DFLOAT(J1)*A1(J2)*G(J2))/(DFLOAT(J2)*A1(J1)) GND=COEF*F(J)*G(J)*DSQRT(DFLOAT(2*J+1)) C IF(ABS(M3).LE.J) THEN GNT(J)=GND ELSE GNT(J)=0.D0 ENDIF C ENDDO C 10 RETURN C END C C======================================================================= C SUBROUTINE HARSPH(NL,THETA,PHI,YLM,NC) C C This routine computes the complex spherical harmonics using Condon and C Shortley phase convention. C USE DIM_MOD C USE EXPFAC2_MOD USE FACTSQ_MOD C COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C C DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ DATA PI,SMALL /3.141593,0.0001/ C X=COS(THETA) IF(ABS(X).LT.SMALL) X=0.0 IF(ABS(X+1.).LT.SMALL) X=-1.0 IF(ABS(X-1.).LT.SMALL) X=1.0 C YLM(0,0)=CMPLX(SQ4PI_INV) YLM(1,0)=X*SQR3_INV DO L=2,NC Y=1./FLOAT(L) YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) &-1.5))*YLM(L-2,0) ENDDO C C2=-1. IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) ELSE C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) ENDIF C C1=1. COEF=(1.,0.) DO M=1,NC C1=C1*C2 COEF=COEF*C YMM=SQ4PI_INV*COEF*FSQ(M) YLM(M,M)=YMM YLM(M,-M)=C1*CONJG(YMM) YMMP=X*SQRT(FLOAT(M+M+3))*YMM YLM(M+1,M)=YMMP YLM(M+1,-M)=C1*CONJG(YMMP) IF(M.LT.NC-1) THEN DO L=M+2,NC YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2( &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M)) YLM(L,-M)=C1*CONJG(YLM(L,M)) ENDDO ENDIF ENDDO C RETURN C END C C======================================================================= C SUBROUTINE HARSPH2(NL,THETA,PHI,YLM,NC) C C This routine computes the complex spherical harmonics using Condon and C Shortley phase convention. This version for m=0 only C USE DIM_MOD C USE EXPFAC2_MOD USE FACTSQ_MOD C COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C C DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ DATA PI,SMALL /3.141593,0.0001/ C X=COS(THETA) IF(ABS(X).LT.SMALL) X=0.0 IF(ABS(X+1.).LT.SMALL) X=-1.0 IF(ABS(X-1.).LT.SMALL) X=1.0 C YLM(0,0)=CMPLX(SQ4PI_INV) YLM(1,0)=X*SQR3_INV DO L=2,NC Y=1./FLOAT(L) YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) &-1.5))*YLM(L-2,0) ENDDO C RETURN C END C C======================================================================= C SUBROUTINE HARSPH3(NL,THETA,PHI,YLM2,NC) C C This routine computes the complex spherical harmonics using Condon and C Shortley phase convention. C USE DIM_MOD C USE EXPFAC2_MOD USE FACTSQ_MOD C COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C COMPLEX YLM2(LINMAX) C DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ DATA PI,SMALL /3.141593,0.0001/ C X=COS(THETA) IF(ABS(X).LT.SMALL) X=0.0 IF(ABS(X+1.).LT.SMALL) X=-1.0 IF(ABS(X-1.).LT.SMALL) X=1.0 C YLM(0,0)=CMPLX(SQ4PI_INV) YLM(1,0)=X*SQR3_INV DO L=2,NC Y=1./FLOAT(L) YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) &-1.5))*YLM(L-2,0) ENDDO C C2=-1. IF((THETA.GE.0.).AND.(THETA.LE.PI)) THEN C=-0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) ELSE C=0.5*SQRT(1.-X*X)*EXP((0.,1.)*PHI) ENDIF C C1=1. COEF=(1.,0.) DO M=1,NC C1=C1*C2 COEF=COEF*C YMM=SQ4PI_INV*COEF*FSQ(M) YLM(M,M)=YMM YLM(M,-M)=C1*CONJG(YMM) YMMP=X*SQRT(FLOAT(M+M+3))*YMM YLM(M+1,M)=YMMP YLM(M+1,-M)=C1*CONJG(YMMP) IF(M.LT.NC-1) THEN DO L=M+2,NC YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2( &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M)) YLM(L,-M)=C1*CONJG(YLM(L,M)) ENDDO ENDIF ENDDO C DO L=0,NC IL=L*L+L+1 DO M=-L,L IND=IL+M YLM2(IND)=YLM(L,M) ENDDO ENDDO C RETURN C END C C======================================================================= C SUBROUTINE HEADERS(IUO2) C C This subroutine writes headers containing the main parameters C of the calculation in the result file. The number of C lines written depends of the spectroscopy C C Last modified : 31 Jan 2013 C USE DIM_MOD C USE ALGORITHM_MOD USE APPROX_MOD USE EXAFS_MOD USE HEADER_MOD USE INFILES_MOD USE INIT_A_MOD USE INIT_J_MOD USE INIT_L_MOD USE INIT_M_MOD USE MOYEN_MOD USE PARCAL_MOD USE PARCAL_A_MOD USE TYPCAL_MOD USE TYPCAL_A_MOD USE TYPEXP_MOD USE VALIN_MOD USE VALIN_AV_MOD USE VALFIN_MOD USE VALEX_A_MOD C C C C C C C C C C C WRITE(IUO2,1) WRITE(IUO2,2) C C Input files section: C C Checking the size of filenames C N_CHAR1=0 DO J_CHAR=1,24 IF(INFILE1(J_CHAR:J_CHAR).EQ.' ') GOTO 500 N_CHAR1=N_CHAR1+1 ENDDO 500 CONTINUE C N_CHAR2=0 DO J_CHAR=1,24 IF(INFILE2(J_CHAR:J_CHAR).EQ.' ') GOTO 501 N_CHAR2=N_CHAR2+1 ENDDO 501 CONTINUE C N_CHAR3=0 DO J_CHAR=1,24 IF(INFILE3(J_CHAR:J_CHAR).EQ.' ') GOTO 502 N_CHAR3=N_CHAR3+1 ENDDO 502 CONTINUE C N_CHAR4=0 DO J_CHAR=1,24 IF(INFILE4(J_CHAR:J_CHAR).EQ.' ') GOTO 503 N_CHAR4=N_CHAR4+1 ENDDO 503 CONTINUE C WRITE(IUO2,3) INFILE1(6:N_CHAR1) WRITE(IUO2,4) INFILE2(4:N_CHAR2) IF(INTERACT.NE.'NOINTER') THEN WRITE(IUO2,5) INFILE3(5:N_CHAR3) ENDIF WRITE(IUO2,6) INFILE4(6:N_CHAR4) WRITE(IUO2,2) C C Type of calculation C WRITE(IUO2,2) C IF(SPECTRO.EQ.'PHD') THEN WRITE(IUO2,11) SPECTRO,ALGO1 IF(ALGO1.EQ.'SE') THEN WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH ELSEIF(ALGO1.EQ.'CE') THEN WRITE(IUO2,13) NDIF ENDIF WRITE(IUO2,14) VINT ELSEIF(SPECTRO.EQ.'XAS') THEN WRITE(IUO2,11) SPECTRO,ALGO1 IF(ALGO1.EQ.'SE') THEN WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH ELSEIF(ALGO1.EQ.'CE') THEN WRITE(IUO2,13) NDIF ENDIF WRITE(IUO2,14) VINT ELSEIF(SPECTRO.EQ.'LED') THEN WRITE(IUO2,11) SPECTRO,ALGO1 IF(ALGO1.EQ.'SE') THEN WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH ELSEIF(ALGO1.EQ.'CE') THEN WRITE(IUO2,13) NDIF ENDIF WRITE(IUO2,14) VINT ELSEIF(SPECTRO.EQ.'AED') THEN WRITE(IUO2,11) SPECTRO,ALGO2 IF(ALGO1.EQ.'SE') THEN WRITE(IUO2,12) NO,NDIF,IFWD,IPW,ILENGTH ELSEIF(ALGO1.EQ.'CE') THEN WRITE(IUO2,13) NDIF ENDIF WRITE(IUO2,14) VINT ELSEIF(SPECTRO.EQ.'APC') THEN WRITE(IUO2,15) SPECTRO,ALGO1,ALGO2 WRITE(IUO2,14) VINT ELSEIF(SPECTRO.EQ.'EIG') THEN WRITE(IUO2,11) SPECTRO,ALGO1 ELSEIF(SPECTRO.EQ.'RES') THEN CONTINUE ELSEIF(SPECTRO.EQ.'ELS') THEN CONTINUE ENDIF C WRITE(IUO2,2) C C Initial state parameters C IF(SPECTRO.EQ.'PHD') THEN WRITE(IUO2,21) NI,NLI,S_O,INITL ELSEIF(SPECTRO.EQ.'XAS') THEN WRITE(IUO2,22) EDGE,NEDGE,INITL ELSEIF(SPECTRO.EQ.'LED') THEN CONTINUE ELSEIF(SPECTRO.EQ.'AED') THEN WRITE(IUO2,24) AUGER,MULTIPLET ELSEIF(SPECTRO.EQ.'APC') THEN WRITE(IUO2,21) NI,NLI,S_O,INITL WRITE(IUO2,24) AUGER,MULTIPLET ELSEIF(SPECTRO.EQ.'RES') THEN CONTINUE ELSEIF(SPECTRO.EQ.'ELS') THEN CONTINUE ENDIF C WRITE(IUO2,2) C C Angular and energy parameters C IF(SPECTRO.EQ.'PHD') THEN WRITE(IUO2,35) WRITE(IUO2,34) THLUM,PHILUM,ELUM WRITE(IUO2,2) WRITE(IUO2,36) WRITE(IUO2,31) THETA0,THETA1 WRITE(IUO2,32) PHI0,PHI1 WRITE(IUO2,33) E0,EFIN ELSEIF(SPECTRO.EQ.'XAS') THEN WRITE(IUO2,35) WRITE(IUO2,33) EK_INI,EK_FIN WRITE(IUO2,34) THLUM,PHILUM,ELUM ELSEIF(SPECTRO.EQ.'LED') THEN WRITE(IUO2,35) WRITE(IUO2,31) THLUM,PHILUM WRITE(IUO2,2) WRITE(IUO2,36) WRITE(IUO2,31) THETA0,THETA1 WRITE(IUO2,32) PHI0,PHI1 WRITE(IUO2,2) WRITE(IUO2,33) E0,EFIN ELSEIF(SPECTRO.EQ.'AED') THEN WRITE(IUO2,36) WRITE(IUO2,31) THETA0_A,THETA1_A WRITE(IUO2,32) PHI0_A,PHI1_A ELSEIF(SPECTRO.EQ.'APC') THEN WRITE(IUO2,35) WRITE(IUO2,34) THLUM,PHILUM,ELUM WRITE(IUO2,2) WRITE(IUO2,37) WRITE(IUO2,31) THETA0,THETA1 WRITE(IUO2,32) PHI0,PHI1 WRITE(IUO2,33) E0,EFIN WRITE(IUO2,2) WRITE(IUO2,38) WRITE(IUO2,31) THETA0_A,THETA1_A WRITE(IUO2,32) PHI0_A,PHI1_A ELSEIF(SPECTRO.EQ.'EIG') THEN WRITE(IUO2,33) EK_INI,EK_FIN ELSEIF(SPECTRO.EQ.'RES') THEN CONTINUE ELSEIF(SPECTRO.EQ.'ELS') THEN CONTINUE ENDIF C C End of headers C WRITE(IUO2,2) WRITE(IUO2,1) WRITE(IUO2,39) C C Formats C 1 FORMAT('!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!',' &!!!!!!!!!!!!!!!!') 2 FORMAT('!',69X,'!') 3 FORMAT('!',10X,'data file : ',A19,20X,'!') 4 FORMAT('!',10X,'t-matrix file : ',A17,20X,'!') 5 FORMAT('!',10X,'rad integral file: ',A20,20X,'!') 6 FORMAT('!',10X,'cluster file : ',A19,20X,'!') C 11 FORMAT('!',10X,'spectroscopy : ',A3,8X,'algorithm : ',A2, &10X,'!') 12 FORMAT('!',15X,'NO = ',I1,' NDIF = ',I2,' IFWD = ',I1,' IPW = ' &,I1,' ILENGTH = ',I1,5X,'!') 13 FORMAT('!',15X,'NDIF = ',I2,45X,'!') 14 FORMAT('!',10X,'inner potential : ',F6.2,' eV',28X,'!') 15 FORMAT('!',10X,'spectroscopy: ',A3,10X,'algorithm (photo): ',A2,11 &X,'!',/,'!',37X,'algorithm (auger): ',A2, 11X,'!') C 21 FORMAT('!',10X,'initial state : ',I1,A1,1X,A3,' selection rules &:',' INITL = ',I2,6X,'!') 22 FORMAT('!',10X,'initial state : ',A1,I1,2X,' selection rules:', &' INITL = ',I2,8X,'!') 24 FORMAT('!',10X,'initial state : ',A6,2X,' multiplet: ',A3,17X,' &!') C 31 FORMAT('!',10X,'THETA_INI: ',F8.2,6X,'THETA_FIN: ',F8.2,15X,'!') 32 FORMAT('!',10X,'PHI_INI : ',F8.2,6X,'PHI_FIN : ',F8.2,15X,'!') 33 FORMAT('!',10X,'E_INI : ',F8.2,' eV',3X,'E_FIN : ',F8.2,' eV &',12X,'!') 34 FORMAT('!',10X,'THETA_LUM: ',F8.2,2X,'PHI_LUM: ',F8.2,2X,'E_LUM: ' &,F8.2,' eV !') 35 FORMAT('!',10X,'incoming beam : ',40X,'!') 36 FORMAT('!',10X,'outgoing beam : ',40X,'!') 37 FORMAT('!',10X,'photoelectron beam:',40X,'!') 38 FORMAT('!',10X,'auger beam :',40X,'!') 39 FORMAT(71X) C RETURN C END C C======================================================================= C INTEGER FUNCTION IG(J) C C This function is returns the value 1 if J is an integer C and 2 if it is a half-integer C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C REAL*8 J,JJ C DATA SMALL /0.0001D0/ C JJ=ABS(J+J) C LL=INT(JJ+SMALL) C IF(MOD(LL,2).EQ.0) THEN IG=1 ELSE IG=2 ENDIF C END C C======================================================================= C SUBROUTINE LOCATE(XX,N,X,J) C C C This subroutine is taken from the book : C "Numerical Recipes : The Art of Scientific C Computing" par W.H. PRESS, B.P. FLANNERY, C S.A. TEUKOLSKY et W.T. VETTERLING C (Cambridge University Press 1992) C C It performs a search in an ordered table using a bisection method. C Given a monotonic array XX(1:N) and a value X, it returns J such C that X is between XX(J) and XX(J+1). C INTEGER J,N INTEGER JL,JM,JU C REAL X,XX(N) C JL=0 JU=N+1 10 IF(JU-JL.GT.1)THEN JM=(JU+JL)/2 IF((XX(N).GT.XX(1)).EQV.(X.GT.XX(JM)))THEN JL=JM ELSE JU=JM ENDIF GOTO 10 ENDIF J=JL C RETURN C END C C======================================================================= C SUBROUTINE LPM(E,XLPM,*) C C This routine generates the electron mean free path C C ILPM=-1: XLPM is set to 1.E+30 C ILPM=0 : XLPM is the value given in the input data file C ILPM=1 : XLPM computed from Tokutaka et al, Surf. Sci. 149,349 (1985) C ILPM=2 : XLPM computed from the Seah and Dench expression C C Last modified : 15 Sep 2009 C USE LPMOY_MOD , NZ => NZA, XMAT => XMTA, RHO => RHOTA USE OUTUNITS_MOD USE TESTS_MOD USE VALIN_MOD C E=E+VINT C IF(ILPM.EQ.-1) THEN XLPM=1.E+30 ELSEIF(ILPM.EQ.0) THEN XLPM=XLPM0 ELSEIF(ILPM.EQ.1) THEN Q=FLOAT(NZ)*RHO/XMAT CSTE1=ALOG(Q/4.50)/(ALOG(7.74/4.50)) CSTE2=ALOG(Q/3.32)/(ALOG(7.74/3.32)) CSTE3=ALOG(Q/3.32)/(ALOG(4.50/3.32)) A1=0.7271+0.2595*ALOG(E) A2=-3.2563+0.9395*ALOG(E) A3=-2.5716+0.8226*ALOG(E) IF(E.GE.350.) GO TO 10 XLN=CSTE1*(0.0107-0.0083*ALOG(E))+A1 GO TO 20 10 IF((NZ.GE.24).AND.(NZ.LE.74)) GO TO 30 XLN=CSTE2*(1.6551-0.2890*ALOG(E))+A2 GO TO 20 30 IF(NZ.GE.42) GO TO 40 XLN=CSTE3*(0.6847-0.1169*ALOG(E))+A2 GO TO 20 40 XLN=CSTE1*(0.9704-0.1721*ALOG(E))+A3 20 XLPM=EXP(XLN) ELSEIF(ILPM.EQ.2) THEN XLPM=1430./(E**2)+0.54*SQRT(E) ELSE RETURN 1 ENDIF C E=E-VINT IF(IPRINT.GT.0) WRITE(IUO1,80) E,XLPM C 80 FORMAT(/////,2X,'========= E = ',F7.2,' eV',5X,'MEAN',' FREE PATH & = ',F6.3,' ANGSTROEMS ','=========') C RETURN C END C C======================================================================= C SUBROUTINE N_J(J1,MJ1,J2,MJ2,MJ6,NJ,I_INT,N_IN) C C This subroutine calculates Wigner's 3j and 6j coefficients C using a downward recursion scheme due to Schulten and Gordon. C The 3j are defined as (J1 J2 J) where in fact L1=MJ1, etc are C (L1 L2 L) C azimuthal quantum numbers, and the 6j as {J1 J2 J} where now C {L1 L2 L} C J1, L1, etc are the same kind of orbital quantum numbers. C The result is stored as NJ(J). C C The parameter N allows to choose between 3j and 6j calculation, and C Clebsch-Gordan. It can take the values : C C N = 2 ----> Clebsch-Gordan C N = 3 ----> Wigner's 3j C N = 6 ----> Wigner's 6j C C The Clebsch-Gordan coefficients are related to Wigner's 3j through : C C CG(J1,M1,J2,M2|J,MJ) = ( J1 J2 J )*sqrt(2*J+1)*(-1)**(J1-J2+MJ) C ( M1 M2 -MJ ) C I_INT is a flag that returns 1 if the index J of the nj symbol C is integer and 0 if it is a half integer. C C Note : For 3j, MJ6 is ignored while for 6j, we have : C C J1=J1 MJ1=L1 J2=J2 MJ2=L2 MJ6=L C C Ref. : K. Schulten and R. G. Gordon, J. Math. Phys. 16, 1961 (1975) C C Last modified : 8 Dec 2008 ----> D. Sebilleau C C USE DIM_MOD USE LOGAMAD_MOD C IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL*4 NJ(0:N_GAUNT) C REAL*8 J1,J2,J,MJ1,MJ2,MJ,JP1,JP2 REAL*8 F(0:N_GAUNT),A(0:N_GAUNT),B(0:N_GAUNT) REAL*8 JL12,JK12,MJ6,SIG REAL*8 JJ1,JJ2,JL1,JL2,JL3,JJ12,JJ_MIN,JJ_MAX C C DATA SMALL /0.0001D0/ C IS=0 C IF(N_IN.EQ.2) THEN N_OU=3 I_CG=1 ELSE N_OU=N_IN I_CG=0 ENDIF C IF(N_OU.EQ.3) THEN C C------------------------------ 3j case --------------------------------- C C C Test to check if J1 and J2 are integer or semi-integer C C Integer : IG=1 C Half-integer : IG=2 C C Each angular momentum J is represented by the integer index L and C the corresponding MJ by M C L1=INT(J1+SMALL) L2=INT(J2+SMALL) M1=INT(MJ1+SIGN(SMALL,MJ1)) M2=INT(MJ2+SIGN(SMALL,MJ2)) DIF1=J1-DFLOAT(L1) DIF2=J2-DFLOAT(L2) C C IGx is a flag telling the code which case of Gamma function to use : C C IGx = 1 : integer case C IGx = 2 : half-integer case C IF(ABS(DIF1).LT.SMALL) THEN IG1=1 ELSE IG1=2 ENDIF IF(ABS(DIF2).LT.SMALL) THEN IG2=1 ELSE IG2=2 ENDIF IF(IG1.EQ.IG2) THEN IGG=1 IF(IG1.EQ.2) IS=1 ELSE IGG=2 ENDIF C C Here, we assume that (J1,J2) are both either integer or half-integer C If J is integer, the corresponding index is L = j (for loops or storage) C while if J is an half-integer, this index is L= j - 1/2 = int(j) C C Integer indices are used for loops and for storage while true values C are used for the initial values. When J1 and J2 are both half-integers, C the values of J are integer and L should be increased by 1 C JL12=J1+J2 JK12=J1-J2 C L12=INT(JL12 + SIGN(SMALL,JL12)) K12=INT(JK12 + SIGN(SMALL,JK12)) C LM1=INT(J1+MJ1 + SIGN(SMALL,J1+MJ1)) LM2=INT(J2+MJ2 + SIGN(SMALL,J2+MJ2)) KM1=INT(J1-MJ1 + SIGN(SMALL,J1-MJ1)) KM2=INT(J2-MJ2 + SIGN(SMALL,J2-MJ2)) C MJ=-MJ1-MJ2 C M=INT(MJ+SIGN(SMALL,MJ)) L12M=INT(JL12+MJ+SIGN(SMALL,JL12+MJ)) K12M=INT(JL12-MJ+SIGN(SMALL,JL12-MJ)) L1_2=INT(J1+J1+SIGN(SMALL,J1)) L2_2=INT(J2+J2+SIGN(SMALL,J2)) L12_2=INT(JL12+JL12+SIGN(SMALL,JL12)) C IF(IG(JL12).EQ.1) THEN I_INT=1 ELSE I_INT=0 ENDIF C C Initialisation of the 3j symbol NJ(J) = (J1 J2 J) C (MJ1 MJ2 MJ) C DO L=0,L12 NJ(L)=0. ENDDO C IF((ABS(MJ1).GT.J1).OR.(ABS(MJ2).GT.J2)) GOTO 10 C C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward C recursion scheme. This scheme writes as C C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0 C F(L12+1)=0.D0 A(L12+1)=0.D0 D1=GLD(L2_2+1,1)-GLD(L12_2+2,1) D2=GLD(L1_2+1,1)-GLD(LM2+1,1) D3=GLD(L12M+1,1)-GLD(KM2+1,1) D4=GLD(K12M+1,1)-GLD(LM1+1,1)-GLD(KM1+1,1) C N12=INT(JK12-MJ + SIGN(SMALL,JK12-MJ)) C IF(I_CG.EQ.1) THEN IF(MOD(N12,2).EQ.0) THEN SIG=1.D0 ELSE SIG=-1.D0 ENDIF ENDIF C IF(MOD(N12,2).EQ.0) THEN F(L12)=DSQRT(DEXP(D1+D2+D3+D4)) ELSE F(L12)=-DSQRT(DEXP(D1+D2+D3+D4)) ENDIF C A(L12)=2.D0*DSQRT(J1*J2*(1.D0+2.D0*JL12)*(JL12*JL12-MJ*MJ)) B(L12)=-(2.D0*JL12+1.D0)*((J1*J1-J2*J2+JK12)*MJ-JL12*(JL12+1.D0) &*(MJ2-MJ1)) C IF(ABS(M).LE.L12) THEN IF(I_CG.EQ.0) THEN NJ(L12)=SNGL(F(L12)) ELSE NJ(L12)=SNGL(F(L12)*SIG*DSQRT(JL12+JL12+1.D0)) ENDIF ELSE NJ(L12)=0. ENDIF C LMIN=MAX0(ABS(K12),ABS(M)) C C Downward recursion for NJ(J) C DO L=L12-1,LMIN,-1 LP1=L+1 LP2=L+2 C C Value of the angular momentum J corresponding to the loop index L C IF(IGG.EQ.1) THEN J=DFLOAT(L) JP1=DFLOAT(LP1) JP2=DFLOAT(LP2) ELSE J=DFLOAT(L) + 0.5D0 JP1=DFLOAT(LP1) + 0.5D0 JP2=DFLOAT(LP2) + 0.5D0 ENDIF C A(L)=DSQRT((J*J-JK12*JK12)*((JL12+1.D0)*(JL12+1.D0)-J*J)*(J*J- &MJ*MJ)) B(L)=-(2.D0*J+1.D0)*(J1*(J1+1.D0)*MJ-J2*(J2+1.D0)*MJ-J*JP1*(MJ &2-MJ1)) F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1)) C IF(ABS(MJ).LE.J) THEN IF(I_CG.EQ.0) THEN NJ(L)=SNGL(F(L)) ELSE NJ(L)=SNGL(F(L)*SIG*DSQRT(J+J+1.D0)) ENDIF ELSE NJ(L)=0. ENDIF C ENDDO C 10 CONTINUE C ELSEIF(N_OU.EQ.6) THEN C C------------------------------ 6j case --------------------------------- C C Change of notation for greater readability ---> NJ(JJ) C C True angular momentum value : begins with a J (JJn,JLn) C Corresponding integer storage and loop index : begins by L (LJn,LLn) C JJ1=J1 JJ2=J2 JL1=MJ1 JL2=MJ2 JL3=MJ6 C LJ1=INT(JJ1+SIGN(SMALL,JJ1)) LJ2=INT(JJ2+SIGN(SMALL,JJ2)) LL1=INT(JL1+SIGN(SMALL,JL1)) LL2=INT(JL2+SIGN(SMALL,JL2)) LL3=INT(JL3+SIGN(SMALL,JL3)) C JJ12=JJ1-JJ2 JL12=JL1-JL2 C LJ12=INT(JJ12+SIGN(SMALL,JJ12)) LL12=INT(JL12+SIGN(SMALL,JL12)) C JJ_MIN=MAX(ABS(LJ12),ABS(LL12)) JJ_MAX=MIN(JJ1+JJ2,JL1+JL2) LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN)) LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX)) C C Initialisation of the 6j symbol NJ(J) = {J1 J2 J } C {L1 L2 L3} C DO L=0,LJJ_MAX NJ(L)=0. ENDDO C C Initial values (J1+J2+1) and (J1+J2) for J to be used in the downward C recursion scheme. This scheme writes as C C J A(J+1) NJ(J+1) + B(J) NJ(J) + (J+1) A(J) NJ(J-1) = 0 C C There are two possible initial values as max(|J1-J2|,|L1-L2|) <= J <= C min(J1+J2,L1+L2) : C C {J1 J2 L1+L2} and {J1 J2 J1+J2} = {L1 L2 J1+J2} C {L1 L2 L3 } {L1 L2 L3 } {J1 J2 L3 } C C They can be calculated from equation (6.3.1) of Edmonds page 97 C F(LJJ_MAX+1)=0.D0 A(LJJ_MAX+1)=0.D0 C IF(ABS(JJ_MAX-JL1-JL2).LT.SMALL) THEN F(LJJ_MAX)=SIXJ_IN(JJ1,JJ2,JL1,JL2,JL3) ELSE F(LJJ_MAX)=SIXJ_IN(JL1,JL2,JJ1,JJ2,JL3) ENDIF NJ(LJJ_MAX)=SNGL(F(LJJ_MAX)) C A(LJJ_MAX)=SQRT((JJ_MAX*JJ_MAX-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1. &D0)*(JJ1+JJ2+1.D0)-JJ_MAX*JJ_MAX)*(JJ_MAX*JJ_MAX-(JL1-JL2)*(JL1-JL &2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0)-JJ_MAX*JJ_MAX)) B(LJJ_MAX)=(JJ_MAX+JJ_MAX+1.D0)*(JJ_MAX*(JJ_MAX+1.D0)*(-JJ_MAX*( &JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1*(JL1+1.D0)*(JJ_MAX &*(JJ_MAX+1.D0)+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*(JJ_M &AX*(JJ_MAX+1.D0)-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(JJ_MAX+JJ_MAX)*(J &J_MAX+1.D0)*JL3*(JL3+1.D0)) C IF(IG(JJ_MAX).EQ.1) THEN I_INT=1 ELSE I_INT=0 ENDIF C C Downward recurrence relation C DO L=LJJ_MAX-1,LJJ_MIN,-1 LP1=L+1 LP2=L+2 C C Value of the angular momentum J corresponding to the loop index L C IF(IG(JJ_MAX).EQ.1) THEN J=DFLOAT(L) JP1=DFLOAT(LP1) JP2=DFLOAT(LP2) ELSE J=DFLOAT(L) + 0.5D0 JP1=DFLOAT(LP1) + 0.5D0 JP2=DFLOAT(LP2) + 0.5D0 ENDIF C A(L)=SQRT((J*J-(JJ1-JJ2)*(JJ1-JJ2))*((JJ1+JJ2+1.D0)*(JJ1+JJ2+1 &.D0)-J*J)*(J*J-(JL1-JL2)*(JL1-JL2))*((JL1+JL2+1.D0)*(JL1+JL2+1.D0) &-J*J)) B(L)=(J+J+1)*(J*JP1*(-J*JP1+JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))+JL1 &*(JL1+1.D0)*(J*JP1+JJ1*(JJ1+1.D0)-JJ2*(JJ2+1.D0))+JL2*(JL2+1.D0)*( &J*JP1-JJ1*(JJ1+1.D0)+JJ2*(JJ2+1.D0))-(J+J)*JP1*JL3*(JL3+1.D0)) C F(L)=-(JP1*A(LP2)*F(LP2)+B(LP1)*F(LP1))/(JP2*A(LP1)) NJ(L)=SNGL(F(L)) C ENDDO C ENDIF C RETURN C END C C======================================================================= C SUBROUTINE ORDRE2(NINI,VALINI,NFIN,VALFIN) C C Given a set of **integer** numbers VALINI, this routine orders them C and suppresses the values appearing more than once. The remaining C values are stored in VALFIN. C C VALINI(K+1).GT.VALINI(K) : decreasing order C VALINI(K+1).LT.VALINI(K) : increasing order C C C INTEGER VALINI(NINI),VALFIN(NINI),R1 C LOGICAL BUBBLE C DO J=1,NINI-1 K=J BUBBLE=.TRUE. 150 IF(K.GE.1.AND.BUBBLE) THEN IF(VALINI(K+1).LT.VALINI(K)) THEN R1=VALINI(K) VALINI(K)=VALINI(K+1) VALINI(K+1)=R1 ELSE BUBBLE=.FALSE. ENDIF K=K-1 GOTO 150 ENDIF ENDDO C JFIN=1 VALFIN(1)=VALINI(1) DO J=1,NINI-1 IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.0) THEN JFIN=JFIN+1 VALFIN(JFIN)=VALINI(J+1) ENDIF ENDDO NFIN=JFIN C RETURN C END C C======================================================================= C SUBROUTINE ORDRE(NINI,VALINI,NFIN,VALFIN) C C Given a set of **real** numbers VALINI, this routine orders them and C suppresses the values appearing more than once. The remaining C values are stored in VALFIN. C C VALINI(K+1).GT.VALINI(K) : decreasing order C VALINI(K+1).LT.VALINI(K) : increasing order C C DIMENSION VALINI(NINI),VALFIN(NINI) C LOGICAL BUBBLE C DATA SMALL /0.00001/ C DO J=1,NINI-1 K=J BUBBLE=.TRUE. 150 IF(K.GE.1.AND.BUBBLE) THEN IF(VALINI(K+1).GT.VALINI(K)) THEN R1=VALINI(K) VALINI(K)=VALINI(K+1) VALINI(K+1)=R1 ELSE BUBBLE=.FALSE. END IF K=K-1 GOTO 150 ENDIF ENDDO C JFIN=1 VALFIN(1)=VALINI(1) DO J=1,NINI-1 IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN JFIN=JFIN+1 VALFIN(JFIN)=VALINI(J+1) ENDIF ENDDO NFIN=JFIN C RETURN C END C C======================================================================= C SUBROUTINE PLM(X,PLMM,NC) C C This routine computes the Legendre functions. It is a modified version C of that written by W.H. PRESS, B.P. FLANNERY, S.A. TEUKOLSKY and C W.T. VETTERLING in "Numerical Recipes : The Art of Scientific C Computing" (Cambridge University Press 1992). C DIMENSION PLMM(0:100,0:100) C PLMM(0,0)=1. PLMM(1,0)=X DO L=2,NC PLMM(L,0)=(X*(L+L-1)*PLMM(L-1,0)-(L-1)*PLMM(L-2,0))/L ENDDO C DO M=1,NC PMM=1. FACT=1. SOMX2=SQRT(1.-X*X) FACT=1. DO I=1,M PMM=-PMM*FACT*SOMX2 FACT=FACT+2. ENDDO PMMP1=X*FACT*PMM PLMM(M,M)=PMM PLMM(M+1,M)=PMMP1 IF(M.LT.NC-1) THEN DO L=M+2,NC PLL=(X*(L+L-1)*PMMP1-(L+M-1)*PMM)/(L-M) PMM=PMMP1 PMMP1=PLL PLMM(L,M)=PLL ENDDO ENDIF ENDDO C RETURN C END C C============================================================================= C SUBROUTINE POLHAN(ISPHER,NO,NC,RHO,HLM) C C This routine calculates a function HLM(L,M), related to the the Hankel C polynomials and their derivatives with respect to z=1/ikr, C necessary for the Rehr-Albers expansion of the propagator. C USE DIM_MOD C COMPLEX HLM(0:NO_ST_M,0:NL_M-1),RHO,Z,ONEC C ONEC=(1.,0.) C IF(ISPHER.GE.1) THEN Z=(0.,-1.)/RHO C C Case M = 0 C HLM(0,0)=ONEC HLM(0,1)=ONEC-Z DO L=2,NC HLM(0,L)=HLM(0,L-2)-FLOAT(L+L-1)*Z*HLM(0,L-1) ENDDO C C Case M > 0 C IF(NO.GE.1) THEN DO M=1,NO HLM(M,M)=-Z*HLM(M-1,M-1)*FLOAT(M+M-1) HLM(M,M+1)=HLM(M,M)*FLOAT(M+M+1)*(ONEC-Z*FLOAT(M+1)) DO L=M+2,NC HLM(M,L)=HLM(M,L-2)-FLOAT(L+L-1)*Z*(HLM(M,L-1)+HLM(M-1,L-1 &)) ENDDO ENDDO ENDIF ELSE DO M=0,NO DO L=M,NC HLM(M,L)=ONEC ENDDO ENDDO ENDIF C RETURN C END C C======================================================================= C SUBROUTINE POLLEG(NC,X,PL) C C This routine computes the Legendre polynomials up to order NC-1 C DIMENSION PL(0:100) C PL(0)=1. PL(1)=X DO 10 L=2,NC-1 L1=L-1 L2=L-2 L3=2*L-1 PL(L)=(X*FLOAT(L3)*PL(L1)-FLOAT(L1)*PL(L2))/FLOAT(L) 10 CONTINUE C RETURN C END C C======================================================================= C FUNCTION PRSCAL(A1,A2) C C This function computes the dot product of the two vectors A1 and A2 C DIMENSION A1(3),A2(3) C PRSCAL=A1(1)*A2(1)+A1(2)*A2(2)+A1(3)*A2(3) C RETURN C END C C======================================================================= C SUBROUTINE PRVECT(A1,A2,A3,C) C C This function computes the vector product of the two vectors A1 and A2. C The result is A3; C is a scaling factor C DIMENSION A1(3),A2(3),A3(3) C A3(1)=(A1(2)*A2(3)-A1(3)*A2(2))/C A3(2)=(A1(3)*A2(1)-A1(1)*A2(3))/C A3(3)=(A1(1)*A2(2)-A1(2)*A2(1))/C C RETURN C END C C======================================================================= C SUBROUTINE READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*,*,*,*,*,*,*,*,*,* &,*,*,*) C C This subroutine reads the input data from unit ICOM and writes C them in the control file IUO1. Then, it stores the data in C the various COMMON blocks C C Last modified : 26 Apr 2013 C USE DIM_MOD C USE ADSORB_MOD USE AMPLI_MOD USE APPROX_MOD USE ATOMS_MOD USE AUGER_MOD USE BASES_MOD USE COEFRLM_MOD USE CONVACC_MOD USE CONVTYP_MOD USE C_G_MOD USE C_G_A_MOD USE C_G_M_MOD USE CRANGL_MOD USE DEBWAL_MOD , T => TEMP USE DEXPFAC2_MOD USE DFACTSQ_MOD USE EIGEN_MOD USE EXAFS_MOD USE EXPFAC_MOD USE EXPFAC2_MOD USE EXPROT_MOD USE FACTSQ_MOD USE FDIF_MOD USE FIXSCAN_MOD USE FIXSCAN_A_MOD USE HEADER_MOD , AUGER1 => AUGER USE INDAT_MOD USE INFILES_MOD USE INUNITS_MOD USE INIT_A_MOD USE INIT_J_MOD USE INIT_L_MOD USE INIT_M_MOD USE LIMAMA_MOD USE LINLBD_MOD USE LOGAMAD_MOD USE LPMOY_MOD , XM => XMTA, RH => RHOTA USE MILLER_MOD USE MOYEN_MOD USE MOYEN_A_MOD USE OUTFILES_MOD USE OUTUNITS_MOD USE PARCAL_MOD USE PARCAL_A_MOD USE RA_MOD USE RELADS_MOD USE RELAX_MOD USE RESEAU_MOD USE SPECTRUM_MOD USE SPIN_MOD USE TESTS_MOD USE TYPCAL_MOD USE TYPCAL_A_MOD USE TYPEM_MOD USE TYPEXP_MOD USE VALIN_MOD USE VALIN_AV_MOD USE VALFIN_MOD USE VALEX_A_MOD USE XMRHO_MOD C C C C REAL*8 J1,J2,MJ1,MJ2,MJ3,JJ,DXDEN,DEXPF REAL*8 JJ_MIN,JJ_MAX,JJ12,JL12,SMALL,SQPI C REAL TEXTE1(10),TEXTE2(10),TEXTE3(10) REAL TEXTE4(10),TEXTE5(10),TEXTE6(10) REAL TEXTE6B(10),TEXTE7(10) REAL THFWD(NATP_M),THBWD(NATP_M),GLG(0:N_GAUNT),NJ(0:N_GAUNT) REAL ALPHAR,BETAR,RACC C C C DOUBLE PRECISION FACT1L,FACT2L C C C C C CHARACTER*7 TESLEC,RIEN C C CHARACTER*3 CODRES(8),CODCTR(7),CRIST,CENTR,UNLENGTH C C CHARACTER*1 EDGE_C,EDGE_I,EDGE_A,MULT DATA CODRES/'CUB','TET','ORB','MNC','TCN','TRG','HEX','EXT'/ DATA CODCTR/'P','I','F','R','A','B','C'/ DATA PIS180,BOHR/0.017453,0.529177/ DATA SQPI,SMALL /1.772453850906D0,1.D-6/ C I_EXT=0 I_EXT_A=0 IVG0=0 IRET=0 NCRIST=0 NCENTR=0 I_SO=0 DO I=1,10 PCREL(I)=0. ENDDO STEREO=' NO' C C C.......... Reading of the input data in unit ICOM .......... C C READ(ICOM,1) RIEN READ(ICOM,2) TEXTE1 READ(ICOM,1) RIEN READ(ICOM,1) RIEN READ(ICOM,2) TEXTE2 READ(ICOM,1) RIEN C READ(ICOM,3) CRIST,CENTR,IBAS,NAT READ(ICOM,4) A,BSURA,CSURA,UNIT C IF(IBAS.EQ.0) THEN DO JLINE=1,100 READ(ICOM,5) TESLEC IF(TESLEC.EQ.'SPECTRO') THEN BACKSPACE ICOM BACKSPACE ICOM BACKSPACE ICOM GOTO 600 ENDIF ENDDO ENDIF C READ(ICOM,6) ALPHAD,BETAD,GAMMAD READ(ICOM,7) IH,IK,II,IL READ(ICOM,8) NIV,COUPUR,ITEST,IESURF IF(NAT.GT.1) THEN DO I=1,NAT J=3*(I-1) READ(ICOM,9) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT(I) ENDDO ELSE READ(ICOM,9) X1,Y1,Z1,CHEM(1),NZA ENDIF C READ(ICOM,5) TESLEC IF(TESLEC.EQ.'VECBAS ') THEN BACKSPACE ICOM ELSE IRET=10 GOTO 605 ENDIF C DO I=1,8 IF(CRIST.EQ.CODRES(I)) NCRIST=I IF(I.NE.8) THEN IF(CENTR.EQ.CODCTR(I)) NCENTR=I ENDIF ENDDO IF((NCRIST.EQ.0).OR.(NCENTR.EQ.0)) THEN IRET=1 GOTO 605 ENDIF C IF(NCRIST.EQ.8) THEN DO I=1,3 J=3*(I-1) IVN(I)=1 READ(ICOM,9) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J) IF(ABS(VECBAS(1+J)).LT.0.0001) THEN IF(ABS(VECBAS(2+J)).LT.0.0001) THEN IF(ABS(VECBAS(3+J)).LT.0.0001) THEN IVG0=IVG0+1 IVN(I)=0 ENDIF ENDIF ENDIF ENDDO ELSE READ(ICOM,9) X3,Y3,Z3 READ(ICOM,9) X4,Y4,Z4 READ(ICOM,9) X5,Y5,Z5 ENDIF READ(ICOM,10) IREL,NREL,(PCREL(I),I=1,2) IF(IREL.EQ.1) THEN IF(NREL.GT.2) THEN NLIGNE=INT(FLOAT(NREL-2)/4.)+1 DO J=1,NLIGNE READ(ICOM,11) (PCREL(I),I=1,4) ENDDO ENDIF IF(NREL.GT.10) THEN IRET=4 GOTO 605 ENDIF ELSEIF(IREL.EQ.0) THEN NREL=0 ENDIF IF(NREL.EQ.0) THEN DO JREL=1,10 PCREL(JREL)=0. ENDDO ENDIF READ(ICOM,12) OMEGAD1,OMEGAD2,IADS C READ(ICOM,1) RIEN 600 READ(ICOM,2) TEXTE3 READ(ICOM,1) RIEN C READ(ICOM,13) SPECTRO,ISPIN,IDICHR,IPOL READ(ICOM,44) I_AMP C IF(SPECTRO.EQ.'PHD') THEN INTERACT='DIPOLAR' ELSEIF(SPECTRO.EQ.'LED') THEN INTERACT='NOINTER' ELSEIF(SPECTRO.EQ.'XAS') THEN INTERACT='DIPOLAR' ELSEIF(SPECTRO.EQ.'AED') THEN INTERACT='COULOMB' ELSEIF(SPECTRO.EQ.'APC') THEN INTERACT='DIPCOUL' ELSEIF(SPECTRO.EQ.'EIG') THEN INTERACT='DIPOLAR' ENDIF C IF((IPOL.EQ.0).AND.(IDICHR.GT.0)) THEN PRINT 513 STOP ENDIF IF((IDICHR.EQ.2).AND.(ISPIN.EQ.0)) THEN PRINT 514 STOP ENDIF C IF(ISPIN.EQ.0) THEN NSPIN2=1 NSPIN=1 ELSEIF(ISPIN.EQ.1) THEN NSPIN2=4 NSPIN=2 ENDIF C IF(SPECTRO.EQ.'LED') THEN DO JLINE=1,10 READ(ICOM,1) RIEN ENDDO GOTO 607 ELSEIF(SPECTRO.EQ.'XAS') THEN IF(IDICHR.GT.1) THEN PRINT 512 STOP ENDIF DO JLINE=1,19 READ(ICOM,1) RIEN ENDDO GOTO 602 ELSEIF(SPECTRO.EQ.'AED') THEN DO JLINE=1,24 READ(ICOM,1) RIEN ENDDO GOTO 603 ELSEIF(SPECTRO.EQ.'EIG') THEN DO JLINE=1,34 READ(ICOM,1) RIEN ENDDO GOTO 608 ENDIF C IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN READ(ICOM,1) RIEN READ(ICOM,2) TEXTE4 READ(ICOM,1) RIEN C READ(ICOM,20) NI,NLI,S_O,INITL,I_SO C IF((NLI.EQ.'s').OR.(NLI.EQ.'S')) THEN LI=0 ELSEIF((NLI.EQ.'p').OR.(NLI.EQ.'P')) THEN LI=1 ELSEIF((NLI.EQ.'d').OR.(NLI.EQ.'D')) THEN LI=2 ELSEIF((NLI.EQ.'f').OR.(NLI.EQ.'F')) THEN LI=3 ELSEIF((NLI.EQ.'g').OR.(NLI.EQ.'G')) THEN LI=4 ELSE IRET=5 GOTO 605 ENDIF IF(LI.GT.LI_M) THEN IRET=6 GOTO 605 ENDIF IF(I_SO.EQ.0) THEN S_O=' ' ELSEIF(I_SO.EQ.1) THEN IF(S_O.EQ.'1/2') THEN IF(LI.GT.1) IRET=7 ELSEIF(S_O.EQ.'3/2') THEN IF((LI.LT.1).OR.(LI.GT.2)) IRET=7 ELSEIF(S_O.EQ.'5/2') THEN IF((LI.LT.2).OR.(LI.GT.3)) IRET=7 ELSEIF(S_O.EQ.'7/2') THEN IF((LI.LT.3).OR.(LI.GT.4)) IRET=7 ELSEIF(S_O.EQ.'9/2') THEN IF(LI.NE.4) IRET=7 ENDIF ELSEIF(I_SO.EQ.2) THEN S_O=' ' ENDIF C READ(ICOM,14) IPHI,ITHETA,IE,IFTHET READ(ICOM,15) NPHI,NTHETA,NE,NFTHET READ(ICOM,16) PHI0,THETA0,E0,R1 READ(ICOM,16) PHI1,THETA1,EFIN,R2 READ(ICOM,17) THLUM,PHILUM,ELUM READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR C DO JLINE=1,9 READ(ICOM,1) RIEN ENDDO ENDIF C 607 IF(SPECTRO.EQ.'LED') THEN READ(ICOM,1) RIEN READ(ICOM,2) TEXTE4 READ(ICOM,1) RIEN C READ(ICOM,14) IPHI,ITHETA,IE,IFTHET READ(ICOM,15) NPHI,NTHETA,NE,NFTHET READ(ICOM,16) PHI0,THETA0,E0,R1 READ(ICOM,16) PHI1,THETA1,EFIN,R2 READ(ICOM,17) TH_INI,PHI_INI READ(ICOM,18) IMOD,IMOY,ACCEPT,ICHKDIR C THLUM=TH_INI PHILUM=PHI_INI ELUM=0. IDICHR=0 INITL=0 ENDIF C IF(SPECTRO.NE.'XAS') THEN IF(IPHI.EQ.-1) THEN IPHI=1 I_EXT=0 ICHKDIR=0 STEREO='YES' IF(ABS(PHI1-PHI0).LT.0.0001) THEN PHI0=0. PHI1=360. NPHI=361 ENDIF IF(ABS(THETA1-THETA0).LT.0.0001) THEN THETA0=0. THETA1=88. NTHETA=89 ENDIF ELSEIF(IPHI.EQ.2) THEN IPHI=1 I_EXT=1 ELSEIF(IPHI.EQ.3) THEN IPHI=1 I_EXT=-1 ELSEIF(ITHETA.EQ.2) THEN ITHETA=1 I_EXT=1 ELSEIF(ITHETA.EQ.3) THEN ITHETA=1 I_EXT=-1 ELSEIF(IE.EQ.2) THEN IE=1 I_EXT=1 ELSEIF(IE.EQ.3) THEN IE=1 I_EXT=-1 ELSEIF(IE.EQ.4) THEN IF(SPECTRO.EQ.'PHD') THEN IE=1 I_EXT=2 IMOD=0 ELSE IE=1 I_EXT=1 ENDIF ENDIF ENDIF C ICALC=IPHI*IE+IPHI*ITHETA+IE*ITHETA IF((ICALC.NE.0).AND.(IFTHET.EQ.0)) IRET=3 C C When the direction of the analyzer might be experimentally C inaccurate, the calculation will be done for nine C direction across the one given in the data file C with an increment of one degree. C IF(ICHKDIR.EQ.1) THEN IF((ITHETA.EQ.1).AND.(IPHI.EQ.0)) THEN NPHI=9 PHI0=PHI0-4. PHI1=PHI0+8. ELSEIF((IPHI.EQ.1).AND.(ITHETA.EQ.0)) THEN NTHETA=9 THETA0=THETA0-4. THETA1=THETA0+8. ENDIF ENDIF C C Initialization of the values for the scanned angle and the "fixed" one C IF(IPHI.EQ.1) THEN N_FIXED=NTHETA N_SCAN=NPHI FIX0=THETA0 FIX1=THETA1 SCAN0=PHI0 SCAN1=PHI1 IPH_1=0 ELSEIF(ITHETA.EQ.1) THEN N_FIXED=NPHI N_SCAN=NTHETA FIX0=PHI0 FIX1=PHI1 SCAN0=THETA0 SCAN1=THETA1 IPH_1=1 ELSEIF(IE.EQ.1) THEN IF(NTHETA.GE.NPHI) THEN N_FIXED=NPHI N_SCAN=NTHETA FIX0=PHI0 FIX1=PHI1 SCAN0=THETA0 SCAN1=THETA1 IPH_1=1 ELSE N_FIXED=NTHETA N_SCAN=NPHI FIX0=THETA0 FIX1=THETA1 SCAN0=PHI0 SCAN1=PHI1 IPH_1=0 ENDIF ENDIF C 602 IF(SPECTRO.EQ.'XAS') THEN READ(ICOM,1) RIEN READ(ICOM,2) TEXTE5 READ(ICOM,1) RIEN C READ(ICOM,39) EDGE,NEDGE,INITL,THLUM,PHILUM READ(ICOM,19) NE_X,EK_INI,EK_FIN,EPH_INI C LI=NEDGE/2 IF(NEDGE.GT.1) I_SO=2 IF(EDGE.EQ.'K') THEN NI=1 ELSEIF(EDGE.EQ.'L') THEN NI=2 ELSEIF(EDGE.EQ.'M') THEN NI=3 ELSEIF(EDGE.EQ.'N') THEN NI=4 ELSEIF(EDGE.EQ.'O') THEN NI=5 ELSEIF(EDGE.EQ.'P') THEN NI=6 ENDIF ELSE DO JLINE=1,5 READ(ICOM,1) RIEN ENDDO ENDIF C 603 IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN C READ(ICOM,1) RIEN READ(ICOM,2) TEXTE6 READ(ICOM,1) RIEN C READ(ICOM,40) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A READ(ICOM,42) I_MULT,IM1,MULT,IM2 READ(ICOM,14) IPHI_A,ITHETA_A,IFTHET_A,I_INT READ(ICOM,15) NPHI_A,NTHETA_A,NFTHET_A READ(ICOM,41) PHI0_A,THETA0_A,R1_A READ(ICOM,41) PHI1_A,THETA1_A,R2_A READ(ICOM,18) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A C LI_C=NEDGE_C/2 LI_I=NEDGE_I/2 LI_A=NEDGE_A/2 C IF((EDGE_I.EQ.EDGE_A).AND.(LI_I.EQ.LI_A)) THEN I_SHELL=1 ELSE I_SHELL=0 ENDIF C IE_A=0 NE_A=1 I_CP_A=0 C IF(EDGE_C.EQ.'K') THEN AUGER=' '//EDGE_C//EDGE_I//CHAR(48+NEDGE_I)//EDGE_A//CHAR(48+N &EDGE_A) ELSE AUGER=EDGE_C//CHAR(48+NEDGE_C)//EDGE_I//CHAR(48+NEDGE_I)//EDGE &_A//CHAR(48+NEDGE_A) ENDIF AUGER1=AUGER C IF(IPHI_A.EQ.-1) THEN IPHI_A=1 I_EXT_A=0 ICHKDIR_A=0 STEREO='YES' IF(ABS(PHI1_A-PHI0_A).LT.0.0001) THEN PHI0_A=0. PHI1_A=360. NPHI_A=361 ENDIF IF(ABS(THETA1_A-THETA0_A).LT.0.0001) THEN THETA0_A=0. THETA1_A=88. NTHETA_A=89 ENDIF ELSEIF(IPHI_A.EQ.2) THEN IPHI_A=1 I_EXT_A=1 ELSEIF(IPHI_A.EQ.3) THEN IPHI_A=1 I_EXT_A=-1 ELSEIF(ITHETA_A.EQ.2) THEN ITHETA_A=1 I_EXT_A=1 ELSEIF(ITHETA_A.EQ.3) THEN ITHETA_A=1 I_EXT_A=-1 ENDIF C C Check for the consistency of the data for the two electrons in C APECS, in particular when the sample is rotated (IMOD=1) C IF(SPECTRO.EQ.'APC') THEN IF((LI_C.NE.LI).OR.(IMOD_A.NE.IMOD)) THEN IRET=11 GOTO 605 ENDIF DTH=THETA1-THETA0 DTH_A=THETA1_A-THETA0_A DPH=PHI1-PHI0 DPH_A=PHI1_A-PHI0_A IF((IMOD_A.EQ.1).AND.(IPHI_A.NE.IPHI)) IRET=13 IF((IMOD_A.EQ.1).AND.(ITHETA_A.NE.ITHETA)) IRET=13 IF((IMOD_A.EQ.1).AND.(NPHI_A.NE.NPHI)) IRET=13 IF((IMOD_A.EQ.1).AND.(NTHETA_A.NE.NTHETA)) IRET=13 IF((IMOD_A.EQ.1).AND.(DTH_A.NE.DTH)) IRET=13 IF((IMOD_A.EQ.1).AND.(DPH_A.NE.DPH)) IRET=13 ENDIF C C When the direction of the analyzer might be experimentally C inaccurate, the calculation will be done for nine C direction across the one given in the data file C with an increment of one degree. C IF(ICHKDIR_A.EQ.1) THEN IF((ITHETA_A.EQ.1).AND.(IPHI_A.EQ.0)) THEN NPHI_A=9 PHI0_A=PHI0_A-4. PHI1_A=PHI0_A+8. ELSEIF((IPHI_A.EQ.1).AND.(ITHETA_A.EQ.0)) THEN NTHETA_A=9 THETA0_A=THETA0_A-4. THETA1_A=THETA0_A+8. ENDIF ENDIF C C Initialization of the values for the scanned angle and the "fixed" one C IF(IPHI_A.EQ.1) THEN N_FIXED_A=NTHETA_A N_SCAN_A=NPHI_A FIX0_A=THETA0_A FIX1_A=THETA1_A SCAN0_A=PHI0_A SCAN1_A=PHI1_A IPH_1_A=0 ELSEIF(ITHETA_A.EQ.1) THEN N_FIXED_A=NPHI_A N_SCAN_A=NTHETA_A FIX0_A=PHI0_A FIX1_A=PHI1_A SCAN0_A=THETA0_A SCAN1_A=THETA1_A IPH_1_A=1 ENDIF C ELSE DO JLINE=1,10 READ(ICOM,1) RIEN ENDDO ENDIF C IF(SPECTRO.EQ.'XAS') THEN I_CP=1 NE=NE_X ELSE I_CP=0 ENDIF C 608 IF(SPECTRO.EQ.'EIG') THEN C READ(ICOM,1) RIEN READ(ICOM,2) TEXTE6B READ(ICOM,1) RIEN C READ(ICOM,43) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP C NE=NE_EIG N_LINE_E=INT((FLOAT(NE_EIG)-0.0001)/4.)+1 N_LAST=4-(4*N_LINE_E-NE_EIG) C IF(N_LINE_E.GT.1) THEN DO JLINE=1,N_LINE_E-1 J=(JLINE-1)*4 READ(ICOM,7) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3 &),I_SPECTRUM(J+4) ENDDO ENDIF C J=4*(N_LINE_E-1) C READ(ICOM,7) (I_SPECTRUM(J+K), K=1,N_LAST) C READ(ICOM,46) I_PWM,METHOD,RACC,EXPO READ(ICOM,47) N_MAX,N_ITER,N_TABLE,SHIFT READ(ICOM,48) I_XN,I_VA,I_GN,I_WN READ(ICOM,49) LEVIN,ALPHAR,BETAR C ACC=DBLE(RACC) IF(ABS(I_PWM).LE.2) THEN I_ACC=0 N_ITER=N_MAX ELSEIF(I_PWM.EQ.3) THEN I_ACC=1 N_ITER=N_MAX ELSEIF(I_PWM.EQ.-3) THEN I_ACC=-1 N_ITER=N_MAX ELSEIF(I_PWM.EQ.4) THEN I_ACC=2 ELSEIF(I_PWM.EQ.-4) THEN I_ACC=-2 ENDIF IF(N_MAX.LT.N_ITER) N_ITER=N_MAX C ALPHA=DCMPLX(ALPHAR) BETA=DCMPLX(BETAR) C C ELSE DO JLINE=1,9 READ(ICOM,1) RIEN ENDDO C ENDIF C 609 READ(ICOM,1) RIEN READ(ICOM,2) TEXTE7 READ(ICOM,1) RIEN C READ(ICOM,21) NO,NDIF,ISPHER,I_GR C IF(ISPHER.EQ.0) THEN IDWSPH=0 NO=0 ENDIF IF(NO.LT.0) NO=8 NUMAX(1)=NO/2 C READ(ICOM,22) ISFLIP,IR_DIA,ITRTL,I_TEST C IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) I_TEST_A=I_TEST IF(I_TEST.EQ.1) THEN IF(INTERACT.EQ.'DIPOLAR') THEN INITL=1 LI=0 IPOL=1 ELSEIF(INTERACT.EQ.'COULOMB') THEN LI_C=0 LI_I=0 ENDIF ENDIF C READ(ICOM,23) NEMET C BACKSPACE ICOM NLG=INT((NEMET-0.0001)/3) +1 DO N=1,NLG NRL=3*N JD=3*(N-1)+1 IF(N.EQ.NLG) NRL=NEMET READ(ICOM,24) NEMO,(IEMET(J), J=JD, NRL) IF(N.EQ.1) NEMET1=NEMO ENDDO C READ(ICOM,25) ISOM,NONVOL(JFICH),NPATHP,VINT C IF(I_TEST.EQ.2) THEN IF(ABS(IPOL).EQ.1) THEN THLUM=-90. PHILUM=0. ELSEIF(ABS(IPOL).EQ.2) THEN THLUM=0. PHILUM=0. ENDIF IMOD=0 VINT=0. A=1. ENDIF C IF((NFICHLEC.EQ.1).OR.(IBAS.EQ.1)) ISOM=0 C READ(ICOM,26) IFWD,NTHOUT,I_NO,I_RA C IF(NTHOUT.EQ.NDIF-1) IFWD=0 C IF(I_RA.EQ.1) NO=0 DO JAT=1,NAT READ(ICOM,27) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT) IF(I_RA.EQ.0) THEN N_RA(JAT)=NO NUMAX(JAT)=NO/2 ELSEIF(I_RA.EQ.1) THEN NUMAX(JAT)=N_RA(JAT)/2 NO=MAX(N_RA(JAT),NO) ENDIF ENDDO C READ(ICOM,5) TESLEC IF(TESLEC.EQ.'IPW,NCU') THEN BACKSPACE ICOM ELSE IRET=8 GOTO 605 ENDIF C READ(ICOM,28) IPW,NCUT,PCTINT,IPP READ(ICOM,29) ILENGTH,RLENGTH,UNLENGTH READ(ICOM,30) IDWSPH,ISPEED,IATTS,IPRINT C IF(IDWSPH.EQ.0) ISPEED=1 C READ(ICOM,31) IDCM,TD,T,RSJ READ(ICOM,32) ILPM,XLPM0 C IF((IDCM.GE.1).OR.(ILPM.EQ.1)) THEN CALL ATDATA ENDIF NLEC=INT((NAT-0.0001)/4)+1 C DO I=1,NLEC NDEB=4*(I-1) + 1 NFIN=MIN0(4*I,NAT) READ(ICOM,33) (UJ2(J),J=NDEB,NFIN) ENDDO C DO JLINE=1,5 READ(ICOM,1) RIEN ENDDO READ(ICOM,5) TESLEC IF(TESLEC.EQ.'DATA FI') THEN BACKSPACE ICOM ELSE IRET=9 GOTO 605 ENDIF C READ(ICOM,34) INFILE1,IUI1 READ(ICOM,34) INFILE2,IUI2 READ(ICOM,34) INFILE3,IUI3 READ(ICOM,34) INFILE4,IUI4 READ(ICOM,34) INFILE5,IUI5 READ(ICOM,34) INFILE6,IUI6 C IF(SPECTRO.NE.'APC') THEN DO JLINE=1,9 READ(ICOM,1) RIEN ENDDO ELSE DO JLINE=1,6 READ(ICOM,1) RIEN ENDDO READ(ICOM,34) INFILE7,IUI7 READ(ICOM,34) INFILE8,IUI8 READ(ICOM,34) INFILE9,IUI9 ENDIF C C Set up of the switch controlling external C reading of the detector directions and C averaging over them for an undetected electron C IF(SPECTRO.EQ.'APC') THEN IF((I_EXT.EQ.-1).OR.(I_EXT_A.EQ.-1)) THEN IF(I_EXT*I_EXT_A.EQ.0) THEN WRITE(IUO1,523) I_EXT=-1 I_EXT_A=-1 OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') READ(IUI6,713) IDIR,NSET READ(IUI9,713) IDIR_A,NSET_A IF(IDIR.EQ.2) THEN IF(NSET.NE.NSET_A) WRITE(IUO1,524) NSET,NSET_A STOP ENDIF ENDIF ENDIF IF(I_INT.EQ.1) THEN I_EXT=2 ELSEIF(I_INT.EQ.2) THEN I_EXT_A=2 ELSEIF(I_INT.EQ.3) THEN I_EXT=2 I_EXT_A=2 ENDIF ENDIF C IF(I_EXT.EQ.-1) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,701) IDIR,I_SET,N_POINTS READ(IUI6,702) I_PH,N_FIXED,N_SCAN DO JS=1,I_SET READ(IUI6,703) TH_0(JS),PH_0(JS) ENDDO CLOSE(IUI6) IF(IDIR.NE.2) IRET=12 IF(I_PH.NE.IPH_1) IPH_1=I_PH IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN IF(I_PH.EQ.0) THEN NTHETA=N_FIXED NPHI=N_SCAN ELSE NTHETA=N_SCAN NPHI=N_FIXED ENDIF ICHKDIR=2 ENDIF ENDIF IF(I_EXT.GE.1) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,701) IDIR,I_SET,N_POINTS CLOSE(IUI6) IF((IDIR.NE.1).AND.(I_EXT.EQ.2)) IRET=12 N_FIXED=N_POINTS N_SCAN=1 NTHETA=N_POINTS NPHI=1 ENDIF IF(I_EXT_A.GE.1) THEN IF(SPECTRO.EQ.'APC') THEN OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A CLOSE(IUI9) ELSE OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A CLOSE(IUI6) ENDIF IF((IDIR_A.NE.1).AND.(I_EXT_A.EQ.2)) IRET=12 N_FIXED_A=N_POINTS_A N_SCAN_A=1 NTHETA_A=N_POINTS_A NPHI_A=1 ENDIF C IF(I_EXT_A.EQ.-1) THEN IF(SPECTRO.EQ.'APC') THEN OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') READ(IUI9,701) IDIR_A,I_SET_A,N_POINTS_A READ(IUI9,702) I_PH_A,N_FIXED_A,N_SCAN_A CLOSE(IUI9) ELSE OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,701) IDIR_A,I_SET_A,N_POINTS_A READ(IUI6,702) I_PH_A,N_FIXED_A,N_SCAN_A CLOSE(IUI6) ENDIF IF(IDIR_A.NE.2) IRET=12 IF(I_PH_A.EQ.0) THEN NTHETA_A=N_FIXED_A NPHI_A=N_SCAN_A ELSE NTHETA_A=N_SCAN_A NPHI_A=N_FIXED_A ENDIF ICHKDIR_A=2 ENDIF C DO JLINE=1,5 READ(ICOM,1) RIEN ENDDO C READ(ICOM,34) OUTFILE1,IUO1 READ(ICOM,34) OUTFILE2,IUO2 READ(ICOM,34) OUTFILE3,IUO3 READ(ICOM,34) OUTFILE4,IUO4 C IUSCR=MAX0(ICOM,IUI2,IUI3,IUI4,IUI5,IUI6,IUI7,IUI8,IUI9,IUO1,IUO2, &IUO3,IUO4)+1 IUSCR2=IUSCR+1 C IF(IADS.GE.1) THEN OPEN(UNIT=IUI5, FILE=INFILE5, STATUS='OLD') READ(IUI5,1) RIEN READ(IUI5,12) NATA,NADS1,NADS2,NADS3 IF(NATA.EQ.1) THEN NADS2=0 NADS3=0 ELSEIF(NATA.EQ.2) THEN NADS3=0 ENDIF READ(IUI5,35) (NZAT(I),I=NAT+1,NAT+NATA) READ(IUI5,36) (CHEM(I),I=NAT+1,NAT+NATA) READ(IUI5,37) (UJ2(NAT+J),J=1,NATA) READ(IUI5,38) NRELA,(PCRELA(I),I=1,NRELA) IF(NRELA.EQ.0) THEN DO JRELA=1,3 PCRELA(JRELA)=0. ENDDO ENDIF NADS=NADS1+NADS2+NADS3 DO JADS=1,NADS READ(IUI5,9) (ADS(I,JADS),I=1,3) ENDDO CLOSE(IUI5) ELSE NATA=0 NRELA=0 ENDIF C GOTO 601 C 605 REWIND ICOM DO JLINE=1,500 READ(ICOM,5) TESLEC IF(TESLEC.EQ.'CONTROL') THEN BACKSPACE ICOM READ(ICOM,34) OUTFILE1,IUO1 GOTO 601 ENDIF ENDDO C 601 IF((JFICH.EQ.1).OR.(ISOM.EQ.0)) THEN c LINE REMOVED BY PYMSSPEC ENDIF IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN WRITE(IUO1,105) INDATA(JFICH) ENDIF C IF(IRET.EQ.1) RETURN 1 IF(IRET.EQ.3) RETURN 3 IF(IRET.EQ.4) RETURN 4 IF(IRET.EQ.5) RETURN 5 IF(IRET.EQ.6) RETURN 6 IF(IRET.EQ.7) RETURN 7 IF(IRET.EQ.8) RETURN 8 IF(IRET.EQ.9) RETURN 9 IF(IRET.EQ.10) RETURN 10 IF(IRET.EQ.11) RETURN 11 IF(IRET.EQ.12) RETURN 12 IF(IRET.EQ.13) RETURN 13 C C C.......... Writing of the input data in unit IUO1 .......... C C WRITE(IUO1,100) WRITE(IUO1,101) WRITE(IUO1,101) WRITE(IUO1,102) TEXTE1 WRITE(IUO1,101) WRITE(IUO1,101) WRITE(IUO1,203) C IF(I_TEST.NE.2) THEN WRITE(IUO1,201) TEXTE2 ELSE IF(ABS(IPOL).EQ.1) THEN WRITE(IUO1,525) ELSEIF(ABS(IPOL).EQ.2) THEN WRITE(IUO1,526) ENDIF ENDIF C IF(NAT.GT.NATP_M) RETURN 2 IF(NE.GT.NE_M) RETURN 2 IF(NEMET.GT.NEMET_M) RETURN 2 C IF(I_TEST.EQ.2) GOTO 606 IF(IBAS.EQ.0) THEN WRITE(IUO1,204) A,IBAS GOTO 604 ENDIF WRITE(IUO1,103) CRIST,CENTR,IBAS,NAT IF(NCRIST.EQ.1) THEN BSURA=1. CSURA=1. WRITE(IUO1,304) A ELSEIF((NCRIST.EQ.2).OR.(NCRIST.EQ.7).OR.(NCRIST.EQ.6)) THEN BSURA=1. WRITE(IUO1,404) A,CSURA IF((NCRIST.EQ.6).AND.(CSURA.EQ.1.)) THEN WRITE(IUO1,206) ALPHAD ELSEIF(NCRIST.EQ.4) THEN WRITE(IUO1,306) BETAD ENDIF ELSEIF((NCRIST.EQ.3).OR.(NCRIST.EQ.5).OR.(NCRIST.EQ.8)) THEN WRITE(IUO1,104) A,BSURA,CSURA IF(NCRIST.NE.3) THEN WRITE(IUO1,106) ALPHAD,BETAD,GAMMAD ENDIF ENDIF IF(NCRIST.EQ.7) THEN WRITE(IUO1,107) IH,IK,II,IL ELSE WRITE(IUO1,207) IH,IK,IL ENDIF WRITE(IUO1,108) NIV,COUPUR,ITEST,IESURF IF(NAT.GT.1) THEN DO I=1,NAT J=3*(I-1) WRITE(IUO1,109) ATBAS(1+J),ATBAS(2+J),ATBAS(3+J),CHEM(I),NZAT( &I) ENDDO ENDIF IF(NCRIST.EQ.8) THEN DO I=1,3 J=3*(I-1) WRITE(IUO1,209) VECBAS(1+J),VECBAS(2+J),VECBAS(3+J) ENDDO ENDIF IF(IREL.GE.1) THEN WRITE(IUO1,110) IREL,NREL,(PCREL(I),I=1,2) IF(NREL.GT.2) THEN NLIGNE=INT(FLOAT(NREL-2)/4.)+1 DO J=1,NLIGNE WRITE(IUO1,210) (PCREL(I),I=1,4) ENDDO ENDIF IF(NREL.GT.10) RETURN 4 WRITE(IUO1,112) OMEGAD1,OMEGAD2,IADS ENDIF IF((IREL.EQ.0).AND.(IADS.EQ.1)) WRITE(IUO1,212) IADS IF(IADS.GE.1) THEN WRITE(IUO1,501) DO JADS=1,NADS IF(JADS.LE.NADS1) THEN IF(JADS.EQ.1) WRITE(IUO1,303) NAT+1 WRITE(IUO1,309) (ADS(I,JADS),I=1,3) ELSEIF((JADS.GT.NADS1).AND.(JADS.LE.(NADS1+NADS2))) THEN IF(JADS.EQ.(NADS1+1)) WRITE(IUO1,303) NAT+2 WRITE(IUO1,309) (ADS(I,JADS),I=1,3) ELSEIF(JADS.GT.(NADS1+NADS2)) THEN IF(JADS.EQ.(NADS2+1)) WRITE(IUO1,303) NAT+3 WRITE(IUO1,309) (ADS(I,JADS),I=1,3) ENDIF ENDDO ENDIF IF((IREL.GT.0).OR.(NRELA.GT.0)) WRITE(IUO1,502) IF(NRELA.GT.0) THEN WRITE(IUO1,311) (PCRELA(I),I=1,NRELA) ENDIF 604 IF(IREL.GT.0) THEN WRITE(IUO1,211) (PCREL(I),I=1,NREL) ENDIF C 606 IF(SPECTRO.EQ.'APC') WRITE(IUO1,517) C IF(SPECTRO.EQ.'PHD') THEN C IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,503) ELSE WRITE(IUO1,527) ENDIF ENDIF IF(IE.EQ.1) WRITE(IUO1,504) IF(ITHETA.EQ.1) WRITE(IUO1,505) IF(IFTHET.EQ.1) WRITE(IUO1,506) IF(I_AMP.EQ.1) WRITE(IUO1,534) C WRITE(IUO1,201) TEXTE4 WRITE(IUO1,113) ISPIN,IDICHR,IPOL WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET C IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN WRITE(IUO1,508) STOP ENDIF IF(ABS(THLUM).GT.90.0) THEN WRITE(IUO1,509) STOP ENDIF ENDIF C WRITE(IUO1,116) PHI0,THETA0,E0,R1 WRITE(IUO1,216) PHI1,THETA1,EFIN,R2 WRITE(IUO1,117) THLUM,PHILUM,ELUM WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR C IF(IMOY.GT.3) IMOY=3 IF(IMOY.LT.0) IMOY=0 IF(IMOY.EQ.0) NDIR=1 IF(IMOY.EQ.1) NDIR=5 IF(IMOY.EQ.2) NDIR=13 IF(IMOY.EQ.3) NDIR=49 IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1 C ELSEIF(SPECTRO.EQ.'LED') THEN C IF(IPHI.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,529) ELSE WRITE(IUO1,530) ENDIF ENDIF IF(IE.EQ.1) WRITE(IUO1,531) IF(ITHETA.EQ.1) WRITE(IUO1,532) IF(IFTHET.EQ.1) WRITE(IUO1,506) IF(I_AMP.EQ.1) WRITE(IUO1,534) C WRITE(IUO1,201) TEXTE4 WRITE(IUO1,141) ISPIN WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET C IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN WRITE(IUO1,508) STOP ENDIF ENDIF C WRITE(IUO1,116) PHI0,THETA0,E0,R1 WRITE(IUO1,216) PHI1,THETA1,EFIN,R2 WRITE(IUO1,142) TH_INI,PHI_INI WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR C IF(IMOY.GT.3) IMOY=3 IF(IMOY.LT.0) IMOY=0 IF(IMOY.EQ.0) NDIR=1 IF(IMOY.EQ.1) NDIR=5 IF(IMOY.EQ.2) NDIR=13 IF(IMOY.EQ.3) NDIR=49 C ELSEIF(SPECTRO.EQ.'XAS') THEN C WRITE(IUO1,507) IF(I_AMP.EQ.1) WRITE(IUO1,534) WRITE(IUO1,201) TEXTE5 WRITE(IUO1,113) ISPIN,IDICHR,IPOL WRITE(IUO1,134) EDGE,NEDGE,INITL,THLUM,PHILUM WRITE(IUO1,119) NE_X,EK_INI,EK_FIN,EPH_INI C ELSEIF(SPECTRO.EQ.'AED') THEN C IF(IPHI_A.EQ.1) THEN IF(STEREO.EQ.' NO') THEN WRITE(IUO1,515) ELSE WRITE(IUO1,528) ENDIF ENDIF IF(ITHETA_A.EQ.1) WRITE(IUO1,516) IF(I_AMP.EQ.1) WRITE(IUO1,534) WRITE(IUO1,201) TEXTE6 WRITE(IUO1,113) ISPIN,IDICHR,IPOL WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A WRITE(IUO1,140) I_MULT,IM1,MULT,IM2 WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A C IF(IMOY_A.GT.3) IMOY_A=3 IF(IMOY_A.LT.0) IMOY_A=0 IF(IMOY_A.EQ.0) NDIR_A=1 IF(IMOY_A.EQ.1) NDIR_A=5 IF(IMOY_A.EQ.2) NDIR_A=13 IF(IMOY_A.EQ.3) NDIR_A=49 C ELSEIF(SPECTRO.EQ.'APC') THEN C WRITE(IUO1,518) IF(IPHI.EQ.1) WRITE(IUO1,503) IF(ITHETA.EQ.1) WRITE(IUO1,505) IF(IFTHET.EQ.1) WRITE(IUO1,506) IF(I_AMP.EQ.1) WRITE(IUO1,534) C WRITE(IUO1,201) TEXTE4 WRITE(IUO1,113) ISPIN,IDICHR,IPOL WRITE(IUO1,120) NI,NLI,S_O,INITL,I_SO WRITE(IUO1,114) IPHI,ITHETA,IE,IFTHET WRITE(IUO1,115) NPHI,NTHETA,NE,NFTHET C IF((ITHETA.EQ.1).AND.(IFTHET.EQ.0)) THEN IF((THETA0.LT.-90.0).OR.(THETA1.GT.90.0)) THEN WRITE(IUO1,508) STOP ENDIF IF(ABS(THLUM).GT.90.0) THEN WRITE(IUO1,509) STOP ENDIF ENDIF C WRITE(IUO1,116) PHI0,THETA0,E0,R1 WRITE(IUO1,216) PHI1,THETA1,EFIN,R2 WRITE(IUO1,117) THLUM,PHILUM,ELUM WRITE(IUO1,118) IMOD,IMOY,ACCEPT,ICHKDIR C IF(IMOY.GT.3) IMOY=3 IF(IMOY.LT.0) IMOY=0 IF(IMOY.EQ.0) NDIR=1 IF(IMOY.EQ.1) NDIR=5 IF(IMOY.EQ.2) NDIR=13 IF(IMOY.EQ.3) NDIR=49 IF((LI.EQ.0).AND.(INITL.NE.0)) INITL=1 C WRITE(IUO1,519) IF(IPHI_A.EQ.1) WRITE(IUO1,515) IF(ITHETA_A.EQ.1) WRITE(IUO1,516) WRITE(IUO1,201) TEXTE6 WRITE(IUO1,113) ISPIN,IDICHR,IPOL WRITE(IUO1,135) EDGE_C,NEDGE_C,EDGE_I,NEDGE_I,EDGE_A,NEDGE_A WRITE(IUO1,140) I_MULT,IM1,MULT,IM2 WRITE(IUO1,136) IPHI_A,ITHETA_A,IFTHET_A,I_INT WRITE(IUO1,137) NPHI_A,NTHETA_A,NFTHET_A WRITE(IUO1,138) PHI0_A,THETA0_A,R1_A WRITE(IUO1,139) PHI1_A,THETA1_A,R2_A WRITE(IUO1,118) IMOD_A,IMOY_A,ACCEPT_A,ICHKDIR_A C IF(IMOY_A.GT.3) IMOY_A=3 IF(IMOY_A.LT.0) IMOY_A=0 IF(IMOY_A.EQ.0) NDIR_A=1 IF(IMOY_A.EQ.1) NDIR_A=5 IF(IMOY_A.EQ.2) NDIR_A=13 IF(IMOY_A.EQ.3) NDIR_A=49 C WRITE(IUO1,520) C ELSEIF(SPECTRO.EQ.'EIG') THEN C WRITE(IUO1,143) NE_EIG,E0_EIG,EFIN_EIG,I_DAMP DO JLINE=1,N_LINE_E-1 J=(JLINE-1)*4 WRITE(IUO1,145) I_SPECTRUM(J+1),I_SPECTRUM(J+2),I_SPECTRUM(J+3 &),I_SPECTRUM(J+4) ENDDO J=4*(N_LINE_E-1) WRITE(IUO1,145) (I_SPECTRUM(J+K),K=1,N_LAST) C WRITE(IUO1,146) I_PWM,METHOD,RACC,EXPO WRITE(IUO1,147) N_MAX,N_ITER,N_TABLE,SHIFT WRITE(IUO1,148) I_XN,I_VA,I_GN,I_WN WRITE(IUO1,149) LEVIN,ALPHAR,BETAR WRITE(IUO1,533) C ENDIF C WRITE(IUO1,201) TEXTE7 C IF(SPECTRO.NE.'EIG') THEN C WRITE(IUO1,121) NO,NDIF,ISPHER,I_GR C IF(SPECTRO.EQ.'XAS') NDIF=NDIF+1 C WRITE(IUO1,122) ISFLIP,IR_DIA,ITRTL,I_TEST C IF(ISFLIP.EQ.0) THEN NSTEP=3 ELSE NSTEP=1 ENDIF DO N=1,NLG NRL=3*N JD=3*(N-1)+1 IF(N.EQ.NLG) NRL=NEMET IF(N.EQ.1) NEMO=NEMET1 IF(N.LT.NLG) THEN WRITE(IUO1,123) NEMO,(IEMET(J), J=JD, NRL) ELSE NTE=NEMET-JD+1 IF(NTE.EQ.1) WRITE(IUO1,223) NEMO,(IEMET(J),J=JD,NEMET) IF(NTE.EQ.2) WRITE(IUO1,323) NEMO,(IEMET(J),J=JD,NEMET) IF(NTE.EQ.3) WRITE(IUO1,123) NEMO,(IEMET(J),J=JD,NEMET) ENDIF ENDDO ENDIF IF(SPECTRO.NE.'EIG') THEN WRITE(IUO1,124) ISOM,NONVOL(JFICH),NPATHP,VINT WRITE(IUO1,125) IFWD,NTHOUT,I_NO,I_RA DO JAT=1,NAT WRITE(IUO1,126) N_RA(JAT),THFWD(JAT),IBWD(JAT),THBWD(JAT) RTHFWD(JAT)=THFWD(JAT)*PIS180 RTHBWD(JAT)=THBWD(JAT)*PIS180 ENDDO WRITE(IUO1,127) IPW,NCUT,PCTINT,IPP WRITE(IUO1,128) ILENGTH,RLENGTH,UNLENGTH WRITE(IUO1,129) IDWSPH,ISPEED,IATTS,IPRINT ELSE WRITE(IUO1,144) VINT ENDIF WRITE(IUO1,130) IDCM,TD,T,RSJ WRITE(IUO1,131) ILPM,XLPM0 DO I=1,NLEC NDEB=4*(I-1) + 1 NFIN=4*I IF(I.EQ.NLEC) NFIN=NAT NUJ=NFIN-NDEB+1 IF(NUJ.EQ.1) WRITE(IUO1,132) (UJ2(J),J=NDEB,NFIN) IF(NUJ.EQ.2) WRITE(IUO1,232) (UJ2(J),J=NDEB,NFIN) IF(NUJ.EQ.3) WRITE(IUO1,332) (UJ2(J),J=NDEB,NFIN) IF(NUJ.EQ.4) WRITE(IUO1,432) (UJ2(J),J=NDEB,NFIN) ENDDO IF(IADS.EQ.1) THEN IF(NATA.EQ.1) WRITE(IUO1,133) (UJ2(J),J=NAT+1,NAT+NATA) IF(NATA.EQ.2) WRITE(IUO1,233) (UJ2(J),J=NAT+1,NAT+NATA) IF(NATA.EQ.3) WRITE(IUO1,333) (UJ2(J),J=NAT+1,NAT+NATA) ENDIF C IF(UNLENGTH.EQ.'ATU') RLENGTH=RLENGTH*BOHR/A IF(UNLENGTH.EQ.'ANG') RLENGTH=RLENGTH/A IF(IBAS.GT.0) THEN OMEGA1=OMEGAD1*PIS180 OMEGA2=OMEGAD2*PIS180 ENDIF QD=0. DO J=1,NATM UJ2(J)=UJ2(J)/(A*A) ENDDO IF(E0.EQ.0.) E0=0.0001 NPOINT=NPHI*NE*NTHETA ISORT1=0 IF(NPOINT.GT.250) THEN ISORT1=1 WRITE(IUO1,510) ENDIF C IF(IDWSPH.EQ.1) THEN NFAC=N_GAUNT ELSE NFAC=4*NL_M ENDIF IF(SPECTRO.EQ.'EIG') THEN C C Switch for including vibrational damping into the MS matrix C C I_VIB = 0 : no vibrations included C I_VIB = 1 : vibrations included C C and mean free path-like damping C C I_MFP = 0 : no Im(k) damping included C I_MFP = 1 : Im(k) damping included C I_VIB=MOD(I_DAMP,2) IF(I_VIB.EQ.1) THEN IDWSPH=1 ELSE IDWSPH=0 ENDIF IF(I_DAMP.LE.1) THEN I_MFP=0 ELSE I_MFP=1 ENDIF ENDIF C C Storage of the logarithm of the Gamma function GLD(N+1,N_INT) C for integer (N_INT=1) and semi-integer (N_INT=2) values : C C GLD(N+1,1) = Log(N!) for N integer C GLD(N+1/2,2) = Log(N!) for N semi-integer C IF((ISPHER.GE.0).OR.(I_MULT.EQ.1)) THEN GLG(1)=0.0 GLD(1,1)=0.D0 GLD(1,2)=DLOG(SQPI/2.D0) DO I=2,NFAC J=I-1 GLG(I)=GLG(J)+ALOG(FLOAT(J)) GLD(I,1)=GLD(J,1)+DLOG(DFLOAT(J)) GLD(I,2)=GLD(J,2)+DLOG(DFLOAT(J) +0.5D0) ENDDO ELSEIF((IFTHET.EQ.1).AND.(ITEST.EQ.1)) THEN GLG(1)=0.0 DO I=2,NFAC J=I-1 GLG(I)=GLG(J)+ALOG(FLOAT(J)) ENDDO ENDIF EXPF(0,0)=1. EXPR(0,0)=1. FACT1L=0.D0 DO L=1,2*NL_M-2 XDEN=1./SQRT(FLOAT(L+L+1)) DXDEN=1.D0/DSQRT(DFLOAT(L+L+1)) FACT1L=FACT1L+DLOG(DFLOAT(L)) FACT2L=DLOG(DFLOAT(L+1)) DO M1=0,L EXPF(M1,L)=EXP(0.5*(GLG(L+M1+1)-GLG(L-M1+1))) DEXPF=DEXP(0.5D0*(GLD(L+M1+1,1)-GLD(L-M1+1,1))) EXPR(M1,L)=EXP(0.5*(GLG(L+L+1)-GLG(L+M1+1)-GLG(L-M1+1))) EXPF2(L,M1)=EXPF(M1,L)*XDEN DEXPF2(L,M1)=DEXPF*DXDEN IF(M1.GT.0) THEN FACT2L=FACT2L+DLOG(DFLOAT(1+L+M1)) ENDIF IF(L.LT.NL_M) THEN DO M2=0,L CF(L,M1,M2)=SQRT(FLOAT((L*L-M1*M1)*(L*L-M2*M2)))/FLOAT(L) ENDDO ENDIF ENDDO FSQ(L)=EXP(0.5*REAL(FACT2L-FACT1L)) DFSQ(L)=DEXP(0.5D0*(FACT2L-FACT1L)) ENDDO C IF((INITL.LT.-1).OR.(INITL.GT.2)) THEN INITL=1 WRITE(IUO1,511) ENDIF NEPS=2-ABS(IPOL) IF(IDICHR.GE.1) NEPS=1 ISTEP_LF=ABS(INITL) IF(INITL.EQ.-1) THEN LF1=LI-1 LF2=LF1 ELSEIF(INITL.EQ.1) THEN LF1=LI+1 LF2=LF1 ELSEIF(INITL.EQ.2) THEN LF1=LI-1 LF2=LI+1 ELSEIF(INITL.EQ.0) THEN LF1=LI LF2=LI ISTEP_LF=1 ENDIF C C Initialization of the values of ji if spin-orbit is taken C into account. C C Here : JI is the loop index going from JF1 to JF2 with : C C JI=1 : ji = li + 1/2 C JI=2 : ji = li - 1/2 C IF(I_SO.EQ.0) THEN JF1=1 JF2=2 ELSEIF(I_SO.EQ.1) THEN IF(S_O.EQ.'1/2') THEN IF(LI.EQ.0) THEN JF1=1 JF2=1 ELSEIF(LI.EQ.1) THEN JF1=2 JF2=2 ENDIF ELSEIF(S_O.EQ.'3/2') THEN IF(LI.EQ.1) THEN JF1=1 JF2=1 ELSEIF(LI.EQ.2) THEN JF1=2 JF2=2 ENDIF ELSEIF(S_O.EQ.'5/2') THEN IF(LI.EQ.2) THEN JF1=1 JF2=1 ELSEIF(LI.EQ.3) THEN JF1=2 JF2=2 ENDIF ELSEIF(S_O.EQ.'7/2') THEN IF(LI.EQ.3) THEN JF1=1 JF2=1 ELSEIF(LI.EQ.4) THEN JF1=2 JF2=2 ENDIF ELSEIF(S_O.EQ.'9/2') THEN IF(LI.EQ.4) THEN JF1=1 JF2=1 ELSE RETURN 7 ENDIF ELSE RETURN 7 ENDIF ELSEIF(I_SO.EQ.2) THEN JF1=1 JF2=2 ELSE RETURN 7 ENDIF C IF(NI.LE.5) THEN NNL=NI*(NI-1)/2 +LI+1 ELSEIF(NI.EQ.6) THEN NNL=NI*(NI-1)/2 +LI ELSEIF(NI.EQ.7) THEN NNL=NI*(NI-1)/2 +LI-3 ENDIF C C Storage of the Clebsch-Gordan coefficients for the spin-orbit C dependent coupling matrix elements in the array CG(MJI,JI,JSPIN). C C Here : JI=1 : ji = li + 1/2 C JI=2 : ji = li - 1/2 C MJI : mji + 1/2 C JSPIN=1 : msi = +1/2 C JSPIN=2 : msi = -1/2 C C so that all indices remain integer C IF((I_SO.GT.0).OR.(ISPIN.EQ.1).OR.(SPECTRO.EQ.'APC')) THEN DO JS=1,2 DO JI=1,2 DO MJI=-LI,LI+1 CG(MJI,JI,JS)=0.0 ENDDO ENDDO ENDDO DO MJI=-LI,LI+1 CG(MJI,1,1)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1)) CG(MJI,1,2)=SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1)) IF((MJI.GT.-LI).AND.(MJI.LT.LI+1)) THEN CG(MJI,2,1)=-SQRT(FLOAT(LI-MJI+1)/FLOAT(LI+LI+1)) CG(MJI,2,2)=SQRT(FLOAT(LI+MJI)/FLOAT(LI+LI+1)) ENDIF ENDDO ENDIF C C C Storage of the Clebsch-Gordan coefficients for the Auger multiplet C dependent coupling matrix elements in the array CGA(LJ1,MJ1,LJ2,MJ2,LJ). C C Here : LJ1 is an integer index related to J1 (LJ1=2*J1) C LMJ1 is an integer index related to MJ1 (LMJ1=2*MJ1) C LJ2 is an integer index related to J2 (LJ2=2*J2) C LMJ2 is an integer index related to MJ2 (LMJ2=2*MJ2) C LJ is an integer index related to J : C J = FLOAT(LJ) for J integer C J = FLOAT(LJ) + 0.5 for J half integer C C so that all indices remain integer C IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN IF(I_MULT.EQ.1) THEN N=3 MJ3=0.D0 LJ_MAX=2*(LI_I+LI_A+1) DO LJ1=0,LJ_MAX J1=DFLOAT(LJ1)/2.D0 DO LMJ1=-LJ1,LJ1,2 MJ1=DFLOAT(LMJ1)/2.D0 DO LJ2=0,LJ_MAX J2=DFLOAT(LJ2)/2.D0 DO LMJ2=-LJ2,LJ2,2 MJ2=DFLOAT(LMJ2)/2.D0 CALL N_J(J1,MJ1,J2,MJ2,MJ3,NJ,I_INT,N) C JJ12=J1-J2 JL12=MJ1-MJ2 C LJ12=INT(JJ12+SIGN(SMALL,JJ12)) LL12=INT(JL12+SIGN(SMALL,JL12)) C JJ_MIN=ABS(LJ12) JJ_MAX=J1+J2 LJJ_MIN=INT(JJ_MIN+SIGN(SMALL,JJ_MIN)) LJJ_MAX=INT(JJ_MAX+SIGN(SMALL,JJ_MAX)) C DO LJJ=LJJ_MIN,LJJ_MAX,1 IF(I_INT.EQ.1) THEN JJ=DFLOAT(LJJ) ELSE JJ=DFLOAT(LJJ)+0.5D0 ENDIF L_EXP=INT(J1-J2+MJ1+MJ2) IF(MOD(L_EXP,2).EQ.0) THEN CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=NJ(LJJ)*SQRT(2.*REAL(JJ &)+1.) ELSE CGA(LJ1,LMJ1,LJ2,LMJ2,LJJ)=-NJ(LJJ)*SQRT(2.*REAL(J &J)+1.) ENDIF ENDDO ENDDO ENDDO ENDDO ENDDO ENDIF ENDIF C C Storage of another of the spin Clebsch-Gordan used C when the Auger line is multiplet-resolved. It C originates from the coupling of SA and SC, C the spins of the Auger electron of the original C core electron (which is supposed to be the same C as that of the photoelectron). C C CG_S(I,J,K) with : I = 1 ---> MSA = -1/2 C I = 2 ---> MSA = 1/2 C J = 1 ---> MSC = -1/2 C J = 2 ---> MSC = 1/2 C K = 1 ---> S = 0 C K = 2 ---> S = 1 C C MS = MSA+MSC C IF(I_MULT.EQ.1) THEN CG_S(1,1,1)=0. CG_S(1,1,2)=1. CG_S(1,2,1)=-0.707107 CG_S(1,2,2)= 0.707107 CG_S(2,1,1)= 0.707107 CG_S(2,1,2)= 0.707107 CG_S(2,2,1)= 0. CG_S(2,2,2)= 1. ENDIF C C Initialization of the variables used when only one multiplet C is taken into account in the Auger peak C IF(I_MULT.EQ.1) THEN MULTIPLET=CHAR(48+IM1)//MULT//CHAR(48+IM2) IF(MOD(IM1,2).EQ.0) THEN WRITE(IUO1,522) IM1 STOP ENDIF S_MUL=(IM1-1)/2 J_MUL=IM2 IF(MULT.EQ.'S') THEN L_MUL=0 ELSEIF(MULT.EQ.'P') THEN L_MUL=1 ELSEIF(MULT.EQ.'D') THEN L_MUL=2 ELSEIF(MULT.EQ.'F') THEN L_MUL=3 ELSEIF(MULT.EQ.'G') THEN L_MUL=4 ELSEIF(MULT.EQ.'H') THEN L_MUL=5 ELSEIF(MULT.EQ.'I') THEN L_MUL=6 ELSEIF(MULT.EQ.'K') THEN L_MUL=7 ELSEIF(MULT.EQ.'L') THEN L_MUL=8 ELSEIF(MULT.EQ.'M') THEN L_MUL=9 ELSE WRITE(IUO1,521) MULTIPLET STOP ENDIF ENDIF C C.......... Check of the dimensioning in the Gaussian case .......... C CALL STOP_EXT(I_EXT,I_EXT_A,SPECTRO) C C.................... Read FORMAT .................... C C 1 FORMAT(A7) 2 FORMAT(21X,10A4) 3 FORMAT(7X,A3,9X,A1,9X,I1,6X,I4) 4 FORMAT(8X,F6.3,4X,F6.3,4X,F6.3,3X,A3) 5 FORMAT(49X,A7) 6 FORMAT(7X,F6.2,4X,F6.2,4X,F6.2) 7 FORMAT(8X,I2,8X,I2,8X,I2,8X,I2) 8 FORMAT(8X,I2,8X,F6.3,3X,I3,9X,I1) 9 FORMAT(8X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2) 10 FORMAT(9X,I1,8X,I2,7X,F5.1,5X,F5.1) 11 FORMAT(7X,F5.1,3(5X,F5.1)) 12 FORMAT(7X,F6.2,4X,F6.2,6X,I1) 13 FORMAT(7X,A3,9X,I1,9X,I1,8X,I2) 14 FORMAT(8X,I2,9X,I1,9X,I1,9X,I1,9X,I1) 15 FORMAT(7X,I3,7X,I3,7X,I3,7X,I3) 16 FORMAT(6X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3) 17 FORMAT(6X,F7.2,3X,F7.2,2X,F8.2) 18 FORMAT(9X,I1,9X,I1,8X,F5.2,6X,I1) 19 FORMAT(7X,I3,6X,F7.2,3X,F7.2,2X,F8.2) 20 FORMAT(8X,I1,A1,8X,A3,7X,I2,8X,I2) 21 FORMAT(8X,I2,8X,I2,9X,I1,9X,I1) 22 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1) 23 FORMAT(8X,I2) 24 FORMAT(8X,I2,3(8X,I2)) 25 FORMAT(9X,I1,8X,I2,6X,I4,8X,F6.2) 26 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1) 27 FORMAT(9X,I1,6X,F6.2,7X,I1,7X,F6.2) 28 FORMAT(9X,I1,9X,I1,7X,F8.4,4X,I1) 29 FORMAT(9X,I1,7X,F6.2,4X,A3) 30 FORMAT(9X,I1,8X,I2,9X,I1,9X,I1) 31 FORMAT(9X,I1,6X,F8.3,2X,F8.3,5X,F4.2) 32 FORMAT(8X,I2,7X,F6.2) 33 FORMAT(8X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5) 34 FORMAT(9X,A24,5X,I2) 35 FORMAT(18X,I2,8X,I2,8X,I2) 36 FORMAT(18X,A2,8X,A2,8X,A2) 37 FORMAT(18X,F8.5,2X,F8.5,2X,F8.5) 38 FORMAT(9X,I1,7X,F5.1,5X,F5.1,5X,F5.1) 39 FORMAT(8X,A1,I1,8X,I2,6X,F7.2,3X,F7.2) 40 FORMAT(8X,A1,I1,8X,A1,I1,8X,A1,I1) 41 FORMAT(6X,F7.2,3X,F7.2,5X,F6.3) 42 FORMAT(9X,I1,8X,I1,A1,I1) 43 FORMAT(7X,I3,6X,F7.2,3X,F7.2,6X,I1) 44 FORMAT(9X,I1) 46 FORMAT(8X,I2,6X,A4,9X,F7.5,2X,F6.3) 47 FORMAT(5X,I5,6X,I4,6X,I4,8X,F6.3) 48 FORMAT(9X,I1,9X,I1,9X,I1,9X,I1) 49 FORMAT(8X,I2,6X,F7.2,3X,F7.2) C C C.................... Write FORMAT .................... C C 100 FORMAT(//////////,'******************************', '************* &***************************************') 101 FORMAT('*********************',40X,'*********************') 102 FORMAT('*********************',10A4,'*********************') 103 FORMAT(10X,A3,9X,A1,9X,I1,6X,I4,9X,'CRIST,CENTR,IBAS,NAT') 104 FORMAT(11X,F6.3,4X,F6.3,4X,F6.3,15X,'A,BSURA,CSURA') 105 FORMAT(///,'ooooooooooooooooooooooooooooooooooooooooo','oooooooooo &ooooooooooooooooooooooooooooooo',/,'oooooooooooooooo',50X,'ooooooo &ooooooooo',/,'oooooooooooooooo INPUT DATA FILE : ',A24,' ooo &ooooooooooooo',/,'oooooooooooooooo',50X,'oooooooooooooooo',/,'oooo &oooooooooooooooooooooooo','ooooooooooooooooooooooooooooooooooooooo &oooooooooo','ooooo',///) 106 FORMAT(10X,F6.2,4X,F6.2,4X,F6.2,16X,'ALPHAD,BETAD,GAMMAD') 107 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'H,K,I,L') 108 FORMAT(12X,I1,8X,F6.3,3X,I3,9X,I1,9X,'NIV,COUPUR,ITEST,IESURF') 109 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,2X,A2,2X,I2,4X,'ATBAS,CHEM(NAT)',' &,NZAT(NAT)') 110 FORMAT(12X,I1,8X,I2,7X,F5.1,5X,F5.1,7X,'IREL,NREL,PCREL(NREL)') 112 FORMAT(10X,F6.2,4X,F6.2,6X,I1,19X,'OMEGA1,OMEGA2,IADS') 113 FORMAT(12X,I1,9X,I1,8X,I2,19X,'ISPIN,IDICHR,IPOL') 114 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI,ITHETA,IE,', &'IFTHET') 115 FORMAT(10X,I3,7X,I3,7X,I3,7X,I3,9X,'NPHI,NTHETA,NE,NFTHET') 116 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI0,THETA0,E0,R0') 117 FORMAT(9X,F7.2,3X,F7.2,2X,F8.2,16X,'THLUM,PHILUM,ELUM') 118 FORMAT(12X,I1,9X,I1,8X,F5.2,6X,I1,9X,'IMOD,IMOY,ACCEPT,ICHKDIR') 119 FORMAT(10X,I3,6X,F7.2,3X,F7.2,2X,F8.2,6X,'NE,EK_INI,','EK_FIN,EPH_ &INI') 120 FORMAT(11X,I1,A1,8X,A3,7X,I2,8X,I2,9X,'LI,S-O,INITL,I_SO') 121 FORMAT(11X,I2,8X,I2,9X,I1,9X,I1,9X,'NO,NDIF,ISPHER,I_GR') 122 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'ISFLIP,IR_DIA,ITRTL,I_TEST') 123 FORMAT(11X,I2,3(8X,I2),9X,'NEMET,IEMET(NEMET)') 124 FORMAT(12X,I1,8X,I2,6X,I4,7X,F6.2,6X,'ISOM,NONVOL,NPATH,VINT') 125 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'IFWD,NTHOUT,I_NO,I_RA') 126 FORMAT(12X,I1,7X,F6.2,6X,I1,7X,F6.2,6X,'N_RA(NAT),THFWD(NAT)',',IB &WD(NAT),THBWD(NAT)') 127 FORMAT(12X,I1,9X,I1,7X,F8.4,4X,I1,9X,'IPW,NCUT,PCTINT,IPP') 128 FORMAT(12X,I1,7X,F6.2,4X,A3,19X,'ILENGTH,RLENGTH,UNLENGTH') 129 FORMAT(12X,I1,8X,I2,9X,I1,9X,I1,9X,'IDWSPH,ISPEED,IATT,IPRINT') 130 FORMAT(12X,I1,6X,F8.3,2X,F8.3,5X,F4.2,6X,'IDCM,TD,T,RSJ') 131 FORMAT(11X,I2,7X,F6.2,26X,'ILPM,XLPM0') 132 FORMAT(11X,F8.5,33X,'UJ2(NAT) : ','SUBSTRATE') 133 FORMAT(11X,F8.5,33X,'UJ2(NATA) : ','ADSORBATES') 134 FORMAT(11X,A1,I1,8X,I2,6X,F7.2,3X,F7.2,6X,'EDGE,INITL,THLUM,','PHI &LUM') 135 FORMAT(11X,A1,I1,8X,A1,I1,8X,A1,I1,19X,'EDGE_C,EDGE_I,','EDGE_A') 136 FORMAT(11X,I2,9X,I1,9X,I1,9X,I1,9X,'IPHI_A,ITHETA_A,','IFTHET_A,I_ &INT') 137 FORMAT(10X,I3,7X,I3,7X,I3,19X,'NPHI_A,NTHETA_A,NFTHET_A') 138 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI0_A,THETA0_A,R0_A') 139 FORMAT(9X,F7.2,3X,F7.2,5X,F6.3,15X,'PHI1_A,THETA1_A,R1_A') 140 FORMAT(12X,I1,8X,I1,A1,I1,28X,'I_MULT,MULT') 141 FORMAT(12X,I1,39X,'ISPIN') 142 FORMAT(9X,F7.2,3X,F7.2,26X,'TH_INI,PHI_INI') 143 FORMAT(10X,I3,6X,F7.2,3X,F7.2,6X,I1,9X,'NE,EK_INI,EK_FIN,I_DAMP') 144 FORMAT(10X,F6.2,36X,'VINT') 145 FORMAT(11X,I2,8X,I2,8X,I2,8X,I2,9X,'I_SPECTRUM(NE)') 146 FORMAT(11X,I2,6X,A4,9X,F7.5,2X,F6.3,5X,'I_PWM,METHOD,ACC,EXPO') 147 FORMAT(8X,I5,6X,I4,6X,I4,8X,F6.3,5X,'N_MAX,N_ITER,N_TABLE,SHIFT') 148 FORMAT(12X,I1,9X,I1,9X,I1,9X,I1,9X,'I_XN,I_VA,I_GN,I_WN') 149 FORMAT(11X,I2,6X,F7.2,3X,F7.2,16X,'L,ALPHA,BETA') C 201 FORMAT(///,21X,10A4,////) 203 FORMAT('**************************************************', &'********************************',//////////) 204 FORMAT(11X,F6.3,5X,I1,29X,'A,IBAS') 206 FORMAT(10X,F6.2,36X,'ALPHAD') 207 FORMAT(11X,I2,8X,I2,8X,I2,19X,'H,K,L') 209 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'VECBAS') 210 FORMAT(10X,F5.1,3(5X,F5.1),7X,'PCREL(NREL)') 211 FORMAT(20X,'SUBSTRATE : ',10(F5.1,',')) 212 FORMAT(32X,I1,19X,'IADS') 216 FORMAT(9X,F7.2,3X,F7.2,3X,F7.2,5X,F6.3,5X,'PHI1,THETA1,EFIN,R1') 223 FORMAT(11X,I2,1(8X,I2),29X,'NEMET,IEMET(NEMET)') 232 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NAT) : ','SUBSTRATE') 233 FORMAT(11X,F8.5,2X,F8.5,23X,'UJ2(NATA) : ','ADSORBATES') C 303 FORMAT(/,33X,'ATOMS OF TYPE ',I1,' :',/) 304 FORMAT(11X,F6.3,35X,'A') 306 FORMAT(10X,F6.2,36X,'BETAD') 309 FORMAT(11X,F9.6,1X,F9.6,1X,F9.6,12X,'XADS,YADS,ZADS') 311 FORMAT(20X,'ADSORBATE : ',3(F5.1,',')) 323 FORMAT(11X,I2,2(8X,I2),19X,'NEMET,IEMET(NEMET)') 332 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NAT) : ','SUBSTRATE') 333 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,13X,'UJ2(NATA) : ','ADSORBATES') C 404 FORMAT(11X,F6.3,4X,F6.3,25X,'A,CSURA') 432 FORMAT(11X,F8.5,2X,F8.5,2X,F8.5,2X,F8.5,3X,'UJ2(NAT) : ','SUBSTRA &TE') C 501 FORMAT(//,30X,'POSITION OF THE ADSORBATES :') 502 FORMAT(///,25X,'VALUE OF THE RELAXATIONS :',/) 503 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL PHOTOELECTRON',' D &IFFRACTION') 504 FORMAT(///,18X,'TYPE OF CALCULATION : FINE STRUCTURE ','OSCILLATIO &NS') 505 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR PHOTOELECTRON',' DIFFR &ACTION') 506 FORMAT(///,23X,'TYPE OF CALCULATION : SCATTERING FACTOR') 507 FORMAT(///,28X,'TYPE OF CALCULATION : EXAFS') 508 FORMAT(///,2X,' <<<<<<<<<< THE THETA VARIATION EXCEEDS THE ', 'P &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///) 509 FORMAT(///,2X,' <<<<<<<<<< THE THLUM VARIATION EXCEEDS THE ', 'P &HYSICAL LIMITS (-90,+90) >>>>>>>>>>',///) 510 FORMAT(///,4X,' <<<<<<<<<< AS THE CALCULATION HAS MORE THAN ','25 &0 POINTS, SOME OUTPUTS HAVE BEEN SUPRESSED >>>>>>>>>>',///) 511 FORMAT(///,4X,' <<<<<<<<<< INCORRECT VALUE OF INITL, THE ', 'C &ALCULATION IS PERFORMED WITH INITL = 1 >>>>>>>>>>') 512 FORMAT(///,4X,' <<<<<<<<<< IMPOSSIBLE TO HAVE A SPIN RESOLVED ',' &EXAFS EXPERIMENT : DECREASE IDICHR >>>>>>>>>>') 513 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IPOL = 0 AND ','ID &ICHR > 0 >>>>>>>>>>') 514 FORMAT(///,15X,' <<<<<<<<<< IMPOSSIBLE TO HAVE IDICHR = 2 AND ',' &ISPIN = 0 >>>>>>>>>>') 515 FORMAT(///,12X,'TYPE OF CALCULATION : AZIMUTHAL AUGER ELECTRON',' &DIFFRACTION') 516 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR AUGER ELECTRON',' DIFF &RACTION') 517 FORMAT(///,10X,'TYPE OF CALCULATION : AUGER PHOTOELECTRON ','COINC &IDENCE SPECTROSCOPY') 518 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ','----- &-------------------') 519 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ','----- &-------------------') 520 FORMAT(///,9X,'----------------------------------------------','-- &--------------------') 521 FORMAT(///,4X,' <<<<<<<<<< ',A3,' IS NOT IMPLEMENTED IN THIS ','V &ERSION >>>>>>>>>>') 522 FORMAT(///,4X,' <<<<<<<<<< WRONG NAME FOR THE MULTIPLET',' >>>>> &>>>>>',/,4X,' <<<<<<<<<< ODD NUMBER ','EXPECTED INSTEAD OF',I2,' & >>>>>>>>>>') 523 FORMAT(///,4X,' <<<<<<<<<< BOTH DETECTOR DIRECTIONS MUST BE ','EI &THER INTERNAL OR EXTERNAL >>>>>>>>>>',/,8X,' -----> PROCEEDING WI &TH EXTERNAL DIRECTIONS',/) 524 FORMAT(///,4X,' <<<<<<<<<< AVERAGING OVER ',I3,' DOMAINS ','FOR P &HOTOELECTRON >>>>>>>>>>',/,4X,' <<<<<<<<<< AVERAGING OVER ',I3, &' DOMAINS ','FOR AUGER ELECTRON >>>>>>>>>>',/,8X,' -----> IMPOSS &IBLE : CHECK INPUT FILES !') 525 FORMAT(///,14X,'ATOMIC CALCULATION : Z AXIS ALONG POLARIZATION ',' &DIRECTION',/,' ',/,' ',/,' ') 526 FORMAT(///,18X,'ATOMIC CALCULATION : Z AXIS ALONG LIGHT ','DIRECTI &ON',/,' ',/,' ',/,' ') 527 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' PHOTOELEC &TRON DIFFRACTION') 528 FORMAT(///,10X,'TYPE OF CALCULATION : FULL HEMISPHERE',' AUGER ELE &CTRON DIFFRACTION') 529 FORMAT(///,14X,'TYPE OF CALCULATION : AZIMUTHAL LEED',' VARIATIONS &') 530 FORMAT(///,11X,'TYPE OF CALCULATION : FULL HEMISPHERE',' LEED') 531 FORMAT(///,18X,'TYPE OF CALCULATION : LEED ENERGY ','VARIATIONS') 532 FORMAT(///,16X,'TYPE OF CALCULATION : POLAR LEED',' VARIATIONS') 533 FORMAT(///,17X,'TYPE OF CALCULATION : EIGENVALUE',' ANALYSIS') 534 FORMAT(///,22X,'THE AMPLITUDES WILL BE PRINTED SEPARATELY') C 701 FORMAT(6X,I1,1X,I3,2X,I4) 702 FORMAT(6X,I1,1X,I3,3X,I3) 703 FORMAT(15X,F8.3,3X,F8.3) 713 FORMAT(6X,I1,1X,I3) C RETURN C END C C======================================================================= C FUNCTION SIG2(RJ,JTYP) C C This routine evaluates the mean square displacements. C USE DIM_MOD C USE DEBWAL_MOD , T => TEMP USE MASSAT_MOD , XM => XMT USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT C REAL MJ C C C DATA COEF/145.52539/ DATA RZ2,RZ4,RZ6/1.644934,1.082323,1.017343/ C A=TD/T BJ=QD*RJ U=BJ/A MJ=XM(JTYP) C=COEF/(2.*MJ*TD) COMP=RZ2-U*U*RZ4+U*U*U*U*RZ6 X1=0. X2=0. X3=0. X4=0. DO 10 N=1,8 Z=FLOAT(N) X1=X1+EXP(-Z*A)*((A/Z)+(1./(Z*Z))) X2=X2+1./(Z**8+U*U*(Z**6)) X3=X3+EXP(-Z*A)*Z/(Z*Z+U*U) X4=X4+EXP(-Z*A)/(Z*Z+U*U) 10 CONTINUE P1=1.+4.*(RZ2-X1)/(A*A) P2=-2.*(1.-COS(BJ))/(BJ*BJ) P3=-4.*(COMP-(U**6)*X2)/(A*A) P4=4.*SIN(BJ)*X3/(A*BJ) P5=4.*COS(BJ)*X4/(A*A) SIG2=C*(P1+P2+P3+P4+P5)/(A0*A0) C RETURN C END C C======================================================================= C DOUBLE PRECISION FUNCTION SIXJ_IN(J1,J2,L1,L2,L3) C C This function calculates the initial value {J1 J2 L1+L2} C {L1 L2 L3 } C C A 6j symbol {J1 J2 J3} is non zero only if C {J4 J5 J6} C C (J1,J2,J3),(J4,J5,J3),(J2,J4,J6) and (J1,J5,J6) satisfy the triangular inequality : C C (a,b,c) non zero if |a-b| <= c <= (a+b) . This means also that (a+b) and c must C have the same nature (integer or half-integer). C C (J1,J2,J3) and (J4,J5,J3) are taken care of by the bounds of J3, JJ_MIN and JJ_MAX, C as chosen in the N_J routine. Here we check the two last ones. C C Last modified : 8 Dec 2008 C C USE DIM_MOD USE LOGAMAD_MOD C IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL*8 J1,J2,L1,L2,L3 C C DATA SMALL /0.0001/ C IZERO=0 C C Check for unphysical values of L3 C IF(DABS(J2-L1).GT.L3) IZERO=1 IF(J2+L1.LT.L3) IZERO=1 IF(IG(J2+L1).NE.IG(L3)) IZERO=1 IF(DABS(J1-L2).GT.L3) IZERO=1 IF(J1+L2.LT.L3) IZERO=1 IF(IG(J1+L2).NE.IG(L3)) IZERO=1 C IF(IZERO.EQ.1) THEN SIXJ_IN=0.D0 ELSE C C Storage indices of the angular momenta. C LJ1=INT(J1+SIGN(SMALL,J1)) LJ2=INT(J2+SIGN(SMALL,J2)) LL1=INT(L1+SIGN(SMALL,L1)) LL2=INT(L2+SIGN(SMALL,L2)) LL3=INT(L3+SIGN(SMALL,L3)) LL1_2=INT(L1+L1+SIGN(SMALL,L1)) LL2_2=INT(L2+L2+SIGN(SMALL,L2)) C MSIGN=INT(J1+J2+L1+L2+SIGN(SMALL,J1+J2+L1+L2)) IF(MOD(MSIGN,2).EQ.0) THEN SIGNE=1.D0 ELSE SIGNE=-1.D0 ENDIF C D1=GLD(LL1_2+1,1) + GLD(LL2_2+1,1) - GLD(LL1_2+LL2_2+2,1) D2=GLD(INT(J1+J2+L1+L2)+2,IG(J1+J2+L1+L2)) - GLD(INT(J1+J2-L1-L2 &)+1,IG(J1+J2-L1-L2)) D3=GLD(INT(J1-J2+L1+L2)+1,IG(J1-J2+L1+L2)) - GLD(INT(J1+L2-L3)+1 &,IG(J1+L2-L3)) D4=GLD(INT(J2-J1+L1+L2)+1,IG(J2-J1+L1+L2)) -GLD(INT(-J1+L2+L3)+1 &,IG(-J1+L2+L3)) D5=GLD(INT(J1-L2+L3)+1,IG(J1-L2+L3)) - GLD(INT(J1+L2+L3)+2,IG(J1 &+L2+L3)) D6=GLD(INT(J2+L3-L1)+1,IG(J2+L3-L1)) - GLD(INT(J2-L3+L1)+1,IG(J2 &-L3+L1)) D7=GLD(INT(L1+L3-J2)+1,IG(L1+L3-J2)) +GLD(INT(L1+J2+L3)+2,IG(L1+ &J2+L3)) C SIXJ_IN=SIGNE*DSQRT(DEXP(D1+D2+D3+D4+D5+D6-D7)) C ENDIF C END C C======================================================================= C SUBROUTINE SPH_HAR(NL,X,CF,YLM,NC) C C This routine computes the complex spherical harmonics using Condon and C Shortley phase convention. C C If the angular direction R=(THETAR,PHIR) is given in cartesian C coordinates by (XR,YR,ZR), the arguments of the subroutine are : C C X = ZR = cos(THETAR) C CF = XR + i YR = sin(THETAR)*exp(i PHIR) C C NL is the dimensioning of the YLM array and NC is C the maximum l value to be computed. C USE DIM_MOD C USE EXPFAC2_MOD USE FACTSQ_MOD C COMPLEX YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF C DATA SQ4PI_INV,SQR3_INV /0.282095,0.488602/ C C YLM(0,0)=CMPLX(SQ4PI_INV) YLM(1,0)=X*SQR3_INV DO L=2,NC Y=1./FLOAT(L) YLM(L,0)=X*SQRT(4.-Y*Y)*YLM(L-1,0) - (1.-Y)*SQRT(1.+2./(FLOAT(L) &-1.5))*YLM(L-2,0) ENDDO C C2=-1. C=-0.5*CF C C1=1. COEF=(1.,0.) DO M=1,NC C1=C1*C2 COEF=COEF*C YMM=SQ4PI_INV*COEF*FSQ(M) YLM(M,M)=YMM YLM(M,-M)=C1*CONJG(YMM) YMMP=X*SQRT(FLOAT(M+M+3))*YMM YLM(M+1,M)=YMMP YLM(M+1,-M)=C1*CONJG(YMMP) IF(M.LT.NC-1) THEN DO L=M+2,NC YLM(L,M)=(X*(L+L-1)*EXPF2(L-1,M)*YLM(L-1,M) - (L+M-1)*EXPF2( &L-2,M)*YLM(L-2,M))/(EXPF2(L,M)*(L-M)) YLM(L,-M)=C1*CONJG(YLM(L,M)) ENDDO ENDIF ENDDO C RETURN C END C C======================================================================= C SUBROUTINE SPH_HAR2(NL,X,CF,YLM,NC) C C This routine computes the complex spherical harmonics using Condon and C Shortley phase convention. C C If the angular direction R=(THETAR,PHIR) is given in cartesian C coordinates by (XR,YR,ZR), the arguments of the subroutine are : C C X = ZR = cos(THETAR) C CF = XR + i YR = sin(THETAR)*exp(i PHIR) C C NL is the dimensioning of the YLM array and NC is C the maximum l value to be computed. C C This is the double precision version of sph_har.f C C USE DIM_MOD C USE DEXPFAC2_MOD USE DFACTSQ_MOD C C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMPLEX*16 YLM(0:NL,-NL:NL),COEF,YMM,YMMP,C,CF C DATA SQ4PI_INV,SQR3_INV /0.282094791774D0,0.488602511903D0/ C C YLM(0,0)=DCMPLX(SQ4PI_INV) YLM(1,0)=X*SQR3_INV DO L=2,NC Y=1.D0/DFLOAT(L) YLM(L,0)=X*DSQRT(4.D0-Y*Y)*YLM(L-1,0) - (1.D0-Y)*DSQRT(1.D0+2.D0 &/(DFLOAT(L)-1.5D0))*YLM(L-2,0) ENDDO C C2=-1.D0 C=-0.5D0*CF C C1=1.D0 COEF=(1.D0,0.D0) DO M=1,NC C1=C1*C2 COEF=COEF*C YMM=SQ4PI_INV*COEF*DFSQ(M) YLM(M,M)=YMM YLM(M,-M)=C1*DCONJG(YMM) YMMP=X*DSQRT(DFLOAT(M+M+3))*YMM YLM(M+1,M)=YMMP YLM(M+1,-M)=C1*DCONJG(YMMP) IF(M.LT.NC-1) THEN DO L=M+2,NC YLM(L,M)=(X*DFLOAT(L+L-1)*DEXPF2(L-1,M)*YLM(L-1,M) - DFLOAT( &L+M-1)*DEXPF2(L-2,M)*YLM(L-2,M))/(DEXPF2(L,M)*DFLOAT(L-M)) YLM(L,-M)=C1*DCONJG(YLM(L,M)) ENDDO ENDIF ENDDO C RETURN C END C C======================================================================= C SUBROUTINE STOP_EXT(I_EXT,I_EXT_A,SPECTRO) C C This routine stops the code when the dimension N_TILT_M in the C spec.inc file is insufficient for the number of values to C Gaussian average over (as generated by the ext_dir.f code) C USE DIM_MOD C USE INFILES_MOD USE INUNITS_MOD USE OUTUNITS_MOD C C C CHARACTER*3 SPECTRO C NSET=1 NSET_A=1 C IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN IF(I_EXT.EQ.-1) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,15) IDIR,NSET CLOSE(IUI6) ENDIF IF(I_EXT_A.EQ.-1) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,15) IDIR,NSET_A CLOSE(IUI6) ENDIF ENDIF IF(SPECTRO.EQ.'APC') THEN IF(I_EXT.EQ.-1) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,15) IDIR,NSET CLOSE(IUI6) ENDIF IF(I_EXT_A.EQ.-1) THEN OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') READ(IUI9,15) IDIR,NSET_A CLOSE(IUI9) ENDIF ENDIF C IF(MAX(NSET,NSET_A).GT.N_TILT_M) THEN WRITE(IUO1,10) MAX(NSET,NSET_A) STOP ENDIF C 10 FORMAT(///,16X,'<<<<<<<<<< N_TILT_M SHOULD BE AT LEAST ',I3,' >> &>>>>>>>>') 15 FORMAT(6X,I1,1X,I3) C RETURN C END C C======================================================================= C SUBROUTINE STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A,NPHI &,NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) C C This subroutine stops the code before the long MS calculations C when the dimensioning NDIM_M of the treatment routines C (treat_aed,treat_apc,treat_phd,treat_xas) is insufficient. C C C Last modified : 06 Oct 2006 C USE DIM_MOD USE OUTUNITS_MOD C CHARACTER*3 SPECTRO C C IF(ISOM.EQ.0) THEN C C Photoelectron diffraction case C IF(SPECTRO.EQ.'PHD') THEN IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN NDP=NEMET*NTHETA*NPHI*NE ELSEIF(I_EXT.EQ.-1) THEN NDP=NEMET*NTHETA*NPHI*NE*2 ELSEIF(I_EXT.EQ.2) THEN NDP=NEMET*NTHETA*NE ENDIF NTT=NPLAN*NDP IF(NTT.GT.NDIM_M) GOTO 10 IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 C C Auger electron diffraction case C ELSEIF(SPECTRO.EQ.'AED') THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NEMET*NTHETA_A*NPHI_A*NE ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NEMET*NTHETA_A*NPHI_A*NE*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NEMET*NTHETA_A*NE ENDIF NTT=NPLAN*NDP IF(NTT.GT.NDIM_M) GOTO 20 IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 C C X-ray absorption case C ELSEIF(SPECTRO.EQ.'XAS') THEN NDP=NEMET*NE NTT=NPLAN*NDP IF(NTT.GT.NDIM_M) GOTO 30 C C Auger Photoelectron coincidence spectroscopy case C ELSEIF(SPECTRO.EQ.'APC') THEN IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NEMET*NTHETA*NPHI*NE*NTHETA_A ENDIF ELSEIF(I_EXT.EQ.-1) THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NEMET*NTHETA*NPHI*NE*2*NTHETA_A ENDIF ELSEIF(I_EXT.EQ.2) THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NEMET*NTHETA*NE*NTHETA_A*NPHI_A*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NEMET*NTHETA*NE*NTHETA_A ENDIF ENDIF NTT=NPLAN*NDP IF(NTT.GT.NDIM_M) GOTO 40 IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 ENDIF C ELSE C C Photoelectron diffraction case C IF(SPECTRO.EQ.'PHD') THEN IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN NDP=NTHETA*NPHI*NE ELSEIF(I_EXT.EQ.-1) THEN NDP=NTHETA*NPHI*NE*2 ELSEIF(I_EXT.EQ.2) THEN NDP=NTHETA*NE ENDIF NTT=NFICHLEC*NDP IF(NTT.GT.NDIM_M) GOTO 10 IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 C C Auger electron diffraction case C ELSEIF(SPECTRO.EQ.'AED') THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NTHETA_A*NPHI_A*NE ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NTHETA_A*NPHI_A*NE*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NTHETA_A*NE ENDIF NTT=NFICHLEC*NDP IF(NTT.GT.NDIM_M) GOTO 20 IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 C C X-ray absorption case C ELSEIF(SPECTRO.EQ.'XAS') THEN NDP=NE NTT=NFICHLEC*NDP IF(NTT.GT.NDIM_M) GOTO 30 C C Auger Photoelectron coincidence spectroscopy case C ELSEIF(SPECTRO.EQ.'APC') THEN IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NTHETA*NPHI*NE*NTHETA_A*NPHI_A*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NTHETA*NPHI*NE*NTHETA_A ENDIF ELSEIF(I_EXT.EQ.-1) THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NTHETA*NPHI*NE*2*NTHETA_A*NPHI_A*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NTHETA*NPHI*NE*2*NTHETA_A ENDIF ELSEIF(I_EXT.EQ.2) THEN IF((I_EXT_A.EQ.0).OR.(I_EXT_A.EQ.1)) THEN NDP=NTHETA*NE*NTHETA_A*NPHI_A ELSEIF(I_EXT_A.EQ.-1) THEN NDP=NTHETA*NE*NTHETA_A*NPHI_A*2 ELSEIF(I_EXT_A.EQ.2) THEN NDP=NTHETA*NE*NTHETA_A ENDIF ENDIF NTT=NFICHLEC*NDP IF(NTT.GT.NDIM_M) GOTO 40 IF((NTHETA.GT.NTH_M).OR.(NPHI.GT.NPH_M)) GOTO 50 IF((NTHETA_A.GT.NTH_M).OR.(NPHI_A.GT.NPH_M)) GOTO 50 ENDIF ENDIF C GOTO 5 C 10 WRITE(IUO1,11) NTT STOP 20 WRITE(IUO1,21) NTT STOP 30 WRITE(IUO1,31) NTT STOP 40 WRITE(IUO1,41) NTT STOP 50 WRITE(IUO1,51) MAX(NTHETA,NPHI,NTHETA_A,NPHI_A) STOP C 11 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT &_PHD SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE &AT LEAST ',I8,' >>>>>>>>>>') 21 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT &_AED SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE &AT LEAST ',I8,' >>>>>>>>>>') 31 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT &_XAS SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE &AT LEAST ',I8,' >>>>>>>>>>') 41 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL',' IN &THE >>>>>>>>>>',/,8X,'<<<<<<<<<< INCLUDE FILE ','FOR THE TREAT &_APC SUBROUTINE >>>>>>>>>>',/,8X,'<<<<<<<<<< NDIM_M BE &AT LEAST ',I8,' >>>>>>>>>>') 51 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL',' &IN THE INCLUDE FILE - SHOULD BE AT LEAST ',I6,' >>>>>>>>>>') C 5 RETURN C END C C======================================================================= C SUBROUTINE SUP_ZEROS(TL,LMAX,NE,NAT,IUO1,ITRTL) C C This routine suppresses possible zeros in the TL arrays so that C the code runs faster because of lower values of LMAX. Actually, C the TL array is not modified, it is just the LMAX array that is C altered. This is particularly useful for energy variations or C for matrix inversion C USE DIM_MOD C COMPLEX TL_,TL(0:NT_M,4,NATM,NE_M) C INTEGER LMAX(NATM,NE_M) C IF(ITRTL.EQ.1) THEN SMALL=0.1 ELSEIF(ITRTL.EQ.2) THEN SMALL=0.01 ELSEIF(ITRTL.EQ.3) THEN SMALL=0.001 ELSEIF(ITRTL.EQ.4) THEN SMALL=0.0001 ELSEIF(ITRTL.EQ.5) THEN SMALL=0.00001 ELSEIF(ITRTL.EQ.6) THEN SMALL=0.000001 ELSEIF(ITRTL.EQ.7) THEN SMALL=0.0000001 ELSEIF(ITRTL.EQ.8) THEN SMALL=0.00000001 ELSE ITRTL=9 SMALL=0.000000001 ENDIF C WRITE(IUO1,10) WRITE(IUO1,15) ITRTL C DO JE=1,NE WRITE(IUO1,20) JE DO JAT=1,NAT NONZERO=0 LM=LMAX(JAT,JE) DO L=0,LM TL_=TL(L,1,JAT,JE) IF((ABS(REAL(TL_)).GE.SMALL).OR.(ABS(AIMAG(TL_)).GE.SMALL)) &THEN NONZERO=NONZERO+1 ENDIF ENDDO LMAX(JAT,JE)=NONZERO-1 WRITE(IUO1,30) JAT,LM,NONZERO-1 ENDDO ENDDO C WRITE(IUO1,40) C 10 FORMAT(//,' ---> CHECK FOR ZEROS IN THE TL FILE TO REDUCE',' THE & AMOUNT OF COMPUTING :',/) 15 FORMAT(/,' (ONLY THE MATRIX ELEMENTS NON ZERO ','TO THE FIRST ',I &1,' DECIMAL DIGITS ARE KEPT)',/) 20 FORMAT(/,15X,'ENERGY POINT No ',I3,/) 30 FORMAT(8X,'PROTOTYPICAL ATOM No ',I5,' INITIAL LMAX = ',I2,' FI &NAL LMAX = ',I2) 40 FORMAT(//) C RETURN C END C C======================================================================= C FUNCTION UJ_SQ(JTYP) C C This routine evaluates the mean square displacements UJ_SQ, C first along une direction (x, y or z): UJ2 within the Debye model, C using the Debye function formulation C C X1 is the Debye function phi_1 C UJ_SQ is given in unit of the square of the lattice parameter A0 C Temperatures are expressed in Kelvin C C The coefficient COEF equals: C C 3 hbar^{2} N_A 10^{3} / (4 k_B) C C where N_A is the Avogadro number, k_B is Boltzmann's constant C and 10^3 arises from the fact that the atomic mass is C expressed in grams C C Then UJ_SQ is obtained as UJ_SQ = (2 + RSJ) UJJ for surface atoms C UJ_SQ = 3 UJJ for bulk atoms C C C For empty spheres, two possibilities are provided. By construction, C they are very light (their mass is taken as 1/1836 of the mass C of a H atom) and so they will vibrate a lot (IDCM = 1). When C setting IDCM = 2, their mean square displacement is set to a C tiny value so that they hardly vibrate (frozen empty spheres) C C Last modified : 31 Jan 2017 C USE DIM_MOD C USE DEBWAL_MOD , T => TEMP USE MASSAT_MOD , XM => XMT USE RESEAU_MOD , N1 => NCRIST, N2 => NCENTR, N3 => IBAS, N4 => NAT &, A0 => A, R1 => BSURA, R2 => CSURA, UN => UNIT USE VIBRAT_MOD C REAL MJ C C C DATA COEF /36.381551/ ! 3 hbar^{2} / (4 k_B) for MJ in grams DATA RZ2 /1.644934/ ! Pi^2 / 6 DATA LITTLE /0.01/ ! lowest temperature for calculation of phi_1 C N_MAX=20 C C Computation of the 1D mean square displacement UJ2 C A=TD/T MJ=XM(JTYP) C=COEF/(MJ*TD) C X1=0. IF(T.GT.LITTLE) THEN DO N=1,N_MAX Z=FLOAT(N) X1=X1+EXP(-Z*A)*(A+1./Z)/Z ENDDO ENDIF C P1=1.+4.*(RZ2-X1)/(A*A) UJJ=C*P1/(A0*A0) C C 3D mean square displacement UJ_SQ C IF(IDCM.EQ.1) THEN UJ_SQ=(3.+FLOAT(I_FREE(JTYP))*(RSJ-1.))*UJJ ELSEIF(IDCM.EQ.2) THEN UJ_SQ=1.0E-20 ENDIF C RETURN C END C C======================================================================= C SUBROUTINE DIRAN(VINT,ECIN,J_EL) C C This subroutine calculates the direction(s) of the analyzer with C or without an angular averaging. C C DIRANA is the internal direction C ANADIR is the external direction C C J_EL is the type of electron : 1 ---> photoelectron C 2 ---> Auger electron C C Last modified : 23/03/2006 C C USE DIRECT_MOD USE DIRECT_A_MOD USE MOYEN_MOD USE MOYEN_A_MOD USE OUTUNITS_MOD USE TESTS_MOD , I1 => ITEST, I2 => ISORT1, N1 => NPATHP, I3 => ISO &M USE TYPCAL_MOD USE TYPCAL_A_MOD C COMPLEX COEF,IC DATA PI,PIS2,PIS180 /3.141593,1.570796,0.017453/ C IC=(0.,1.) C IF(J_EL.EQ.1) THEN ANADIR(1,1)=SIN(RTHEXT)*COS(RPHI) ANADIR(2,1)=SIN(RTHEXT)*SIN(RPHI) ANADIR(3,1)=COS(RTHEXT) IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN CALL REFRAC(VINT,ECIN,RTHEXT,RTHINT) ELSE RTHINT=RTHEXT ENDIF IF((IPRINT.GT.0).AND.(I_EXT.NE.2)) THEN DTHEXT=RTHEXT/PIS180 DTHINT=RTHINT/PIS180 IF(I_TEST.NE.2) WRITE(IUO1,20) DTHEXT,DTHINT ENDIF DIRANA(1,1)=SIN(RTHINT)*COS(RPHI) DIRANA(2,1)=SIN(RTHINT)*SIN(RPHI) DIRANA(3,1)=COS(RTHINT) THETAR(1)=RTHINT PHIR(1)=RPHI C C The change in the definition below is necessary as RPHI is C used to define the rotation axis of the direction of the detector C when doing polar variations C IF(ITHETA.EQ.1) THEN IF(RPHI.GT.PIS2) THEN RTHEXT=-RTHEXT RPHI=RPHI-PI ELSEIF(RPHI.LT.-PIS2) THEN RTHEXT=-RTHEXT RPHI=RPHI+PI ENDIF ENDIF C IF(IMOY.GE.1) THEN N=2**(IMOY-1) S=SIN(ACCEPT*PI/180.) RN=FLOAT(N) J=1 DO K1=-N,N RK1=FLOAT(K1) DO K2=-N,N RK2=FLOAT(K2) D=SQRT(RK1*RK1+RK2*RK2) IF((D-RN).GT.0.000001) GOTO 10 IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 10 C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S) J=J+1 C ANADIR(1,J)=(RK1*S*COS(RTHEXT)*COS(RPHI) -RK2*S*SIN(RPHI)+ &C*ANADIR(1,1))/RN ANADIR(2,J)=(RK1*S*COS(RTHEXT)*SIN(RPHI) +RK2*S*COS(RPHI)+ &C*ANADIR(2,1))/RN ANADIR(3,J)=(-RK1*S*SIN(RTHEXT) +C*ANADIR(3,1))/RN THETA_R=ACOS(ANADIR(3,J)) COEF=ANADIR(1,J)+IC*ANADIR(2,J) CALL ARCSIN(COEF,ANADIR(3,J),PHI_R) IF((ABS(I_EXT).LE.1).AND.(I_TEST.NE.2)) THEN CALL REFRAC(VINT,ECIN,THETA_R,THINT_R) ELSE THINT_R=THETA_R ENDIF C DIRANA(1,J)=SIN(THINT_R)*COS(PHI_R) DIRANA(2,J)=SIN(THINT_R)*SIN(PHI_R) DIRANA(3,J)=COS(THINT_R) C THETAR(J)=THINT_R PHIR(J)=PHI_R 10 CONTINUE ENDDO ENDDO ENDIF C ELSEIF(J_EL.EQ.2) THEN ANADIR_A(1,1)=SIN(RTHEXT_A)*COS(RPHI_A) ANADIR_A(2,1)=SIN(RTHEXT_A)*SIN(RPHI_A) ANADIR_A(3,1)=COS(RTHEXT_A) IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN CALL REFRAC(VINT,ECIN,RTHEXT_A,RTHINT_A) ELSE RTHINT_A=RTHEXT_A ENDIF IF((IPRINT.GT.0).AND.(I_EXT_A.NE.2)) THEN DTHEXT_A=RTHEXT_A/PIS180 DTHINT_A=RTHINT_A/PIS180 IF(I_TEST_A.NE.2) WRITE(IUO1,21) DTHEXT_A,DTHINT_A ENDIF DIRANA_A(1,1)=SIN(RTHINT_A)*COS(RPHI_A) DIRANA_A(2,1)=SIN(RTHINT_A)*SIN(RPHI_A) DIRANA_A(3,1)=COS(RTHINT_A) THETAR_A(1)=RTHINT_A PHIR_A(1)=RPHI_A C C The change in the definition below is necessary as RPHI is C used to define the rotation axis of the direction of the detector C when doing polar variations C IF(ITHETA_A.EQ.1) THEN IF(RPHI_A.GT.PIS2) THEN RTHEXT_A=-RTHEXT_A RPHI_A=RPHI_A-PI ELSEIF(RPHI_A.LT.-PIS2) THEN RTHEXT_A=-RTHEXT_A RPHI_A=RPHI_A+PI ENDIF ENDIF C IF(IMOY_A.GE.1) THEN N=2**(IMOY_A-1) S=SIN(ACCEPT_A*PI/180.) RN=FLOAT(N) J=1 DO K1=-N,N RK1=FLOAT(K1) DO K2=-N,N RK2=FLOAT(K2) D=SQRT(RK1*RK1+RK2*RK2) IF((D-RN).GT.0.000001) GOTO 15 IF((K1.EQ.0).AND.(K2.EQ.0)) GOTO 15 C=SQRT(RN*RN-(RK1*RK1+RK2*RK2)*S*S) J=J+1 C ANADIR_A(1,J)=(RK1*S*COS(RTHEXT_A)*COS(RPHI_A) -RK2*S*SIN( &RPHI_A)+C*ANADIR_A(1,1))/RN ANADIR_A(2,J)=(RK1*S*COS(RTHEXT_A)*SIN(RPHI_A) +RK2*S*COS( &RPHI_A)+C*ANADIR_A(2,1))/RN ANADIR_A(3,J)=(-RK1*S*SIN(RTHEXT_A) +C*ANADIR_A(3,1))/RN THETA_R_A=ACOS(ANADIR_A(3,J)) COEF=ANADIR_A(1,J)+IC*ANADIR_A(2,J) CALL ARCSIN(COEF,ANADIR_A(3,J),PHI_R_A) IF((ABS(I_EXT_A).LE.1).AND.(I_TEST_A.NE.2)) THEN CALL REFRAC(VINT,ECIN,THETA_R_A,THINT_R_A) ELSE THINT_R_A=THETA_R_A ENDIF C DIRANA_A(1,J)=SIN(THINT_R_A)*COS(PHI_R_A) DIRANA_A(2,J)=SIN(THINT_R_A)*SIN(PHI_R_A) DIRANA_A(3,J)=COS(THINT_R_A) C THETAR_A(J)=THINT_R_A PHIR_A(J)=PHI_R_A 15 CONTINUE ENDDO ENDDO ENDIF C ENDIF C 20 FORMAT(/,10X,'PHOTOELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T &HETA =', F7.2) 21 FORMAT(/,10X,'AUGER ELECTRON EXTERNAL THETA =',F7.2,5X,'INTERNAL T &HETA =', F7.2) C RETURN C END C C======================================================================= C SUBROUTINE REFRAC(VINT,EKIN,RTHETA,RTHINT) C C This routine calculates the refraction of a plane wave beam induced C by the surface potential barrier VINT. EKIN is the kinetic energy C outside the crystal. C C Last modified : 3 Dec 2008 C DATA PIS180,SMALL /0.017453,0.001/ C IF(VINT.LT.0.) VINT=ABS(VINT) IF(ABS(VINT).LT.SMALL) THEN RTHINT=RTHETA ELSE U=VINT/(EKIN+VINT) DTHETA=RTHETA/PIS180 REFRA=SIN(RTHETA)*SIN(RTHETA)*(1.-U) RTHINT=ASIN(SQRT(REFRA)) IF(DTHETA.LT.0.) THEN RTHINT=-RTHINT ENDIF ENDIF C RETURN C END C C======================================================================= C SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL) C C This subroutine performs a weighted sum of the results C corresponding to different directions of the detector. C The directions and weights are read from an external input file C C JEL is the electron undetected (i.e. for which the outgoing C directions are integrated over the unit sphere). It is always C 1 for one electron spectroscopies (PHD). For APECS, It can be C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron C detected) C C Last modified : 31 Jan 2007 C USE DIM_MOD USE INFILES_MOD USE INUNITS_MOD USE OUTUNITS_MOD C C PARAMETER(N_MAX=5810,NPM=20) C REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M) REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX) REAL*4 SR_1,SF_1,SR_2,SF_2 REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX) REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX) C CHARACTER*3 SPECTRO,SPECTRO2 CHARACTER*5 LIKE CHARACTER*13 OUTDATA C C C C DATA JVOL,JTOT/0,-1/ DATA LIKE /'-like'/ C REWIND IUO2 C READ(IUO2,15) SPECTRO,OUTDATA IF(SPECTRO.NE.'APC') THEN READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM SPECTRO2='XAS' ELSE READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I &THETA_A,IE_A READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM READ(IUO2,8) NPHI_A,NTHETA_A IF(JEL.EQ.1) THEN SPECTRO2='AED' ELSEIF(JEL.EQ.2) THEN SPECTRO2='PHD' ELSEIF(JEL.EQ.0) THEN SPECTRO2='XAS' ENDIF ENDIF C IF(NPLAN.GT.NPM) THEN WRITE(IUO1,4) NPLAN+2 STOP ENDIF C C Reading the number of angular points C IF(SPECTRO.NE.'APC') THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,1) N_POINTS READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 N_POINTS_A=1 ELSE IF(JEL.EQ.1) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,1) N_POINTS READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 IF(I_EXT_A.EQ.0) THEN N_POINTS_A=NTHETA_A*NPHI_A ELSE OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') READ(IUI9,1) N_POINTS_A READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 ENDIF NTHETA0=NTHETA_A NPHI0=NPHI_A ELSEIF(JEL.EQ.2) THEN OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') READ(IUI9,1) N_POINTS_A READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 IF(I_EXT.EQ.0) THEN N_POINTS=NTHETA*NPHI ELSE OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,1) N_POINTS READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 ENDIF NTHETA0=NTHETA NPHI0=NPHI ELSEIF(JEL.EQ.0) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') READ(IUI6,1) N_POINTS READ(IUI9,1) N_POINTS_A READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 ENDIF ENDIF C IF(SPECTRO.NE.'APC') THEN NANGLE=1 ELSE IF(JEL.EQ.1) THEN NANGLE=N_POINTS_A ELSEIF(JEL.EQ.2) THEN NANGLE=N_POINTS ELSEIF(JEL.EQ.0) THEN NANGLE=1 ENDIF ENDIF C C Initialization of the arrays C DO JE=1,NE DO JANGLE=1,NANGLE DO JPLAN=1,NPLAN+2 SUMR_1(JPLAN,JE,JANGLE)=0. SUMF_1(JPLAN,JE,JANGLE)=0. IF(IDICHR.GT.0) THEN SUMR_2(JPLAN,JE,JANGLE)=0. SUMF_2(JPLAN,JE,JANGLE)=0. ENDIF ENDDO ENDDO ENDDO C C Reading of the data to be angle integrated C DO JE=1,NE C DO JANGLE=1,N_POINTS IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE) DO JANGLE_A=1,N_POINTS_A IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN READ(IUI9,2) THA,PHA,W_A(JANGLE_A) ENDIF C DO JPLAN=1,NPLAN+2 C IF(IDICHR.EQ.0) THEN IF(SPECTRO.NE.'APC') THEN READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE) &,SR_1,SF_1 ELSE READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1 ENDIF ELSE IF(SPECTRO.NE.'APC') THEN READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE &),SR_1,SF_1,SR_2,SF_2 ELSE READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2 ENDIF ENDIF C IF(JEL.EQ.1) THEN SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1 &*W(JANGLE) SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1 &*W(JANGLE) ELSEIF(JEL.EQ.2) THEN SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A &(JANGLE_A) SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A &(JANGLE_A) ELSEIF(JEL.EQ.0) THEN SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A &(JANGLE_A) SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A &(JANGLE_A) ENDIF IF(IDICHR.GT.0) THEN IF(JEL.EQ.1) THEN SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR &_2*W(JANGLE) SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF &_2*W(JANGLE) ELSEIF(JEL.EQ.2) THEN SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W &_A(JANGLE_A) SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W &_A(JANGLE_A) ELSEIF(JEL.EQ.0) THEN SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W &_A(JANGLE_A) SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W &_A(JANGLE_A) ENDIF ENDIF C ENDDO C ENDDO IF(I_EXT_A.NE.0) THEN REWIND IUI9 READ(IUI9,1) NDUM READ(IUI9,1) NDUM ENDIF ENDDO C IF(I_EXT.NE.0) THEN REWIND IUI6 READ(IUI6,1) NDUM READ(IUI6,1) NDUM ENDIF ENDDO C CLOSE(IUI6) CLOSE(IUI9) REWIND IUO2 C WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP WRITE(IUO2,18) NE,NPLAN,ISOM ELSEIF(JEL.EQ.1) THEN WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A &,ITHETA_A,IE_A WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM ELSEIF(JEL.EQ.2) THEN WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM ENDIF C DO JE=1,NE DO JANGLE=1,NANGLE IF(SPECTRO.EQ.'APC') THEN IF(JEL.EQ.1) THEN THETA=DTHETAA(JANGLE) PHI=DPHIA(JANGLE) ELSEIF(JEL.EQ.2) THEN THETA=DTHETA(JANGLE) PHI=DPHI(JANGLE) ENDIF ENDIF C DO JPLAN=1,NPLAN IF(IDICHR.EQ.0) THEN IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU &MF_1(JPLAN,JE,JANGLE) ELSE WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, &JANGLE),SUMF_1(JPLAN,JE,JANGLE) ENDIF ELSE IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU &MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG &LE) ELSE WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, &JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL &AN,JE,JANGLE) ENDIF ENDIF ENDDO C IF(IDICHR.EQ.0) THEN IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM &F_1(NPLAN+1,JE,JANGLE) WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM &F_1(NPLAN+2,JE,JANGLE) ELSE WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE) WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE) ENDIF ELSE IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM &F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE &,JANGLE) WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM &F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE &,JANGLE) ELSE WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2( &NPLAN+1,JE,JANGLE) WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2( &NPLAN+2,JE,JANGLE) ENDIF ENDIF C ENDDO ENDDO C 1 FORMAT(13X,I4) 2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6) 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN &THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>') 5 FORMAT(6X,I1,1X,I3,3X,I3) 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) 9 FORMAT(9(2X,I1),2X,I2) 13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E &12.6) 15 FORMAT(2X,A3,11X,A13) 16 FORMAT(2X,A3,A5,1X,A3,2X,A13) 18 FORMAT(I4,2X,I3,2X,I1) 19 FORMAT(4(2X,I1)) 20 FORMAT(8(2X,I1)) 21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X &,E12.6) 24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E &12.6,2X,E12.6,2X,E12.6) 33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6) 34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) 43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6) 44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X &,E12.6) C RETURN C END C C======================================================================= C SUBROUTINE DWSPH(JTYP,JE,X,TLT,ISPEED) C C This routine recomputes the T-matrix elements taking into account the C mean square displacements. C C When the argument X is tiny, no vibrations are taken into account C C Last modified : 25 Apr 2013 C USE DIM_MOD C USE TRANS_MOD C DIMENSION GNT(0:N_GAUNT) C COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC C COMPLEX*16 FFL(0:2*NL_M) C DATA PI4,EPS /12.566371,1.0E-10/ C ZEROC=(0.,0.) C IF(X.GT.EPS) THEN C C Standard case: vibrations C IF(ISPEED.LT.0) THEN NSUM_LB=ABS(ISPEED) ENDIF C COEF=PI4*EXP(-X) NL2=2*LMAX(JTYP,JE)+2 IBESP=5 MG1=0 MG2=0 C CALL BESPHE(NL2,IBESP,X,FFL) C DO L=0,LMAX(JTYP,JE) XL=FLOAT(L+L+1) SL1=ZEROC C DO L1=0,LMAX(JTYP,JE) XL1=FLOAT(L1+L1+1) CALL GAUNT(L,MG1,L1,MG2,GNT) L2MIN=ABS(L1-L) IF(ISPEED.GE.0) THEN L2MAX=L1+L ELSEIF(ISPEED.LT.0) THEN L2MAX=L2MIN+2*(NSUM_LB-1) ENDIF SL2=0. C DO L2=L2MIN,L2MAX,2 XL2=FLOAT(L2+L2+1) C=SQRT(XL1*XL2/(PI4*XL)) SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2))) ENDDO C SL1=SL1+SL2*TL(L1,1,JTYP,JE) ENDDO C TLT(L,1,JTYP,JE)=COEF*SL1 C ENDDO C ELSE C C Argument X tiny: no vibrations C DO L=0,LMAX(JTYP,JE) C TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE) C ENDDO C ENDIF C RETURN C END C C======================================================================= C SUBROUTINE FACDIF1(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M,FSPH,JAT,J &E,*) C C This routine computes a spherical wave scattering factor C C Last modified : 03/04/2006 C USE DIM_MOD USE APPROX_MOD USE EXPFAC_MOD USE TRANS_MOD USE TYPCAL_MOD , I2 => IPHI, I3 => IE, I4 => ITHETA, I5 => IMOD, I &6 => IPOL, I7 => I_CP, I8 => I_EXT, I9 => I_TEST C DIMENSION PLMM(0:100,0:100) DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) C COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE COMPLEX RHOJK C C DATA PI/3.141593/ C A=1. INTER=0 IF(ITL.EQ.1) VKE=VK(JE) RHOJ=VKE*RJ RHOJK=VKE*RJK HLM1=(1.,0.) HLM2=(1.,0.) HLM3=(1.,0.) HLM4=(1.,0.) IEM=1 CSTH=COS(BETA) IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN INTER=1 BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI)) ENDIF CALL PLM(CSTH,PLMM,LMAX(JAT,JE)) IF(ISPHER.EQ.0) NO1=0 IF(ISPHER.EQ.1) THEN IF(NO.EQ.8) THEN NO1=LMAX(JAT,JE)+1 ELSE NO1=NO ENDIF CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM) IF(IEM.EQ.0) THEN HLM4=HLM(0,L) ENDIF IF(RJK.GT.0.0001) THEN NDUM=0 CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN) ENDIF CALL DJMN(THRJ,D,L) A1=ABS(D(0,M,L)) IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1 & ENDIF MUMAX=MIN0(L,NO1) SMU=(0.,0.) DO 10 MU=0,MUMAX IF(MOD(MU,2).EQ.0) THEN B=1. ELSE B=-1. IF(SIN(BETA).LT.0.) THEN A=-1. ENDIF ENDIF IF(ISPHER.LE.1) THEN ALMU=(1.,0.) C=1. ENDIF IF(ISPHER.EQ.0) GOTO 40 IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L)) IF(MU.GT.0) THEN C=B*FLOAT(L+L+1)/EXPF(MU,L) ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B* * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU ELSE C=1. ALMU=CMPLX(D(M,0,L))/BLMU ENDIF 40 SNU=(0.,0.) NU1=INT(0.5*(NO1-MU)+0.0001) NUMAX=MIN0(NU1,L-MU) DO 20 NU=0,NUMAX SLP=(0.,0.) LPMIN=MAX0(MU,NU) DO 30 LP=LPMIN,LMAX(JAT,JE) IF(ISPHER.EQ.1) THEN HLM1=HLM(NU,LP) IF(RJK.GT.0.0001) HLM3=HLN(0,LP) ENDIF SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3 30 CONTINUE IF(ISPHER.EQ.1) THEN HLM2=HLM(MU+NU,L) ENDIF SNU=SNU+SLP*HLM2 20 CONTINUE SMU=SMU+SNU*C*ALMU*A*B 10 CONTINUE FSPH=SMU/(VKE*HLM4) C RETURN C END C C======================================================================= C SUBROUTINE FACDIF(COSTH,JAT,JE,FTHETA) C C This routine computes the plane wave scattering factor C USE DIM_MOD C USE TRANS_MOD C DIMENSION PL(0:100) C COMPLEX FTHETA C FTHETA=(0.,0.) NL=LMAX(JAT,JE)+1 CALL POLLEG(NL,COSTH,PL) DO 20 L=0,NL-1 FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L) 20 CONTINUE FTHETA=FTHETA/VK(JE) C RETURN C END C C======================================================================= C SUBROUTINE PLOTFD(A,LMX,ITL,NL,NAT,NE) C C This routine prepares the output for a plot of the scattering factor C USE DIM_MOD C USE APPROX_MOD USE FDIF_MOD USE INIT_L_MOD , L => LI, I2 => INITL, I3 => NNL, I4 => LF1, I5 => & LF2, I10 => ISTEP_LF USE INIT_J_MOD USE OUTFILES_MOD USE OUTUNITS_MOD USE PARCAL_MOD , N3 => NPHI, N4 => NE, N5 => NTHETA, N6 => NEPS USE TYPCAL_MOD , I7 => IFTHET, I8 => IMOD, I9 => IPOL, I12 => I_CP &, I13 => I_EXT, I14 => I_TEST USE VALIN_MOD , U1 => THLUM, U2 => PHILUM, U3 => ELUM, N7 => NONVO &L USE VALFIN_MOD C C C DIMENSION LMX(NATM,NE_M) C COMPLEX FSPH,VKE C C C DATA PI,CONV/3.141593,0.512314/ C OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN') IF(ISPHER.EQ.0) THEN L=0 LMAX=0 ELSE LMAX=L ENDIF PHITOT=360. THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI NPHI=(NFTHET+1)*IPHI+(1-IPHI) NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+ * (1-ITHETA) NE=NFTHET*IE + (1-IE) WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN DO 10 JT=1,NTHT DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1)) RTHETA=DTHETA*PI/180. TEST=SIN(RTHETA) IF(TEST.GE.0.) THEN POZ=PI EPS=1. ELSE POZ=0. EPS=-1. ENDIF BETA=RTHETA*EPS IF(ABS(TEST).LT.0.0001) THEN NPHIM=1 ELSE NPHIM=NPHI ENDIF DO 20 JP=1,NPHIM DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1)) RPHI=DPHI*PI/180. GAMMA=POZ-RPHI DO 30 JE=1,NE IF(NE.EQ.1) THEN ECIN=E0 ELSE ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) ENDIF IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.) DO 40 JAT=1,NAT IF(L.GT.LMX(JAT,JE)) GOTO 90 DO 50 M=-LMAX,LMAX CALL FACDIF1(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M,FSPH,J &AT,JE,*60) GOTO 70 60 WRITE(IUO1,80) STOP 70 REFTH=REAL(FSPH) XIMFTH=AIMAG(FSPH) WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN 50 CONTINUE GOTO 40 90 WRITE(IUO1,100) JAT STOP 40 CONTINUE 30 CONTINUE 20 CONTINUE 10 CONTINUE CLOSE(IUO3) 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2) 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2,1X,F6.2,1X, &F8.2) 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ','IS Z &ERO >>>>>') 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM',' : ' &,I2,' >>>>>') C RETURN C END C C======================================================================= C SUBROUTINE FINDPATHS(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIMI &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) C C This routine generates all the paths and filters them according to the C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). C It corresponds to the spin-independent case from a non spin-orbit C resolved initial core state LI C C Last modified : 16 May 2007 C USE DIM_MOD C USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH USE COOR_MOD USE DEBWAL_MOD USE INIT_L_MOD USE PATH_MOD USE ROT_MOD USE TESTPA_MOD USE TESTPB_MOD USE TRANS_MOD USE TLDW_MOD USE VARIA_MOD C DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) DIMENSION JPOS(NDIF_M,3),R(NDIF_M) C C C COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK COMPLEX IC,COMPL1,PW(0:NDIF_M) COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) COMPLEX YLM1(0:NL_M,-NL_M:NL_M) COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 C DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ C IC=(0.,1.) IEULER=1 C IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) C C I_CP = 0 : all open paths generated C I_CP = 1 : only closed paths generated C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO JTYP=1,N_TYP IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) ND=ND+1 C C I_ABS = 0 : the atom before the scatterer is not the absorber C I_ABS = 1 : the atom before the scatterer is the absorber C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) C IF(ND.EQ.1) THEN I_ABS=1 ELSE I_ABS=0 ENDIF C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPJ=NATYP(JTYP) ELSE NBTYPJ=1 ENDIF C DO JNUM=1,NBTYPJ JATL=NCORR(JNUM,JTYP) IF(JATL.EQ.IATL) GOTO 12 XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 JPOS(ND,1)=JTYP JPOS(ND,2)=JNUM JPOS(ND,3)=JATL NPATH(ND)=NPATH(ND)+1. IF(ND.GT.1) THEN COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( &R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(ITYP).EQ.0) THEN IF(COSTHMIJ.LT.COSFWDI) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(ITYP).EQ.1) THEN IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF ENDIF IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 RHOIJ=VK(JE)*R(ND) CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1.) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THIJ=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 ZSURFI=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(ITYP)=SIG2(R(ND-1),ITYP) ENDIF IF(ABS(ZSURFI).LE.SMALL) THEN IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO &STHMIJ) ELSE CSKZ2I=1. ENDIF UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.)) ELSE UII=UJ2(ITYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UI2=VK2(JE)*UII CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED) ENDIF 40 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) ENDIF ENDIF IF(ND.EQ.1) THEN RHO01=RHOIJ TH01=THIJ PHI01=PHIIJ CALL DJMN2(TH01,RLM01,LF2,2) GOTO 30 ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) LMJ=LMAX(ITYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, &BMIJ,CMIJ,RHOMI,RHOIJ) 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F &REF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 42 I_ABS=0 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO KTYP=1,N_TYP ND=ND+1 IF(ND.GT.NDIF) GOTO 20 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPK=NATYP(KTYP) ELSE NBTYPK=1 ENDIF C DO KNUM=1,NBTYPK KATL=NCORR(KNUM,KTYP) IF(KATL.EQ.JATL) GOTO 22 JPOS(ND,1)=KTYP JPOS(ND,2)=KNUM JPOS(ND,3)=KATL XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF(IT(ND-1).EQ.1) GOTO 32 RHOJK=R(ND)*VK(JE) NPATH(ND)=NPATH(ND)+1. COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) &/(R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(JTYP).EQ.0) THEN IF(COSTHIJK.LT.COSFWDJ) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(JTYP).EQ.1) THEN IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH &EN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF IF(IT(ND-1).EQ.1) GOTO 32 CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THJK=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) IF(ND-1.LT.NDIF) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 ZSURFJ=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(JTYP)=SIG2(R(ND-1),JTYP) ENDIF IF(ABS(ZSURFJ).LE.SMALL) THEN IF(ABS(COSTHIJK-1.).GT.SMALL) THEN CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 &.*COSTHIJK) ELSE CSKZ2J=1. ENDIF UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) ELSE UJJ=UJ2(JTYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UJ2=VK2(JE)*UJJ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) ENDIF 50 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) ENDIF ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) CALL ARCSIN(COMPL1,CTROIS1,PHIJK) LMJ=LMAX(JTYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT)) & IT(ND)=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN CALL ARCSIN(COMPL1,CTROIS1,PHIJK) ENDIF CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A &IJK,BIJK,CIJK,RHOIJ,RHOJK) CEX(ND)=CEXP(IC*RHOJK)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI &JK,FREF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 32 CALL FINDPATHS2(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) 32 DIJ=DIJ-R(ND) 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDDO 20 CONTINUE ND=ND-1 ENDDO 42 DIJ=DIJ-R(ND) 12 IF(ND.GT.1) THEN IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDIF ENDDO ND=ND-1 ENDDO C RETURN C END C C======================================================================= C SUBROUTINE FINDPATHS2(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) C C This routine generates all the paths and filters them according to the C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). C It corresponds to the spin-independent case from a non spin-orbit C resolved initial core state LI C C Last modified : 16 May 2007 C USE DIM_MOD C USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH USE COOR_MOD USE DEBWAL_MOD USE INIT_L_MOD USE PATH_MOD USE ROT_MOD USE TESTPA_MOD USE TESTPB_MOD USE TRANS_MOD USE TLDW_MOD USE VARIA_MOD C COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK COMPLEX IC,COMPL1,PW(0:NDIF_M) COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) COMPLEX YLM1(0:NL_M,-NL_M:NL_M) COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 C DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) DIMENSION JPOS(NDIF_M,3),R(NDIF_M) C C C DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ C IC=(0.,1.) IEULER=1 C IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) C C I_CP = 0 : all open paths generated C I_CP = 1 : only closed paths generated C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO JTYP=1,N_TYP IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) ND=ND+1 C C I_ABS = 0 : the atom before the scatterer is not the absorber C I_ABS = 1 : the atom before the scatterer is the absorber C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) C IF(ND.EQ.1) THEN I_ABS=1 ELSE I_ABS=0 ENDIF C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPJ=NATYP(JTYP) ELSE NBTYPJ=1 ENDIF C DO JNUM=1,NBTYPJ JATL=NCORR(JNUM,JTYP) IF(JATL.EQ.IATL) GOTO 12 XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 JPOS(ND,1)=JTYP JPOS(ND,2)=JNUM JPOS(ND,3)=JATL NPATH(ND)=NPATH(ND)+1. IF(ND.GT.1) THEN COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( &R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(ITYP).EQ.0) THEN IF(COSTHMIJ.LT.COSFWDI) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(ITYP).EQ.1) THEN IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF ENDIF IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 RHOIJ=VK(JE)*R(ND) CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1.) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THIJ=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 ZSURFI=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(ITYP)=SIG2(R(ND-1),ITYP) ENDIF IF(ABS(ZSURFI).LE.SMALL) THEN IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO &STHMIJ) ELSE CSKZ2I=1. ENDIF UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.)) ELSE UII=UJ2(ITYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UI2=VK2(JE)*UII CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED) ENDIF 40 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) ENDIF ENDIF IF(ND.EQ.1) THEN RHO01=RHOIJ TH01=THIJ PHI01=PHIIJ CALL DJMN2(TH01,RLM01,LF2,2) GOTO 30 ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) LMJ=LMAX(ITYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, &BMIJ,CMIJ,RHOMI,RHOIJ) 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F &REF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 42 I_ABS=0 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO KTYP=1,N_TYP ND=ND+1 IF(ND.GT.NDIF) GOTO 20 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPK=NATYP(KTYP) ELSE NBTYPK=1 ENDIF C DO KNUM=1,NBTYPK KATL=NCORR(KNUM,KTYP) IF(KATL.EQ.JATL) GOTO 22 JPOS(ND,1)=KTYP JPOS(ND,2)=KNUM JPOS(ND,3)=KATL XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF(IT(ND-1).EQ.1) GOTO 32 RHOJK=R(ND)*VK(JE) NPATH(ND)=NPATH(ND)+1. COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) &/(R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(JTYP).EQ.0) THEN IF(COSTHIJK.LT.COSFWDJ) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(JTYP).EQ.1) THEN IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH &EN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF IF(IT(ND-1).EQ.1) GOTO 32 CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THJK=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) IF(ND-1.LT.NDIF) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 ZSURFJ=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(JTYP)=SIG2(R(ND-1),JTYP) ENDIF IF(ABS(ZSURFJ).LE.SMALL) THEN IF(ABS(COSTHIJK-1.).GT.SMALL) THEN CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 &.*COSTHIJK) ELSE CSKZ2J=1. ENDIF UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) ELSE UJJ=UJ2(JTYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UJ2=VK2(JE)*UJJ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) ENDIF 50 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) ENDIF ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) CALL ARCSIN(COMPL1,CTROIS1,PHIJK) LMJ=LMAX(JTYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) &=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN CALL ARCSIN(COMPL1,CTROIS1,PHIJK) ENDIF CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A &IJK,BIJK,CIJK,RHOIJ,RHOJK) CEX(ND)=CEXP(IC*RHOJK)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI &JK,FREF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 32 CALL FINDPATHS3(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) 32 DIJ=DIJ-R(ND) 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDDO 20 CONTINUE ND=ND-1 ENDDO 42 DIJ=DIJ-R(ND) 12 IF(ND.GT.1) THEN IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDIF ENDDO ND=ND-1 ENDDO C RETURN C END C C======================================================================= C SUBROUTINE FINDPATHS3(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) C C This routine generates all the paths and filters them according to the C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). C It corresponds to the spin-independent case from a non spin-orbit C resolved initial core state LI C C Last modified : 16 May 2007 C USE DIM_MOD C USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH USE COOR_MOD USE DEBWAL_MOD USE INIT_L_MOD USE PATH_MOD USE ROT_MOD USE TESTPA_MOD USE TESTPB_MOD USE TRANS_MOD USE TLDW_MOD USE VARIA_MOD C DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) DIMENSION JPOS(NDIF_M,3),R(NDIF_M) C C C COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK COMPLEX IC,COMPL1,PW(0:NDIF_M) COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) COMPLEX YLM1(0:NL_M,-NL_M:NL_M) COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 C DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ C IC=(0.,1.) IEULER=1 C IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) C C I_CP = 0 : all open paths generated C I_CP = 1 : only closed paths generated C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO JTYP=1,N_TYP IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) ND=ND+1 C C I_ABS = 0 : the atom before the scatterer is not the absorber C I_ABS = 1 : the atom before the scatterer is the absorber C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) C IF(ND.EQ.1) THEN I_ABS=1 ELSE I_ABS=0 ENDIF C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPJ=NATYP(JTYP) ELSE NBTYPJ=1 ENDIF C DO JNUM=1,NBTYPJ JATL=NCORR(JNUM,JTYP) IF(JATL.EQ.IATL) GOTO 12 XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 JPOS(ND,1)=JTYP JPOS(ND,2)=JNUM JPOS(ND,3)=JATL NPATH(ND)=NPATH(ND)+1. IF(ND.GT.1) THEN COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( &R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(ITYP).EQ.0) THEN IF(COSTHMIJ.LT.COSFWDI) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(ITYP).EQ.1) THEN IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF ENDIF IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 RHOIJ=VK(JE)*R(ND) CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1.) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THIJ=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 ZSURFI=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(ITYP)=SIG2(R(ND-1),ITYP) ENDIF IF(ABS(ZSURFI).LE.SMALL) THEN IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO &STHMIJ) ELSE CSKZ2I=1. ENDIF UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.)) ELSE UII=UJ2(ITYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UI2=VK2(JE)*UII CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED) ENDIF 40 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) ENDIF ENDIF IF(ND.EQ.1) THEN RHO01=RHOIJ TH01=THIJ PHI01=PHIIJ CALL DJMN2(TH01,RLM01,LF2,2) GOTO 30 ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) LMJ=LMAX(ITYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, &BMIJ,CMIJ,RHOMI,RHOIJ) 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F &REF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 42 I_ABS=0 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO KTYP=1,N_TYP ND=ND+1 IF(ND.GT.NDIF) GOTO 20 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPK=NATYP(KTYP) ELSE NBTYPK=1 ENDIF C DO KNUM=1,NBTYPK KATL=NCORR(KNUM,KTYP) IF(KATL.EQ.JATL) GOTO 22 JPOS(ND,1)=KTYP JPOS(ND,2)=KNUM JPOS(ND,3)=KATL XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF(IT(ND-1).EQ.1) GOTO 32 RHOJK=R(ND)*VK(JE) NPATH(ND)=NPATH(ND)+1. COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) &/(R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(JTYP).EQ.0) THEN IF(COSTHIJK.LT.COSFWDJ) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(JTYP).EQ.1) THEN IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH &EN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF IF(IT(ND-1).EQ.1) GOTO 32 CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THJK=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) IF(ND-1.LT.NDIF) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 ZSURFJ=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(JTYP)=SIG2(R(ND-1),JTYP) ENDIF IF(ABS(ZSURFJ).LE.SMALL) THEN IF(ABS(COSTHIJK-1.).GT.SMALL) THEN CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 &.*COSTHIJK) ELSE CSKZ2J=1. ENDIF UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) ELSE UJJ=UJ2(JTYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UJ2=VK2(JE)*UJJ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) ENDIF 50 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) ENDIF ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) CALL ARCSIN(COMPL1,CTROIS1,PHIJK) LMJ=LMAX(JTYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) &=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN CALL ARCSIN(COMPL1,CTROIS1,PHIJK) ENDIF CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A &IJK,BIJK,CIJK,RHOIJ,RHOJK) CEX(ND)=CEXP(IC*RHOJK)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI &JK,FREF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 32 CALL FINDPATHS4(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) 32 DIJ=DIJ-R(ND) 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDDO 20 CONTINUE ND=ND-1 ENDDO 42 DIJ=DIJ-R(ND) 12 IF(ND.GT.1) THEN IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDIF ENDDO ND=ND-1 ENDDO C RETURN C END C C======================================================================= C SUBROUTINE FINDPATHS4(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) C C This routine generates all the paths and filters them according to the C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). C It corresponds to the spin-independent case from a non spin-orbit C resolved initial core state LI C C Last modified : 16 May 2007 C USE DIM_MOD C USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH USE COOR_MOD USE DEBWAL_MOD USE INIT_L_MOD USE PATH_MOD USE ROT_MOD USE TESTPA_MOD USE TESTPB_MOD USE TRANS_MOD USE TLDW_MOD USE VARIA_MOD C DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) DIMENSION JPOS(NDIF_M,3),R(NDIF_M) C C C COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK COMPLEX IC,COMPL1,PW(0:NDIF_M) COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) COMPLEX YLM1(0:NL_M,-NL_M:NL_M) COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 C DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ C IC=(0.,1.) IEULER=1 C IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) C C I_CP = 0 : all open paths generated C I_CP = 1 : only closed paths generated C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO JTYP=1,N_TYP IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) ND=ND+1 C C I_ABS = 0 : the atom before the scatterer is not the absorber C I_ABS = 1 : the atom before the scatterer is the absorber C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) C IF(ND.EQ.1) THEN I_ABS=1 ELSE I_ABS=0 ENDIF C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPJ=NATYP(JTYP) ELSE NBTYPJ=1 ENDIF C DO JNUM=1,NBTYPJ JATL=NCORR(JNUM,JTYP) IF(JATL.EQ.IATL) GOTO 12 XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 JPOS(ND,1)=JTYP JPOS(ND,2)=JNUM JPOS(ND,3)=JATL NPATH(ND)=NPATH(ND)+1. IF(ND.GT.1) THEN COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( &R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(ITYP).EQ.0) THEN IF(COSTHMIJ.LT.COSFWDI) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(ITYP).EQ.1) THEN IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF ENDIF IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 RHOIJ=VK(JE)*R(ND) CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1.) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THIJ=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 ZSURFI=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(ITYP)=SIG2(R(ND-1),ITYP) ENDIF IF(ABS(ZSURFI).LE.SMALL) THEN IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO &STHMIJ) ELSE CSKZ2I=1. ENDIF UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.)) ELSE UII=UJ2(ITYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UI2=VK2(JE)*UII CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED) ENDIF 40 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) ENDIF ENDIF IF(ND.EQ.1) THEN RHO01=RHOIJ TH01=THIJ PHI01=PHIIJ CALL DJMN2(TH01,RLM01,LF2,2) GOTO 30 ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) LMJ=LMAX(ITYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, &BMIJ,CMIJ,RHOMI,RHOIJ) 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F &REF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 42 I_ABS=0 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO KTYP=1,N_TYP ND=ND+1 IF(ND.GT.NDIF) GOTO 20 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPK=NATYP(KTYP) ELSE NBTYPK=1 ENDIF C DO KNUM=1,NBTYPK KATL=NCORR(KNUM,KTYP) IF(KATL.EQ.JATL) GOTO 22 JPOS(ND,1)=KTYP JPOS(ND,2)=KNUM JPOS(ND,3)=KATL XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF(IT(ND-1).EQ.1) GOTO 32 RHOJK=R(ND)*VK(JE) NPATH(ND)=NPATH(ND)+1. COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) &/(R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(JTYP).EQ.0) THEN IF(COSTHIJK.LT.COSFWDJ) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(JTYP).EQ.1) THEN IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH &EN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF IF(IT(ND-1).EQ.1) GOTO 32 CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THJK=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) IF(ND-1.LT.NDIF) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 ZSURFJ=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(JTYP)=SIG2(R(ND-1),JTYP) ENDIF IF(ABS(ZSURFJ).LE.SMALL) THEN IF(ABS(COSTHIJK-1.).GT.SMALL) THEN CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 &.*COSTHIJK) ELSE CSKZ2J=1. ENDIF UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) ELSE UJJ=UJ2(JTYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UJ2=VK2(JE)*UJJ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) ENDIF 50 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) ENDIF ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) CALL ARCSIN(COMPL1,CTROIS1,PHIJK) LMJ=LMAX(JTYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) &=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN CALL ARCSIN(COMPL1,CTROIS1,PHIJK) ENDIF CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A &IJK,BIJK,CIJK,RHOIJ,RHOJK) CEX(ND)=CEXP(IC*RHOJK)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI &JK,FREF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 32 CALL FINDPATHS5(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK,THJK,PH &IJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) 32 DIJ=DIJ-R(ND) 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDDO 20 CONTINUE ND=ND-1 ENDDO 42 DIJ=DIJ-R(ND) 12 IF(ND.GT.1) THEN IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDIF ENDDO ND=ND-1 ENDDO C RETURN C END C C======================================================================= C SUBROUTINE FINDPATHS5(ND,ITYP,IATL,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHIM &I,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) C C This routine generates all the paths and filters them according to the C criteria given in the input data file (IFSPH,IFWD,IPW,ILENGTH). C It corresponds to the spin-independent case from a non spin-orbit C resolved initial core state LI C C Last modified : 16 May 2007 C USE DIM_MOD C USE APPROX_MOD , ILE => ILENGTH, RLE => RLENGTH USE COOR_MOD USE DEBWAL_MOD USE INIT_L_MOD USE PATH_MOD USE ROT_MOD USE TESTPA_MOD USE TESTPB_MOD USE TRANS_MOD USE TLDW_MOD USE VARIA_MOD C DIMENSION XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) DIMENSION JPOS(NDIF_M,3),R(NDIF_M) C C C COMPLEX PW1,PWI,FTHETA,RHOMI,RHOIJ,RHOJK COMPLEX IC,COMPL1,PW(0:NDIF_M) COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) COMPLEX YLM1(0:NL_M,-NL_M:NL_M) COMPLEX YLM2(0:NL_M,-NL_M:NL_M),CTL,CTL2 C DATA XCOMP,PI4,SMALL /1.E-10,12.566371,0.0001/ C IC=(0.,1.) IEULER=1 C IF(IFWD.EQ.1) COSFWDI=COS(RTHFWD(ITYP)) IF(IBWD(ITYP).EQ.1) COSBWDI=COS(RTHBWD(ITYP)) C C I_CP = 0 : all open paths generated C I_CP = 1 : only closed paths generated C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO JTYP=1,N_TYP IF(IFWD.EQ.1) COSFWDJ=COS(RTHFWD(JTYP)) IF(IBWD(JTYP).EQ.1) COSBWDJ=COS(RTHBWD(JTYP)) ND=ND+1 C C I_ABS = 0 : the atom before the scatterer is not the absorber C I_ABS = 1 : the atom before the scatterer is the absorber C I_ABS = 2 : the atom after the scatterer is the absorber (XAS only) C IF(ND.EQ.1) THEN I_ABS=1 ELSE I_ABS=0 ENDIF C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPJ=NATYP(JTYP) ELSE NBTYPJ=1 ENDIF C DO JNUM=1,NBTYPJ JATL=NCORR(JNUM,JTYP) IF(JATL.EQ.IATL) GOTO 12 XR(ND)=SYM_AT(1,JATL)-SYM_AT(1,IATL) YR(ND)=SYM_AT(2,JATL)-SYM_AT(2,IATL) ZR(ND)=SYM_AT(3,JATL)-SYM_AT(3,IATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 JPOS(ND,1)=JTYP JPOS(ND,2)=JNUM JPOS(ND,3)=JATL NPATH(ND)=NPATH(ND)+1. IF(ND.GT.1) THEN COSTHMIJ=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1))/( &R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(ITYP).EQ.0) THEN IF(COSTHMIJ.LT.COSFWDI) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(ITYP).EQ.1) THEN IF((COSTHMIJ.GT.COSBWDI).AND.(COSTHMIJ.LT.-SMALL)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHMIJ.LT.COSFWDI).AND.(COSTHMIJ.GE.0.)) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF ENDIF IF((IT(ND-1).EQ.1).AND.(ND.GT.1)) GOTO 42 RHOIJ=VK(JE)*R(ND) CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1.) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THIJ=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) CALL ARCSIN(COMPL1,CTROIS1,PHIIJ) IF((ND.GT.1).AND.((ND-1).LT.NDIF)) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 40 ZSURFI=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(ITYP)=SIG2(R(ND-1),ITYP) ENDIF IF(ABS(ZSURFI).LE.SMALL) THEN IF(ABS(COSTHMIJ-1.).GT.SMALL) THEN CSKZ2I=(CTROIS1-COS(THMI))*(CTROIS1-COS(THMI))/(2.-2.*CO &STHMIJ) ELSE CSKZ2I=1. ENDIF UII=UJ2(ITYP)*(1.+CSKZ2I*(RSJ-1.)) ELSE UII=UJ2(ITYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UI2=VK2(JE)*UII CALL DWSPH(ITYP,JE,XK2UI2,TLT,ISPEED) ENDIF 40 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UII*(1.-COSTHMIJ)) ENDIF ENDIF IF(ND.EQ.1) THEN RHO01=RHOIJ TH01=THIJ PHI01=PHIIJ CALL DJMN2(TH01,RLM01,LF2,2) GOTO 30 ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHMIJ,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) LMJ=LMAX(ITYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THIJ,PHIIJ,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,JTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND)=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 42 CALL EULER(THIJ,PHIIJ,THMI,PHIMI,AMIJ,BMIJ,CMIJ,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,ITYP,JTYP,JE,I_ABS,ISPEED,ISPHER,AMIJ, &BMIJ,CMIJ,RHOMI,RHOIJ) 30 CEX(ND)=CEXP(IC*RHOIJ)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(JATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ,F &REF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 42 I_ABS=0 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF-1)) THEN N_TYP=N_PROT ELSE N_TYP=1 ENDIF C DO KTYP=1,N_TYP ND=ND+1 IF(ND.GT.NDIF) GOTO 20 C IF((I_CP.EQ.0).OR.(ND.NE.NDIF)) THEN NBTYPK=NATYP(KTYP) ELSE NBTYPK=1 ENDIF C DO KNUM=1,NBTYPK KATL=NCORR(KNUM,KTYP) IF(KATL.EQ.JATL) GOTO 22 JPOS(ND,1)=KTYP JPOS(ND,2)=KNUM JPOS(ND,3)=KATL XR(ND)=SYM_AT(1,KATL)-SYM_AT(1,JATL) YR(ND)=SYM_AT(2,KATL)-SYM_AT(2,JATL) ZR(ND)=SYM_AT(3,KATL)-SYM_AT(3,JATL) R(ND)=SQRT(XR(ND)*XR(ND)+YR(ND)*YR(ND)+ZR(ND)*ZR(ND)) DIJ=DIJ+R(ND) IF((ILE.EQ.1).AND.(DIJ.GT.RLE)) IT(ND-1)=1 IF(IT(ND-1).EQ.1) GOTO 32 RHOJK=R(ND)*VK(JE) NPATH(ND)=NPATH(ND)+1. COSTHIJK=(XR(ND)*XR(ND-1)+YR(ND)*YR(ND-1)+ZR(ND)*ZR(ND-1)) &/(R(ND)*R(ND-1)) IF(IFWD.EQ.1) THEN IF(IBWD(JTYP).EQ.0) THEN IF(COSTHIJK.LT.COSFWDJ) THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ELSEIF(IBWD(JTYP).EQ.1) THEN IF((COSTHIJK.GT.COSBWDJ).AND. (COSTHIJK.LT.-SMALL)) TH &EN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF IF((COSTHIJK.LT.COSFWDJ).AND.(COSTHIJK.GE.0.))THEN NTHOF=NTHOF+1 IN(ND-1)=1 IF(NTHOF.GT.NTHOUT) THEN IT(ND-1)=1 ENDIF ENDIF ENDIF ENDIF IF(IT(ND-1).EQ.1) GOTO 32 CTROIS1=ZR(ND)/R(ND) IF(CTROIS1.GT.1) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF THJK=ACOS(CTROIS1) COMPL1= XR(ND)+IC*YR(ND) IF(ND-1.LT.NDIF) THEN IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 50 ZSURFJ=ZSURF-ZR(ND-1) IF(IDCM.EQ.1) THEN UJ2(JTYP)=SIG2(R(ND-1),JTYP) ENDIF IF(ABS(ZSURFJ).LE.SMALL) THEN IF(ABS(COSTHIJK-1.).GT.SMALL) THEN CSKZ2J=(CTROIS1-COS(THIJ))*(CTROIS1-COS(THIJ))/(2.-2 &.*COSTHIJK) ELSE CSKZ2J=1. ENDIF UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) ELSE UJJ=UJ2(JTYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UJ2=VK2(JE)*UJJ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) ENDIF 50 IF(IDWSPH.EQ.1) THEN DW(ND-1)=1. ELSE DW(ND-1)=EXP(-VK2(JE)*UJJ*(1.-COSTHIJK)) ENDIF ENDIF IF(IPW.EQ.1) THEN CALL FACDIF(COSTHIJK,JPOS(ND-1,1),JE,FTHETA) PWI=FTHETA*DW(ND-1)/R(ND) PW(ND)=PW(ND-1)*PWI CTL2=PI4*PW(ND)*CEX(1)/VK(JE) CALL ARCSIN(COMPL1,CTROIS1,PHIJK) LMJ=LMAX(JTYP,JE) IF(ND.GT.NCUT) THEN IT(ND)=1 ELSE IT(ND)=0 ENDIF CALL HARSPH2(NL_M,TH01,PHI01,YLM1,LF2) CALL HARSPH2(NL_M,THJK,PHIJK,YLM2,LMJ) XMAXT=0. DO LJ=0,LMJ CTL=CTL2*TL(LJ,1,KTYP,JE)*YLM2(LJ,0) DO LF=LF1,LF2,ISTEP_LF PW1=CTL*YLM1(LF,0)*TL(LF,1,1,JE) XMAXT=AMAX1(XMAXT,CABS(PW1)) ENDDO ENDDO IF((PCTINT*FREF-XMAXT.LT.-XCOMP).AND.(ND.GT.NCUT))IT(ND) &=0 ENDIF IF((IT(ND-1).EQ.1).OR.(IT(ND).EQ.1)) GOTO 32 IF((ND.LT.NDIF).OR.(IPW.EQ.0)) THEN CALL ARCSIN(COMPL1,CTROIS1,PHIJK) ENDIF CALL EULER(THJK,PHIJK,THIJ,PHIIJ,AIJK,BIJK,CIJK,IEULER) IF((I_CP.EQ.1).AND.(ND.EQ.NDIF)) I_ABS=2 CALL MATDIF(NO,ND-1,LF2,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A &IJK,BIJK,CIJK,RHOIJ,RHOJK) CEX(ND)=CEXP(IC*RHOJK)/R(ND) CEXDW(ND)=CEX(ND)*DW(ND-1) IF((IJ.EQ.1).OR.(ND.EQ.NCUT)) THEN IF((I_CP.EQ.0).OR.(KATL.EQ.1)) THEN CALL PATHOP(JPOS,ND,JE,I_CP,RHO01,PHI01,RHOJK,THJK,PHI &JK,FREF,IJ,DIJ,TAU) NPATH2(ND)=NPATH2(ND)+1. ENDIF ENDIF IF(ND.EQ.NDIF) GOTO 32 c CALL FINDPATHS(ND,KTYP,KATL,I_CP,R,XR,YR,ZR,RHOJK, c 1 THJK,PHIJK,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) 32 DIJ=DIJ-R(ND) 22 IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDDO 20 CONTINUE ND=ND-1 ENDDO 42 DIJ=DIJ-R(ND) 12 IF(ND.GT.1) THEN IF(IN(ND-1).EQ.1) NTHOF=NTHOF-1 IT(ND-1)=0 IN(ND-1)=0 ENDIF ENDDO ND=ND-1 ENDDO C RETURN C END C C======================================================================= C SUBROUTINE MATDIF(NO,ND,LF,JTYP,KTYP,JE,I_ABS,ISPEED,ISPHER,A21,B2 &1,C21,RHO1,RHO2) C C This routine calculates the Rehr-Albers scattering matrix C F_{LAMBDA1,LAMBDA2}. The result is stored in the COMMON block C /SCATMAT/ as F21(NSPIN2_M,NLAMBDA_M,NLAMBDA_M,NDIF_M). C C Last modified : 3 Aug 2007 C USE DIM_MOD C USE EXPFAC_MOD USE LBD_MOD USE LINLBD_MOD USE RA_MOD USE SCATMAT_MOD USE TRANS_MOD USE TLDW_MOD C REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) C COMPLEX HLM1(0:NO_ST_M,0:NL_M-1),HLM2(0:NO_ST_M,0:NL_M-1) COMPLEX SL,RHO1,RHO2,IC,ZEROC,ONEC,ONEOVK COMPLEX SL_2_1,SL_2_2 COMPLEX EXP1,EXP2,PROD1,PROD2 C DATA PI,SMALL /3.141593,0.0001/ C IC=(0.,1.) ZEROC=(0.,0.) ONEC=(1.,0.) ONEOVK=1./VK(JE) IB=0 LMJ=LMAX(JTYP,JE) IF(ABS(ABS(B21)-PI).LT.SMALL) IB=-1 IF(ABS(B21).LT.SMALL) IB=1 IF(NO.EQ.8) THEN NN2=LMAX(JTYP,JE)+1 ELSE NN2=NO ENDIF C C NO is atom-dependent and is decreased with the rank of the scatterer C in the path when I_NO > 0. Here LAMBDA1 depends on the scatterer JTYP C while LAMBDA2 depends on the next atom (KTYP) in the path C IF(I_NO.EQ.0) THEN NO1=N_RA(JTYP) NO2=N_RA(KTYP) ELSE NO1=MAX(N_RA(JTYP)-(ND-1)/I_NO,0) NO2=MAX(N_RA(KTYP)-ND/I_NO,0) ENDIF IF(I_ABS.EQ.0) THEN NUMAX1=NO1/2 NUMAX2=NO2/2 ELSEIF(I_ABS.EQ.1) THEN NUMAX1=MIN0(LF,NO1/2) NUMAX2=NO2/2 ELSEIF(I_ABS.EQ.2) THEN NUMAX1=NO1/2 NUMAX2=MIN0(LF,NO2/2) ENDIF LBDM(1,ND)=(NO1+1)*(NO1+2)/2 LBDM(2,ND)=(NO2+1)*(NO2+2)/2 C EXP2=-EXP(-IC*A21) EXP1=EXP(-IC*C21) C DO LAMBDA1=1,LBDMAX DO LAMBDA2=1,LBDMAX F21(1,LAMBDA2,LAMBDA1,ND)=ZEROC ENDDO ENDDO C IF(ABS(RHO1-RHO2).GT.SMALL) THEN CALL POLHAN(ISPHER,NUMAX1,LMJ,RHO1,HLM1) CALL POLHAN(ISPHER,NN2,LMJ,RHO2,HLM2) NEQUAL=0 ELSE CALL POLHAN(ISPHER,NN2,LMJ,RHO1,HLM1) NEQUAL=1 ENDIF C C Calculation of the scattering matrix when the scattering angle C is different from 0 and pi C IF(IB.EQ.0) THEN CALL DJMN(B21,RLM,LMJ) DO NU1=0,NUMAX1 MUMAX1=NO1-2*NU1 IF(I_ABS.EQ.1) MUMAX1=MIN(LF-NU1,MUMAX1) DO NU2=0,NUMAX2 MUMAX2=NO2-2*NU2 C C Case MU1 = 0 C LAMBDA1=LBD(0,NU1) C C Case MU2 = 0 C LAMBDA2=LBD(0,NU2) LMIN=MAX(NU1,NU2) SL=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(NU2,L)=HLM1(NU2,L) ENDIF IF(ISPEED.EQ.1) THEN SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TL(L,1,JTYP,JE)*HLM1(NU1,L &)*HLM2(NU2,L) ELSE SL=SL+FLOAT(L+L+1)*RLM(0,0,L)*TLT(L,1,JTYP,JE)*HLM1(NU1, &L)*HLM2(NU2,L) ENDIF ENDDO F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK C C Case MU2 > 0 C PROD2=ONEC SIG2=1. DO MU2=1,MUMAX2 LAMBDA2_1=LBD(MU2,NU2) LAMBDA2_2=LBD(-MU2,NU2) PROD2=PROD2*EXP2 SIG2=-SIG2 LMIN=MAX(NU1,MU2+NU2) SL=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L) ENDIF C1=EXPF(0,L)/EXPF(MU2,L) IF(ISPEED.EQ.1) THEN SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TL(L,1,JTYP,JE)*HLM &1(NU1,L)*HLM2(MU2+NU2,L) ELSE SL=SL+FLOAT(L+L+1)*RLM(MU2,0,L)*C1*TLT(L,1,JTYP,JE)*HL &M1(NU1,L)*HLM2(MU2+NU2,L) ENDIF ENDDO F21(1,LAMBDA2_1,LAMBDA1,ND)=SL*PROD2*ONEOVK*SIG2 F21(1,LAMBDA2_2,LAMBDA1,ND)=SL*ONEOVK/PROD2 ENDDO C C Case MU1 > 0 C PROD1=ONEC SIG1=1. DO MU1=1,MUMAX1 LAMBDA1_1=LBD(MU1,NU1) LAMBDA1_2=LBD(-MU1,NU1) PROD1=PROD1*EXP1 SIG1=-SIG1 C C Case MU2 = 0 C LAMBDA2=LBD(0,NU2) LMIN=MAX(MU1,NU1,NU2) SL=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(NU2,L)=HLM1(NU2,L) ENDIF C1=EXPF(MU1,L)/EXPF(0,L) IF(ISPEED.EQ.1) THEN SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TL(L,1,JTYP,JE)*HLM &1(NU1,L)*HLM2(NU2,L) ELSE SL=SL+FLOAT(L+L+1)*RLM(0,MU1,L)*C1*TLT(L,1,JTYP,JE)*HL &M1(NU1,L)*HLM2(NU2,L) ENDIF ENDDO F21(1,LAMBDA2,LAMBDA1_1,ND)=SL*PROD1*ONEOVK*SIG1 F21(1,LAMBDA2,LAMBDA1_2,ND)=SL*ONEOVK/PROD1 C C Case MU2 > 0 C PROD2=ONEC SIG2=SIG1 DO MU2=1,MUMAX2 LAMBDA2_1=LBD(MU2,NU2) LAMBDA2_2=LBD(-MU2,NU2) PROD2=PROD2*EXP2 SIG2=-SIG2 LMIN=MAX(MU1,NU1,MU2+NU2) SL_2_1=ZEROC SL_2_2=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(MU2+NU2,L)=HLM1(MU2+NU2,L) ENDIF C1=EXPF(MU1,L)/EXPF(MU2,L) IF(ISPEED.EQ.1) THEN SL=FLOAT(L+L+1)*C1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2( &MU2+NU2,L) ELSE SL=FLOAT(L+L+1)*C1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2 &(MU2+NU2,L) ENDIF SL_2_1=SL_2_1+SL*RLM(MU2,-MU1,L) SL_2_2=SL_2_2+SL*RLM(MU2,MU1,L) ENDDO F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL_2_2*PROD1*PROD2*ONEOVK* &SIG2 F21(1,LAMBDA2_2,LAMBDA1_1,ND)=SL_2_1*PROD1*ONEOVK/PROD2 F21(1,LAMBDA2_1,LAMBDA1_2,ND)=SL_2_1*ONEOVK*PROD2*SIG2/P &ROD1 F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL_2_2*ONEOVK/(PROD1*PROD2 &) ENDDO ENDDO ENDDO ENDDO C C Calculation of the scattering matrix when the scattering angle C is equal to 0 (forward scattering) or pi (backscattering) C ELSEIF(IB.EQ.1) THEN DO NU1=0,NUMAX1 DO NU2=0,NUMAX2 MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2) IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1) C C Case MU = 0 C LAMBDA1=LBD(0,NU1) LAMBDA2=LBD(0,NU2) LMIN=MAX(NU1,NU2) SL=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(NU2,L)=HLM1(NU2,L) ENDIF IF(ISPEED.EQ.1) THEN SL=SL+FLOAT(L+L+1)*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2, &L) ELSE SL=SL+FLOAT(L+L+1)*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2(NU2 &,L) ENDIF ENDDO F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK C C Case MU > 0 C CST1=1. DO MU=1,MUMAX1 LAMBDA1=LBD(MU,NU2) LAMBDA2=LBD(-MU,NU2) CST1=-CST1 LMIN=MAX(NU1,MU+NU2) SL=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(MU+NU2,L)=HLM1(MU+NU2,L) ENDIF IF(ISPEED.EQ.1) THEN SL=SL+FLOAT(L+L+1)*CST1*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL &M2(MU+NU2,L) ELSE SL=SL+FLOAT(L+L+1)*CST1*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H &LM2(MU+NU2,L) ENDIF ENDDO F21(1,LAMBDA1,LAMBDA1,ND)=SL*ONEOVK F21(1,LAMBDA2,LAMBDA2,ND)=SL*ONEOVK ENDDO ENDDO ENDDO ELSEIF(IB.EQ.-1) THEN DO NU1=0,NUMAX1 DO NU2=0,NUMAX2 MUMAX1=MIN0(NO1-2*NU1,NO1-2*NU2) IF(I_ABS.EQ.1) MUMAX1=MIN0(LF-NU1,MUMAX1) C C Case MU = 0 C LAMBDA1=LBD(0,NU1) LAMBDA2=LBD(0,NU2) LMIN=MAX(NU1,NU2) SL=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(NU2,L)=HLM1(NU2,L) ENDIF IF(MOD(L,2).EQ.0) THEN CST2=1.0 ELSE CST2=-1.0 ENDIF IF(ISPEED.EQ.1) THEN SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HLM2 &(NU2,L) ELSE SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*HLM &2(NU2,L) ENDIF ENDDO F21(1,LAMBDA2,LAMBDA1,ND)=SL*ONEOVK C C Case MU > 0 C CST1=1. DO MU=1,MUMAX1 MUP=-MU LAMBDA1_1=LBD(MUP,NU1) LAMBDA1_2=LBD(-MUP,NU1) LAMBDA2_1=LBD(MU,NU2) LAMBDA2_2=LBD(-MU,NU2) CST1=-CST1 LMIN=MAX(NU1,MU+NU2) SL=ZEROC DO L=LMIN,LMJ IF(NEQUAL.EQ.1) THEN HLM2(MU+NU2,L)=HLM1(MU+NU2,L) ENDIF IF(MOD(L,2).EQ.0) THEN CST2=CST1 ELSE CST2=-CST1 ENDIF IF(ISPEED.EQ.1) THEN SL=SL+FLOAT(L+L+1)*CST2*TL(L,1,JTYP,JE)*HLM1(NU1,L)*HL &M2(MU+NU2,L) ELSE SL=SL+FLOAT(L+L+1)*CST2*TLT(L,1,JTYP,JE)*HLM1(NU1,L)*H &LM2(MU+NU2,L) ENDIF ENDDO F21(1,LAMBDA2_1,LAMBDA1_1,ND)=SL*ONEOVK F21(1,LAMBDA2_2,LAMBDA1_2,ND)=SL*ONEOVK ENDDO ENDDO ENDDO ENDIF C RETURN C END C C======================================================================= C SUBROUTINE PATHOP(JPOS,JORDP,JE,I_CP,RHO01,PHI01,RHOIJ,THIJ,PHIIJ, &FREF,IJ,D,TAU) C C This subroutine calculates the contribution of a given path to C the scattering path operator TAU. C C Last modified : 3 Aug 2007 C USE DIM_MOD C USE APPROX_MOD USE EXPFAC_MOD USE EXTREM_MOD USE INIT_L_MOD USE INIT_J_MOD USE LBD_MOD USE LINLBD_MOD USE OUTUNITS_MOD USE PATH_MOD USE PRINTP_MOD USE RA_MOD USE ROT_MOD USE SCATMAT_MOD , F => F21 USE TESTS_MOD USE TLDW_MOD USE TRANS_MOD USE VARIA_MOD C INTEGER JPOS(NDIF_M,3),AMU1 C C REAL RLMIJ(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) C COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) COMPLEX H(NLAMBDA_M,NLAMBDA_M) COMPLEX G(NLAMBDA_M,NLAMBDA_M) COMPLEX HLM01(0:NO_ST_M,0:NL_M-1),HLMIJ(0:NO_ST_M,0:NL_M-1) COMPLEX SUM_NUJ_0,SUM_MUJ_0,SUM_NU1_0 COMPLEX SUM_NUJ_1,SUM_MUJ_1,SUM_NU1_1 COMPLEX SUM_NU1_2,SUM_NU1_3 COMPLEX RHO01,RHOIJ COMPLEX RLMF_0,RLMF_1 COMPLEX CF,CJ,OVK COMPLEX EXP_J,EXP_F,SUM_1 COMPLEX TL_J COMPLEX COEF,ONEC,ZEROC C C C DATA PI,XCOMP /3.141593,1.E-10/ C ZEROC=(0.,0.) ONEC=(1.,0.) C OVK=(1.,0.)/VK(JE) IF(NPATHP.GT.0) THEN FM1=FMIN(JORDP) XMAX=0. ENDIF EXP_J=CEXP((0.,-1.)*(PHIIJ-PI)) EXP_F=CEXP((0.,1.)*PHI01) JTYP=JPOS(JORDP,1) ITYP=JPOS(1,1) JATL=JPOS(JORDP,3) IF(I_CP.EQ.0) THEN LMJ=LMAX(JTYP,JE) ELSE LMJ=LF2 ENDIF IF(NO.EQ.8) THEN NN2=LMJ+1 ELSE NN2=NO ENDIF IF(NO.GT.LF2) THEN NN=LF2 ELSE NN=NO ENDIF C C NO is atom-dependent and is decreased with the rank of the scatterer C in the path when I_NO > 0 (except for the first scatterer ITYP for C which there is no such decrease) C NO1=N_RA(ITYP) IF(I_NO.EQ.0) THEN IF(IJ.EQ.1) THEN NOJ=N_RA(JTYP) ELSE NOJ=0 ENDIF ELSE IF(IJ.EQ.1) THEN NOJ= MAX(N_RA(JTYP)-(JORDP-1)/I_NO,0) ELSE NOJ=0 ENDIF ENDIF NUMX=NO1/2 NUMAXJ=NOJ/2 C C Calculation of the attenuation coefficients along the path C COEF=CEX(1)*OVK DO JSC=2,JORDP COEF=COEF*CEXDW(JSC) ENDDO C C Call of the subroutines used for the R-A termination matrix C This termination matrix is now merged into PATHOP C CALL DJMN2(-THIJ,RLMIJ,LMJ,1) CALL POLHAN(ISPHER,NN,LF2,RHO01,HLM01) CALL POLHAN(ISPHER,NN2,LMJ,RHOIJ,HLMIJ) C LBD1M1=LBDM(1,1) LBD1M2=LBDM(2,1) C C Calculation of the L-independent part of TAU, called H C IF(JORDP.GE.3) THEN DO JPAT=2,JORDP-1 LBD2M=LBDM(1,JPAT) LBD3M=LBDM(2,JPAT) DO LAMBDA1=1,LBD1M1 DO LAMBDA3=1,LBD3M SUM_1=ZEROC DO LAMBDA2=1,LBD2M IF(JPAT.GT.2) THEN SUM_1=SUM_1+H(LAMBDA2,LAMBDA1)*F(1,LAMBDA3,LAMBDA2,JPA &T) ELSE SUM_1=SUM_1+F(1,LAMBDA2,LAMBDA1,1)*F(1,LAMBDA3,LAMBDA2 &,2) ENDIF ENDDO G(LAMBDA3,LAMBDA1)=SUM_1 ENDDO ENDDO DO LAMBDA1=1,LBD1M1 DO LAMBDA2=1,LBD3M H(LAMBDA2,LAMBDA1)=G(LAMBDA2,LAMBDA1) ENDDO ENDDO ENDDO ELSEIF(JORDP.EQ.2) THEN DO LAMBDA1=1,LBD1M1 DO LAMBDA2=1,LBD1M2 H(LAMBDA2,LAMBDA1)=F(1,LAMBDA2,LAMBDA1,1) ENDDO ENDDO ELSEIF(JORDP.EQ.1) THEN DO LAMBDA1=1,LBD1M1 DO LAMBDA2=1,LBD1M1 H(LAMBDA2,LAMBDA1)=ONEC ENDDO ENDDO ENDIF C C Calculation of the path operator TAU C DO LF=LF1,LF2,ISTEP_LF ILF=LF*LF+LF+1 C NU1MAX1=MIN(LF,NUMX) C C Case MF = 0 C DO LJ=0,LMJ ILJ=LJ*LJ+LJ+1 NUJMAX=MIN(LJ,NUMAXJ) IF(JORDP.EQ.1) THEN NU1MAX=MIN(NU1MAX1,LJ) ELSE NU1MAX=NU1MAX1 ENDIF C IF(ISPEED.EQ.1) THEN TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE) ELSE TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE) ENDIF C C Case MJ = 0 C SUM_NU1_0=ZEROC C DO NU1=0,NU1MAX IF(JORDP.GT.1) THEN MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) ELSE MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) ENDIF C DO MU1=-MU1MAX,MU1MAX LAMBDA1=LBD(MU1,NU1) AMU1=ABS(MU1) C RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF) C SUM_NUJ_0=ZEROC C IF(JORDP.GT.1) THEN DO NUJ=0,NUJMAX MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) C SUM_MUJ_0=ZEROC C DO MUJ=-MUJMAX,MUJMAX C LAMBDAJ=LBD(MUJ,NUJ) C SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0,L &J) ENDDO SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) C ENDDO ELSE SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ) ENDIF C SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 C ENDDO C ENDDO C TAU(ILJ,ILF,JATL)=TAU(ILJ,ILF,JATL)+TL_J*SUM_NU1_0 C IF(NPATHP.EQ.0) GOTO 35 C FM2=FMAX(JORDP) XINT=CABS(TL_J*SUM_NU1_0) XMAX=AMAX1(XINT,XMAX) FMAX(JORDP)=AMAX1(FM2,XINT) IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN FREF=FMAX(JORDP) ENDIF 35 CONTINUE C C Case MJ > 0 C CJ=ONEC DO MJ=1,LJ INDJ=ILJ+MJ INDJP=ILJ-MJ CJ=CJ*EXP_J C SUM_NU1_0=ZEROC SUM_NU1_1=ZEROC C DO NU1=0,NU1MAX IF(JORDP.GT.1) THEN MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) ELSE MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) ENDIF C DO MU1=-MU1MAX,MU1MAX LAMBDA1=LBD(MU1,NU1) AMU1=ABS(MU1) C RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,0,LF) C SUM_NUJ_0=ZEROC SUM_NUJ_1=ZEROC C IF(JORDP.GT.1) THEN DO NUJ=0,NUJMAX MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) C SUM_MUJ_0=ZEROC SUM_MUJ_1=ZEROC C DO MUJ=-MUJMAX,MUJMAX C LAMBDAJ=LBD(MUJ,NUJ) C SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,- &MJ,LJ) SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,M &J,LJ) C ENDDO C SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ) C ENDDO ELSE SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ) SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ) ENDIF C SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1 C ENDDO C ENDDO C TAU(INDJP,ILF,JATL)=TAU(INDJP,ILF,JATL)+CONJG(CJ)*TL_J*SUM_N &U1_1 TAU(INDJ,ILF,JATL)=TAU(INDJ,ILF,JATL)+CJ*TL_J*SUM_NU1_0 C IF(NPATHP.EQ.0) GOTO 45 C FM2=FMAX(JORDP) XINT1=CABS(CJ*TL_J*SUM_NU1_0) XINT2=CABS(CONJG(CJ)*TL_J*SUM_NU1_1) XMAX=AMAX1(XINT1,XINT2,XMAX) FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2) IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN FREF=FMAX(JORDP) ENDIF 45 CONTINUE ENDDO ENDDO C C Case MF > 0 C CF=ONEC DO MF=1,LF INDF=ILF+MF INDFP=ILF-MF CF=CF*EXP_F C DO LJ=0,LMJ ILJ=LJ*LJ+LJ+1 NUJMAX=MIN(LJ,NUMAXJ) IF(JORDP.EQ.1) THEN NU1MAX=MIN(NU1MAX1,LJ) ELSE NU1MAX=NU1MAX1 ENDIF C IF(ISPEED.EQ.1) THEN TL_J=COEF*TL(LF,1,1,JE)*TL(LJ,1,JTYP,JE) ELSE TL_J=COEF*TLT(LF,1,1,JE)*TLT(LJ,1,JTYP,JE) ENDIF C C Case MJ = 0 C SUM_NU1_0=ZEROC SUM_NU1_1=ZEROC C DO NU1=0,NU1MAX IF(JORDP.GT.1) THEN MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) ELSE MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) ENDIF C DO MU1=-MU1MAX,MU1MAX LAMBDA1=LBD(MU1,NU1) AMU1=ABS(MU1) C RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF) RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF) C SUM_NUJ_0=ZEROC C IF(JORDP.GT.1) THEN DO NUJ=0,NUJMAX MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) C SUM_MUJ_0=ZEROC C DO MUJ=-MUJMAX,MUJMAX C LAMBDAJ=LBD(MUJ,NUJ) C SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ,0 &,LJ) C ENDDO C SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) C ENDDO ELSE SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,0,LJ) ENDIF C SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 SUM_NU1_1=SUM_NU1_1+RLMF_1*SUM_NUJ_0 C ENDDO C ENDDO C TAU(ILJ,INDF,JATL)=TAU(ILJ,INDF,JATL)+CF*TL_J*SUM_NU1_0 TAU(ILJ,INDFP,JATL)=TAU(ILJ,INDFP,JATL)+CONJG(CF)*TL_J*SUM_N &U1_1 C IF(NPATHP.EQ.0) GOTO 25 C FM2=FMAX(JORDP) XINT1=CABS(CF*TL_J*SUM_NU1_0) XINT2=CABS(CONJG(CF)*TL_J*SUM_NU1_1) XMAX=AMAX1(XINT1,XINT2,XMAX) FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2) IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN FREF=FMAX(JORDP) ENDIF 25 CONTINUE C C Case MJ > 0 C CJ=ONEC DO MJ=1,LJ INDJ=ILJ+MJ INDJP=ILJ-MJ CJ=CJ*EXP_J C SUM_NU1_0=ZEROC SUM_NU1_1=ZEROC SUM_NU1_2=ZEROC SUM_NU1_3=ZEROC C DO NU1=0,NU1MAX IF(JORDP.GT.1) THEN MU1MAX=MIN(LF-NU1,NO1-NU1-NU1) ELSE MU1MAX=MIN(LF-NU1,NO1-NU1-NU1,LJ) ENDIF C DO MU1=-MU1MAX,MU1MAX LAMBDA1=LBD(MU1,NU1) AMU1=ABS(MU1) C RLMF_1=HLM01(AMU1+NU1,LF)*RLM01(MU1,-MF,LF) RLMF_0=HLM01(AMU1+NU1,LF)*RLM01(MU1,MF,LF) C SUM_NUJ_0=ZEROC SUM_NUJ_1=ZEROC C IF(JORDP.GT.1) THEN DO NUJ=0,NUJMAX MUJMAX=MIN(LJ,NOJ-NUJ-NUJ) C SUM_MUJ_0=ZEROC SUM_MUJ_1=ZEROC C DO MUJ=-MUJMAX,MUJMAX C LAMBDAJ=LBD(MUJ,NUJ) C SUM_MUJ_1=SUM_MUJ_1+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ &,-MJ,LJ) SUM_MUJ_0=SUM_MUJ_0+H(LAMBDAJ,LAMBDA1)*RLMIJ(MUJ &,MJ,LJ) C ENDDO C SUM_NUJ_0=SUM_NUJ_0+SUM_MUJ_0*HLMIJ(NUJ,LJ) SUM_NUJ_1=SUM_NUJ_1+SUM_MUJ_1*HLMIJ(NUJ,LJ) C ENDDO ELSE SUM_NUJ_1=HLMIJ(NU1,LJ)*RLMIJ(MU1,-MJ,LJ) SUM_NUJ_0=HLMIJ(NU1,LJ)*RLMIJ(MU1,MJ,LJ) ENDIF C SUM_NU1_0=SUM_NU1_0+RLMF_0*SUM_NUJ_0 SUM_NU1_1=SUM_NU1_1+RLMF_0*SUM_NUJ_1 SUM_NU1_2=SUM_NU1_2+RLMF_1*SUM_NUJ_0 SUM_NU1_3=SUM_NU1_3+RLMF_1*SUM_NUJ_1 C ENDDO C ENDDO C TAU(INDJP,INDF,JATL)=TAU(INDJP,INDF,JATL)+CF*CONJG(CJ)*TL_ &J*SUM_NU1_1 TAU(INDJP,INDFP,JATL)=TAU(INDJP,INDFP,JATL)+CONJG(CF*CJ)*T &L_J*SUM_NU1_3 TAU(INDJ,INDF,JATL)=TAU(INDJ,INDF,JATL)+CF*CJ*TL_J*SUM_NU1 &_0 TAU(INDJ,INDFP,JATL)=TAU(INDJ,INDFP,JATL)+CONJG(CF)*CJ*TL_ &J*SUM_NU1_2 C IF(NPATHP.EQ.0) GOTO 15 C FM2=FMAX(JORDP) XINT1=CABS(CF*CJ*TL_J*SUM_NU1_0) XINT2=CABS(CF*CONJG(CJ)*TL_J*SUM_NU1_1) XINT3=CABS(CONJG(CF)*CJ*TL_J*SUM_NU1_2) XINT4=CABS(CONJG(CF*CJ)*TL_J*SUM_NU1_3) XMAX=AMAX1(XINT1,XINT2,XINT3,XINT4,XMAX) FMAX(JORDP)=AMAX1(FM2,XINT1,XINT2,XINT3,XINT4) IF((FMAX(JORDP)-FM2).GT.XCOMP) NPMA(JORDP)=NPATH(JORDP) IF((IREF.EQ.1).AND.(JORDP.EQ.NCUT)) THEN FREF=FMAX(JORDP) ENDIF 15 CONTINUE ENDDO ENDDO ENDDO ENDDO C IF(NPATHP.EQ.0) GOTO 16 FMIN(JORDP)=AMIN1(FM1,XMAX) IF(XMAX.GT.FMN(NPATHP)) THEN CALL LOCATE(FMN,NPATHP,XMAX,JMX) DO KF=NPATHP,JMX+2,-1 FMN(KF)=FMN(KF-1) JON(KF)=JON(KF-1) PATH(KF)=PATH(KF-1) DMN(KF)=DMN(KF-1) DO KD=1,10 JPON(KF,KD)=JPON(KF-1,KD) ENDDO ENDDO FMN(JMX+1)=XMAX JON(JMX+1)=JORDP PATH(JMX+1)=NPATH(JORDP) DMN(JMX+1)=D DO KD=1,JORDP JPON(JMX+1,KD)=JPOS(KD,3) ENDDO ENDIF IF((FMIN(JORDP)-FM1).LT.-XCOMP) NPMI(JORDP)=NPATH(JORDP) IF((IPRINT.EQ.3).AND.(IJ.EQ.1)) THEN WRITE(IUSCR,1) JORDP,NPATH(JORDP),XMAX,D,(JPOS(KD,3),KD=1,JORDP) & ENDIF C 16 RETURN C 1 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X)) C END C C======================================================================= C SUBROUTINE COUMAT(ITL,MI,LF,MF,DELTA,RADIAL,MATRIX) C C This routine calculates the spin-independent PhD optical matrix C elements for dipolar excitations. It is stored in C MATRIX(JDIR,JPOL) C C Here, the conventions are : C C IPOL=1 : linearly polarized light C IPOL=2 : circularly polarized light C C JPOL=1 : +/x polarization for circular/linear light C JPOL=2 : -/y polarization for circular/linear light C C When IDICHR=0, JDIR = 1,2 and 3 correspond respectively to the x,y C and z directions for the linear polarization. But for IDICHR=1, C these basis directions are those of the position of the light. C C Last modified : 8 Dec 2008 C USE DIM_MOD C USE INIT_L_MOD , L2 => NNL, L3 => LF1, L4 => LF2, L5 => ISTEP_LF USE SPIN_MOD , I1 => ISPIN, N1 => NSPIN, N2 => NSPIN2, I2 => ISFLI &P, I8 => IR_DIA, N3 => NSTEP USE TYPCAL_MOD , I3 => IPHI, I4 => IE, I5 => ITHETA, I6 => IFTHET, & I7 => IMOD, I9 => I_CP, I10 => I_EXT C COMPLEX MATRIX(3,2),SUM_1,SUM_2,DELTA,YLM(3,-1:1),RADIAL COMPLEX ONEC,IC,IL,COEF,PROD C REAL RLM(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1),GNT(0:N_GAUNT) REAL THETA(3),PHI(3) C DATA PI4S3,C_LIN,SQR2 /4.188790,1.447202,1.414214/ DATA PIS2 /1.570796/ C ONEC=(1.,0.) IC=(0.,1.) C IF(INITL.EQ.0) GOTO 2 C M=MF-MI C IF(MOD(LF,4).EQ.0) THEN IL=ONEC ELSEIF(MOD(LF,4).EQ.1) THEN IL=IC ELSEIF(MOD(LF,4).EQ.2) THEN IL=-ONEC ELSEIF(MOD(LF,4).EQ.3) THEN IL=-IC ENDIF C CALL GAUNT(LI,MI,LF,MF,GNT) C IF(ITL.EQ.0) THEN c COEF=CEXP(IC*DELTA)*CONJG(IL) COEF=CEXP(IC*DELTA)*IL ELSE IF(IDICHR.EQ.0) THEN c COEF=PI4S3*CONJG(IL) COEF=PI4S3*IL ELSE c COEF=C_LIN*CONJG(IL) COEF=C_LIN*IL ENDIF ENDIF C PROD=COEF*RADIAL*GNT(1) C IF(IDICHR.EQ.0) THEN YLM(1,-1)=(0.345494,0.) YLM(1,0)=(0.,0.) YLM(1,1)=(-0.345494,0.) YLM(2,-1)=(0.,-0.345494) YLM(2,0)=(0.,0.) YLM(2,1)=(0.,-0.345494) YLM(3,-1)=(0.,0.) YLM(3,0)=(0.488602,0.) YLM(3,1)=(0.,0.) C DO JDIR=1,3 MATRIX(JDIR,1)=PROD*CONJG(YLM(JDIR,M)) ENDDO C ELSEIF(IDICHR.GE.1) THEN C THETA(1)=PIS2 PHI(1)=0. THETA(2)=PIS2 PHI(2)=PIS2 THETA(3)=0. PHI(3)=0. C DO JDIR=1,3 CALL DJMN(THETA(JDIR),RLM,1) SUM_1=RLM(-1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR)) SUM_2=RLM(1,M,1)*PROD*CEXP((0.,-1.)*M*PHI(JDIR)) IF(IPOL.EQ.2) THEN MATRIX(JDIR,1)=SQR2*SUM_1 MATRIX(JDIR,2)=SQR2*SUM_2 ELSEIF(ABS(IPOL).EQ.1) THEN MATRIX(JDIR,1)=(SUM_2-SUM_1) MATRIX(JDIR,2)=(SUM_2+SUM_1)*IC ENDIF ENDDO ENDIF GOTO 1 C 2 DO JDIR=1,3 MATRIX(JDIR,1)=ONEC MATRIX(JDIR,2)=ONEC ENDDO C 1 RETURN C END C C======================================================================= C SUBROUTINE PHDDIF_SE(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK,NATC &LU,NFICHLEC,JFICH,NP) C C This subroutine computes the PhD formula in the spin-independent case C from a non spin-orbit resolved initial core state LI. C C Alternatively, it can compute the PhD amplitude for the APECS process. C C The calculation is performed using a series expansion for the C expression of the scattering path operator C C Last modified : 10 Jan 2016 C USE DIM_MOD C USE ALGORITHM_MOD USE AMPLI_MOD USE APPROX_MOD USE COOR_MOD , NTCLU => NATCLU, NTP => NATYP USE DEBWAL_MOD USE DIRECT_MOD , RTHETA => RTHEXT USE EXTREM_MOD USE FIXSCAN_MOD USE INFILES_MOD USE INUNITS_MOD USE INIT_L_MOD USE INIT_J_MOD USE LIMAMA_MOD USE LINLBD_MOD USE MOYEN_MOD USE OUTFILES_MOD USE OUTUNITS_MOD USE PARCAL_MOD USE PATH_MOD USE PRINTP_MOD USE RESEAU_MOD USE SPIN_MOD USE TESTPA_MOD USE TESTPB_MOD USE TESTS_MOD USE TRANS_MOD USE TYPCAL_MOD USE TYPEM_MOD USE TYPEXP_MOD USE VALIN_MOD , PHLUM => PHILUM USE VALIN_AV_MOD USE VALFIN_MOD C REAL NPATH1(0:NDIF_M),NOPA REAL LUM(3),AXE(3),EPS(3),DIRLUM(3),E_PH(NE_M) C COMPLEX IC,ONEC,ZEROC,COEF,PW(0:NDIF_M),DELTA COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI COMPLEX TAU(LINMAX,LINFMAX,NATCLU_M) COMPLEX YLMR(0:NL_M,-NL_M:NL_M),MATRIX(3,2) COMPLEX YLME(0:NL_M,-NL_M:NL_M) COMPLEX R2,MLFLI(2,-LI_M:LI_M,3,2,3) COMPLEX SJDIR_1,SJDIR_2,SJDIF_1,SJDIF_2 COMPLEX RHOK(NE_M,NATM,0:18,5,NSPIN2_M),RD COMPLEX SLJDIF,ATT_M,MLIL0(2,-LI_M:LI_M,6),SLF_1,SLF_2 COMPLEX SL0DIF,SMJDIF C DIMENSION VAL(NATCLU_M),NATYP(NATM),DIRPOL(3,2) DIMENSION EMET(3),R_L(9),COORD(3,NATCLU_M) DIMENSION R(NDIF_M),XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) DIMENSION JPOS(NDIF_M,3),JPA(NDIF_M) C C C CHARACTER*7 STAT CHARACTER*13 OUTDATA1,OUTDATA2 C C CHARACTER*24 OUTFILE CHARACTER*24 AMPFILE C DATA PI,PIS180,CONV /3.141593,0.017453,0.512314/ DATA FINSTRUC,CVECT,SMALL /0.007297,1.0,0.0001/ C ALGO1='SE' ALGO2=' ' ALGO3=' ' ALGO4=' ' C I_DIR=0 NSET=1 JEL=1 OUTDATA1='CROSS-SECTION' IF(I_AMP.EQ.1) THEN I_MI=1 OUTDATA2='MS AMPLITUDES' ELSE I_MI=0 ENDIF C IF(SPECTRO.EQ.'PHD') THEN IOUT=IUO2 OUTFILE=OUTFILE2 STAT='UNKNOWN' IF(I_MI.EQ.1) THEN IOUT2=IUSCR2+1 N_DOT=1 DO J_CHAR=1,24 IF(OUTFILE(J_CHAR:J_CHAR).EQ.'.') GOTO 888 N_DOT=N_DOT+1 ENDDO 888 CONTINUE AMPFILE=OUTFILE(1:N_DOT)//'amp' OPEN(UNIT=IOUT2, FILE=AMPFILE, STATUS=STAT) ENDIF ELSEIF(SPECTRO.EQ.'APC') THEN IOUT=IUSCR2+1 OUTFILE='res/phot.amp' STAT='UNKNOWN' ENDIF C C Position of the light when the analyzer is along the z axis : C (X_LUM_Z,Y_LUM_Z,Z_LUM_Z) C RTHLUM=THLUM*PIS180 RPHLUM=PHLUM*PIS180 X_LUM_Z=SIN(RTHLUM)*COS(RPHLUM) Y_LUM_Z=SIN(RTHLUM)*SIN(RPHLUM) Z_LUM_Z=COS(RTHLUM) C IF(IMOD.EQ.0) THEN C C The analyzer is rotated C DIRLUM(1)=X_LUM_Z DIRLUM(2)=Y_LUM_Z DIRLUM(3)=Z_LUM_Z ELSE C C The sample is rotated ---> light and analyzer rotated C IF(I_EXT.EQ.0) THEN RTH0=THETA0*PIS180 RPH0=PHI0*PIS180 RTH=RTH0 RPH=RPH0 C C R_L is the rotation matrix from 0z to (THETA0,PHI0) expressed as C a function of the Euler angles ALPHA=PHI0, BETA=THETA0, GAMMA=-PHI0 C It is stored as (1 2 3) C (4 5 6) C (7 8 9) C R_L(1)=COS(RTH0)*COS(RPH0)*COS(RPH0)+SIN(RPH0)*SIN(RPH0) R_L(2)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0) R_L(3)=SIN(RTH0)*COS(RPH0) R_L(4)=COS(RTH0)*SIN(RPH0)*COS(RPH0)-SIN(RPH0)*COS(RPH0) R_L(5)=COS(RTH0)*SIN(RPH0)*SIN(RPH0)+COS(RPH0)*COS(RPH0) R_L(6)=SIN(RTH0)*SIN(RPH0) R_L(7)=-SIN(RTH0)*COS(RPH0) R_L(8)=-SIN(RTH0)*SIN(RPH0) R_L(9)=COS(RTH0) C C Position of the light when the analyzer is along (THETA0,PHI0) : LUM(3) C LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9) C ENDIF ENDIF C IC=(0.,1.) ONEC=(1.,0.) ZEROC=(0.,0.) NSCAT=NATCLU-1 ATTSE=1. ATTSJ=1. NPATH2(0)=1. NPATH(0)=1. NPMA(0)=1. NPMI(0)=1. ZSURF=VAL(1) C IF((ISOM.EQ.0).OR.(JFICH.EQ.1)) THEN OPEN(UNIT=IOUT, FILE=OUTFILE, STATUS=STAT) ENDIF C C Writing the headers in the output file C CALL HEADERS(IOUT) C IF((ISOM.EQ.0).OR.((ISOM.GT.0).AND.(JFICH.EQ.1))) THEN WRITE(IOUT,12) SPECTRO,OUTDATA1 WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IP &H_1,I_EXT IF(I_MI.EQ.1) THEN WRITE(IOUT2,12) SPECTRO,OUTDATA2 WRITE(IOUT2,12) STEREO WRITE(IOUT2,19) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,I &E,IPH_1,I_EXT WRITE(IOUT2,20) PHI0,THETA0,PHI1,THETA1,NONVOL(1) ENDIF ENDIF C IF(ISOM.EQ.0) THEN WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE IF(I_MI.EQ.1) THEN WRITE(IOUT2,79) NPLAN,NEMET,NTHETA,NPHI,NE ENDIF ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN WRITE(IOUT,11) NTHETA,NPHI,NE IF(I_MI.EQ.1) THEN WRITE(IOUT2,11) NTHETA,NPHI,NE ENDIF ENDIF C C Construction of the linear index LAMBDA=(MU,NU) C LAMBDA0=0 DO N_O=0,NO NMX=N_O/2 DO NU=0,NMX DO MU=-N_O,N_O NMU=2*NU+ABS(MU) IF(NMU.EQ.N_O) THEN LAMBDA0=LAMBDA0+1 LBD(MU,NU)=LAMBDA0 ENDIF ENDDO ENDDO ENDDO LBDMAX=LAMBDA0 IJK=0 C C Loop over the planes C DO JPLAN=1,NPLAN Z=VAL(JPLAN) IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN DZZEM=ABS(Z-ZEM) IF(DZZEM.LT.SMALL) GOTO 10 GOTO 1 ENDIF 10 CONTINUE C C Loop over the different absorbers in a given plane C DO JEMET=1,NEMET CALL EMETT(JEMET,IEMET,Z,SYM_AT,NATYP,EMET,NTYPEM,JNEM,*4) GO TO 2 4 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN IF(I_TEST.NE.2) WRITE(IUO1,51) JPLAN,NTYPEM ENDIF GO TO 3 2 IF((ABS(EMET(3)).GT.COUPUR).AND.(IBAS.EQ.1)) GOTO 5 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN IF(I_TEST.NE.2) THEN WRITE(IUO1,52) JPLAN,EMET(1),EMET(2),EMET(3),NTYPEM ENDIF ENDIF IF(ISOM.EQ.1) NP=JPLAN ZSURFE=VAL(1)-EMET(3) C C Loop over the energies C DO JE=1,NE FMIN(0)=1. FMAX(0)=1. IF(NE.GT.1) THEN ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) E_PH(JE)=ELUM+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) ELSEIF(NE.EQ.1) THEN ECIN=E0 E_PH(JE)=ELUM ENDIF IF(I_TEST.NE.1) THEN CFM=8.*PI*E_PH(JE)*FINSTRUC ELSE CFM=1. ENDIF CALL LPM(ECIN,XLPM,*6) XLPM1=XLPM/A IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR ENDIF IF(ITL.EQ.0) THEN VK(JE)=SQRT(ECIN+VINT)*CONV*A*(1.,0.) VK2(JE)=CABS(VK(JE)*VK(JE)) ENDIF GAMMA=1./(2.*XLPM1) IF(IPOTC.EQ.0) THEN VK(JE)=VK(JE)+IC*GAMMA ENDIF IF(I_TEST.NE.1) THEN VKR=REAL(VK(JE)) ELSE VKR=1. ENDIF IF(I_MI.EQ.1) THEN WRITE(IOUT2,21) ECIN,VKR*CFM ENDIF IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN IF(IDCM.GE.1) WRITE(IUO1,22) DO JAT=1,N_PROT IF(IDCM.EQ.0) THEN XK2UJ2=VK2(JE)*UJ2(JAT) ELSE XK2UJ2=VK2(JE)*UJ_SQ(JAT) WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A ENDIF CALL DWSPH(JAT,JE,XK2UJ2,TLT,ISPEED) DO LAT=0,LMAX(JAT,JE) TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) ENDDO ENDDO ENDIF IF(ABS(I_EXT).GE.1) THEN OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') READ(IUI6,13) I_DIR,NSET,N_DUM1 READ(IUI6,14) I_DUM1,N_DUM2,N_DUM3 ENDIF C C Initialization of TAU(INDJ,LINFMAX,JTYP) C JATL=0 DO JTYP=1,N_PROT NBTYP=NATYP(JTYP) LMJ=LMAX(JTYP,JE) DO JNUM=1,NBTYP JATL=JATL+1 DO LF=LF1,LF2,ISTEP_LF ILF=LF*LF+LF+1 DO MF=-LF,LF INDF=ILF+MF DO LJ=0,LMJ ILJ=LJ*LJ+LJ+1 DO MJ=-LJ,LJ INDJ=ILJ+MJ TAU(INDJ,INDF,JATL)=ZEROC ENDDO ENDDO ENDDO ENDDO ENDDO ENDDO C C Storage of the coupling matrix elements MLFLI along the basis C directions X,Y ET Z C C These basis directions refer to the polarization if IDICHR = 0 C but to the light when IDICHR = 1 C C JBASE = 1 : X C JBASE = 2 : Y C JBASE = 3 : Z C DO MI=-LI,LI DO LF=LF1,LF2,ISTEP_LF LR=1+(1+LF-LI)/2 DELTA=DLT(JE,NTYPEM,NNL,LR) RD=RHOK(JE,NTYPEM,NNL,LR,1) DO MF=-LF,LF IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 333 IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 333 MR=2+MF-MI CALL COUMAT(ITL,MI,LF,MF,DELTA,RD,MATRIX) DO JBASE=1,3 MLFLI(1,MI,MR,LR,JBASE)=MATRIX(JBASE,1) IF(IDICHR.GE.1) THEN MLFLI(2,MI,MR,LR,JBASE)=MATRIX(JBASE,2) ENDIF ENDDO 333 CONTINUE ENDDO ENDDO ENDDO C C Calculation of the scattering path operator TAU C IF(I_TEST.EQ.2) GOTO 666 PW(0)=ONEC PW(1)=ONEC ND=0 TH01=0. PHI01=0. RHO01=ZEROC THMI=0. PHMI=0. RHOMI=ZEROC JATLEM=JNEM IF(NTYPEM.GT.1) THEN DO JAEM=NTYPEM-1,1,-1 JATLEM=JATLEM+NATYP(JAEM) ENDDO ENDIF DO JD=1,NDIF NPATH2(JD)=0. NPATH(JD)=0. IT(JD)=0 IN(JD)=0 FMIN(JD)=1.E+20 FMAX(JD)=0. ENDDO NTHOF=0 C C Calculation of the maximal intensity for the paths of order NCUT C (plane waves). This will be taken as a reference for the IPW filter. C IF(IPW.EQ.1) THEN NDIFOLD=NDIF NOOLD=NO ISPHEROLD=ISPHER NDIF=NCUT NO=0 ISPHER=0 IREF=1 IPW=0 IJ=0 DIJ=0. FREF=0. CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PH &MI,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) NDIF=NDIFOLD NO=NOOLD ISPHER=ISPHEROLD PW(0)=ONEC PW(1)=ONEC IPW=1 ND=0 TH01=0. PHI01=0. RHO01=ZEROC THMI=0. PHMI=0. RHOMI=ZEROC JATLEM=JNEM IF(NTYPEM.GT.1) THEN DO JAEM=NTYPEM-1,1,-1 JATLEM=JATLEM+NATYP(JAEM) ENDDO ENDIF DO JD=1,NDIF NPATH2(JD)=0. NPATH(JD)=0. IT(JD)=0 IN(JD)=0 FMIN(JD)=1.E+20 FMAX(JD)=0. ENDDO NTHOF=0 C C New initialization of TAU(INDJ,INDF,JATL) after the PW calculation C JATL=0 DO JTYP=1,N_PROT NBTYP=NATYP(JTYP) LMJ=LMAX(JTYP,JE) DO JNUM=1,NBTYP JATL=JATL+1 DO LF=LF1,LF2,ISTEP_LF ILF=LF*LF+LF+1 DO MF=-LF,LF INDF=ILF+MF DO LJ=0,LMJ ILJ=LJ*LJ+LJ+1 DO MJ=-LJ,LJ INDJ=ILJ+MJ TAU(INDJ,INDF,JATL)=ZEROC ENDDO ENDDO ENDDO ENDDO ENDDO ENDDO ENDIF C C Generation and print-out of the paths C IF (NPATHP.GT.0) THEN DO JP=1,NPATHP-1 FMN(JP)=0. PATH(JP)=0. JON(JP)=0 ENDDO FMN(NPATHP)=-1. PATH(NPATHP)=0. JON(NPATHP)=0 ENDIF IREF=0 IJ=1 IF(IPRINT.EQ.3) THEN OPEN(UNIT=IUSCR, STATUS='SCRATCH') ENDIF DIJ=0. CALL FINDPATHS(ND,NTYPEM,JATLEM,I_CP,R,XR,YR,ZR,RHOMI,THMI,PHMI &,ZSURF,JPOS,PW,JE,FREF,DIJ,TAU) IF(NPATHP.EQ.0) GOTO 15 IF(NSCAT.GT.1) THEN XPATOT=REAL((DFLOAT(NSCAT)**DFLOAT(NDIF+1) -1.D0)/DFLOAT(NSCA &T-1)) ELSE XPATOT=FLOAT(NDIF+1) ENDIF IF(XPATOT.LT.2.14748E+09) THEN NPATOT=INT(XPATOT) IF(NPATOT.LT.NPATHP) NPATHP=NPATOT-1 ENDIF WRITE(IUO1,84) NPATHP WRITE(IUO1,81) DO JPT=1,NPATHP IF(PATH(NPATHP).GT.2.14E+09) THEN WRITE(IUO1,82) JPT,JON(JPT),PATH(JPT),FMN(JPT),DMN(JPT),JNE &M,(JPON(JPT,KD),KD=1,JON(JPT)) ELSE WRITE(IUO1,83) JPT,JON(JPT),INT(PATH(JPT)),FMN(JPT),DMN(JPT &),JNEM,(JPON(JPT,KD),KD=1,JON(JPT)) ENDIF ENDDO IF(IPRINT.EQ.3) THEN IF(XPATOT.GT.2.14748E+09) GOTO 172 WRITE(IUO1,85) WRITE(IUO1,71) NPATOT=INT(XPATOT) DO JOP=0,NDIF IF(JOP.EQ.0) THEN XINT0=FMAX(0) DIST0=0. WRITE(IUO1,70) JOP,JOP+1,XINT0,DIST0,JNEM GOTO 75 ENDIF WRITE(IUO1,77) DO JLINE=1,NPATOT-1 READ(IUSCR,69,ERR=75,END=75) JOPA,NOPA,XMAX,DIST0,(JPA(KD &),KD=1,JOPA) IF(JOPA.EQ.JOP) THEN IF(NOPA.GT.2.14E+09) THEN WRITE(IUO1,76) JOPA,NOPA,XMAX,DIST0,JNEM,(JPA(KD),KD=1 &,JOPA) ELSE WRITE(IUO1,70) JOPA,INT(NOPA),XMAX,DIST0,JNEM,(JPA(KD) &,KD=1,JOPA) ENDIF ENDIF ENDDO IF(JOP.EQ.NDIF) WRITE(IUO1,80) 75 REWIND IUSCR ENDDO GOTO 73 172 WRITE(IUO1,74) CLOSE(IUSCR,STATUS='DELETE') 73 ENDIF DO JD=0,NDIF NPATH1(JD)=REAL(DFLOAT(NSCAT)**DFLOAT(JD)) IF(NPATH1(JD).GT.2.14E+09) THEN IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0. WRITE(IUO1,53) JD,NPATH1(JD),NPATH2(JD),FMIN(JD),NPMI(JD),F &MAX(JD),NPMA(JD) IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT ELSE IF(FMIN(JD).EQ.0.1E+21) FMIN(JD)=0. WRITE(IUO1,58) JD,INT(NPATH1(JD)+0.1),INT(NPATH2(JD)+0.1),F &MIN(JD),INT(NPMI(JD)+0.1),FMAX(JD),INT(NPMA(JD)+0.1) IF((IPW.EQ.1).AND.(JD.GT.NCUT)) WRITE(IUO1,68) FREF*PCTINT ENDIF ENDDO 666 CONTINUE C C Calculation of the Photoelectron Diffraction formula C C C Loop over the 'fixed' angle C 15 DO J_FIXED=1,N_FIXED IF(N_FIXED.GT.1) THEN IF(I_EXT.EQ.0) THEN FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) XINCRF=FLOAT(J_FIXED-1)*FIX_STEP ELSE XINCRF=0. ENDIF ELSEIF(N_FIXED.EQ.1) THEN XINCRF=0. ENDIF IF(ABS(I_EXT).GE.1) THEN READ(IUI6,86) JSET,JLINE,THD,PHD IF(I_EXT.EQ.-1) BACKSPACE IUI6 THETA0=THD PHI0=PHD ENDIF IF(IPH_1.EQ.1) THEN IF(I_EXT.EQ.0) THEN DPHI=PHI0+XINCRF ELSE DPHI=PHD ENDIF RPHI=DPHI*PIS180 IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI ELSE ISAUT=0 IF(I_EXT.EQ.0) THEN DTHETA=THETA0+XINCRF ELSE DTHETA=THD ENDIF RTHETA=DTHETA*PIS180 IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 IF(I_EXT.GE.1) ISAUT=0 IF(I_TEST.EQ.2) ISAUT=0 IF(ISAUT.GT.0) GOTO 8 IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) C C THETA-dependent number of PHI points for stereographic C representation (to obtain a uniform sampling density). C (Courtesy of J. Osterwalder - University of Zurich) C IF(STEREO.EQ.'YES') THEN N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+SMALL)+1 ENDIF C ENDIF IF((N_FIXED.GT.1).AND.(IMOD.EQ.1)) THEN C C When there are several sets of scans (N_FIXED > 1), C the initial position LUM of the light is recalculated C for each initial position (RTH,RPH) of the analyzer C IF(IPH_1.EQ.1) THEN RTH=THETA0*PIS180 RPH=RPHI ELSE RTH=RTHETA RPH=PHI0*PIS180 ENDIF C R_L(1)=COS(RTH)*COS(RPH) R_L(2)=-SIN(RPH) R_L(3)=SIN(RTH)*COS(RPH) R_L(4)=COS(RTH)*SIN(RPH) R_L(5)=COS(RPH) R_L(6)=SIN(RTH)*SIN(RPH) R_L(7)=-SIN(RTH) R_L(8)=0. R_L(9)=COS(RTH) C LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9) ENDIF C C Loop over the scanned angle C DO J_SCAN=1,N_SCAN IF(N_SCAN.GT.1) THEN XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1) ELSEIF(N_SCAN.EQ.1) THEN XINCRS=0. ENDIF IF(I_EXT.EQ.-1) THEN READ(IUI6,86) JSET,JLINE,THD,PHD BACKSPACE IUI6 ENDIF IF(IPH_1.EQ.1) THEN ISAUT=0 IF(I_EXT.EQ.0) THEN DTHETA=THETA0+XINCRS ELSE DTHETA=THD ENDIF RTHETA=DTHETA*PIS180 IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 IF(I_EXT.GE.1) ISAUT=0 IF(I_TEST.EQ.2) ISAUT=0 IF(ISAUT.GT.0) GOTO 8 IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) ELSE IF(I_EXT.EQ.0) THEN DPHI=PHI0+XINCRS ELSE DPHI=PHD ENDIF RPHI=DPHI*PIS180 IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI ENDIF C C Loop over the sets of directions to average over (for gaussian average) C C SSETDIR_1=0. SSETDIF_1=0. SSETDIR_2=0. SSETDIF_2=0. C SSET2DIR_1=0. SSET2DIF_1=0. SSET2DIR_2=0. SSET2DIF_2=0. C IF(I_EXT.EQ.-1) THEN JREF=INT(NSET)/2+1 ELSE JREF=1 ENDIF C DO J_SET=1,NSET IF(I_EXT.EQ.-1) THEN READ(IUI6,86) JSET,JLINE,THD,PHD,W DTHETA=THD DPHI=PHD RTHETA=DTHETA*PIS180 RPHI=DPHI*PIS180 C C Here, there are several sets of scans (NSET > 1), so C the initial position LUM of the light must be C recalculated for each initial position of the analyzer C RTH=TH_0(J_SET)*PIS180 RPH=PH_0(J_SET)*PIS180 C IF(IMOD.EQ.1) THEN R_L(1)=COS(RTH)*COS(RPH) R_L(2)=-SIN(RPH) R_L(3)=SIN(RTH)*COS(RPH) R_L(4)=COS(RTH)*SIN(RPH) R_L(5)=COS(RPH) R_L(6)=SIN(RTH)*SIN(RPH) R_L(7)=-SIN(RTH) R_L(8)=0. R_L(9)=COS(RTH) C LUM(1)=X_LUM_Z*R_L(1)+Y_LUM_Z*R_L(2)+Z_LUM_Z*R_L(3) LUM(2)=X_LUM_Z*R_L(4)+Y_LUM_Z*R_L(5)+Z_LUM_Z*R_L(6) LUM(3)=X_LUM_Z*R_L(7)+Y_LUM_Z*R_L(8)+Z_LUM_Z*R_L(9) C ENDIF ELSE W=1. ENDIF C IF(I_EXT.EQ.-1) PRINT 89 C CALL DIRAN(VINT,ECIN,JEL) C IF(J_SET.EQ.JREF) THEN DTHETAP=DTHETA DPHIP=DPHI ENDIF C IF(I_EXT.EQ.-1) THEN WRITE(IUO1,88) DTHETA,DPHI ENDIF C C .......... Case IMOD=1 only .......... C C Calculation of the position of the light when the analyzer is at C (THETA,PHI). DIRLUM is the direction of the light and its initial C value (at (THETA0,PHI0)) is LUM. AXE is the direction of the theta C rotation axis and EPS is defined so that (AXE,DIRLUM,EPS) is a C direct orthonormal basis. The transform of a vector R by a rotation C of OMEGA about AXE is then given by C C R' = R COS(OMEGA) + (AXE.R)(1-COS(OMEGA)) AXE + (AXE^R) SIN(OMEGA) C C Here, DIRANA is the internal direction of the analyzer and ANADIR C its external position C C Note that when the initial position of the analyzer is (RTH,RPH) C which coincides with (RTH0,RPH0) only for the first fixed angle C IF(IMOD.EQ.1) THEN IF(ITHETA.EQ.1) THEN AXE(1)=-SIN(RPH) AXE(2)=COS(RPH) AXE(3)=0. RANGLE=RTHETA-RTH ELSEIF(IPHI.EQ.1) THEN AXE(1)=0. AXE(2)=0. AXE(3)=1. RANGLE=RPHI-RPH ENDIF CALL PRVECT(AXE,LUM,EPS,CVECT) PRS=PRSCAL(AXE,LUM) IF(J_SCAN.EQ.1) THEN DIRLUM(1)=LUM(1) DIRLUM(2)=LUM(2) DIRLUM(3)=LUM(3) ELSE DIRLUM(1)=LUM(1)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(1)+ &SIN(RANGLE)*EPS(1) DIRLUM(2)=LUM(2)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(2)+ &SIN(RANGLE)*EPS(2) DIRLUM(3)=LUM(3)*COS(RANGLE)+PRS*(1.-COS(RANGLE))*AXE(3)+ &SIN(RANGLE)*EPS(3) ENDIF ENDIF IF(DIRLUM(3).GT.1.) DIRLUM(3)=1. IF(DIRLUM(3).LT.-1.) DIRLUM(3)=-1. THETALUM=ACOS(DIRLUM(3)) IF(I_TEST.EQ.2) THETALUM=-THETALUM COEF=DIRLUM(1)+IC*DIRLUM(2) CALL ARCSIN(COEF,DIRLUM(3),PHILUM) ANALUM=ANADIR(1,1)*DIRLUM(1) + ANADIR(2,1)*DIRLUM(2) +ANADIR( &3,1)*DIRLUM(3) C SEPSDIR_1=0. SEPSDIF_1=0. SEPSDIR_2=0. SEPSDIF_2=0. C C Loop over the directions of polarization C DO JEPS=1,NEPS IF((JEPS.EQ.1).AND.(IPOL.GE.0)) THEN DIRPOL(1,JEPS)=COS(THETALUM)*COS(PHILUM) DIRPOL(2,JEPS)=COS(THETALUM)*SIN(PHILUM) DIRPOL(3,JEPS)=-SIN(THETALUM) ELSE DIRPOL(1,JEPS)=-SIN(PHILUM) DIRPOL(2,JEPS)=COS(PHILUM) DIRPOL(3,JEPS)=0. ENDIF IF(ABS(IPOL).EQ.1) THEN IF(IPRINT.GT.0) THEN WRITE(IUO1,61) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3), & (DIRPOL(K,1),K=1,3),ANALUM ENDIF ELSE IF((JEPS.EQ.1).AND.(IPRINT.GT.0)) THEN WRITE(IUO1,63) (DIRANA(J,1),J=1,3),(DIRLUM(K),K=1,3),ANA &LUM ENDIF ENDIF IF((JEPS.EQ.1).AND.(I_EXT.EQ.-1)) PRINT 89 C C Calculation of the coupling matrix MLIL0 C DO MI=-LI,LI DO LF=LF1,LF2,ISTEP_LF LR=1+(1+LF-LI)/2 LRR=3*(LR-1) DO MF=-LF,LF MR=2+MF-MI IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 777 IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 777 LMR=LRR+MR IF(IDICHR.EQ.0) THEN IF(I_TEST.NE.1) THEN MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRPOL(1,JEPS) & +MLFLI(1,MI,MR,LR,2)*DIRPOL(2,JEPS) +MLFLI(1,MI,MR,LR,3)*DIRPOL(3 &,JEPS) ELSE MLIL0(1,MI,LMR)=ONEC ENDIF ELSEIF(IDICHR.GE.1) THEN IF(I_TEST.NE.1) THEN MLIL0(1,MI,LMR)=MLFLI(1,MI,MR,LR,1)*DIRLUM(1) +MLF &LI(1,MI,MR,LR,2)*DIRLUM(2) +MLFLI(1,MI,MR,LR,3)*DIRLUM(3) MLIL0(2,MI,LMR)=MLFLI(2,MI,MR,LR,1)*DIRLUM(1) +MLF &LI(2,MI,MR,LR,2)*DIRLUM(2) +MLFLI(2,MI,MR,LR,3)*DIRLUM(3) ELSE MLIL0(1,MI,LMR)=ONEC ENDIF ENDIF 777 CONTINUE ENDDO ENDDO ENDDO C SRDIF_1=0. SRDIR_1=0. SRDIF_2=0. SRDIR_2=0. C C Loop over the different directions of the analyzer contained in a cone C DO JDIR=1,NDIR IF(IATTS.EQ.1) THEN ATTSE=EXP(-ZSURFE*GAMMA/DIRANA(3,JDIR)) ENDIF C SMIDIR_1=0. SMIDIF_1=0. SMIDIR_2=0. SMIDIF_2=0. C C Loop over the equiprobable azimuthal quantum numbers MI corresponding C to the initial state LI C LME=LMAX(1,JE) CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME) DO MI=-LI,LI SJDIR_1=ZEROC SJDIF_1=ZEROC SJDIR_2=ZEROC SJDIF_2=ZEROC C C Calculation of the direct emission (used a a reference for the C output), which is not contained in the calculation of TAU C DO LF=LF1,LF2,ISTEP_LF LR=1+(1+LF-LI)/2 LRR=3*(LR-1) ILF=LF*LF+LF+1 IF(ISPEED.EQ.1) THEN R2=TL(LF,1,1,JE) ELSE R2=TLT(LF,1,1,JE) ENDIF DO MF=-LF,LF MR=2+MF-MI LMR=LRR+MR INDF=ILF+MF IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 444 IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 444 SJDIR_1=SJDIR_1+YLME(LF,MF)*ATTSE*MLIL0(1,MI,LMR)*R2 IF(IDICHR.GE.1) THEN SJDIR_2=SJDIR_2+YLME(LF,MF)*ATTSE*MLIL0(2,MI,LMR)*R2 & ENDIF C C Contribution of the absorber to TAU (initialization of SJDIF) C IF(I_TEST.EQ.2) GOTO 444 SL0DIF=ZEROC DO L0=0,LME IL0=L0*L0+L0+1 SL0DIF=SL0DIF+YLME(L0,0)*TAU(IL0,INDF,1) DO M0=1,L0 IND01=IL0+M0 IND02=IL0-M0 SL0DIF=SL0DIF+(YLME(L0,M0)*TAU(IND01,INDF,1)+YLME(L &0,-M0)*TAU(IND02,INDF,1)) ENDDO ENDDO SJDIF_1=SJDIF_1+SL0DIF*MLIL0(1,MI,LMR) IF(IDICHR.GE.1) THEN SJDIF_2=SJDIF_2+SL0DIF*MLIL0(2,MI,LMR) ENDIF 444 CONTINUE ENDDO ENDDO SJDIF_1=SJDIF_1*ATTSE IF(IDICHR.GE.1) THEN SJDIF_2=SJDIF_2*ATTSE ENDIF C C Loop over the last atom J encountered by the photoelectron C before escaping the solid C IF(I_TEST.EQ.2) GOTO 111 DO JTYP=2,N_PROT NBTYP=NATYP(JTYP) LMJ=LMAX(JTYP,JE) DO JNUM=1,NBTYP JATL=NCORR(JNUM,JTYP) XOJ=SYM_AT(1,JATL)-EMET(1) YOJ=SYM_AT(2,JATL)-EMET(2) ZOJ=SYM_AT(3,JATL)-EMET(3) ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ) ZSURFJ=VAL(1)-SYM_AT(3,JATL) CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLMR,LMJ) IF(IATTS.EQ.1) THEN ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR)) ENDIF CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+ZOJ*DIRANA &(3,JDIR))/ROJ IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78 CTROIS1=ZOJ/ROJ IF(CTROIS1.GT.1.) THEN CTROIS1=1. ELSEIF(CTROIS1.LT.-1.) THEN CTROIS1=-1. ENDIF IF(IDCM.GE.1) THEN UJ2(JTYP)=UJ_SQ(JTYP) ENDIF IF(ABS(ZSURFJ).LE.SMALL) THEN IF(ABS(CSTHJR-1.).GT.SMALL) THEN CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)*(DIRANA(3,JDIR)-CTRO &IS1)/(2.-2.*CSTHJR) ELSE CSKZ2J=1. ENDIF UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) ELSE UJJ=UJ2(JTYP) ENDIF IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN XK2UJ2=VK2(JE)*UJJ CALL DWSPH(JTYP,JE,XK2UJ2,TLT,ISPEED) ENDIF 78 IF(IDWSPH.EQ.1) THEN DWTER=1. ELSE DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR)) ENDIF IF(JATL.EQ.JATLEM) THEN ATT_M=ATTSE*DWTER ELSE ATT_M=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*CSTHJR) ENDIF C SLF_1=ZEROC SLF_2=ZEROC DO LF=LF1,LF2,ISTEP_LF LR=1+(1+LF-LI)/2 LRR=3*(LR-1) ILF=LF*LF+LF+1 DO MF=-LF,LF MR=2+MF-MI INDF=ILF+MF IF((MF.LT.MI-1).OR.(MF.GT.MI+1)) GOTO 555 IF((INITL.EQ.0).AND.(MF.NE.MI)) GOTO 555 LMR=LRR+MR SLJDIF=ZEROC DO LJ=0,LMJ ILJ=LJ*LJ+LJ+1 SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDF,JATL) IF(LJ.GT.0) THEN DO MJ=1,LJ INDJ1=ILJ+MJ INDJ2=ILJ-MJ SMJDIF=SMJDIF+(YLMR(LJ,MJ)*TAU(INDJ1,INDF,JATL)+YL &MR(LJ,-MJ)*TAU(INDJ2,INDF,JATL)) ENDDO ENDIF SLJDIF=SLJDIF+SMJDIF ENDDO SLF_1=SLF_1+SLJDIF*MLIL0(1,MI,LMR) IF(IDICHR.GE.1) THEN SLF_2=SLF_2+SLJDIF*MLIL0(2,MI,LMR) ENDIF 555 CONTINUE ENDDO ENDDO SJDIF_1=SJDIF_1+SLF_1*ATT_M IF(IDICHR.GE.1) THEN SJDIF_2=SJDIF_2+SLF_2*ATT_M ENDIF C C End of the loops over the last atom J C ENDDO ENDDO C C Writing the amplitudes in file IOUT for APECS, or C in file IOUT2 for PhD (orientated orbitals' case) C 111 IF(SPECTRO.EQ.'APC') THEN WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEPS, &JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1 IF(IDICHR.GE.1) THEN WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JEP &S,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2 ENDIF ELSE IF(I_MI.EQ.1) THEN WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN,JE &PS,JDIR,MI,SJDIR_1,SJDIR_1+SJDIF_1 IF(IDICHR.GE.1) THEN WRITE(IOUT2,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN, &JEPS,JDIR,MI,SJDIR_2,SJDIR_2+SJDIF_2 ENDIF ENDIF C C Computing the square modulus C SMIDIF_1=SMIDIF_1+CABS(SJDIR_1+SJDIF_1)*CABS(SJDIR_1+SJD &IF_1) SMIDIR_1=SMIDIR_1+CABS(SJDIR_1)*CABS(SJDIR_1) IF(IDICHR.GE.1) THEN SMIDIF_2=SMIDIF_2+CABS(SJDIR_2+SJDIF_2)*CABS(SJDIR_2+S &JDIF_2) SMIDIR_2=SMIDIR_2+CABS(SJDIR_2)*CABS(SJDIR_2) ENDIF ENDIF C C End of the loop over MI C ENDDO C IF(SPECTRO.EQ.'APC') GOTO 220 SRDIR_1=SRDIR_1+SMIDIR_1 SRDIF_1=SRDIF_1+SMIDIF_1 IF(IDICHR.GE.1) THEN SRDIR_2=SRDIR_2+SMIDIR_2 SRDIF_2=SRDIF_2+SMIDIF_2 ENDIF 220 CONTINUE C C End of the loop on the directions of the analyzer C ENDDO C IF(SPECTRO.EQ.'APC') GOTO 221 SEPSDIF_1=SEPSDIF_1+SRDIF_1*VKR*CFM/NDIR SEPSDIR_1=SEPSDIR_1+SRDIR_1*VKR*CFM/NDIR IF(IDICHR.GE.1) THEN SEPSDIF_2=SEPSDIF_2+SRDIF_2*VKR*CFM/NDIR SEPSDIR_2=SEPSDIR_2+SRDIR_2*VKR*CFM/NDIR ENDIF 221 CONTINUE C C End of the loop on the polarization C ENDDO C SSETDIR_1=SSETDIR_1+SEPSDIR_1*W SSETDIF_1=SSETDIF_1+SEPSDIF_1*W IF(ICHKDIR.EQ.2) THEN IF(JSET.EQ.JREF) THEN SSET2DIR_1=SEPSDIR_1 SSET2DIF_1=SEPSDIF_1 ENDIF ENDIF IF(IDICHR.GE.1) THEN SSETDIR_2=SSETDIR_2+SEPSDIR_2*W SSETDIF_2=SSETDIF_2+SEPSDIF_2*W IF(ICHKDIR.EQ.2) THEN IF(JSET.EQ.JREF) THEN SSET2DIR_2=SEPSDIR_2 SSET2DIF_2=SEPSDIF_2 ENDIF ENDIF ENDIF C C End of the loop on the set averaging C ENDDO C IF(SPECTRO.EQ.'APC') GOTO 222 IF(IDICHR.EQ.0) THEN IF(ISOM.EQ.2) THEN WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS &ETDIF_1 IF(ICHKDIR.EQ.2) THEN WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1, &SSET2DIF_1 ENDIF ELSE WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS &ETDIF_1 IF(ICHKDIR.EQ.2) THEN WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1, &SSET2DIF_1 ENDIF ENDIF ELSE IF(ISOM.EQ.2) THEN WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS &ETDIF_1,SSETDIR_2,SSETDIF_2 IF(ICHKDIR.EQ.2) THEN WRITE(IOUT,72) JPLAN,JFICH,DTHETAP,DPHIP,ECIN,SSET2DIR_1, &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2 ENDIF ELSE WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSETDIR_1,SS &ETDIF_1,SSETDIR_2,SSETDIF_2 IF(ICHKDIR.EQ.2) THEN WRITE(IOUT,72) JPLAN,JEMET,DTHETAP,DPHIP,ECIN,SSET2DIR_1, &SSET2DIF_1,SSET2DIR_2,SSET2DIF_2 ENDIF ENDIF ENDIF 222 CONTINUE C C End of the loop on the scanned angle C ENDDO C 8 CONTINUE C C End of the loop on the fixed angle C ENDDO C C End of the loop on the energy C CLOSE(IUI6) ENDDO C 3 CONTINUE C C End of the loop on the emitters C ENDDO C GO TO 1 5 IPLAN=JPLAN-1 IJK=IJK+1 IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN ENDIF 1 CONTINUE C C End of the loop on the planes C ENDDO C IF(ABS(I_EXT).GE.1) CLOSE(IUI6) IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*) IF(SPECTRO.EQ.'APC') CLOSE(IOUT) IF(SPECTRO.EQ.'APC') GOTO 7 c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN NP=0 CALL TREAT_PHD(ISOM,NFICHLEC,JFICH,NP) ENDIF IF(I_EXT.EQ.2) THEN CALL WEIGHT_SUM(ISOM,I_EXT,0,1) ENDIF GOTO 7 6 WRITE(IUO1,55) C 9 FORMAT(9(2X,I1),2X,I2) 11 FORMAT(I4,2X,I4,2X,I4) 12 FORMAT(2X,A3,11X,A13) 13 FORMAT(6X,I1,1X,I3,2X,I4) 14 FORMAT(6X,I1,1X,I3,3X,I3) 19 FORMAT(2(2X,I1),1X,I2,6(2X,I1),2X,I2) 20 FORMAT(2(5X,F6.2,2X,F6.2),2X,I1) 21 FORMAT(10X,E12.6,3X,E12.6) 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/,2 &5X,' BY DEBYE UNCORRELATED MODEL:',/) 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2') 51 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' DOES NOT CONTAIN ', *'ANY ABSORBER OF TYPE ',I2,' *******') 52 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' POSITION OF ','THE AB &SORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X,'******* ',19X &,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******') 53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1,/, &10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1,/,10X,' MINIMAL INTENS &ITY : ',E12.6,2X,'No OF THE PATH : ',F15.1, & /,10X,' MAXIMAL INTENSITY : ',E12.6,2X,'No OF T &HE PATH : ',F15.1) 54 FORMAT(//,7X,'DUE TO THE SIZE OF THE CLUSTER, THE SUMMATION', *' HAS BEEN TRUNCATED TO THE ',I2,' TH PLANE') 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT', *'AVAILABLE >>>>>>>>>>') 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X, *'MEAN FREE PATH = ',F6.3,' * A',//) 57 FORMAT(25X,'CLUSTER RADIUS = ',F6.3,' *A') 58 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',I10,/,10 &X,' EFFECTIVE NUMBER OF PATHS : ',I10, /,10X,' MI &NIMAL INTENSITY : ',E12.6,2X,'No OF THE PATH : ',I10, & /,10X,' MAXIMAL INTENSITY : ',E12.6, & 2X,'No OF THE PATH : ',I10) 59 FORMAT(//,15X,'THE SCATTERING DIRECTION IS GIVEN INSIDE ', *'THE CRYSTAL') 60 FORMAT(7X,'THE POSITIONS OF THE ATOMS ARE GIVEN WITH RESPECT ', *'TO THE ABSORBER') 61 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6. &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI &GHT ', ' : (',F6.3,',',F6.3,',',F6.3, & ')',/,16X,'DIRECTION OF THE POLARIZATION : ( &', F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZER.LIGHT ',' & : ',F7.4) 63 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (',F6. &3,',',F6.3,',',F6.3, ') ..........',/,16X,'DIRECTION OF THE LI &GHT ', ' : (',F6.3,',',F6.3,',',F6.3,')',/,16X,'ANALYZE &R.LIGHT : ',F7.4) 65 FORMAT(////,3X,'++++++++++++++++++',9X, *'THETA = ',F6.2,' DEGREES',9X,'++++++++', *'++++++++++',///) 66 FORMAT(////,3X,'++++++++++++++++++',9X, *'PHI = ',F6.2,' DEGREES',9X,'++++++++++', *'++++++++++',///) 67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) 68 FORMAT(10X,' CUT-OFF INTENSITY : ',E12.6) 69 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X)) 70 FORMAT(2X,I2,2X,I10,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X)) 71 FORMAT(//,1X,'JDIF',4X,'No OF THE PATH',2X,'INTENSITY',3X,'LENGTH' &,4X,'ABSORBER',2X,'ORDER OF THE SCATTERERS',/) 72 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1 &2.6,2X,E12.6) 74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ','===== &>') 76 FORMAT(2X,I2,2X,E12.6,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X)) 77 FORMAT(' ') 79 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4) 80 FORMAT(///) 81 FORMAT(//,1X,'RANK',1X,'ORDER',4X,'No PATH',3X,'INTENSITY',3X,'LEN >H',4X,'ABS',3X,'ORDER OF THE SCATTERERS',/) 82 FORMAT(I3,4X,I2,1X,E12.6,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X)) 83 FORMAT(I3,4X,I2,1X,I10,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X)) 84 FORMAT(/////,18X,'THE ',I3,' MORE INTENSE PATHS BY DECREASING',' O &RDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ','OF A)') 85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ',/,24X,'(THE L &ENGTH IS GIVEN IN UNITS OF A)') 86 FORMAT(2X,I3,1X,I4,5X,F8.3,3X,F8.3,3X,E12.6) 87 FORMAT(2X,I2,2X,I3,2X,I2,2X,I3,2X,I3,2X,I3,2X,I1,2X,I2,2X,I2,2X,E1 &2.6,2X,E12.6,2X,E12.6,2X,E12.6) 88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =', F6.2) 89 FORMAT(/,4X,'..........................................','........ &.............................') C 7 RETURN C END C C======================================================================= C SUBROUTINE TREAT_PHD(ISOM,NFICHLEC,JFICH,NP) C C This routine sums up the calculations corresponding to different C absorbers or different planes when this has to be done C (parameter ISOM in the input data file). C C Last modified : 24 Jan 2013 C USE DIM_MOD USE OUTUNITS_MOD USE TYPEXP_MOD , DUMMY => SPECTRO USE VALIN_MOD USE VALFIN_MOD C PARAMETER(N_HEAD=5000,N_FILES=1000) C CHARACTER*3 SPECTRO C CHARACTER*13 OUTDATA CHARACTER*72 HEAD(N_HEAD,N_FILES) C REAL TAB(NDIM_M,4) REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M) C C DATA JVOL,JTOT/0,-1/ C REWIND IUO2 C C Reading and storing the headers: C NHEAD=0 DO JLINE=1,N_HEAD READ(IUO2,888) HEAD(JLINE,JFICH) NHEAD=NHEAD+1 IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333 ENDDO C 333 CONTINUE C READ(IUO2,15) SPECTRO,OUTDATA READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE,IPH_1 &,I_EXT C IF(I_EXT.EQ.2) THEN IPH_1=0 ENDIF C IF(ISOM.EQ.0) THEN C C........ ISOM = 0 : case of independent input files ................. C READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE C IF(IPH_1.EQ.1) THEN N_FIXED=NPHI FIX0=PHI0 FIX1=PHI1 N_SCAN=NTHETA ELSE N_FIXED=NTHETA FIX0=THETA0 FIX1=THETA1 IF(STEREO.EQ.'YES') THEN NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001) &+1 IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 ENDIF N_SCAN=NPHI ENDIF C IF(I_EXT.EQ.-1) THEN N_SCAN=2*N_SCAN ENDIF C IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN NDP=NEMET*NTHETA*NPHI*NE ELSEIF(I_EXT.EQ.-1) THEN NDP=NEMET*NTHETA*NPHI*NE*2 ELSEIF(I_EXT.EQ.2) THEN NDP=NEMET*NTHETA*NE N_FIXED=NTHETA N_SCAN=NPHI IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 ENDIF C NTT=NPLAN*NDP IF(NTT.GT.NDIM_M) GOTO 5 C DO JPLAN=1,NPLAN DO JEMET=1,NEMET DO JE=1,NE C DO J_FIXED=1,N_FIXED IF(N_FIXED.GT.1) THEN XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1) ELSEIF(N_FIXED.EQ.1) THEN XINCRF=0. ENDIF IF(IPH_1.EQ.1) THEN JPHI=J_FIXED ELSE THETA=THETA0+XINCRF JTHETA=J_FIXED IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11 ENDIF IF(STEREO.EQ.' NO') THEN N_SCAN_R=N_SCAN ELSE RTHETA=THETA*0.017453 FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 ENDIF C DO J_SCAN=1,N_SCAN_R IF(IPH_1.EQ.1) THEN JTHETA=J_SCAN ELSE JPHI=J_SCAN ENDIF C JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*N_FIXED*N_SCAN + (JE-1)*N &_FIXED*N_SCAN +(JTHETA-1)*NPHI + JPHI C IF(I_EXT.LE.0) THEN IF(STEREO.EQ.' NO') THEN JPHI2=JPHI ELSE JPHI2=(JTHETA-1)*NPHI+JPHI ENDIF ELSE JPHI2=JTHETA ENDIF C READ(IUO2,2) JPL IF(JPLAN.EQ.JPL) THEN BACKSPACE IUO2 IF(IDICHR.EQ.0) THEN READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE &),TAB(JLIN,1),TAB(JLIN,2) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) ENDIF ELSE READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) ENDIF ENDIF ELSE BACKSPACE IUO2 DO JL=JLIN,JPLAN*NDP TAB(JL,1)=0.0 TAB(JL,2)=0.0 TAB(JL,3)=0.0 TAB(JL,4)=0.0 ENDDO GOTO 10 ENDIF ENDDO ENDDO 11 CONTINUE ENDDO ENDDO 10 CONTINUE ENDDO C REWIND IUO2 C C Skipping the NHEAD lines of headers before rewriting: C DO JLINE=1,NHEAD READ(IUO2,888) HEAD(JLINE,JFICH) ENDDO C WRITE(IUO2,15) SPECTRO,OUTDATA WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM C DO JE=1,NE DO JTHETA=1,NTHETA IF(STEREO.EQ.' NO') THEN NPHI_R=NPHI ELSE RTHETA=DTHETA(JTHETA)*0.017453 FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 ENDIF DO JPHI=1,NPHI_R TOTDIF_1=0. TOTDIR_1=0. VOLDIF_1=0. VOLDIR_1=0. TOTDIF_2=0. TOTDIR_2=0. VOLDIF_2=0. VOLDIR_2=0. IF(I_EXT.EQ.-1) THEN TOTDIF2_1=0. TOTDIR2_1=0. VOLDIF2_1=0. VOLDIR2_1=0. TOTDIF2_2=0. TOTDIR2_2=0. VOLDIF2_2=0. VOLDIR2_2=0. ENDIF C DO JPLAN=1,NPLAN C SF_1=0. SR_1=0. SF_2=0. SR_2=0. IF(I_EXT.EQ.-1) THEN SF2_1=0. SR2_1=0. SF2_2=0. SR2_2=0. ENDIF C DO JEMET=1,NEMET JLIN=(JPLAN-1)*NDP + (JEMET-1)*NE*NTHETA*NPHI + (JE-1)*NTHE &TA*NPHI +(JTHETA-1)*NPHI + JPHI SF_1=SF_1+TAB(JLIN,2) SR_1=SR_1+TAB(JLIN,1) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN SF2_1=SF2_1+TAB(JLIN2,2) SR2_1=SR2_1+TAB(JLIN2,1) ENDIF IF(IDICHR.GE.1) THEN SF_2=SF_2+TAB(JLIN,4) SR_2=SR_2+TAB(JLIN,3) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN SF2_2=SF2_2+TAB(JLIN2,4) SR2_2=SR2_2+TAB(JLIN2,3) ENDIF ENDIF ENDDO IF(I_EXT.LE.0) THEN IF(STEREO.EQ.' NO') THEN JPHI2=JPHI ELSE JPHI2=(JTHETA-1)*NPHI+JPHI ENDIF ELSE JPHI2=JTHETA ENDIF IF(IDICHR.EQ.0) THEN WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR &_1,SF_1 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), &SR2_1,SF2_1 ENDIF ELSE WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S &R_1,SF_1,SR_2,SF_2 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) &,SR2_1,SF2_1,SR2_2,SF2_2 ENDIF ENDIF IF(JPLAN.GT.NONVOL(JFICH)) THEN VOLDIF_1=VOLDIF_1+SF_1 VOLDIR_1=VOLDIR_1+SR_1 IF(I_EXT.EQ.-1) THEN VOLDIF2_1=VOLDIF2_1+SF2_1 VOLDIR2_1=VOLDIR2_1+SR2_1 ENDIF IF(IDICHR.GE.1) THEN VOLDIF_2=VOLDIF_2+SF_2 VOLDIR_2=VOLDIR_1+SR_2 IF(I_EXT.EQ.-1) THEN VOLDIF2_2=VOLDIF2_2+SF2_2 VOLDIR2_2=VOLDIR2_1+SR2_2 ENDIF ENDIF ENDIF TOTDIF_1=TOTDIF_1+SF_1 TOTDIR_1=TOTDIR_1+SR_1 IF(I_EXT.EQ.-1) THEN TOTDIF2_1=TOTDIF2_1+SF2_1 TOTDIR2_1=TOTDIR2_1+SR2_1 ENDIF IF(IDICHR.GE.1) THEN TOTDIF_2=TOTDIF_2+SF_2 TOTDIR_2=TOTDIR_2+SR_2 IF(I_EXT.EQ.-1) THEN TOTDIF2_2=TOTDIF2_2+SF2_2 TOTDIR2_2=TOTDIR2_2+SR2_2 ENDIF ENDIF ENDDO IF(IDICHR.EQ.0) THEN WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOLD &IR_1,VOLDIF_1 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO &LDIR2_1,VOLDIF2_1 ENDIF WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOTD &IR_1,TOTDIF_1 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO &TDIR2_1,TOTDIF2_1 ENDIF ELSE WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VOL &DIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V &OLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2 ENDIF WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TOT &DIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T &OTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2 ENDIF ENDIF ENDDO ENDDO ENDDO C ELSE C C........ ISOM not= 0 : multiple input files to be summed up .......... C READ(IUO2,7) NTHETA,NPHI,NE C IF(IPH_1.EQ.1) THEN N_FIXED=NPHI FIX0=PHI0 FIX1=PHI1 N_SCAN=NTHETA ELSE N_FIXED=NTHETA FIX0=THETA0 FIX1=THETA1 IF(STEREO.EQ.'YES') THEN NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/(THETA1-THETA0)+0.0001) &+1 IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 ENDIF N_SCAN=NPHI ENDIF C IF(I_EXT.EQ.-1) THEN N_SCAN=2*N_SCAN ENDIF C IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN NDP=NTHETA*NPHI*NE ELSEIF(I_EXT.EQ.-1) THEN NDP=NTHETA*NPHI*NE*2 ELSEIF(I_EXT.EQ.2) THEN NDP=NTHETA*NE N_FIXED=NTHETA N_SCAN=NPHI IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 ENDIF C NTT=NFICHLEC*NDP IF(NTT.GT.NDIM_M) GOTO 5 C IF(ISOM.EQ.1) THEN NPLAN=NP NF=NP ELSEIF(ISOM.EQ.2) THEN NEMET=NFICHLEC NF=NFICHLEC NPLAN=1 ENDIF C DO JF=1,NF C C Reading the headers for each file: C IF(JF.GT.1) THEN DO JLINE=1,NHEAD READ(IUO2,888) HEAD(JLINE,JF) ENDDO ENDIF C DO JE=1,NE C DO J_FIXED=1,N_FIXED IF(N_FIXED.GT.1) THEN XINCRF=FLOAT(J_FIXED-1)*(FIX1-FIX0)/FLOAT(N_FIXED-1) ELSEIF(N_FIXED.EQ.1) THEN XINCRF=0. ENDIF IF(IPH_1.EQ.1) THEN JPHI=J_FIXED ELSE THETA=THETA0+XINCRF JTHETA=J_FIXED IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12 ENDIF IF(STEREO.EQ.' NO') THEN N_SCAN_R=N_SCAN ELSE RTHETA=THETA*0.017453 FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 ENDIF C DO J_SCAN=1,N_SCAN_R IF(IPH_1.EQ.1) THEN JTHETA=J_SCAN ELSE JPHI=J_SCAN ENDIF C JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN +(JTHETA-1)*NPHI + &JPHI IF(I_EXT.LE.0) THEN IF(STEREO.EQ.' NO') THEN JPHI2=JPHI ELSE JPHI2=(JTHETA-1)*NPHI+JPHI ENDIF ELSE JPHI2=JTHETA ENDIF C IF(ISOM.EQ.1) THEN READ(IUO2,2) JPL IF(JF.EQ.JPL) THEN BACKSPACE IUO2 IF(IDICHR.EQ.0) THEN READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN( &JE),TAB(JLIN,1),TAB(JLIN,2) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) ENDIF ELSE READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN &(JE),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),EC &IN(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) ENDIF ENDIF ELSE BACKSPACE IUO2 DO JLINE=1,NHEAD BACKSPACE IUO2 ENDDO DO JL=JLIN,JF*NDP TAB(JL,1)=0.0 TAB(JL,2)=0.0 TAB(JL,3)=0.0 TAB(JL,4)=0.0 ENDDO GOTO 13 ENDIF ELSEIF(ISOM.EQ.2) THEN IF(IDICHR.EQ.0) THEN READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE &),TAB(JLIN,1),TAB(JLIN,2) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) ENDIF ELSE READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J &E),TAB(JLIN,1),TAB(JLIN,2),TAB(JLIN,3),TAB(JLIN,4) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2),ECIN &(JE),TAB(JLIN2,1),TAB(JLIN2,2),TAB(JLIN2,3),TAB(JLIN2,4) ENDIF ENDIF ENDIF ENDDO 12 CONTINUE ENDDO ENDDO 13 CONTINUE ENDDO C REWIND IUO2 C C Writing the headers: C DO JLINE=1,2 WRITE(IUO2,888) HEAD(JLINE,1) ENDDO DO JF=1,NFICHLEC DO JLINE=3,6 WRITE(IUO2,888) HEAD(JLINE,JF) ENDDO WRITE(IUO2,888) HEAD(2,JF) ENDDO DO JLINE=7,NHEAD WRITE(IUO2,888) HEAD(JLINE,1) ENDDO C WRITE(IUO2,15) SPECTRO,OUTDATA WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM C IF(ISOM.EQ.1) THEN C DO JE=1,NE C DO JTHETA=1,NTHETA IF(STEREO.EQ.' NO') THEN NPHI_R=NPHI ELSE RTHETA=DTHETA(JTHETA)*0.017453 FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 ENDIF DO JPHI=1,NPHI_R C TOTDIF_1=0. TOTDIR_1=0. VOLDIF_1=0. VOLDIR_1=0. TOTDIF_2=0. TOTDIR_2=0. VOLDIF_2=0. VOLDIR_2=0. IF(I_EXT.EQ.-1) THEN TOTDIF2_1=0. TOTDIR2_1=0. VOLDIF2_1=0. VOLDIR2_1=0. TOTDIF2_2=0. TOTDIR2_2=0. VOLDIF2_2=0. VOLDIR2_2=0. ENDIF C DO JPLAN=1,NPLAN JF=JPLAN C JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + JP &HI C SR_1=TAB(JLIN,1) SF_1=TAB(JLIN,2) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN SF2_1=TAB(JLIN2,2) SR2_1=TAB(JLIN2,1) ENDIF IF(I_EXT.LE.0) THEN IF(STEREO.EQ.' NO') THEN JPHI2=JPHI ELSE JPHI2=(JTHETA-1)*NPHI+JPHI ENDIF ELSE JPHI2=JTHETA ENDIF IF(IDICHR.EQ.0) THEN WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), &SR_1,SF_1 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE &),SR2_1,SF2_1 ENDIF ELSE SR_2=TAB(JLIN,3) SF_2=TAB(JLIN,4) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN SF2_2=TAB(JLIN2,4) SR2_2=TAB(JLIN2,3) ENDIF WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) &,SR_1,SF_1,SR_2,SF_2 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J &E),SR2_1,SF2_1,SR2_2,SF2_2 ENDIF ENDIF IF(NONVOL(JPLAN).EQ.0) THEN VOLDIF_1=VOLDIF_1+SF_1 VOLDIR_1=VOLDIR_1+SR_1 IF(I_EXT.EQ.-1) THEN VOLDIF2_1=VOLDIF2_1+SF2_1 VOLDIR2_1=VOLDIR2_1+SR2_1 ENDIF IF(IDICHR.GE.1) THEN VOLDIF_2=VOLDIF_2+SF_2 VOLDIR_2=VOLDIR_2+SR_2 IF(I_EXT.EQ.-1) THEN VOLDIF2_2=VOLDIF2_2+SF2_2 VOLDIR2_2=VOLDIR2_1+SR2_2 ENDIF ENDIF ENDIF TOTDIF_1=TOTDIF_1+SF_1 TOTDIR_1=TOTDIR_1+SR_1 IF(I_EXT.EQ.-1) THEN TOTDIF2_1=TOTDIF2_1+SF2_1 TOTDIR2_1=TOTDIR2_1+SR2_1 ENDIF IF(IDICHR.GE.1) THEN TOTDIF_2=TOTDIF_2+SF_2 TOTDIR_2=TOTDIR_2+SR_2 IF(I_EXT.EQ.-1) THEN TOTDIF2_2=TOTDIF2_2+SF2_2 TOTDIR2_2=TOTDIR2_2+SR2_2 ENDIF ENDIF ENDDO C IF(IDICHR.EQ.0) THEN WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),VO &LDIR_1,VOLDIF_1 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), &VOLDIR2_1,VOLDIF2_1 ENDIF WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),TO &TDIR_1,TOTDIF_1 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), &TOTDIR2_1,TOTDIF2_1 ENDIF ELSE WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),V &OLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) &,VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2 ENDIF WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),T &OTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE) &,TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2 ENDIF ENDIF C ENDDO ENDDO ENDDO ELSEIF(ISOM.EQ.2) THEN DO JE=1,NE C DO JTHETA=1,NTHETA IF(STEREO.EQ.' NO') THEN NPHI_R=NPHI ELSE RTHETA=DTHETA(JTHETA)*0.017453 FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 ENDIF DO JPHI=1,NPHI_R C SF_1=0. SR_1=0. SF_2=0. SR_2=0. IF(I_EXT.EQ.-1) THEN SF2_1=0. SR2_1=0. SF2_2=0. SR2_2=0. ENDIF C DO JEMET=1,NEMET JF=JEMET C JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI +(JTHETA-1)*NPHI + J &PHI C SF_1=SF_1+TAB(JLIN,2) SR_1=SR_1+TAB(JLIN,1) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN SF2_1=SF2_1+TAB(JLIN2,2) SR2_1=SR2_1+TAB(JLIN2,1) ENDIF IF(IDICHR.GE.1) THEN SF_2=SF_2+TAB(JLIN,4) SR_2=SR_2+TAB(JLIN,3) IF(I_EXT.EQ.-1) THEN JLIN2=NTT+JLIN SF2_2=SF2_2+TAB(JLIN2,4) SR2_2=SR2_2+TAB(JLIN2,3) ENDIF ENDIF ENDDO IF(I_EXT.LE.0) THEN IF(STEREO.EQ.' NO') THEN JPHI2=JPHI ELSE JPHI2=(JTHETA-1)*NPHI+JPHI ENDIF ELSE JPHI2=JTHETA ENDIF IF(IDICHR.EQ.0) THEN WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),SR &_1,SF_1 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE &),SR2_1,SF2_1 ENDIF ELSE WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE),S &R_1,SF_1,SR_2,SF_2 IF(I_EXT.EQ.-1) THEN WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2),ECIN(J &E),SR2_1,SF2_1,SR2_2,SF2_2 ENDIF ENDIF ENDDO ENDDO ENDDO ENDIF ENDIF C GOTO 6 C 5 WRITE(IUO1,4) STOP 35 WRITE(IUO1,36) N_FIXED STOP 37 WRITE(IUO1,38) NTHETA*NPHI STOP C 1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4) 2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN &THE TREAT_PHD SUBROUTINE - INCREASE NDIM_M ','>>>>>>>>>>') 7 FORMAT(I4,2X,I4,2X,I4) 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) 9 FORMAT(9(2X,I1),2X,I2) 15 FORMAT(2X,A3,11X,A13) 22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E1 &2.6,2X,E12.6) 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X &,E12.6) 25 FORMAT(37X,E12.6,2X,E12.6) 36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL ', &'IN THE INCLUDE FILE >>>>>>>>>>',/,4X,'<<<<<<<<<< &SHOULD BE AT LEAST ',I6,' >>>>>>>>>>') 38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ','IN THE I &NCLUDE FILE >>>>>>>>>>',/,8X,'<<<<<<<<<< SHOULD BE AT &LEAST ',I6,' >>>>>>>>>>') 888 FORMAT(A72) C 6 RETURN C END