diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym.mk b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym.mk new file mode 100644 index 0000000..a660a3f --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym.mk @@ -0,0 +1,12 @@ +memalloc_src := memalloc/dim_mod.f memalloc/modules.f memalloc/allocation.f +cluster_gen_src := $(wildcard cluster_gen/*.f) +common_sub_src := $(wildcard common_sub/*.f) +renormalization_src := $(wildcard renormalization/*.f) +#aed_mi_mu_noso_nosp_nosym_src := $(wildcard aed_mi_mu_noso_nosp_nosym/*.f) +aed_mi_mu_noso_nosp_nosym_src := $(filter-out aed_mi_mu_noso_nosp_nosym/lapack_axb.f, $(wildcard aed_mi_mu_noso_nosp_nosym/*.f)) + +SRCS = $(memalloc_src) $(cluster_gen_src) $(common_sub_src) $(renormalization_src) $(aed_mi_mu_noso_nosp_nosym_src) +MAIN_F = aed_mi_mu_noso_nosp_nosym/main.f +SO = _aed_mi_mu_noso_nosp_nosym.so + +include ../../../options.mk diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/aeddif_mi_mu.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/aeddif_mi_mu.f new file mode 100644 index 0000000..c577a53 --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/aeddif_mi_mu.f @@ -0,0 +1,789 @@ +C +C======================================================================= +C + SUBROUTINE AEDDIF_MI_MU(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOK, + 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) +C +C This subroutine computes the AED formula in the spin-independent case +C from a multiplet resolved initial core state L1. The +C intermediate state that gives its energy is L2 while the +C core hole that is filled in the process is noted LC. The +C multiplet is characterized by the integer angular momentum +C variables (L_MUL,S_MUL,J_MUL) +C +C Alternatively, it can compute the AED amplitude for the APECS process. +C +C The calculation is performed using a matrix inversion for the +C expression of the scattering path operator +C +C The matrix inversion is performed using the LAPACK inversion +C routines for a general complex matrix +C +C Last modified : 26 Apr 2013 +C + USE DIM_MOD + + USE ALGORITHM_MOD + USE AMPLI_MOD + USE APPROX_MOD + USE COOR_MOD, NTCLU => NATCLU, NTP => NATYP + USE DEBWAL_MOD + USE DIRECT_A_MOD, DIRANA => DIRANA_A, ANADIR => ANADIR_A, + & RTHETA => RTHEXT_A, RPHI => RPHI_A, + & THETAR => THETAR_A, PHIR => PHIR_A + USE EXTREM_MOD + USE FIXSCAN_A_MOD, N_FIXED => N_FIXED_A, N_SCAN => N_SCAN_A, + & IPH_1 => IPH_1_A, FIX0 => FIX0_A, + & FIX1 => FIX1_A, SCAN0 => SCAN0_A, + & SCAN1 => SCAN1_A + USE INFILES_MOD + USE INUNITS_MOD + USE INIT_J_MOD + USE INIT_L_MOD + USE INIT_M_MOD + USE LIMAMA_MOD + USE MOYEN_A_MOD, IMOY => IMOY_A, NDIR => NDIR_A, + & ACCEPT => ACCEPT_A, ICHKDIR => ICHKDIR_A + USE OUTFILES_MOD + USE OUTUNITS_MOD + USE PARCAL_A_MOD, NPHI => NPHI_A, NE => NE_A, + & NTHETA => NTHETA_A, NFTHET => NFTHET_A + USE RESEAU_MOD + USE SPIN_MOD + USE TESTPB_MOD + USE TESTS_MOD + USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, + & VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A, + & LMAX => LMAX_A + USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A, + & IFTHET => IFTHET_A, IMOD => IMOD_A, + & I_CP => I_CP_A, I_EXT => I_EXT_A, + & I_TEST => I_TEST_A + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A, + & PHI1 => PHI1_A, THETA1 => THETA1_A + USE VALIN_MOD, P0 => PHI0, T0 => THETA0, TM => THLUM, + & PM => PHILUM, EM => ELUM +C + COMPLEX IC,ONEC,ZEROC,PW(0:NDIF_M) + COMPLEX TLT(0:NT_M,4,NATM,NE_M),RHOMI + COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M) + COMPLEX YLMR(0:NL_M,-NL_M:NL_M) + COMPLEX YLME(0:NL_M,-NL_M:NL_M) + COMPLEX R2,M_COUL(0:NL_M,-NL_M:NL_M,2,-LI_M:LI_M,2) + COMPLEX SJDIR_1,SJDIF_1 + COMPLEX RHOK(0:NT_M,NATM,0:40,2,NSPIN2_M),COU + COMPLEX SLJDIF,ATT_M,SLE_1 + COMPLEX SL0DIF,SMJDIF +C + DIMENSION VAL(NATCLU_M),NATYP(NATM) + DIMENSION EMET(3),COORD(3,NATCLU_M) + DIMENSION R(NDIF_M),XR(NDIF_M),YR(NDIF_M),ZR(NDIF_M) + DIMENSION JPOS(NDIF_M,3),JPA(NDIF_M) +C + CHARACTER*7 STAT + CHARACTER*24 INFILE + CHARACTER*24 OUTFILE +C + DATA PIS180 /0.017453/ + DATA EV,SMALL /13.60583,0.0001/ + DATA BOHR /0.529177/ +C + ALGO1=' ' + ALGO2='MI' + ALGO3=' ' + ALGO4=' ' +C + IC=(0.,1.) + ONEC=(1.,0.) + ZEROC=(0.,0.) + NSCAT=NATCLU-1 + ATTSE=1. + ATTSJ=1. + ZSURF=VAL(1) +C + I_DIR=0 + NSET=1 + JEL=2 +C + IF(SPECTRO.EQ.'AED') THEN + IOUT=IUO2 + OUTFILE=OUTFILE2 + STAT='UNKNOWN' + IF(ABS(I_EXT).GE.1) THEN + ISET=IUI6 + INFILE=INFILE6 + ENDIF + ELSEIF(SPECTRO.EQ.'APC') THEN + IOUT=IUSCR2 + OUTFILE='res/auger.amp' + STAT='UNKNOWN' + IF(ABS(I_EXT).GE.1) THEN + ISET=IUI9 + INFILE=INFILE9 + ENDIF + ENDIF +C + LF1=LE_MIN + LF2=LE_MAX + ISTEP_LF=2 +C + IF((ISOM.EQ.0).OR.(JFICH.EQ.1)) THEN + OPEN(UNIT=IOUT, FILE=OUTFILE, STATUS=STAT) + ENDIF +C +C Writing the headers in the output file +C + CALL HEADERS(IOUT) +C + IF((ISOM.EQ.0).OR.((ISOM.GT.0).AND.(JFICH.EQ.1))) THEN + WRITE(IOUT,12) SPECTRO + WRITE(IOUT,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE, + 1 IPH_1,I_EXT + ENDIF +C + IF(ISOM.EQ.0) THEN + WRITE(IOUT,79) NPLAN,NEMET,NTHETA,NPHI,NE + ELSEIF((ISOM.NE.0).AND.(JFICH.EQ.1)) THEN + WRITE(IOUT,11) NTHETA,NPHI,NE + ENDIF + IJK=0 +C +C Loop over the planes +C + DO JPLAN=1,NPLAN + Z=VAL(JPLAN) + IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) THEN + DZZEM=ABS(Z-ZEM) + IF(DZZEM.LT.SMALL) GOTO 10 + GOTO 1 + ENDIF + 10 CONTINUE +C +C Loop over the different absorbers in a given plane +C + DO JEMET=1,NEMET + CALL EMETT(JEMET,IEMET,Z,SYM_AT,NATYP,EMET,NTYPEM, + 1 JNEM,*4) + GO TO 2 + 4 IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,51) JPLAN,NTYPEM + ENDIF + GO TO 3 + 2 IF((ABS(EMET(3)).GT.COUPUR).AND.(IBAS.EQ.1)) GOTO 5 + IF((ISORT1.EQ.0).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) THEN + WRITE(IUO1,52) JPLAN,EMET(1),EMET(2),EMET(3),NTYPEM + ENDIF + ENDIF + IF(ISOM.EQ.1) NP=JPLAN + ZSURFE=VAL(1)-EMET(3) + JTE=IEMET(JEMET) + JATLEM=JNEM +C +C Loop over the energies +C + DO JE=1,NE + FMIN(0)=1. + FMAX(0)=1. + IF(I_TEST.NE.1) THEN +CST VKR=REAL(VK(JE)) + VKR=ABS(VK(JE)) + ELSE + VKR=1. + ENDIF +CST ECIN=VKR*VKR*BOHR*BOHR*EV/(A*A)+VINT + ECIN=E0_A/(A*A)+VINT + IF(I_TEST.NE.1) THEN + CFM=2.*VKR + ELSE + CFM=1. + ENDIF + CALL LPM(ECIN,XLPM,*6) + XLPM1=XLPM/A + GAMMA=1./(2.*XLPM1) + IF(IPOTC.EQ.0) THEN + VK(JE)=VK(JE)+IC*GAMMA + ENDIF + IF(IPRINT.GT.0) WRITE(IUO1,56) A,XLPM1 + IF((IPRINT.GT.0).AND.(IBAS.EQ.1)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,57) COUPUR + ENDIF + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) THEN + IF(IDCM.GE.1) WRITE(IUO1,22) + DO JAT=1,N_PROT + IF(IDCM.EQ.0) THEN + XK2UJ2=VK2(JE)*UJ2(JAT) + ELSE + XK2UJ2=VK2(JE)*UJ_SQ(JAT) + WRITE(IUO1,23) JAT,UJ_SQ(JAT)*A*A + ENDIF + CALL DWSPH_A(JAT,JE,XK2UJ2,TLT,ISPEED) + DO LAT=0,LMAX(JAT,JE) + TL(LAT,1,JAT,JE)=TLT(LAT,1,JAT,JE) + ENDDO + ENDDO + ENDIF + IF(ABS(I_EXT).GE.1) THEN + OPEN(UNIT=ISET, FILE=INFILE, STATUS='OLD') + READ(ISET,13) I_DIR,NSET,N_DUM1 + READ(ISET,14) I_DUM1,N_DUM2,N_DUM3 + ENDIF +C +C Initialization of TAU(INDJ,LINFMAX,JTYP) +C + JATL=0 + DO JTYP=1,N_PROT + NBTYP=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYP + JATL=JATL+1 + DO LE=LE_MIN,LE_MAX,2 + ILE=LE*LE+LE+1 + DO ME=-LE,LE + INDE=ILE+ME + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + TAU(INDJ,INDE,JATL)=ZEROC + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +C +C Storage of the coupling matrix elements M_COUL +C + DO MC=-LI,LI + DO ISC=1,2 + SC=FLOAT(ISC)-1.5 + DO LA=LE_MIN,LE_MAX,2 + DO MA=-LA,LA + DO ISA=1,2 + SA=FLOAT(ISA)-1.5 + CALL COUMAT_AM(LA,MA,SA,MC,SC,JTE,RHOK,COU) + M_COUL(LA,MA,ISA,MC,ISC)=COU + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +C +C Matrix inversion for the calculation of TAU +C + IF(I_TEST.EQ.2) GOTO 666 + CALL INV_MAT_MS_A(JE,TAU) + 666 CONTINUE +C +C Calculation of the Auger Electron Diffraction formula +C +C +C Loop over the 'fixed' angle +C + 15 DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + IF(I_EXT.EQ.0) THEN + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + XINCRF=FLOAT(J_FIXED-1)*FIX_STEP + ELSE + XINCRF=0. + ENDIF + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(ABS(I_EXT).GE.1) THEN + READ(ISET,86) JSET,JLINE,THD,PHD + IF(I_EXT.EQ.-1) BACKSPACE ISET + ENDIF + IF(IPH_1.EQ.1) THEN + IF(I_EXT.EQ.0) THEN + DPHI=PHI0+XINCRF + ELSE + DPHI=PHD + ENDIF + RPHI=DPHI*PIS180 + IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI + ELSE + ISAUT=0 + IF(I_EXT.EQ.0) THEN + DTHETA=THETA0+XINCRF + ELSE + DTHETA=THD + ENDIF + RTHETA=DTHETA*PIS180 + IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 + IF(I_EXT.GE.1) ISAUT=0 + IF(I_TEST.EQ.2) ISAUT=0 + IF(ISAUT.GT.0) GOTO 8 + IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA + IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) + IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) +C +C THETA-dependent number of PHI points for stereographic +C representation (to obtain a uniform sampling density). +C (Courtesy of J. Osterwalder - University of Zurich) +C + IF(STEREO.EQ.'YES') THEN + N_SCAN=INT((SCAN1-SCAN0)*SIN(RTHETA)/FIX_STEP+SMALL)+1 + ENDIF +C + ENDIF +C +C Loop over the scanned angle +C + DO J_SCAN=1,N_SCAN + IF(N_SCAN.GT.1) THEN + XINCRS=FLOAT(J_SCAN-1)*(SCAN1-SCAN0)/FLOAT(N_SCAN-1) + ELSEIF(N_SCAN.EQ.1) THEN + XINCRS=0. + ENDIF + IF(I_EXT.EQ.-1) THEN + READ(ISET,86) JSET,JLINE,THD,PHD + BACKSPACE ISET + ENDIF + IF(IPH_1.EQ.1) THEN + ISAUT=0 + IF(I_EXT.EQ.0) THEN + DTHETA=THETA0+XINCRS + ELSE + DTHETA=THD + ENDIF + RTHETA=DTHETA*PIS180 + IF(ABS(DTHETA).GT.90.) ISAUT=ISAUT+1 + IF(I_EXT.GE.1) ISAUT=0 + IF(I_TEST.EQ.2) ISAUT=0 + IF(ISAUT.GT.0) GOTO 8 + IF(IPRINT.GT.0) WRITE(IUO1,65) DTHETA + IF((IPRINT.GT.0).AND.(I_TEST.NE.2)) WRITE(IUO1,59) + IF((IPRINT.EQ.1).AND.(I_TEST.NE.2)) WRITE(IUO1,60) + ELSE + IF(I_EXT.EQ.0) THEN + DPHI=PHI0+XINCRS + ELSE + DPHI=PHD + ENDIF + RPHI=DPHI*PIS180 + IF(IPRINT.GT.0) WRITE(IUO1,66) DPHI + ENDIF +C +C Loop over the sets of directions to average over (for gaussian average) +C +C + SSETDIR_1=0. + SSETDIF_1=0. +C + IF(I_EXT.EQ.-1) THEN + JREF=INT(NSET)/2+1 + ELSE + JREF=1 + ENDIF +C + DO J_SET=1,NSET + IF(I_EXT.EQ.-1) THEN + READ(ISET,86) JSET,JLINE,THD,PHD,W + DTHETA=THD + DPHI=PHD + RTHETA=DTHETA*PIS180 + RPHI=DPHI*PIS180 + ELSE + W=1. + ENDIF +C + IF(I_EXT.EQ.-1) PRINT 89 +C + CALL DIRAN(VINT,ECIN,JEL) + IF(J_SET.EQ.JREF) THEN + DTHETAP=DTHETA + DPHIP=DPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + WRITE(IUO1,88) DTHETA,DPHI + ENDIF +C + WRITE(IUO1,61) (DIRANA(J,1),J=1,3) +C + SRDIF_1=0. + SRDIR_1=0. +C +C Loop over the different directions of the analyzer contained in a cone +C + DO JDIR=1,NDIR + IF(IATTS.EQ.1) THEN + ATTSE=EXP(-ZSURFE*GAMMA/DIRANA(3,JDIR)) + ENDIF +C + SSCDIR_1=0. + SSCDIF_1=0. +C +C Loop over the equiprobable quantum numbers MC,SC and SA +C corresponding respectively to the core hole (MC and spin SC) +C and to the outgoing Auger electron (SA). The sum over the +C equiprobable azimuthal quantum number MJ of the multiplet +C configuration is suppressed here as, because of the selection +C rules, one has MJ = MA + MC + SA + SC +C + LME=LMAX(1,JE) + CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLME,LME) +C + DO ISC=1,2 + SC=FLOAT(ISC)-1.5 +C + SMCDIR_1=0. + SMCDIF_1=0. +C + DO MC=-LI,LI +C + SSADIR_1=0. + SSADIF_1=0. +C + DO ISA=1,2 + SA=FLOAT(ISA)-1.5 +C + SMJMDIR_1=0. + SMJMDIF_1=0. +C + DO MJM=-J_MUL,J_MUL +C + SJDIR_1=ZEROC + SJDIF_1=ZEROC +C +C Calculation of the direct emission (used a a reference for the output) +C + DO L_E=LE_MIN,LE_MAX,2 + ILE=L_E*L_E+L_E+1 + IF(ISPEED.EQ.1) THEN + R2=TL(L_E,1,1,JE) + ELSE + R2=TLT(L_E,1,1,JE) + ENDIF + M_E=MJM-MC-ISA-ISC+3 + IF(ABS(M_E).GT.L_E) GOTO 444 + INDE=ILE+M_E + SJDIR_1=SJDIR_1+YLME(L_E,M_E)*ATTSE* + 1 M_COUL(L_E,M_E,ISA,MC,ISC)*R2 +C +C Contribution of the absorber to TAU (initialization of SJDIF) +C + IF(I_TEST.EQ.2) GOTO 444 + SL0DIF=ZEROC + DO L0=0,LME + IL0=L0*L0+L0+1 + SL0DIF=SL0DIF+YLME(L0,0)*TAU(IL0,INDE,1) + DO M0=1,L0 + IND01=IL0+M0 + IND02=IL0-M0 + SL0DIF=SL0DIF+(YLME(L0,M0)* + 1 TAU(IND01,INDE,1)+ + 2 YLME(L0,-M0)* + 3 TAU(IND02,INDE,1)) + ENDDO + ENDDO + + SJDIF_1=SJDIF_1+SL0DIF*M_COUL(L_E,M_E,ISA,MC,ISC) + 444 CONTINUE + ENDDO + SJDIF_1=SJDIF_1*ATTSE +C +C Loop over the last atom J encountered by the photoelectron +C before escaping the solid +C + IF(I_TEST.EQ.2) GOTO 111 + DO JTYP=2,N_PROT + NBTYP=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYP + JATL=NCORR(JNUM,JTYP) + XOJ=SYM_AT(1,JATL)-EMET(1) + YOJ=SYM_AT(2,JATL)-EMET(2) + ZOJ=SYM_AT(3,JATL)-EMET(3) + ROJ=SQRT(XOJ*XOJ+YOJ*YOJ+ZOJ*ZOJ) + ZSURFJ=VAL(1)-SYM_AT(3,JATL) + CALL HARSPH(NL_M,THETAR(JDIR),PHIR(JDIR),YLMR, + 1 LMJ) + IF(IATTS.EQ.1) THEN + ATTSJ=EXP(-ZSURFJ*GAMMA/DIRANA(3,JDIR)) + ENDIF + CSTHJR=(XOJ*DIRANA(1,JDIR)+YOJ*DIRANA(2,JDIR)+ + 1 ZOJ*DIRANA(3,JDIR))/ROJ + IF((IDWSPH.EQ.1).AND.(ISPEED.EQ.1)) GOTO 78 + CTROIS1=ZOJ/ROJ + IF(CTROIS1.GT.1.) THEN + CTROIS1=1. + ELSEIF(CTROIS1.LT.-1.) THEN + CTROIS1=-1. + ENDIF + IF(IDCM.GE.1) THEN + UJ2(JTYP)=UJ_SQ(JTYP) + ENDIF + IF(ABS(ZSURFJ).LE.SMALL) THEN + IF(ABS(CSTHJR-1.).GT.SMALL) THEN + CSKZ2J=(DIRANA(3,JDIR)-CTROIS1)* + 1 (DIRANA(3,JDIR)-CTROIS1)/(2. + 2 -2.*CSTHJR) + ELSE + CSKZ2J=1. + ENDIF + UJJ=UJ2(JTYP)*(1.+CSKZ2J*(RSJ-1.)) + ELSE + UJJ=UJ2(JTYP) + ENDIF + IF((ISPEED.EQ.0).AND.(IDWSPH.EQ.1)) THEN + XK2UJ2=VK2(JE)*UJJ + CALL DWSPH_A(JTYP,JE,XK2UJ2,TLT,ISPEED) + ENDIF + 78 IF(IDWSPH.EQ.1) THEN + DWTER=1. + ELSE + DWTER=EXP(-VK2(JE)*UJJ*(1.-CSTHJR)) + ENDIF + IF(JATL.EQ.JATLEM) THEN + ATT_M=ATTSE*DWTER + ELSE + ATT_M=ATTSJ*DWTER*CEXP(-IC*VK(JE)*ROJ*CSTHJR) + ENDIF +C + SLE_1=ZEROC + DO L_E=LE_MIN,LE_MAX,2 + ILE=L_E*L_E+L_E+1 + M_E=MJM-MC-ISA-ISC+3 + IF(ABS(M_E).GT.L_E) GOTO 555 + INDE=ILE+M_E + SLJDIF=ZEROC + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + SMJDIF=YLMR(LJ,0)*TAU(ILJ,INDE,JATL) + IF(LJ.GT.0) THEN + DO MJ=1,LJ + INDJ1=ILJ+MJ + INDJ2=ILJ-MJ + SMJDIF=SMJDIF+(YLMR(LJ,MJ)* + 1 TAU(INDJ1,INDE,JATL)+ + 2 YLMR(LJ,-MJ)* + 3 TAU(INDJ2,INDE,JATL)) + ENDDO + ENDIF + SLJDIF=SLJDIF+SMJDIF + ENDDO + SLE_1=SLE_1+SLJDIF*M_COUL(L_E,M_E,ISA,MC,ISC) + 555 CONTINUE + ENDDO + SJDIF_1=SJDIF_1+SLE_1*ATT_M +C +C End of the loops over the last atom J +C + ENDDO + ENDDO +C +C Writing the amplitudes in file IOUT for APECS +C + 111 IF(SPECTRO.EQ.'APC') THEN + IF(I_TEST.EQ.2) SJDIF_1=SJDIR_1 + WRITE(IOUT,87) JFICH,JPLAN,JEMET,JE,J_FIXED,J_SCAN, + 1 JDIR,ISC,MC,ISA,MJM,SJDIR_1,SJDIF_1 + ELSE +C +C Computing the square modulus +C + SSADIF_1=SSADIF_1+CABS(SJDIF_1)*CABS(SJDIF_1) + SSADIR_1=SSADIR_1+CABS(SJDIR_1)*CABS(SJDIR_1) +C + ENDIF +C +C End of the loop over MJM +C + ENDDO +C + SMJMDIF_1=SMJMDIF_1+SSADIF_1 + SMJMDIR_1=SMJMDIR_1+SSADIR_1 +C +C End of the loop over SA +C + ENDDO +C + SMCDIF_1=SMCDIF_1+SMJMDIF_1 + SMCDIR_1=SMCDIR_1+SMJMDIR_1 +C +C End of the loop over MC +C + ENDDO +C + SSCDIF_1=SSCDIF_1+SMCDIF_1 + SSCDIR_1=SSCDIR_1+SMCDIR_1 +C +C End of the loop over SC +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 220 + SRDIR_1=SRDIR_1+SSCDIR_1*VKR*CFM/NDIR + SRDIF_1=SRDIF_1+SSCDIF_1*VKR*CFM/NDIR + 220 CONTINUE +C +C End of the loop on the directions of the analyzer +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 221 + SSETDIR_1=SSETDIR_1+SRDIR_1*W + SSETDIF_1=SSETDIF_1+SRDIF_1*W + IF(ICHKDIR.EQ.2) THEN + IF(JSET.EQ.JREF) THEN + SSET2DIR_1=SRDIR_1 + SSET2DIF_1=SRDIF_1 + ENDIF + ENDIF + 221 CONTINUE +C +C End of the loop on the set averaging +C + ENDDO +C + IF(SPECTRO.EQ.'APC') GOTO 222 + IF(ISOM.EQ.2) THEN + WRITE(IOUT,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + 1 SSETDIR_1,SSETDIF_1 + IF(ICHKDIR.EQ.2) THEN + WRITE(IUO2,67) JPLAN,JFICH,DTHETAP,DPHIP,ECIN, + 1 SSET2DIR_1,SSET2DIF_1 + ENDIF + ELSE + WRITE(IOUT,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + 1 SSETDIR_1,SSETDIF_1 + IF(ICHKDIR.EQ.2) THEN + WRITE(IUO2,67) JPLAN,JEMET,DTHETAP,DPHIP,ECIN, + 1 SSET2DIR_1,SSET2DIF_1 + ENDIF + ENDIF + 222 CONTINUE +C +C End of the loop on the scanned angle +C + ENDDO +C + 8 CONTINUE +C +C End of the loop on the fixed angle +C + ENDDO +C +C End of the loop on the energy +C + CLOSE(ISET) + ENDDO +C + 3 CONTINUE +C +C End of the loop on the emitters +C + ENDDO +C + GO TO 1 + 5 IPLAN=JPLAN-1 + IJK=IJK+1 + IF((IJK.EQ.1).AND.(IPRINT.GT.0)) THEN + IF(I_TEST.NE.2) WRITE(IUO1,54) IPLAN + ENDIF + 1 CONTINUE +C +C End of the loop on the planes +C + ENDDO +C + IF(ABS(I_EXT).GE.1) CLOSE(ISET) + IF((ISOM.EQ.0).OR.(JFICH.EQ.NFICHLEC)) WRITE(IOUT,*) + IF(SPECTRO.EQ.'APC') CLOSE(IOUT) + IF(SPECTRO.EQ.'APC') GOTO 7 +c IF(((NEMET.GT.1).OR.(NPLAN.GT.1)).AND.(ISOM.EQ.0)) THEN + IF(((NEMET.GT.1).OR.(NPLAN.GT.0)).AND.(ISOM.EQ.0)) THEN + NP=0 + CALL TREAT_AED(ISOM,NFICHLEC,JFICH,NP) + ENDIF + IF(I_EXT.EQ.2) THEN + CALL WEIGHT_SUM(ISOM,I_EXT,0,1) + ENDIF + GOTO 7 + 6 WRITE(IUO1,55) +C + 9 FORMAT(9(2X,I1),2X,I2) + 11 FORMAT(I4,2X,I4,2X,I4) + 12 FORMAT(2X,A3) + 13 FORMAT(6X,I1,1X,I3,2X,I4) + 14 FORMAT(6X,I1,1X,I3,3X,I3) + 22 FORMAT(16X,'INTERNAL CALCULATION OF MEAN SQUARE DISPLACEMENTS',/, + 1 25X,' BY DEBYE UNCORRELATED MODEL:',/) + 23 FORMAT(21X,'ATOM TYPE ',I5,' MSD = ',F8.6,' ANG**2') + 51 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' DOES NOT CONTAIN ', + *'ANY ABSORBER OF TYPE ',I2,' *******') + 52 FORMAT(/////,2X,'******* PLANE NUMBER ',I3,' POSITION OF ', + 1'THE ABSORBER : (',F6.3,',',F6.3,',',F6.3,') *******',/,2X, + 2'******* ',19X,'THIS ABSORBER IS OF TYPE ',I2,20X,' *******') + 53 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',F15.1, + 1 /,10X,' EFFECTIVE NUMBER OF PATHS : ',F15.1, + 2 /,10X,' MINIMAL INTENSITY : ',E12.6, + 3 2X,'No OF THE PATH : ',F15.1, + 4 /,10X,' MAXIMAL INTENSITY : ',E12.6, + 5 2X,'No OF THE PATH : ',F15.1) + 54 FORMAT(//,7X,'DUE TO THE SIZE OF THE CLUSTER, THE SUMMATION', + *' HAS BEEN TRUNCATED TO THE ',I2,' TH PLANE') + 55 FORMAT(///,12X,' <<<<<<<<<< THIS VALUE OF ILPM IS NOT', + *'AVAILABLE >>>>>>>>>>') + 56 FORMAT(4X,'LATTICE PARAMETER A = ',F6.3,' ANGSTROEMS',4X, + *'MEAN FREE PATH = ',F6.3,' * A',//) + 57 FORMAT(25X,'CLUSTER RADIUS = ',F6.3,' *A') + 58 FORMAT(//,2X,'ORDER ',I2,' TOTAL NUMBER OF PATHS : ',I10, + 1 /,10X,' EFFECTIVE NUMBER OF PATHS : ',I10, + 2 /,10X,' MINIMAL INTENSITY : ',E12.6, + 3 2X,'No OF THE PATH : ',I10, + 4 /,10X,' MAXIMAL INTENSITY : ',E12.6, + 5 2X,'No OF THE PATH : ',I10) + 59 FORMAT(//,15X,'THE SCATTERING DIRECTION IS GIVEN INSIDE ', + *'THE CRYSTAL') + 60 FORMAT(7X,'THE POSITIONS OF THE ATOMS ARE GIVEN WITH RESPECT ', + *'TO THE ABSORBER') + 61 FORMAT(///,4X,'.......... DIRECTION OF THE DETECTOR : (', + 1 F6.3,',',F6.3,',',F6.3,') ..........') + 65 FORMAT(////,3X,'++++++++++++++++++',9X, + *'THETA = ',F6.2,' DEGREES',9X,'++++++++', + *'++++++++++',///) + 66 FORMAT(////,3X,'++++++++++++++++++',9X, + *'PHI = ',F6.2,' DEGREES',9X,'++++++++++', + *'++++++++++',///) + 67 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6, + 1 2X,E12.6) + 68 FORMAT(10X,' CUT-OFF INTENSITY : ',E12.6) + 69 FORMAT(9X,I2,2X,E12.6,7X,E12.6,1X,F6.3,1X,10(I3,2X)) + 70 FORMAT(2X,I2,2X,I10,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X)) + 71 FORMAT(//,1X,'JDIF',4X,'No OF THE PATH',2X, + 1 'INTENSITY',3X,'LENGTH',4X,'ABSORBER',2X, + 2 'ORDER OF THE SCATTERERS',/) + 74 FORMAT(10X,'<===== NUMBER OF PATHS TOO LARGE FOR PRINTING ', + 1 '=====>') + 76 FORMAT(2X,I2,2X,E12.6,7X,E12.6,2X,F6.3,7X,I2,7X,10(I3,2X)) + 77 FORMAT(' ') + 79 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4) + 80 FORMAT(///) + 81 FORMAT(//,1X,'RANK',1X,'ORDER',4X,'No PATH',3X, + 1 'INTENSITY',3X,'LENGTH',4X,'ABS',3X, + 2 'ORDER OF THE SCATTERERS',/) + 82 FORMAT(I3,4X,I2,1X,E12.6,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X)) + 83 FORMAT(I3,4X,I2,1X,I10,3X,E12.6,2X,F6.3,4X,I2,4X,10(I3,1X)) + 84 FORMAT(/////,18X,'THE ',I3,' MORE INTENSE PATHS BY DECREASING', + 1 ' ORDER :',/,24X,'(THE LENGTH IS GIVEN IN UNITS ', + 2 'OF A)') + 85 FORMAT(/////,25X,' PATHS USED IN THE CALCULATION : ', + 1 /,24X,'(THE LENGTH IS GIVEN IN UNITS OF A)') + 86 FORMAT(2X,I3,1X,I4,5X,F8.3,3X,F8.3,3X,E12.6) + 87 FORMAT(2X,I2,2X,I3,2X,I2,2X,I3,2X,I3,2X,I3,2X,I2,2X,I2,2X,I2, + 1 2X,I2,2X,I2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6) + 88 FORMAT(/,19X,'TILTED THETA =',F6.2,5X,'TILTED PHI =', + 1 F6.2) + 89 FORMAT(/,4X,'..........................................', + 1 '.....................................') +C + 7 RETURN +C + END diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/axb_mat_ms_la_a.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/axb_mat_ms_la_a.f new file mode 100644 index 0000000..369d08c --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/axb_mat_ms_la_a.f @@ -0,0 +1,198 @@ +C +C======================================================================= +C + SUBROUTINE INV_MAT_MS_A(JE,TAU) +C +C This subroutine stores the multiple scattering matrix and computes +C the scattering path operator TAU^{j 0} exactly, without explicitely +C using the inverse matrix. +C +C (Auger electron case) +C +C Last modified : 31 Jul 2007 +C + USE DIM_MOD +C + USE COOR_MOD + USE INIT_L_MOD + USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, VK2 => + & VK2_A, IPOTC => IPOTC_A, ITL => ITL_A, + & LMAX => LMAX_A +C +C PARAMETER(NLTWO=2*NL_M) +C + COMPLEX*16 HL1(0:2*NL_M),SM(LINMAXA*NATCLU_M,LINMAXA*NATCLU_M) + COMPLEX*16 IN(LINMAXA*NATCLU_M,LINMAXA) + COMPLEX*16 SUM_L,ONEC,IC,ZEROC + COMPLEX*16 YLM(0:2*NL_M,-2*NL_M:2*NL_M),TLJ,TLK,EXPKJ +C + COMPLEX TAU(LINMAXA,LINFMAX,NATCLU_M) +C + REAL*8 PI,ATTKJ,GNT(0:N_GAUNT),XKJ,YKJ,ZKJ,RKJ,ZDKJ,KRKJ +C + INTEGER IPIV(LINMAXA*NATCLU_M) +C + CHARACTER*1 CH +C + DATA PI /3.1415926535898D0/ +C + ONEC=(1.D0,0.D0) + IC=(0.D0,1.D0) + ZEROC=(0.D0,0.D0) + IBESS=3 + CH='N' +C +C Construction of the multiple scattering matrix MS = (I-GoT). +C Elements are stored using a linear index LINJ representing +C (J,LJ) +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) + XJ=SYM_AT(1,JATL) + YJ=SYM_AT(2,JATL) + ZJ=SYM_AT(3,JATL) +C + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + TLJ=DCMPLX(TL(LJ,1,JTYP,JE)) + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + JLIN=JLIN+1 +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) + IF(KATL.NE.JATL) THEN + XKJ=DBLE(SYM_AT(1,KATL)-XJ) + YKJ=DBLE(SYM_AT(2,KATL)-YJ) + ZKJ=DBLE(SYM_AT(3,KATL)-ZJ) + RKJ=DSQRT(XKJ*XKJ+YKJ*YKJ+ZKJ*ZKJ) + KRKJ=DBLE(VK(JE))*RKJ + ATTKJ=DEXP(-DIMAG(DCMPLX(VK(JE)))*RKJ) + EXPKJ=(XKJ+IC*YKJ)/RKJ + ZDKJ=ZKJ/RKJ + CALL SPH_HAR2(2*NL_M,ZDKJ,EXPKJ,YLM,LMJ+LMK) + CALL BESPHE2(LMJ+LMK+1,IBESS,KRKJ,HL1) + ENDIF +C + DO LK=0,LMK + ILK=LK*LK+LK+1 + L_MIN=ABS(LK-LJ) + L_MAX=LK+LJ + TLK=DCMPLX(TL(LK,1,KTYP,JE)) + DO MK=-LK,LK + INDK=ILK+MK + KLIN=KLIN+1 + SM(KLIN,JLIN)=ZEROC + SUM_L=ZEROC + IF(KATL.NE.JATL) THEN + CALL GAUNT2(LK,MK,LJ,MJ,GNT) +C + DO L=L_MIN,L_MAX,2 + M=MJ-MK + IF(ABS(M).LE.L) THEN + SUM_L=SUM_L+(IC**L)*HL1(L)* + 1 YLM(L,M)*GNT(L) + ENDIF + ENDDO + SUM_L=SUM_L*ATTKJ*4.D0*PI*IC + ELSE + SUM_L=ZEROC + ENDIF +C + IF(KLIN.EQ.JLIN) THEN + SM(KLIN,JLIN)=ONEC-TLK*SUM_L + IF(JTYP.EQ.1) THEN + IN(KLIN,JLIN)=ONEC + ENDIF + ELSE + SM(KLIN,JLIN)=-TLK*SUM_L + IF(JTYP.EQ.1) THEN + IN(KLIN,JLIN)=ZEROC + ENDIF + ENDIF +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + LW2=(LMAX(1,JE)+1)*(LMAX(1,JE)+1) +C +C Partial inversion of the multiple scattering matrix MS and +C multiplication by T : the LAPACK subroutine performing +C +C A * x = b +C +C is used where b is the block column corresponding to +C the absorber 0 in the identity matrix. x is then TAU^{j 0}. +C + CALL ZGETRF(JLIN,JLIN,SM,LINMAXA*NATCLU_M,IPIV,INFO1) + IF(INFO1.NE.0) THEN + WRITE(6,*) ' ---> INFO1 =',INFO1 + ELSE + CALL ZGETRS(CH,JLIN,LW2,SM,LINMAXA*NATCLU_M,IPIV, + 1 IN,LINMAXA*NATCLU_M,INFO) + ENDIF +C +C Storage of the Tau matrix +C + JLIN=0 + DO JTYP=1,N_PROT + NBTYPJ=NATYP(JTYP) + LMJ=LMAX(JTYP,JE) + DO JNUM=1,NBTYPJ + JATL=NCORR(JNUM,JTYP) +C + DO LJ=0,LMJ + ILJ=LJ*LJ+LJ+1 + TLJ=DCMPLX(TL(LJ,1,JTYP,JE)) + DO MJ=-LJ,LJ + INDJ=ILJ+MJ + JLIN=JLIN+1 +C + KLIN=0 + DO KTYP=1,N_PROT + NBTYPK=NATYP(KTYP) + LMK=LMAX(KTYP,JE) + DO KNUM=1,NBTYPK + KATL=NCORR(KNUM,KTYP) +C + DO LK=0,LMK + ILK=LK*LK+LK+1 + DO MK=-LK,LK + INDK=ILK+MK + KLIN=KLIN+1 + IF((JATL.EQ.1).AND.(LJ.LE.LF2)) THEN + TAU(INDK,INDJ,KATL)=CMPLX(IN(KLIN,JLIN)*TLJ) + ENDIF + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + ENDDO + ENDDO +C + RETURN +C + END + diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/coumat_am.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/coumat_am.f new file mode 100644 index 0000000..59d0cb9 --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/coumat_am.f @@ -0,0 +1,140 @@ +C +C======================================================================= +C + SUBROUTINE COUMAT_AM(LA,MA,SA,MC,SC,JE,RHOK_A,MATRIX_AM) +C +C This routine calculates the multiplet-resolved spin-independent +C Coulomb matrix elements occuring in the Auger process. They +C are stored in MATRIX_AM. The multiplet component is characterized +C by the quantum numbers (L,S,J) which are read from the input +C data file. +C +C Here, the conventions are (direct process D): +C +C (LC,MC) : core hole filled by intermediate electron +C (L1,M1) : Auger electron before excitation +C (L2,M2) : intermediate electron that fills the core hole +C (LA,MA) : Auger electron after excitation +C +C In the exchange process E, the roles of (L1,M1) and (L2,M2) +C are interchanged. +C +C Note that the Clebsch-Gordan corresponding to the spin-orbit +C resolved core state is not included in the formula here. This +C is because in APECS, it appears also in the dipole matrix +C element and it is therefore useless to calculate it twice. +C Therefore, it must be implemented into the cross-section +C subroutine. +C +C The factor i**LA comes from the particular normalization used +C in the phagen code +C +C Last modified : 8 Dec 2008 +C + USE DIM_MOD +C + USE C_G_M_MOD + USE INIT_A_MOD, LC => LI_C, L2 => LI_I, L1 => LI_A + USE TYPCAL_A_MOD, I1 => IPHI_A, I2 => IE_A, I3 => ITHETA_A, + 1 I4 => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A, + 2 I7 => I_EXT_A, I_TEST => I_TEST_A + USE INIT_M_MOD +C + COMPLEX RHOK_A(0:NT_M,NATM,0:40,2,NSPIN2_M) + COMPLEX ZEROC,ONEC,MATRIX_AM + COMPLEX SUM_LB,SUM_M1,IC,IL +C + REAL*4 CG1(0:N_GAUNT),CG2(0:N_GAUNT) + REAL*4 GNT1(0:N_GAUNT),GNT2(0:N_GAUNT),GNT3(0:N_GAUNT) + REAL*4 GNT4(0:N_GAUNT) +C + REAL*8 ZEROD +C + DATA PI4,ONEOSQ2,HALF /12.566371,0.707107,0.5/ +C + ZEROC=(0.,0.) + ONEC=(1.,0.) + IC=(0.,1.) + ZEROD=0.D0 +C + IF(I_TEST.EQ.1) GOTO 2 +C + IF(MOD(LA,4).EQ.0) THEN + IL=ONEC + ELSEIF(MOD(LA,4).EQ.1) THEN + IL=IC + ELSEIF(MOD(LA,4).EQ.2) THEN + IL=-ONEC + ELSEIF(MOD(LA,4).EQ.3) THEN + IL=-IC + ENDIF +C + IF(I_SHELL.EQ.0) THEN + COEF1=ONEOSQ2*PI4 + ELSEIF(I_SHELL.EQ.1) THEN + COEF1=HALF*PI4 + ENDIF +C + IF(MOD(S_MUL,2).EQ.0) THEN + SIGN1=1. + ELSE + SIGN1=-1. + ENDIF +C +C Values of MJ, ML and MS given by the Clebsch-Gordan +C + ML=MA+MC + MS=INT(SA+SC+0.0001) + MJ=ML+MS +C +C Storage indices for the spin Clebsch-Gordan : +C +C ISA(C) = 1 for -1/2 and 2 for 1/2 +C IS = 1 for S_MUL=0 and 2 for S_MUL=1 +C + IS=S_MUL+1 + ISA=INT(SA+1.5001) + ISC=INT(SC+1.5001) +C +C Bounds of the sum over LB +C + LB_MAX_D=MIN(L1+LA,L2+LC) + LB_MIN_D=MAX(ABS(L1-LA),ABS(L2-LC)) + LB_MAX_E=MIN(L2+LA,L1+LC) + LB_MIN_E=MAX(ABS(L2-LA),ABS(L1-LC)) + LB_MIN=MIN(LB_MIN_D,LB_MIN_E) + LB_MAX=MAX(LB_MAX_D,LB_MAX_E) +C + N_CG=2 + CALL N_J(DFLOAT(L_MUL),DFLOAT(ML),DFLOAT(S_MUL),DFLOAT(MS), + 1 ZEROD,CG1,I_INT1,N_CG) +C + SUM_M1=ZEROC + DO M1=-L1,L1 + M2=ML-M1 +C + CALL N_J(DFLOAT(L1),DFLOAT(M1),DFLOAT(L2),DFLOAT(ML-M1), + 1 ZEROD,CG2,I_INT2,N_CG) + CALL GAUNT(L1,M1,LA,MA,GNT1) + CALL GAUNT(LC,MC,L2,M2,GNT2) + CALL GAUNT(L2,M2,LA,MA,GNT3) + CALL GAUNT(LC,MC,L1,M1,GNT4) +C + SUM_LB=ZEROC + DO LB=LB_MIN,LB_MAX + SUM_LB=SUM_LB+(RHOK_A(LA,JE,LB,1,1)*GNT1(LB)*GNT2(LB)+ + 1 RHOK_A(LA,JE,LB,2,1)*GNT3(LB)*GNT4(LB)* + 2 SIGN1)/FLOAT(LB+LB+1) + ENDDO + SUM_M1=SUM_M1+SUM_LB*CG2(L_MUL) + ENDDO +C + MATRIX_AM=SUM_M1*CG1(J_MUL)*CG_S(ISA,ISC,IS)*COEF1*IL +C + GOTO 1 +C + 2 MATRIX_AM=ONEC +C + 1 RETURN +C + END diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/dwsph_a.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/dwsph_a.f new file mode 100644 index 0000000..eaa8118 --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/dwsph_a.f @@ -0,0 +1,88 @@ +C +C======================================================================= +C + SUBROUTINE DWSPH_A(JTYP,JE,X,TLT,ISPEED) +C +C This routine recomputes the T-matrix elements taking into account the +C mean square displacements. +C +C When the argument X is tiny, no vibrations are taken into account +C +C Last modified : 25 Apr 2013 +C + USE DIM_MOD +C + USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, VK2 => + & VK2_A, IPOTC => IPOTC_A, ITL => ITL_A, + & LMAX => LMAX_A +C + DIMENSION GNT(0:N_GAUNT) +C + COMPLEX TLT(0:NT_M,4,NATM,NE_M),SL1,ZEROC +C + COMPLEX*16 FFL(0:2*NL_M) +C + DATA PI4,EPS /12.566371,1.0E-10/ +C + ZEROC=(0.,0.) +C + IF(X.GT.EPS) THEN +C +C Standard case: vibrations +C + IF(ISPEED.LT.0) THEN + NSUM_LB=ABS(ISPEED) + ENDIF +C + COEF=PI4*EXP(-X) + NL2=2*LMAX(JTYP,JE)+2 + IBESP=5 + MG1=0 + MG2=0 +C + CALL BESPHE(NL2,IBESP,X,FFL) +C + DO L=0,LMAX(JTYP,JE) + XL=FLOAT(L+L+1) + SL1=ZEROC +C + DO L1=0,LMAX(JTYP,JE) + XL1=FLOAT(L1+L1+1) + CALL GAUNT(L,MG1,L1,MG2,GNT) + L2MIN=ABS(L1-L) + IF(ISPEED.GE.0) THEN + L2MAX=L1+L + ELSEIF(ISPEED.LT.0) THEN + L2MAX=L2MIN+2*(NSUM_LB-1) + ENDIF + SL2=0. +C + DO L2=L2MIN,L2MAX,2 + XL2=FLOAT(L2+L2+1) + C=SQRT(XL1*XL2/(PI4*XL)) + SL2=SL2+C*GNT(L2)*REAL(DREAL(FFL(L2))) + ENDDO +C + SL1=SL1+SL2*TL(L1,1,JTYP,JE) + ENDDO +C + TLT(L,1,JTYP,JE)=COEF*SL1 +C + ENDDO +C + ELSE +C +C Argument X tiny: no vibrations +C + DO L=0,LMAX(JTYP,JE) +C + TLT(L,1,JTYP,JE)=TL(L,1,JTYP,JE) +C + ENDDO +C + ENDIF +C + RETURN +C + END + diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif1_a.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif1_a.f new file mode 100644 index 0000000..174cdce --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif1_a.f @@ -0,0 +1,115 @@ +C +C======================================================================= +C + SUBROUTINE FACDIF1_A(VKE,RJ,RJK,THRJ,PHIRJ,BETA,GAMMA,L,M, + 1 FSPH,JAT,JE,*) +C +C This routine computes a spherical wave scattering factor +C +C Last modified : 03/04/2006 +C + USE DIM_MOD +C + USE APPROX_MOD + USE EXPFAC_MOD + USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, + & VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A, + & LMAX => LMAX_A + USE TYPCAL_A_MOD, I2 => IPHI_A, I3 => IE_A, I4 => ITHETA_A, + & IFTHET => IFTHET_A, I5 => IMOD_A, I6 => I_CP_A, + & I7 => I_EXT_A, I8 => I_TEST_A +C + DIMENSION PLMM(0:100,0:100) + DIMENSION D(1-NL_M:NL_M-1,1-NL_M:NL_M-1,0:NL_M-1) +C + COMPLEX HLM(0:NO_ST_M,0:NL_M-1),HLN(0:NO_ST_M,0:NL_M-1),FSPH,RHOJ + COMPLEX HLM1,HLM2,HLM3,HLM4,ALMU,BLMU,SLP,SNU,SMU,VKE + COMPLEX RHOJK +C + DATA PI/3.141593/ +C + A=1. + INTER=0 + IF(ITL.EQ.1) VKE=VK(JE) + RHOJ=VKE*RJ + RHOJK=VKE*RJK + HLM1=(1.,0.) + HLM2=(1.,0.) + HLM3=(1.,0.) + HLM4=(1.,0.) + IEM=1 + CSTH=COS(BETA) + IF((IFTHET.EQ.0).OR.(THRJ.LT.0.0001)) THEN + INTER=1 + BLMU=SQRT(4.*PI/FLOAT(2*L+1))*CEXP((0.,-1.)*M*(PHIRJ-PI)) + ENDIF + CALL PLM(CSTH,PLMM,LMAX(JAT,JE)) + IF(ISPHER.EQ.0) NO1=0 + IF(ISPHER.EQ.1) THEN + IF(NO.EQ.8) THEN + NO1=LMAX(JAT,JE)+1 + ELSE + NO1=NO + ENDIF + CALL POLHAN(ISPHER,NO1,LMAX(JAT,JE),RHOJ,HLM) + IF(IEM.EQ.0) THEN + HLM4=HLM(0,L) + ENDIF + IF(RJK.GT.0.0001) THEN + NDUM=0 + CALL POLHAN(ISPHER,NDUM,LMAX(JAT,JE),RHOJK,HLN) + ENDIF + CALL DJMN(THRJ,D,L) + A1=ABS(D(0,M,L)) + IF(((A1.LT.0.0001).AND.(IFTHET.EQ.1)).AND.(INTER.EQ.0)) RETURN 1 + ENDIF + MUMAX=MIN0(L,NO1) + SMU=(0.,0.) + DO 10 MU=0,MUMAX + IF(MOD(MU,2).EQ.0) THEN + B=1. + ELSE + B=-1. + IF(SIN(BETA).LT.0.) THEN + A=-1. + ENDIF + ENDIF + IF(ISPHER.LE.1) THEN + ALMU=(1.,0.) + C=1. + ENDIF + IF(ISPHER.EQ.0) GOTO 40 + IF(INTER.EQ.0) BLMU=CMPLX(D(M,0,L)) + IF(MU.GT.0) THEN + C=B*FLOAT(L+L+1)/EXPF(MU,L) + ALMU=(D(M,MU,L)*CEXP((0.,-1.)*MU*GAMMA)+B* + * CEXP((0.,1.)*MU*GAMMA)*D(M,-MU,L))/BLMU + ELSE + C=1. + ALMU=CMPLX(D(M,0,L))/BLMU + ENDIF + 40 SNU=(0.,0.) + NU1=INT(0.5*(NO1-MU)+0.0001) + NUMAX=MIN0(NU1,L-MU) + DO 20 NU=0,NUMAX + SLP=(0.,0.) + LPMIN=MAX0(MU,NU) + DO 30 LP=LPMIN,LMAX(JAT,JE) + IF(ISPHER.EQ.1) THEN + HLM1=HLM(NU,LP) + IF(RJK.GT.0.0001) HLM3=HLN(0,LP) + ENDIF + SLP=SLP+FLOAT(2*LP+1)*TL(LP,1,JAT,JE)*HLM1*PLMM(LP,MU)*HLM3 + 30 CONTINUE + IF(ISPHER.EQ.1) THEN + HLM2=HLM(MU+NU,L) + ENDIF + SNU=SNU+SLP*HLM2 + 20 CONTINUE + SMU=SMU+SNU*C*ALMU*A*B + 10 CONTINUE + FSPH=SMU/(VKE*HLM4) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif_a.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif_a.f new file mode 100644 index 0000000..4f38377 --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/facdif_a.f @@ -0,0 +1,28 @@ +C +C======================================================================= +C + SUBROUTINE FACDIF_A(COSTH,JAT,JE,FTHETA) +C +C This routine computes the plane wave scattering factor +C + USE DIM_MOD +C + USE TL_AED_MOD, DLT => DLT_A, TL => TL_A, VK => VK_A, + & VK2 => VK2_A, IPOTC => IPOTC_A, ITL => ITL_A, + & LMAX => LMAX_A +C + DIMENSION PL(0:100) +C + COMPLEX FTHETA +C + FTHETA=(0.,0.) + NL=LMAX(JAT,JE)+1 + CALL POLLEG(NL,COSTH,PL) + DO 20 L=0,NL-1 + FTHETA=FTHETA+(2*L+1)*TL(L,1,JAT,JE)*PL(L) + 20 CONTINUE + FTHETA=FTHETA/VK(JE) +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/lapack_axb.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/lapack_axb.f new file mode 100644 index 0000000..8019303 --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/lapack_axb.f @@ -0,0 +1,5123 @@ +C +C======================================================================= +C +C LAPACK Ax=b subroutines +C +C======================================================================= +C +C (version 3.6.1) June 2016 +C +C======================================================================= +C +*> \brief \b ZGETRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGETRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TRANS +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETRS solves a system of linear equations +*> A * X = B, A**T * X = B, or A**H * X = B +*> with a general N-by-N matrix A using the LU factorization computed +*> by ZGETRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the form of the system of equations: +*> = 'N': A * X = B (No transpose) +*> = 'T': A**T * X = B (Transpose) +*> = 'C': A**H * X = B (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The factors L and U from the factorization A = P*L*U +*> as computed by ZGETRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZGETRF; for 1<=i<=N, row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLASWP, ZTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A**T * X = B or A**H * X = B. +* +* Solve U**T *X = B or U**H *X = B, overwriting B with X. +* + CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Solve L**T *X = B, or L**H *X = B overwriting B with X. +* + CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, + $ LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of ZGETRS +* + END +C +C====================================================================== +C +*> \brief \b IEEECK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* .. Scalar Arguments .. +* INTEGER ISPEC +* REAL ONE, ZERO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IEEECK is called from the ILAENV to verify that Infinity and +*> possibly NaN arithmetic is safe (i.e. will not trap). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies whether to test just for inifinity arithmetic +*> or whether to test for infinity and NaN arithmetic. +*> = 0: Verify infinity arithmetic only. +*> = 1: Verify infinity and NaN arithmetic. +*> \endverbatim +*> +*> \param[in] ZERO +*> \verbatim +*> ZERO is REAL +*> Must contain the value 0.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> \endverbatim +*> +*> \param[in] ONE +*> \verbatim +*> ONE is REAL +*> Must contain the value 1.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> +*> RETURN VALUE: INTEGER +*> = 0: Arithmetic failed to produce the correct answers +*> = 1: Arithmetic produced the correct answers +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END +C +C====================================================================== +C +*> \brief \b ILAENV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAENV is called from the LAPACK routines to choose problem-dependent +*> parameters for the local environment. See ISPEC for a description of +*> the parameters. +*> +*> ILAENV returns an INTEGER +*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC +*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. +*> +*> This version provides a set of parameters which should give good, +*> but not optimal, performance on many of the currently available +*> computers. Users are encouraged to modify this subroutine to set +*> the tuning parameters for their particular machine using the option +*> and problem size information in the arguments. +*> +*> This routine will not function correctly if it is converted to all +*> lower case. Converting it to all upper case is allowed. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies the parameter to be returned as the value of +*> ILAENV. +*> = 1: the optimal blocksize; if this value is 1, an unblocked +*> algorithm will give the best performance. +*> = 2: the minimum block size for which the block routine +*> should be used; if the usable block size is less than +*> this value, an unblocked routine should be used. +*> = 3: the crossover point (in a block routine, for N less +*> than this value, an unblocked routine should be used) +*> = 4: the number of shifts, used in the nonsymmetric +*> eigenvalue routines (DEPRECATED) +*> = 5: the minimum column dimension for blocking to be used; +*> rectangular blocks must have dimension at least k by m, +*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) +*> = 6: the crossover point for the SVD (when reducing an m by n +*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +*> this value, a QR factorization is used first to reduce +*> the matrix to a triangular form.) +*> = 7: the number of processors +*> = 8: the crossover point for the multishift QR method +*> for nonsymmetric eigenvalue problems (DEPRECATED) +*> = 9: maximum size of the subproblems at the bottom of the +*> computation tree in the divide-and-conquer algorithm +*> (used by xGELSD and xGESDD) +*> =10: ieee NaN arithmetic can be trusted not to trap +*> =11: infinity arithmetic can be trusted not to trap +*> 12 <= ISPEC <= 16: +*> xHSEQR or related subroutines, +*> see IPARMQ for detailed explanation +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is CHARACTER*(*) +*> The name of the calling subroutine, in either upper case or +*> lower case. +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> \endverbatim +*> +*> \param[in] N3 +*> \verbatim +*> N3 is INTEGER +*> \endverbatim +*> +*> \param[in] N4 +*> \verbatim +*> N4 is INTEGER +*> Problem dimensions for the subroutine NAME; these may not all +*> be required. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The following conventions have been used when calling ILAENV from the +*> LAPACK routines: +*> 1) OPTS is a concatenation of all of the character options to +*> subroutine NAME, in the same order that they appear in the +*> argument list for NAME, even if they are not used in determining +*> the value of the parameter specified by ISPEC. +*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order +*> that they appear in the argument list for NAME. N1 is used +*> first, N2 second, and so on, and unused problem dimensions are +*> passed a value of -1. +*> 3) The parameter value returned by ILAENV is checked for validity in +*> the calling subroutine. For example, ILAENV is used to retrieve +*> the optimal blocksize for STRTRI as follows: +*> +*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +*> IF( NB.LE.1 ) NB = MAX( 1, N ) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF ( C3.EQ.'EVC' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NB = 32 + IF( C3.EQ.'HD3' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NBMIN = 2 + IF( C3.EQ.'HD3' ) THEN + NBMIN = 2 + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NX = 128 + IF( C3.EQ.'HD3' ) THEN + NX = 128 + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or related subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END +C +C====================================================================== +C +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME(CA,CB) +* +* .. Scalar Arguments .. +* CHARACTER CA,CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> CA is CHARACTER*1 +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CB is CHARACTER*1 +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup aux_blas +* +* ===================================================================== + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END +C +C====================================================================== +C +*> \brief \b ZGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETF2 computes an LU factorization of a general m-by-n matrix A +*> using partial pivoting with row interchanges. +*> +*> The factorization has the form +*> A = P * L * U +*> where P is a permutation matrix, L is lower triangular with unit +*> diagonal elements (lower trapezoidal if m > n), and U is upper +*> triangular (upper trapezoidal if m < n). +*> +*> This is the right-looking Level 2 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix to be factored. +*> On exit, the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (min(M,N)) +*> The pivot indices; for 1 <= i <= min(M,N), row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, U(k,k) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and division by zero will occur if it is used +*> to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + INTEGER I, J, JP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IZAMAX + EXTERNAL DLAMCH, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) THEN + IF( ABS(A( J, J )) .GE. SFMIN ) THEN + CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) + ELSE + DO 20 I = 1, M-J + A( J+I, J ) = A( J+I, J ) / A( J, J ) + 20 CONTINUE + END IF + END IF +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), + $ LDA, A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of ZGETF2 +* + END +C +C====================================================================== +C +*> \brief \b ZGETRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGETRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETRF computes an LU factorization of a general M-by-N matrix A +*> using partial pivoting with row interchanges. +*> +*> The factorization has the form +*> A = P * L * U +*> where P is a permutation matrix, L is lower triangular with unit +*> diagonal elements (lower trapezoidal if m > n), and U is upper +*> triangular (upper trapezoidal if m < n). +*> +*> This is the right-looking Level 3 BLAS version of the algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix to be factored. +*> On exit, the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (min(M,N)) +*> The pivot indices; for 1 <= i <= min(M,N), row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and division by zero will occur if it is used +*> to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZGETRF2, ZLASWP, ZTRSM +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL ZGETRF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL ZGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of ZGETRF +* + END +C +C====================================================================== +C +*> \brief \b ZGETRF2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGETRF2 computes an LU factorization of a general M-by-N matrix A +*> using partial pivoting with row interchanges. +*> +*> The factorization has the form +*> A = P * L * U +*> where P is a permutation matrix, L is lower triangular with unit +*> diagonal elements (lower trapezoidal if m > n), and U is upper +*> triangular (upper trapezoidal if m < n). +*> +*> This is the recursive version of the algorithm. It divides +*> the matrix into four submatrices: +*> +*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 +*> A = [ -----|----- ] with n1 = min(m,n)/2 +*> [ A21 | A22 ] n2 = n-n1 +*> +*> [ A11 ] +*> The subroutine calls itself to factor [ --- ], +*> [ A12 ] +*> [ A12 ] +*> do the swaps on [ --- ], solve A12, update A22, +*> [ A22 ] +*> +*> then calls itself to factor A22 and do the swaps on A21. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix to be factored. +*> On exit, the factors L and U from the factorization +*> A = P*L*U; the unit diagonal elements of L are not stored. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (min(M,N)) +*> The pivot indices; for 1 <= i <= min(M,N), row i of the +*> matrix was interchanged with row IPIV(i). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization +*> has been completed, but the factor U is exactly +*> singular, and division by zero will occur if it is used +*> to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup complex16GEcomputational +* +* ===================================================================== + RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION SFMIN + COMPLEX*16 TEMP + INTEGER I, IINFO, N1, N2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER IZAMAX + EXTERNAL DLAMCH, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZSCAL, ZLASWP, ZTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGETRF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN + + IF ( M.EQ.1 ) THEN +* +* Use unblocked code for one row case +* Just need to handle IPIV and INFO +* + IPIV( 1 ) = 1 + IF ( A(1,1).EQ.ZERO ) + $ INFO = 1 +* + ELSE IF( N.EQ.1 ) THEN +* +* Use unblocked code for one column case +* +* +* Compute machine safe minimum +* + SFMIN = DLAMCH('S') +* +* Find pivot and test for singularity +* + I = IZAMAX( M, A( 1, 1 ), 1 ) + IPIV( 1 ) = I + IF( A( I, 1 ).NE.ZERO ) THEN +* +* Apply the interchange +* + IF( I.NE.1 ) THEN + TEMP = A( 1, 1 ) + A( 1, 1 ) = A( I, 1 ) + A( I, 1 ) = TEMP + END IF +* +* Compute elements 2:M of the column +* + IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN + CALL ZSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) + ELSE + DO 10 I = 1, M-1 + A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) + 10 CONTINUE + END IF +* + ELSE + INFO = 1 + END IF + + ELSE +* +* Use recursive code +* + N1 = MIN( M, N ) / 2 + N2 = N-N1 +* +* [ A11 ] +* Factor [ --- ] +* [ A21 ] +* + CALL ZGETRF2( M, N1, A, LDA, IPIV, IINFO ) + + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* [ A12 ] +* Apply interchanges to [ --- ] +* [ A22 ] +* + CALL ZLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) +* +* Solve A12 +* + CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, + $ A( 1, N1+1 ), LDA ) +* +* Update A22 +* + CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, + $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) +* +* Factor A22 +* + CALL ZGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), + $ IINFO ) +* +* Adjust INFO and the pivot indices +* + IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + N1 + DO 20 I = N1+1, MIN( M, N ) + IPIV( I ) = IPIV( I ) + N1 + 20 CONTINUE +* +* Apply interchanges to A21 +* + CALL ZLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) +* + END IF + RETURN +* +* End of ZGETRF2 +* + END +C +C====================================================================== +C +*> \brief \b ZLASWP performs a series of row interchanges on a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASWP + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* .. Scalar Arguments .. +* INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLASWP performs a series of row interchanges on the matrix A. +*> One row interchange is initiated for each of rows K1 through K2 of A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the matrix of column dimension N to which the row +*> interchanges will be applied. +*> On exit, the permuted matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> \endverbatim +*> +*> \param[in] K1 +*> \verbatim +*> K1 is INTEGER +*> The first element of IPIV for which a row interchange will +*> be done. +*> \endverbatim +*> +*> \param[in] K2 +*> \verbatim +*> K2 is INTEGER +*> The last element of IPIV for which a row interchange will +*> be done. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (K2*abs(INCX)) +*> The vector of pivot indices. Only the elements in positions +*> K1 through K2 of IPIV are accessed. +*> IPIV(K) = L implies rows K and L are to be interchanged. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive values of IPIV. If IPIV +*> is negative, the pivots are applied in reverse order. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup complex16OTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Modified by +*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + COMPLEX*16 TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of ZLASWP +* + END +C +C====================================================================== +C +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download XERBLA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END +C +C====================================================================== +C +*> \brief \b ZGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array of DIMENSION ( LDC, n ). +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.6.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA, NCOLA and NROWB as the number of rows and columns of A +* and the number of rows of B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*DCONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMM . +* + END +C +C====================================================================== +C +*> \brief \b ZGERU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERU performs the rank 1 operation +*> +*> A := alpha*x*y**T + A, +*> +*> where alpha is a scalar, x is an m element vector, y is an n element +*> vector and A is an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix A. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array of dimension at least +*> ( 1 + ( m - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the m +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is COMPLEX*16 array of dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, n ). +*> Before entry, the leading m by n part of the array A must +*> contain the matrix of coefficients. On exit, A is +*> overwritten by the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- Reference BLAS level2 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (M.LT.0) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,M)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGERU ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF (INCY.GT.0) THEN + JY = 1 + ELSE + JY = 1 - (N-1)*INCY + END IF + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + DO 10 I = 1,M + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (M-1)*INCX + END IF + DO 40 J = 1,N + IF (Y(JY).NE.ZERO) THEN + TEMP = ALPHA*Y(JY) + IX = KX + DO 30 I = 1,M + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of ZGERU . +* + END +C +C====================================================================== +C +*> \brief \b ZSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSCAL scales a vector by a constant. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = ZA*ZX(I) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = ZA*ZX(I) + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b ZSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSWAP interchanges two vectors. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 + DO I = 1,N + ZTEMP = ZX(I) + ZX(I) = ZY(I) + ZY(I) = ZTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZX(IX) + ZX(IX) = ZY(IY) + ZY(IY) = ZTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN + END +C +C====================================================================== +C +*> \brief \b ZTRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSM solves one of the matrix equations +*> +*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +*> +*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +*> non-unit, upper or lower triangular matrix and op( A ) is one of +*> +*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +*> +*> The matrix X is overwritten on B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether op( A ) appears on the left +*> or right of X as follows: +*> +*> SIDE = 'L' or 'l' op( A )*X = alpha*B. +*> +*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the matrix A is an upper or +*> lower triangular matrix as follows: +*> +*> UPLO = 'U' or 'u' A is an upper triangular matrix. +*> +*> UPLO = 'L' or 'l' A is a lower triangular matrix. +*> \endverbatim +*> +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n' op( A ) = A. +*> +*> TRANSA = 'T' or 't' op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c' op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> On entry, DIAG specifies whether or not A is unit triangular +*> as follows: +*> +*> DIAG = 'U' or 'u' A is assumed to be unit triangular. +*> +*> DIAG = 'N' or 'n' A is not assumed to be unit +*> triangular. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of B. M must be at +*> least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of B. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. When alpha is +*> zero then A is not referenced and B need not be set before +*> entry. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array of DIMENSION ( LDA, k ), +*> where k is m when SIDE = 'L' or 'l' +*> and k is n when SIDE = 'R' or 'r'. +*> Before entry with UPLO = 'U' or 'u', the leading k by k +*> upper triangular part of the array A must contain the upper +*> triangular matrix and the strictly lower triangular part of +*> A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading k by k +*> lower triangular part of the array A must contain the lower +*> triangular matrix and the strictly upper triangular part of +*> A is not referenced. +*> Note that when DIAG = 'U' or 'u', the diagonal elements of +*> A are not referenced either, but are assumed to be unity. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +*> then LDA must be at least max( 1, n ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array of DIMENSION ( LDB, n ). +*> Before entry, the leading m by n part of the array B must +*> contain the right-hand side matrix B, and on exit is +*> overwritten by the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* -- Reference BLAS level3 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = LSAME(TRANSA,'T') + NOUNIT = LSAME(DIAG,'N') + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + + (.NOT.LSAME(TRANSA,'T')) .AND. + + (.NOT.LSAME(TRANSA,'C'))) THEN + INFO = 3 + ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN + INFO = 4 + ELSE IF (M.LT.0) THEN + INFO = 5 + ELSE IF (N.LT.0) THEN + INFO = 6 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 11 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZTRSM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (M.EQ.0 .OR. N.EQ.0) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + B(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF (LSIDE) THEN + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*inv( A )*B. +* + IF (UPPER) THEN + DO 60 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 30 I = 1,M + B(I,J) = ALPHA*B(I,J) + 30 CONTINUE + END IF + DO 50 K = M,1,-1 + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 40 I = 1,K - 1 + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 70 I = 1,M + B(I,J) = ALPHA*B(I,J) + 70 CONTINUE + END IF + DO 90 K = 1,M + IF (B(K,J).NE.ZERO) THEN + IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) + DO 80 I = K + 1,M + B(I,J) = B(I,J) - B(K,J)*A(I,K) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A**T )*B +* or B := alpha*inv( A**H )*B. +* + IF (UPPER) THEN + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 120 K = 1,I - 1 + TEMP = TEMP - DCONJG(A(K,I))*B(K,J) + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) + END IF + B(I,J) = TEMP + 130 CONTINUE + 140 CONTINUE + ELSE + DO 180 J = 1,N + DO 170 I = M,1,-1 + TEMP = ALPHA*B(I,J) + IF (NOCONJ) THEN + DO 150 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + ELSE + DO 160 K = I + 1,M + TEMP = TEMP - DCONJG(A(K,I))*B(K,J) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I)) + END IF + B(I,J) = TEMP + 170 CONTINUE + 180 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 230 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 190 I = 1,M + B(I,J) = ALPHA*B(I,J) + 190 CONTINUE + END IF + DO 210 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 200 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 220 I = 1,M + B(I,J) = TEMP*B(I,J) + 220 CONTINUE + END IF + 230 CONTINUE + ELSE + DO 280 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 240 I = 1,M + B(I,J) = ALPHA*B(I,J) + 240 CONTINUE + END IF + DO 260 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 250 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 270 I = 1,M + B(I,J) = TEMP*B(I,J) + 270 CONTINUE + END IF + 280 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ) +* or B := alpha*B*inv( A**H ). +* + IF (UPPER) THEN + DO 330 K = N,1,-1 + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/DCONJG(A(K,K)) + END IF + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + DO 310 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = DCONJG(A(J,K)) + END IF + DO 300 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 320 I = 1,M + B(I,K) = ALPHA*B(I,K) + 320 CONTINUE + END IF + 330 CONTINUE + ELSE + DO 380 K = 1,N + IF (NOUNIT) THEN + IF (NOCONJ) THEN + TEMP = ONE/A(K,K) + ELSE + TEMP = ONE/DCONJG(A(K,K)) + END IF + DO 340 I = 1,M + B(I,K) = TEMP*B(I,K) + 340 CONTINUE + END IF + DO 360 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + IF (NOCONJ) THEN + TEMP = A(J,K) + ELSE + TEMP = DCONJG(A(J,K)) + END IF + DO 350 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 370 I = 1,M + B(I,K) = ALPHA*B(I,K) + 370 CONTINUE + END IF + 380 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRSM . +* + END +C +C====================================================================== +C +*> \brief \b DLAMCH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMCH determines double precision machine parameters. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CMACH +*> \verbatim +*> Specifies the value to be returned by DLAMCH: +*> = 'E' or 'e', DLAMCH := eps +*> = 'S' or 's , DLAMCH := sfmin +*> = 'B' or 'b', DLAMCH := base +*> = 'P' or 'p', DLAMCH := eps*base +*> = 'N' or 'n', DLAMCH := t +*> = 'R' or 'r', DLAMCH := rnd +*> = 'M' or 'm', DLAMCH := emin +*> = 'U' or 'u', DLAMCH := rmin +*> = 'L' or 'l', DLAMCH := emax +*> = 'O' or 'o', DLAMCH := rmax +*> where +*> eps = relative machine precision +*> sfmin = safe minimum, such that 1/sfmin does not overflow +*> base = base of the machine +*> prec = eps*base +*> t = number of (base) digits in the mantissa +*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +*> emin = minimum exponent before (gradual) underflow +*> rmin = underflow threshold - base**(emin-1) +*> emax = largest exponent before overflow +*> rmax = overflow threshold - (base**emax)*(1-eps) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC1 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC1 determines the machine parameters given by BETA, T, RND, and +*> IEEE1. +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> The number of ( BETA ) digits in the mantissa. +*> \endverbatim +*> +*> \param[out] RND +*> \verbatim +*> Specifies whether proper rounding ( RND = .TRUE. ) or +*> chopping ( RND = .FALSE. ) occurs in addition. This may not +*> be a reliable guide to the way in which the machine performs +*> its arithmetic. +*> \endverbatim +*> +*> \param[out] IEEE1 +*> \verbatim +*> Specifies whether rounding appears to be done in the IEEE +*> 'round to nearest' style. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date April 2012 +*> \ingroup auxOTHERauxiliary +*> +*> \details \b Further \b Details +*> \verbatim +*> +*> The routine is based on the routine ENVRON by Malcolm and +*> incorporates suggestions by Gentleman and Marovich. See +*> +*> Malcolm M. A. (1972) Algorithms to reveal properties of +*> floating-point arithmetic. Comms. of the ACM, 15, 949-951. +*> +*> Gentleman W. M. and Marovich S. B. (1974) More on algorithms +*> that reveal properties of floating point arithmetic units. +*> Comms. of the ACM, 17, 276-277. +*> \endverbatim +*> + SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + ONE = 1 +* +* LBETA, LIEEE1, LT and LRND are the local values of BETA, +* IEEE1, T and RND. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* Compute a = 2.0**m with the smallest positive integer m such +* that +* +* fl( a + 1.0 ) = a. +* + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + B = 1 + C = DLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = DLAMC3( A, B ) + GO TO 20 + END IF +*+ END WHILE +* +* Now compute the base. a and c are neighbouring floating point +* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so +* their difference is beta. Adding 0.25 to c is to ensure that it +* is truncated to beta and not ( beta - 1 ). +* + QTR = ONE / 4 + SAVEC = C + C = DLAMC3( C, -A ) + LBETA = C + QTR +* +* Now determine whether rounding or chopping occurs, by adding a +* bit less than beta/2 and a bit more than beta/2 to a. +* + B = LBETA + F = DLAMC3( B / 2, -B / 100 ) + C = DLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = DLAMC3( B / 2, B / 100 ) + C = DLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.A ) ) + $ LRND = .FALSE. +* +* Try and decide whether rounding is done in the IEEE 'round to +* nearest' style. B/2 is half a unit in the last place of the two +* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit +* zero, and SAVEC is odd. Thus adding B/2 to A should not change +* A, but adding B/2 to SAVEC should change SAVEC. +* + T1 = DLAMC3( B / 2, A ) + T2 = DLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND +* +* Now find the mantissa, t. It should be the integer part of +* log to the base beta of a, however it is safer to determine t +* by powering. So we find t as the smallest positive integer for +* which +* +* fl( beta**t + 1.0 ) = 1.0. +* + LT = 0 + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + FIRST = .FALSE. + RETURN +* +* End of DLAMC1 +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC2 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC2 determines the machine parameters specified in its argument +*> list. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date April 2012 +*> \ingroup auxOTHERauxiliary +*> +*> \param[out] BETA +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> The number of ( BETA ) digits in the mantissa. +*> \endverbatim +*> +*> \param[out] RND +*> \verbatim +*> Specifies whether proper rounding ( RND = .TRUE. ) or +*> chopping ( RND = .FALSE. ) occurs in addition. This may not +*> be a reliable guide to the way in which the machine performs +*> its arithmetic. +*> \endverbatim +*> +*> \param[out] EPS +*> \verbatim +*> The smallest positive number such that +*> fl( 1.0 - EPS ) .LT. 1.0, +*> where fl denotes the computed value. +*> \endverbatim +*> +*> \param[out] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow occurs. +*> \endverbatim +*> +*> \param[out] RMIN +*> \verbatim +*> The smallest normalized number for the machine, given by +*> BASE**( EMIN - 1 ), where BASE is the floating point value +*> of BETA. +*> \endverbatim +*> +*> \param[out] EMAX +*> \verbatim +*> The maximum exponent before overflow occurs. +*> \endverbatim +*> +*> \param[out] RMAX +*> \verbatim +*> The largest positive number for the machine, given by +*> BASE**EMAX * ( 1 - EPS ), where BASE is the floating point +*> value of BETA. +*> \endverbatim +*> +*> \details \b Further \b Details +*> \verbatim +*> +*> The computation of EPS is based on a routine PARANOIA by +*> W. Kahan of the University of California at Berkeley. +*> \endverbatim + SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL DLAMC1, DLAMC4, DLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + ZERO = 0 + ONE = 1 + TWO = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of +* BETA, T, RND, EPS, EMIN and RMIN. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. +* + CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = DLAMC3( B, -HALF ) + THIRD = DLAMC3( SIXTH, SIXTH ) + B = DLAMC3( THIRD, -HALF ) + B = DLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = DLAMC3( HALF, -C ) + B = DLAMC3( HALF, C ) + C = DLAMC3( HALF, -B ) + B = DLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.LEPS ) + $ LEPS = A +* +* Computation of EPS complete. +* +* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). +* Keep dividing A by BETA until (gradual) underflow occurs. This +* is detected when we cannot recover the previous A. +* + RBASE = ONE / LBETA + SMALL = ONE + DO 20 I = 1, 3 + SMALL = DLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = DLAMC3( ONE, SMALL ) + CALL DLAMC4( NGPMIN, ONE, LBETA ) + CALL DLAMC4( NGNMIN, -ONE, LBETA ) + CALL DLAMC4( GPMIN, A, LBETA ) + CALL DLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + LEMIN = NGPMIN - 1 + LT + IEEE = .TRUE. +* ( Non twos-complement machines, with gradual underflow; +* e.g., IEEE standard followers ) + ELSE + LEMIN = MIN( NGPMIN, GPMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) +* ( Twos-complement machines, no gradual underflow; +* e.g., CYBER 205 ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT +* ( Twos-complement machines with gradual underflow; +* no known machine ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF + FIRST = .FALSE. +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* Assume IEEE arithmetic if we found denormalised numbers above, +* or if arithmetic seems to round in the IEEE style, determined +* in routine DLAMC1. A true IEEE machine should have both things +* true; however, faulty machines may have one or the other. +* + IEEE = IEEE .OR. LIEEE1 +* +* Compute RMIN by successive division by BETA. We could compute +* RMIN as BASE**( EMIN - 1 ), but some machines underflow during +* this computation. +* + LRMIN = 1 + DO 30 I = 1, 1 - LEMIN + LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call DLAMC5 to compute EMAX and RMAX. +* + CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of DLAMC2 +* + END +* +************************************************************************ +* +*> \brief \b DLAMC3 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC3 is intended to force A and B to be stored prior to doing +*> the addition of A and B , for use in situations where optimizers +*> might hold one of these in a register. +*> \endverbatim +*> +*> \param[in] A +*> +*> \param[in] B +*> \verbatim +*> The values A and B. +*> \endverbatim + + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC4 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC4 is a service routine for DLAMC2. +*> \endverbatim +*> +*> \param[out] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow, computed by +*> setting A = START and dividing by BASE until the previous A +*> can not be recovered. +*> \endverbatim +*> +*> \param[in] START +*> \verbatim +*> The starting point for determining EMIN. +*> \endverbatim +*> +*> \param[in] BASE +*> \verbatim +*> The base of the machine. +*> \endverbatim +*> + SUBROUTINE DLAMC4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = DLAMC3( A*RBASE, ZERO ) + C1 = A + C2 = A + D1 = A + D2 = A +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = DLAMC3( A / BASE, ZERO ) + C1 = DLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = DLAMC3( A*RBASE, ZERO ) + C2 = DLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of DLAMC4 +* + END +C +C====================================================================== +C +* +************************************************************************ +* +*> \brief \b DLAMC5 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC5 attempts to compute RMAX, the largest machine floating-point +*> number, without overflow. It assumes that EMAX + abs(EMIN) sum +*> approximately to a power of 2. It will fail on machines where this +*> assumption does not hold, for example, the Cyber 205 (EMIN = -28625, +*> EMAX = 28718). It will also fail if the value supplied for EMIN is +*> too large (i.e. too close to zero), probably with overflow. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> The base of floating-point arithmetic. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> The number of base BETA digits in the mantissa of a +*> floating-point value. +*> \endverbatim +*> +*> \param[in] EMIN +*> \verbatim +*> The minimum exponent before (gradual) underflow. +*> \endverbatim +*> +*> \param[in] IEEE +*> \verbatim +*> A logical flag specifying whether or not the arithmetic +*> system is thought to comply with the IEEE standard. +*> \endverbatim +*> +*> \param[out] EMAX +*> \verbatim +*> The largest exponent before overflow +*> \endverbatim +*> +*> \param[out] RMAX +*> \verbatim +*> The largest machine floating-point number. +*> \endverbatim +*> + SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 3.4.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* First compute LEXP and UEXP, two powers of 2 that bound +* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum +* approximately to the bound that is closest to abs(EMIN). +* (EMAX is the exponent of the required number RMAX). +* + LEXP = 1 + EXBITS = 1 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* Now -LEXP is less than or equal to EMIN, and -UEXP is greater +* than or equal to EMIN. EXBITS is the number of bits needed to +* store the exponent. +* + IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* Either there are an odd number of bits used to store a +* floating-point number, which is unlikely, or some bits are +* not used in the representation of numbers, which is possible, +* (e.g. Cray machines) or the mantissa has an implicit bit, +* (e.g. IEEE machines, Dec Vax machines), which is perhaps the +* most likely. We have to assume the last alternative. +* If this is true, then we need to reduce EMAX by one because +* there must be some way of representing zero in an implicit-bit +* system. On machines like Cray, we are reducing EMAX by one +* unnecessarily. +* + EMAX = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* Now create RMAX, the largest machine number, which should +* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . +* +* First compute 1.0 - BETA**(-P), being careful that the +* result is less than 1.0 . +* + RECBAS = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = DLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = DLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of DLAMC5 +* + END +*> \brief \b IPARMQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, ISPEC, LWORK, N +* CHARACTER NAME*( * ), OPTS*( * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever +*> IPARMQ is called with 12 <= ISPEC <= 16 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is integer scalar +*> ISPEC specifies which tunable parameter IPARMQ should +*> return. +*> +*> ISPEC=12: (INMIN) Matrices of order nmin or less +*> are sent directly to xLAHQR, the implicit +*> double shift QR algorithm. NMIN must be +*> at least 11. +*> +*> ISPEC=13: (INWIN) Size of the deflation window. +*> This is best set greater than or equal to +*> the number of simultaneous shifts NS. +*> Larger matrices benefit from larger deflation +*> windows. +*> +*> ISPEC=14: (INIBL) Determines when to stop nibbling and +*> invest in an (expensive) multi-shift QR sweep. +*> If the aggressive early deflation subroutine +*> finds LD converged eigenvalues from an order +*> NW deflation window and LD.GT.(NW*NIBBLE)/100, +*> then the next QR sweep is skipped and early +*> deflation is applied immediately to the +*> remaining active diagonal block. Setting +*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +*> multi-shift QR sweep whenever early deflation +*> finds a converged eigenvalue. Setting +*> IPARMQ(ISPEC=14) greater than or equal to 100 +*> prevents TTQRE from skipping a multi-shift +*> QR sweep. +*> +*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in +*> a multi-shift QR iteration. +*> +*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +*> following meanings. +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the +*> far-from-diagonal matrix entries. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. +*> (If xTRMM is slower than xGEMM, then +*> IPARMQ(ISPEC=16)=1 may be more efficient than +*> IPARMQ(ISPEC=16)=2 despite the greater level of +*> arithmetic work implied by the latter choice.) +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is character string +*> This is a concatenation of the string arguments to +*> TTQRE. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is integer scalar +*> N is the order of the Hessenberg matrix H. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer scalar +*> The amount of workspace available. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Little is known about how best to choose these parameters. +*> It is possible to use different values of the parameters +*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +*> +*> It is probably best to choose different parameters for +*> different matrices and different parameters at different +*> times during the iteration, but this has not been +*> implemented --- yet. +*> +*> +*> The best choices of most of the parameters depend +*> in an ill-understood way on the relative execution +*> rate of xLAQR3 and xLAQR5 and on the nature of each +*> particular eigenvalue problem. Experiment may be the +*> only practical way to determine which choices are most +*> effective. +*> +*> Following is a list of default values supplied by IPARMQ. +*> These defaults may be adjusted in order to attain better +*> performance in any particular computational environment. +*> +*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> IPARMQ(ISPEC=13) Recommended deflation window size. +*> This depends on ILO, IHI and NS, the +*> number of simultaneous shifts returned +*> by IPARMQ(ISPEC=15). The default for +*> (IHI-ILO+1).LE.500 is NS. The default +*> for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +*> +*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +*> a multi-shift QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 0 30 NS = 2+ +*> 30 60 NS = 4+ +*> 60 150 NS = 10 +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default matrices of this order are +*> passed to the implicit double shift routine +*> xLAHQR. See IPARMQ(ISPEC=12) above. These +*> values of NS are used only in case of a rare +*> xLAHQR failure. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function increasing from 10 to 64. +*> +*> IPARMQ(ISPEC=16) Select structured matrix multiply. +*> (See ISPEC=16 above for details.) +*> Default: 3. +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* +* +* Convert NAME to upper case if the first character is lower case. +* + IPARMQ = 0 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + END DO + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF + END IF +* + IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. + $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN + IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN + IF( NH.GE.KACMIN ) + $ IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. + $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + END IF +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END +C +C====================================================================== +C +*> \brief \b IZAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup aux_blas +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 1/15/85. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IZAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IZAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DCABS1(ZX(1)) + DO I = 2,N + IF (DCABS1(ZX(I)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DCABS1(ZX(1)) + IX = IX + INCX + DO I = 2,N + IF (DCABS1(ZX(IX)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN + END +C +C======================================================================= +C +*> \brief \b DCABS1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* .. Scalar Arguments .. +* COMPLEX*16 Z +* .. +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup double_blas_level1 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* -- Reference BLAS level1 routine (version 3.6.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + COMPLEX*16 Z +* .. +* .. +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS,DBLE,DIMAG +* + DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) + RETURN + END +C + diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main.f new file mode 100644 index 0000000..9ecbb48 --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main.f @@ -0,0 +1,21 @@ + SUBROUTINE RUN(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_, + & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_, + & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_, + & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_) + + USE DIM_MOD + IMPLICIT INTEGER (A-Z) +CF2PY INTEGER, INTENT(IN,COPY) :: NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_ +CF2PY INTEGER, INTENT(IN,COPY) :: N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_ + + CALL ALLOCATION(NATP_M_, NATCLU_M_, NAT_EQ_M_, N_CL_L_M_, + & NE_M_, NL_M_, LI_M_, NEMET_M_, NO_ST_M_, NDIF_M_, NSO_M_, + & NTEMP_M_, NODES_EX_M_, NSPIN_M_, NTH_M_, NPH_M_, NDIM_M_, + & N_TILT_M_, N_ORD_M_, NPATH_M_, NGR_M_) + + CALL MAIN_AED_MU_MI() + CALL CLOSE_ALL_FILES() + + END SUBROUTINE RUN diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f new file mode 100644 index 0000000..5bde10b --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/main_aed_mu_mi.f @@ -0,0 +1,1673 @@ +C +C +C ************************************************************ +C * ******************************************************** * +C * * * * +C * * MULTIPLE-SCATTERING SPIN-INDEPENDENT * * +C * * AUGER ELECTRON DIFFRACTION CODE * * +C * * USING MATRIX INVERSION * * +C * * * * +C * ******************************************************** * +C ************************************************************ +C +C +C +C +C Written by D. Sebilleau, Groupe Theorie, +C Departement Materiaux-Nanosciences, +C Institut de Physique de Rennes, +C UMR CNRS-Universite 6251, +C Universite de Rennes-1, +C 35042 Rennes-Cedex, +C France +C +C Contributions : M. Gavaza, H.-F. Zhao, K. Hatada +C +C----------------------------------------------------------------------- +C +C As a general rule in this code, although there might be a few +C exceptions (...), a variable whose name starts with a 'I' is a +C switch, with a 'J' is a loop index and with a 'N' is a number. +C +C The main subroutines are : +C +C * PHDDIF : computes the photoelectron diffraction +C formula +C +C * LEDDIF : computes the low-energy electron +C diffraction formula +C +C * XASDIF : computes the EXAFS or XANES formula +C depending on the energy +C +C * AEDDIF : computes the Auger electron diffraction +C formula +C +C * FINDPATHS : generates the multiple scattering +C paths the electron will follow +C +C * PATHOP : calculates the contribution of a given +C path to the scattering path operator +C +C * MATDIF : computes the Rehr-Albers scattering +C matrices +C +C A subroutine called NAME_A is the Auger equivalent of subroutine +C NAME. The essentail difference between NAME and NAME_A is that +C they do not contain the same arrays. +C +C Always remember, when changing the input data file, to keep the +C format. The rule here is that the last digit of any integer or +C character data must correspond to the tab (+) while for real data, +C the tab precedes the point. +C +C Do not forget, before submitting a calculation, to check the +C consistency of the input data with the corresponding maximal +C values in the include file. +C +C----------------------------------------------------------------------- +C +C Please report any bug or problem to me at : +C +C didier.sebilleau@univ-rennes1.fr +C +C +C +C Last modified : 10 Jan 2016 +C +C======================================================================= +C + SUBROUTINE MAIN_AED_MU_MI() +C +C This routine reads the various input files and calls the subroutine +C performing the requested calculation +C + USE DIM_MOD +C + USE ADSORB_MOD + USE APPROX_MOD + USE ATOMS_MOD + USE AUGER_MOD + USE BASES_MOD + USE CLUSLIM_MOD + USE COOR_MOD + USE DEBWAL_MOD + USE INDAT_MOD + USE INIT_A_MOD + USE INIT_L_MOD + USE INIT_J_MOD + USE INIT_M_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE LIMAMA_MOD + USE LPMOY_MOD + USE MASSAT_MOD + USE MILLER_MOD + USE OUTUNITS_MOD + USE PARCAL_MOD + USE PARCAL_A_MOD + USE RELADS_MOD + USE RELAX_MOD + USE RESEAU_MOD + USE SPIN_MOD + USE TESTS_MOD + USE TRANS_MOD + USE TL_AED_MOD + USE TYPCAL_MOD + USE TYPCAL_A_MOD + USE TYPEM_MOD + USE TYPEXP_MOD + USE VALIN_MOD + USE XMRHO_MOD +C + DIMENSION VEC(3,3),VB1(3),VB2(3),VB3(3),VBS(3) + DIMENSION ROT(3,3),EMET(3) + DIMENSION VAL2(NATCLU_M) + DIMENSION IRE(NATCLU_M,2) + DIMENSION REL(NATCLU_M),RHOT(NATM) + DIMENSION ATOME(3,NATCLU_M),COORD(3,NATCLU_M) + DIMENSION NTYP(NATCLU_M),NATYP_OLD(NATM) + DIMENSION LMAX_TMP(NATM,NE_M),DIST12(NATCLU_M,NATCLU_M) + DIMENSION IBWD_TMP(NATP_M),RTHFWD_TMP(NATP_M),RTHBWD_TMP(NATP_M) + DIMENSION UJ2_TMP(NATM),RHOT_TMP(NATM),XMT_TMP(NATM) +C + COMPLEX TLSTAR,RHOR(NE_M,NATM,0:18,2,NSPIN2_M) + COMPLEX TLSTAR_A + COMPLEX RHOR_A(0:NT_M,NATM,0:40,2,NSPIN2_M),RAD_D,RAD_E + COMPLEX RHOR1STAR,RHOR2STAR +C + INTEGER INV(2) +C + CHARACTER RIEN + CHARACTER*1 B + CHARACTER*2 R + CHARACTER*30 TUNIT,DUMMY +C + DATA PI,BOHR,SMALL/3.141593,0.529177,0.001/ + DATA INV /1,0/ +C + LE_MAX=0 +C +CST READ(*,776) NFICHLEC +CST READ(*,776) ICOM +CST DO JF=1,NFICHLEC +CST READ(*,777) INDATA(JF) +CST ENDDO +C +C.......... Loop on the data files .......... +C + NFICHLEC=1 + ICOM=5 + DO JFICH=1,NFICHLEC +CST OPEN(UNIT=ICOM, FILE=INDATA(JFICH), STATUS='OLD') + OPEN(UNIT=ICOM, FILE='../input/spec.dat', STATUS='OLD') + CALL READ_DATA(ICOM,NFICHLEC,JFICH,ITRTL,*2,*1,*55,*74,*99,*504, + 1 *520,*540,*550,*570,*580,*590,*630) +C +C.......... Atomic case index .......... +C + I_AT=0 + IF((SPECTRO.EQ.'PHD').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'LED').AND.(I_TEST.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'AED').AND.(I_TEST_A.EQ.2)) I_AT=1 + IF((SPECTRO.EQ.'XAS').AND.(I_TEST.EQ.2)) I_AT=1 + IF(SPECTRO.EQ.'APC') THEN + IF((I_TEST.EQ.2).AND.(I_TEST_A.EQ.2)) I_AT=1 + ENDIF +C + IF(IBAS.EQ.1) THEN + IF(ITEST.EQ.0) THEN + NEQ=(2*NIV+1)**3 + ELSE + NEQ=(2*NIV+3)**3 + ENDIF + IF(NEQ*NATP_M.GT.NATCLU_M) GOTO 518 + ENDIF +C + IF(SPECTRO.EQ.'APC') THEN + N_EL=2 + ELSE + N_EL=1 + ENDIF + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN +c IF(I_MULT.EQ.0) THEN + LE_MIN=ABS(LI_C-ABS(LI_I-LI_A)) + LE_MAX=LI_C+LI_A+LI_I +c ELSE +c LE_MIN=ABS(LI_C-L_MUL) +c LE_MAX=LI_C+L_MUL +c ENDIF + ENDIF +C +C.......... Test of the dimensions against the input values .......... +C + IF(NO.GT.NO_ST_M) GOTO 600 + IF(LE_MAX.GT.LI_M) GOTO 620 +C + OPEN(UNIT=IUI2, FILE=INFILE2, STATUS='OLD') + OPEN(UNIT=IUI3, FILE=INFILE3, STATUS='OLD') + IF(INTERACT.EQ.'DIPCOUL') THEN + OPEN(UNIT=IUI7, FILE=INFILE7, STATUS='OLD') + OPEN(UNIT=IUI8, FILE=INFILE8, STATUS='OLD') + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (dipolar excitation or no excitation case) .......... +C + IF(INTERACT.NE.'COULOMB') THEN + IF(SPECTRO.EQ.'APC') WRITE(IUO1,418) + READ(IUI2,3) NAT1,NE1,ITL,IPOTC,LMAX_MODE + IF(ISPIN.EQ.0) THEN + IF(NAT1.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1 + ENDIF + ENDIF + IF((ITL.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IUI2,530) E_MIN,E_MAX,DE + ENDIF + IF((ISPIN.EQ.0).AND.(ITL.EQ.0)) THEN + NLG=INT(NAT1-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1 + READ(IUI2,555) (LMAX(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX. Waiting for a version of PHAGEN +C with LMAX dependent on the energy +C + DO JE=1,NE + DO JAT=1,NAT1 + LMAX(JAT,JE)=LMAX(JAT,1) + ENDDO + ENDDO +C + NL1=1 + DO JAT=1,NAT1 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + ENDIF + IF(ITL.EQ.0) READ(IUI3,101) NATR,NER + IF(ISPIN.EQ.1) THEN + READ(IUI3,106) L_IN,NATR,NER + IF(LI.NE.L_IN) GOTO 606 + ENDIF + NAT2=NAT+NATA + IF((NAT1.NE.NAT2).OR.(NE1.NE.NE)) GOTO 180 + IF((ITL.EQ.0).AND.((NATR.NE.NAT2).OR.(NER.NE.NE))) GOTO 182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL.EQ.0) THEN + DO JAT=1,NAT2 + IF((INITL.NE.0).AND.(IFTHET.NE.1)) THEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + ENDIF + DO JE=1,NE + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 121 + READ(IUI3,103) ENERGIE + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + READ(IUI3,102) RIEN + 121 CONTINUE + DO L=0,LMAX(JAT,JE) + READ(IUI2,7) VK(JE),TL(L,1,JAT,JE) + TL(L,1,JAT,JE)=CSIN(TL(L,1,JAT,JE))*CEXP((0.,1.)* + 1 TL(L,1,JAT,JE)) + ENDDO + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 5 + DO LL=1,18 + READ(IUI3,104) RH1,RH2,DEF1,DEF2 + RHOR(JE,JAT,LL,1,1)=CMPLX(RH1) + RHOR(JE,JAT,LL,2,1)=CMPLX(RH2) + DLT(JE,JAT,LL,1)=CMPLX(DEF1) + DLT(JE,JAT,LL,2)=CMPLX(DEF2) + ENDDO + 5 CONTINUE + ENDDO + ENDDO + ELSE +C +C.......... TL and RHOR calculated by PHAGEN .......... +C + DO JE=1,NE + NLG=INT(NAT2-0.0001)/4 +1 + IF(NE.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2 + READ(IUI2,555) (LMAX(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX(JAT,JE),JAT=JD,NRL) + ENDDO + NL1=1 + DO JAT=1,NAT2 + NL1=MAX0(NL1,LMAX(JAT,1)+1) + ENDDO + IF(NL1.GT.NL_M) GOTO 184 + DO JAT=1,NAT2 + READ(IUI2,*) DUMMY + DO L=0,LMAX(JAT,JE) + IF(LMAX_MODE.EQ.0) THEN + READ(IUI2,9) VK(JE),TLSTAR + ELSE + READ(IUI2,9) VK(JE),TLSTAR + ENDIF + TL(L,1,JAT,JE)=CONJG(TLSTAR) + VK(JE)=CONJG(VK(JE)) + ENDDO + ENDDO +C + IF((IFTHET.EQ.1).OR.(INITL.EQ.0)) GOTO 333 + IF(JE.EQ.1) THEN + DO JDUM=1,7 + READ(IUI3,102) RIEN + ENDDO + ENDIF + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IUI3,105) RHOR1STAR,RHOR2STAR + RHOR(JE,JM,NNL,1,1)=CONJG(RHOR1STAR) + RHOR(JE,JM,NNL,2,1)=CONJG(RHOR2STAR) + ENDDO + 333 VK(JE)=VK(JE)*A + VK2(JE)=CABS(VK(JE)*VK(JE)) + ENDDO + ENDIF +C + CLOSE(IUI2) + CLOSE(IUI3) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL.EQ.1).AND.(LMAX_MODE.NE.0)) THEN + CALL SUP_ZEROS(TL,LMAX,NE,NAT2,IUO1,ITRTL) + ENDIF + + ENDIF +C +C.......... Reading of the TL and radial matrix elements files .......... +C.......... (Coulomb excitation case) .......... +C + IF((INTERACT.EQ.'COULOMB').OR.(INTERACT.EQ.'DIPCOUL')) THEN + IERR=0 + IF(INTERACT.EQ.'COULOMB') THEN + IRD1=IUI2 + IRD2=IUI3 + ELSEIF(INTERACT.EQ.'DIPCOUL') THEN + IRD1=IUI7 + IRD2=IUI8 + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,419) + READ(IRD1,3) NAT1_A,NE1_A,ITL_A,IPOTC_A,LMAX_MODE_A + IF(ISPIN.EQ.0) THEN + IF(NAT1_A.EQ.1) THEN + WRITE(IUO1,561) + ELSE + WRITE(IUO1,560) NAT1_A + ENDIF + ENDIF + IF((ITL_A.EQ.1).AND.(ISPIN.EQ.1)) THEN + READ(IRD1,530) E_MIN_A,E_MAX_A,DE_A + ENDIF + IF(ITL_A.EQ.1) THEN + READ(IRD2, *) RIEN + READ(IRD2, *) RIEN + READ(IRD2, *) RIEN + READ(IRD2,107) LI_C2,LI_I2,LI_A2 + READ(IRD2,117) LE_MIN1,N_CHANNEL + LE_MAX1=LE_MIN1+N_CHANNEL-1 + IF(I_TEST_A.NE.1) THEN + IF((LE_MIN.NE.LE_MIN1).OR.(LE_MAX.NE.LE_MAX1)) GOTO 610 + ELSE + LI_C2=0 + LI_I2=1 + LI_A2=0 + LE_MIN1=1 + N_CHANNEL=1 + ENDIF + ENDIF + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.0)) THEN + NLG=INT(NAT1_A-0.0001)/4 +1 + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT1_A + READ(IRD1,555) (LMAX_A(JAT,1),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,1),JAT=JD,NRL) + ENDDO +C +C Temporary storage of LMAX_A. Waiting for a version of PHAGEN +C with LMAX_A dependent on the energy +C + DO JE=1,NE1_A + DO JAT=1,NAT1_A + LMAX_A(JAT,JE)=LMAX_A(JAT,1) + ENDDO + ENDDO +C + NL1_A=1 + DO JAT=1,NAT1_A + NL1_A=MAX0(NL1_A,LMAX_A(JAT,1)+1) + ENDDO + IF(NL1_A.GT.NL_M) GOTO 184 + ENDIF + IF(ITL_A.EQ.0) READ(IRD2,101) NATR_A,NER_A + IF(ISPIN.EQ.1) THEN + READ(IRD2,106) L_IN_A,NATR_A,NER_A + IF(LI_C.NE.L_IN_A) GOTO 606 + ENDIF + NAT2_A=NAT+NATA + NAT2=NAT2_A + IF((NAT1_A.NE.NAT2_A).OR.(NE1_A.NE.NE_A)) GOTO 180 + IF((ITL_A.EQ.0).AND.((NATR_A.NE.NAT2_A).OR.(NER_A.NE.NE))) + 1 GOTO 182 +C +C.......... DL generated by MUFPOT and RHOR given .......... +C.......... by S. M. Goldberg, C. S. Fadley .......... +C.......... and S. Kono, J. Electron Spectr. .......... +C.......... Relat. Phenom. 21, 285 (1981) .......... +C + IF(ITL_A.EQ.0) THEN + CONTINUE + ELSE +C +C.......... TL_A and RHOR_A calculated by PHAGEN .......... +C + DO JE=1,NE_A + NLG=INT(NAT2_A-0.0001)/4 +1 + IF(NE_A.GT.1) WRITE(IUO1,563) JE + DO NN=1,NLG + NRL=4*NN + JD=4*(NN-1)+1 + IF(NN.EQ.NLG) NRL=NAT2_A + READ(IRD1,555) (LMAX_A(JAT,JE),JAT=JD,NRL) + WRITE(IUO1,556) (LMAX_A(JAT,JE),JAT=JD,NRL) + ENDDO + DO JAT=1,NAT2_A + READ(IRD1,*) DUMMY + DO L=0,LMAX_A(JAT,JE) + IF(LMAX_MODE_A.EQ.0) THEN + READ(IRD1,9) VK_A(JE),TLSTAR + ELSE +CST READ(IRD1,7) VK_A(JE),TLSTAR + READ(IRD1,9) VK_A(JE),TLSTAR + ENDIF + TL_A(L,1,JAT,JE)=CONJG(TLSTAR) + VK_A(JE)=CONJG(VK_A(JE)) + ENDDO + ENDDO +C + IF(IFTHET_A.EQ.1) GOTO 331 + DO LE=LE_MIN,LE_MAX + DO JEMET=1,NEMET + JM=IEMET(JEMET) + READ(IRD2,109) L_E,LB_MIN,LB_MAX + IF(I_TEST_A.EQ.1) THEN + L_E=1 + LB_MIN=0 + LB_MAX=1 + ENDIF + IF(LE.NE.L_E) IERR=1 + L_BOUNDS(L_E,1)=LB_MIN + L_BOUNDS(L_E,2)=LB_MAX + DO LB=LB_MIN,LB_MAX + READ(IRD2,108) L_A,RAD_D,RAD_E + RHOR_A(LE,JM,L_A,1,1)=RAD_D + RHOR_A(LE,JM,L_A,2,1)=RAD_E + IF(I_TEST_A.EQ.1) THEN + IF(LB.EQ.LB_MIN) THEN + RHOR_A(LE,JM,L_A,1,1)=(0.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(1.0,0.0) + ELSEIF(LB.EQ.LB_MAX) THEN + RHOR_A(LE,JM,L_A,1,1)=(1.0,0.0) + RHOR_A(LE,JM,L_A,2,1)=(0.0,0.0) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + 331 VK_A(JE)=VK_A(JE)*A + VK2_A(JE)=CABS(VK_A(JE)*VK_A(JE)) + ENDDO + ENDIF +C + CLOSE(IRD1) + CLOSE(IRD2) +C +C.......... Suppression of possible zeros in the TL array .......... +C.......... (in case of the use of matrix inversion and .......... +C.......... for energy variations) .......... +C + IF((ISPIN.EQ.0).AND.(ITL_A.EQ.1).AND.(LMAX_MODE_A.NE.0)) THEN + CALL SUP_ZEROS(TL_A,LMAX_A,NE_A,NAT2_A,IUO1,ITRTL) + ENDIF + IF(SPECTRO.EQ.'APC') WRITE(IUO1,420) +C + ENDIF +C +C.......... Check of the consistency of the two TL and radial .......... +C.......... matrix elements for APECS .......... +C + IF(SPECTRO.EQ.'APC') THEN +C + I_TL_FILE=0 + I_RD_FILE=0 +C + IF(NAT1.NE.NAT1_A) I_TL_FILE=1 + IF(NE1.NE.NE1_A) I_TL_FILE=1 + IF(ITL.NE.ITL_A) I_TL_FILE=1 + IF(IPOTC.NE.IPOTC_A) I_TL_FILE=1 +C + IF(LI_C.NE.LI_C2) I_RD_FILE=1 + IF(LI_I.NE.LI_I2) I_RD_FILE=1 + IF(LI_A.NE.LI_A2) I_RD_FILE=1 +C + IF(I_TL_FILE.EQ.1) GOTO 608 + IF(I_RD_FILE.EQ.1) GOTO 610 + IF(IERR.EQ.1) GOTO 610 +C + ENDIF +C +C.......... Calculation of the scattering factor (only) .......... +C + IF((IFTHET.EQ.0).AND.(IFTHET_A.EQ.0)) GO TO 8 + IF(IFTHET.EQ.1) THEN +c CALL PLOTFD(A,LMAX,ITL,NL1,NAT2,NE) + ELSEIF(IFTHET_A.EQ.1) THEN +c CALL PLOTFD_A(A,LMAX_A,ITL_A,NL1_A,NAT2_A,NE_A) + ENDIF + WRITE(IUO1,57) +CST STOP + GOTO 999 +C + 8 IF(IBAS.EQ.0) THEN +C +C............... Reading of an external cluster ............... +C +C +C Cluster originating from CLUSTER_NEW.F : IPHA=0 +C Cluster originating from PHAGEN_NEW.F : IPHA=1 (atomic units), IPHA=2 (angstroems) +C Other cluster : the first line must be text; then +C free format : Atomic number,X,Y,Z,number +C of the corresponding prototypical atom ; +C All atoms corresponding to the same +C prototypical atom must follow each other. +C Moreover, the blocks of equivalent atoms +C must be ordered by increasing number of +C prototypical atom. +C + VALZ_MIN=1000.0 + VALZ_MAX=-1000.0 +C + OPEN(UNIT=IUI4, FILE=INFILE4, STATUS='OLD') + READ(IUI4,778,ERR=892) IPHA + GOTO 893 + 892 IPHA=3 + IF(UNIT.EQ.'ANG') THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + ELSEIF(UNIT.EQ.'LPU') THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(UNIT.EQ.'ATU') THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + ELSE + GOTO 890 + ENDIF + 893 NATCLU=0 + DO JAT=1,NAT2 + NATYP(JAT)=0 + ENDDO + IF(IPHA.EQ.0) THEN + CUNIT=1. + TUNIT='UNITS OF THE LATTICE PARAMETER' + ELSEIF(IPHA.EQ.1) THEN + CUNIT=BOHR/A + TUNIT='ATOMIC UNITS' + IEMET(1)=1 + ELSEIF(IPHA.EQ.2) THEN + CUNIT=1./A + TUNIT='ANGSTROEMS' + IEMET(1)=1 + ENDIF + IF(IPRINT.EQ.2) THEN + IF(I_AT.NE.1) THEN + WRITE(IUO1,558) IUI4,TUNIT + IF(IPHA.EQ.3) WRITE(IUO1,549) + ENDIF + ENDIF + JATM=0 + DO JLINE=1,10000 + IF(IPHA.EQ.0) THEN + READ(IUI4,125,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.1) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.2) THEN + READ(IUI4,779,END=780) R,NN,X,Y,Z,JAT + ELSEIF(IPHA.EQ.3) THEN + READ(IUI4,*,END=780) NN,X,Y,Z,JAT + ENDIF + JATM=MAX0(JAT,JATM) + NATCLU=NATCLU+1 + IF(IPHA.NE.3) THEN + CHEM(JAT)=R + ELSE + CHEM(JAT)='XX' + ENDIF + NZAT(JAT)=NN + NATYP(JAT)=NATYP(JAT)+1 + COORD(1,NATCLU)=X*CUNIT + COORD(2,NATCLU)=Y*CUNIT + COORD(3,NATCLU)=Z*CUNIT + VALZ(NATCLU)=Z*CUNIT + IF((IPRINT.GE.2).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,557) NATCLU,COORD(1,NATCLU),COORD(2,NATCLU), + 1 COORD(3,NATCLU),JAT,NATYP(JAT),CHEM(JAT) + ENDIF + ENDDO + 780 NBZ=NATCLU + IF(JATM.NE.NAT) GOTO 514 + CLOSE(IUI4) +C + IF(NATCLU.GT.NATCLU_M) GOTO 510 + DO JA1=1,NATCLU + DO JA2=1,NATCLU + DIST12(JA1,JA2)=SQRT((COORD(1,JA1)-COORD(1,JA2))**2 + 1 +(COORD(2,JA1)-COORD(2,JA2))**2 + 2 +(COORD(3,JA1)-COORD(3,JA2))**2) + IF((JA2.GT.JA1).AND.(DIST12(JA1,JA2).LT.0.001)) GOTO 895 + ENDDO + ENDDO +C + D_UP=VALZ_MAX-VALZ(1) + D_DO=VALZ(1)-VALZ_MIN + IF((D_DO.LE.D_UP).AND.(I_GR.EQ.2)) THEN + I_INV=1 + ELSE + I_INV=0 + ENDIF + ELSE +C +C............... Construction of an internal cluster ............... +C + CALL BASE + CALL ROTBAS(ROT) + IF(IVG0.EQ.2) THEN + NMAX=NIV+1 + ELSE + NMAX=(2*NIV+1)**3 + ENDIF + IF((IPRINT.EQ.2).AND.(IVG0.LE.1)) THEN + WRITE(IUO1,37) + WRITE(IUO1,38) NIV + DO NUM=1,NMAX + CALL NUMAT(NUM,NIV,IA,IB,IC) + WRITE(IUO1,17) NUM,IA,IB,IC + ENDDO + WRITE(IUO1,39) + ENDIF + CALL AMAS(NIV,ATOME,COORD,VALZ,IESURF,COUPUR,ROT, + 1 IRE,NATYP,NBZ,NAT2,NCOUCH,NMAX) + IF((IREL.GE.1).OR.(NRELA.GT.0)) THEN + CALL RELA(NBZ,NPLAN,NAT2,VALZ,VAL2,VAL,COORD,NATYP,REL, + 1 NCOUCH) + IF(IREL.EQ.1) THEN + DO JP=1,NPLAN + VAL(JP)=VAL2(JP) + ENDDO + ENDIF + ENDIF + ENDIF +C +C Storage of the extremal values of x and y for each plane. They define +C the exterior of the cluster when a new cluster has to be build to +C support a point-group +C + IF(I_GR.GE.1) THEN + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + WRITE(IUO1,29) K,VAL(K) + X_MAX(K)=0. + X_MIN(K)=0. + Y_MAX(K)=0. + Y_MIN(K)=0. + ENDDO + ENDIF + DO JAT=1,NATCLU + X=COORD(1,JAT) + Y=COORD(2,JAT) + Z=COORD(3,JAT) + DO JPLAN=1,NPLAN + IF(ABS(Z-VAL(JPLAN)).LT.SMALL) THEN + X_MAX(JPLAN)=MAX(X,X_MAX(JPLAN)) + X_MIN(JPLAN)=MIN(X,X_MIN(JPLAN)) + Y_MAX(JPLAN)=MAX(Y,Y_MAX(JPLAN)) + Y_MIN(JPLAN)=MIN(Y,Y_MIN(JPLAN)) + ENDIF + ENDDO + ENDDO + ENDIF +C +C Instead of the symmetrization of the cluster (this version only) +C + N_PROT=NAT + NAT_ST=0 + DO JTYP=1,JATM + NB_AT=NATYP(JTYP) + IF(NB_AT.GT.NAT_EQ_M) GOTO 614 + DO JA=1,NB_AT + NAT_ST=NAT_ST+1 + NCORR(JA,JTYP)=NAT_ST + ENDDO + ENDDO + DO JC=1,3 + DO JA=1,NATCLU + SYM_AT(JC,JA)=COORD(JC,JA) + ENDDO + ENDDO +C +C Checking surface-like atoms for mean square displacements +C calculations +C + CALL CHECK_VIB(NAT2) +C +C.......... Set up of the variables used for an internal .......... +C.......... calculation of the mean free path and/or of .......... +C.......... the mean square displacements .......... +C + IF((IDCM.EQ.1).OR.(ILPM.EQ.1)) THEN + DO JTYP=1,NAT2 + XMT(JTYP)=XMAT(NZAT(JTYP)) + RHOT(JTYP)=RHOAT(NZAT(JTYP)) + ENDDO + XMTA=XMT(1) + RHOTA=RHOT(1) + NZA=NZAT(1) + ENDIF + IF(IDCM.GT.0) THEN + CALL CHNOT(3,VECBAS,VEC) + DO J=1,3 + VB1(J)=VEC(J,1) + VB2(J)=VEC(J,2) + VB3(J)=VEC(J,3) + ENDDO + CPR=1. + CALL PRVECT(VB2,VB3,VBS,CPR) + VM=PRSCAL(VB1,VBS) + QD=(6.*PI*PI*NAT/VM)**(1./3.) + ENDIF +C +C.......... Writing of the contents of the cluster, .......... +C.......... of the position of the different planes .......... +C.......... and of their respective absorbers in .......... +C.......... the control file IUO1 .......... +C + IF(I_AT.EQ.1) GOTO 153 + IF((IPRINT.EQ.2).AND.(IBAS.GT.0)) THEN + WRITE(IUO1,40) + NCA=0 + DO J=1,NAT + DO I=1,NMAX + NCA=NCA+1 + WRITE(IUO1,20) J,I + WRITE(IUO1,21) (ATOME(L,NCA),L=1,3) + K=IRE(NCA,1) + IF(K.EQ.0) THEN + WRITE(IUO1,22) + ELSE + WRITE(IUO1,23) (COORD(L,K),L=1,3),IRE(NCA,2) + ENDIF + ENDDO + ENDDO + WRITE(IUO1,41) + ENDIF + IF(IBAS.EQ.1) THEN + WRITE(IUO1,24) + NATCLU=0 + DO I=1,NAT + NN=NATYP(I) + NATCLU=NATCLU+NATYP(I) + WRITE(IUO1,26) NN,I + ENDDO + IF(IADS.EQ.1) NATCLU=NATCLU+NADS1+NADS2+NADS3 + WRITE(IUO1,782) NATCLU + IF(NATCLU.GT.NATCLU_M) GOTO 516 + IF(IPRINT.EQ.3) WRITE(IUO1,559) + IF(IPRINT.EQ.3) THEN + NBTA=0 + DO JT=1,NAT2 + NBJT=NATYP(JT) + DO JN=1,NBJT + NBTA=NBTA+1 + WRITE(IUO1,557) NBTA,COORD(1,NBTA),COORD(2,NBTA), + 1 COORD(3,NBTA),JT,JN,CHEM(JT) + ENDDO + ENDDO + ENDIF + ENDIF + 153 IF((ITEST.EQ.1).AND.(IBAS.GT.0)) THEN + CALL TEST(NIV,ROT,NATYP,NBZ,NAT2,IESURF,COUPUR,*56) + ENDIF + IF((IREL.EQ.0).OR.(IBAS.EQ.0)) THEN + CALL ORDRE(NBZ,VALZ,NPLAN,VAL) + IF(I_AT.EQ.0) WRITE(IUO1,50) NPLAN + DO K=1,NPLAN + IF(I_AT.EQ.0) WRITE(IUO1,29) K,VAL(K) + ENDDO + ENDIF +C + IF(I_AT.EQ.0) WRITE(IUO1,30) + IF((IPRINT.GT.0).AND.(I_AT.EQ.0)) THEN + WRITE(IUO1,31) (IEMET(J),J=1,NEMET) + ENDIF + ZEM=1.E+20 + DO L=1,NPLAN + Z=VAL(L) + DO JEMED=1,NEMET + CALL EMETT(JEMED,IEMET,Z,COORD,NATYP,EMET,NTEM,JNEM,*93) + IF(I_AT.EQ.0) WRITE(IUO1,34) L,NTEM,EMET(1),EMET(2),EMET(3) + IF((IPHA.EQ.1).OR.(IPHA.EQ.2)) ZEM=EMET(3) + GO TO 33 + 93 IF(I_AT.EQ.0) WRITE(IUO1,94) L,NTEM + 33 CONTINUE + ENDDO + ENDDO +C +C.......... Loop on the electrons involved in the .......... +C.......... spectroscopy : N_EL = 1 for PHD, XAS .......... +C.......... LEED or AED and N_EL = 2 for APC .......... +C + DO J_EL=1,N_EL +C +C.......... Writing the information on the spectroscopies .......... +C.......... in the control file IUO1 .......... +C + IF(SPECTRO.EQ.'XAS') GOTO 566 + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,236) + ELSE + WRITE(IUO1,248) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,245) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF +C +C---------- Photoelectron diffraction case (PHD) ---------- +C + IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,35) + ELSE + WRITE(IUO1,246) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,44) + IF(IE.EQ.1) WRITE(IUO1,58) + IF(INITL.EQ.0) WRITE(IUO1,118) + IF(I_TEST.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.1)) THEN + WRITE(IUO1,418) + WRITE(IUO1,18) + ENDIF + IF(J_EL.EQ.2) GOTO 222 + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + IF(INITL.NE.0) THEN + WRITE(IUO1,337) + WRITE(IUO1,91) + IF(IPOL.EQ.0) THEN + WRITE(IUO1,88) + ELSEIF(ABS(IPOL).EQ.1) THEN + WRITE(IUO1,87) + ELSEIF(IPOL.EQ.2) THEN + WRITE(IUO1,89) + ENDIF + WRITE(IUO1,91) + IF(IDICHR.GT.0) THEN + WRITE(IUO1,338) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,90) + WRITE(IUO1,43) THLUM,PHILUM + IF((SPECTRO.EQ.'PHD').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF + ENDIF +C + IF(INITL.EQ.2) THEN + WRITE(IUO1,79) LI,LI-1,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,111) JTE,RHOR(JE,JTE,NNL,1,1), + 1 RHOR(JE,JTE,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,444) JTE,DLT(JE,JTE,NNL,1), + 1 DLT(JE,JTE,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.-1) THEN + WRITE(IUO1,82) LI,LI-1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,1,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,1) + ENDIF + ENDIF + ENDDO + ENDDO + ELSEIF(INITL.EQ.1) THEN + WRITE(IUO1,82) LI,LI+1 + IF(I_SO.EQ.1) THEN + WRITE(IUO1,80) S_O + ENDIF + DO JE=1,NE + DO JEM=1,NEMET + JTE=IEMET(JEM) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,113) JTE,RHOR(JE,JTE,NNL,2,1) + IF(ITL.EQ.0) THEN + WRITE(IUO1,445) JTE,DLT(JE,JTE,NNL,2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + 222 CONTINUE + ENDIF +C +C---------- LEED case (LED) ---------- +C + IF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,252) + ELSE + WRITE(IUO1,258) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,254) + IF(IE.EQ.1) WRITE(IUO1,256) + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,260) + WRITE(IUO1,261) THLUM,PHILUM + IF((SPECTRO.EQ.'LED').AND.(IMOD.EQ.1)) THEN + WRITE(IUO1,45) + ENDIF +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF +C +C---------- Auger diffraction case (AED) ---------- +C + IF((SPECTRO.EQ.'AED').OR.(SPECTRO.EQ.'APC')) THEN + IF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,235) + ELSE + WRITE(IUO1,247) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,244) + IF(I_TEST_A.EQ.1) WRITE(IUO1,234) + ENDIF + IF((SPECTRO.EQ.'APC').AND.(J_EL.EQ.2)) THEN + WRITE(IUO1,419) + WRITE(IUO1,18) + ENDIF + IF((SPECTRO.EQ.'AED').OR.(J_EL.EQ.2)) THEN + IF(IPRINT.GT.0) THEN + WRITE(IUO1,92) + WRITE(IUO1,91) + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,335) + ELSE + WRITE(IUO1,336) + ENDIF + WRITE(IUO1,91) + IF(IPOTC_A.EQ.0) THEN + WRITE(IUO1,339) + ELSE + WRITE(IUO1,334) + ENDIF + WRITE(IUO1,91) + WRITE(IUO1,92) + WRITE(IUO1,95) AUGER + CALL AUGER_MULT + IF(I_MULT.EQ.0) THEN + WRITE(IUO1,154) + ELSE + WRITE(IUO1,155) MULTIPLET + ENDIF +C + DO JEM=1,NEMET + JTE=IEMET(JEM) + WRITE(IUO1,112) JTE + DO LE=LE_MIN,LE_MAX + WRITE(IUO1,119) LE + LA_MIN=L_BOUNDS(LE,1) + LA_MAX=L_BOUNDS(LE,2) + DO LA=LA_MIN,LA_MAX + IF(ISPIN.EQ.0) THEN + WRITE(IUO1,115) LA,RHOR_A(LE,JTE,LA,1,1), + 1 RHOR_A(LE,JTE,LA,2,1) + ENDIF + ENDDO + ENDDO + ENDDO +C + IF(I_AT.EQ.0) THEN + IF(INV(J_EL).EQ.0) THEN + IF(NDIF.EQ.1) THEN + IF(ISPHER.EQ.1) THEN + WRITE(IUO1,83) + ELSEIF(ISPHER.EQ.0) THEN + WRITE(IUO1,84) + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,97) NDIF + ELSE + WRITE(IUO1,98) NDIF + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,122) + ELSE + WRITE(IUO1,120) + ENDIF + ENDIF + ELSE + IF(ISPHER.EQ.0) THEN + WRITE(IUO1,85) + ELSE + WRITE(IUO1,86) + ENDIF + ENDIF +C + ENDIF + ENDIF + ENDIF +C +C.......... Check of the dimensioning of the treatment routine .......... +C + CALL STOP_TREAT(NFICHLEC,NPLAN,NEMET,NE,NTHETA,NTHETA_A, + 1 NPHI,NPHI_A,ISOM,I_EXT,I_EXT_A,SPECTRO) +C +C.......... Call of the subroutine performing either .......... +C.......... the PhD, LEED, AED, EXAFS or APECS calculation .......... +C + 566 IF(ISPIN.EQ.0) THEN + IF(SPECTRO.EQ.'PHD') THEN +c CALL PHDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'LED') THEN +c CALL LEDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'AED') THEN + CALL AEDDIF_MI_MU(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP, + 1 RHOR_A,NATCLU,NFICHLEC,JFICH,NP,LE_MIN, + 2 LE_MAX) + ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_MI(NPLAN,VAL,ZEM,IPHA,RHOR,NFICHLEC,JFICH,NP) + ELSEIF(SPECTRO.EQ.'APC') THEN +c IF(J_EL.EQ.1) THEN +c CALL PHDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(J_EL.EQ.2) THEN +c CALL AEDDIF_MI(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR_A, +c 1 NATCLU,NFICHLEC,JFICH,NP,LE_MIN,LE_MAX) +c ENDIF + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF(SPECTRO.EQ.'PHD') THEN +c CALL PHDDIF_SP(NPLAN,VAL,ZEM,IPHA,NAT2,COORD,NATYP,RHOR, +c 1 NATCLU,NFICHLEC,JFICH,NP) +c ELSEIF(SPECTRO.EQ.'AED') THEN +c CALL AEDDIF_SP +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL XASDIF_SP +c ENDIF + continue + ENDIF +C +C.......... End of the MS calculation : .......... +C.......... direct exit or treatment of the results .......... +C +C +C.......... End of the loop on the electrons .......... +C + ENDDO +C + IF(SPECTRO.EQ.'PHD') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,52) + ELSE + WRITE(IUO1,249) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,49) + IF(IE.EQ.1) WRITE(IUO1,59) + ELSEIF(SPECTRO.EQ.'LED') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,253) + ELSE + WRITE(IUO1,259) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,255) + IF(IE.EQ.1) WRITE(IUO1,257) + ELSEIF(SPECTRO.EQ.'XAS') THEN + WRITE(IUO1,51) + ELSEIF(SPECTRO.EQ.'AED') THEN + IF(IPHI_A.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,237) + ELSE + WRITE(IUO1,250) + ENDIF + ENDIF + IF(ITHETA_A.EQ.1) WRITE(IUO1,238) + ELSEIF(SPECTRO.EQ.'APC') THEN + IF(IPHI.EQ.1) THEN + IF(STEREO.EQ.' NO') THEN + WRITE(IUO1,239) + ELSE + WRITE(IUO1,251) + ENDIF + ENDIF + IF(ITHETA.EQ.1) WRITE(IUO1,240) + ENDIF +C + CLOSE(ICOM) + IF((NFICHLEC.GT.1).AND.(ISOM.NE.0)) THEN + WRITE(IUO1,562) + ENDIF + IF(ISOM.EQ.0) CLOSE(IUO2) +CST IF((ISOM.EQ.0).AND.(NFICHLEC.NE.1)) CLOSE(IUO1) +C +C.......... End of the loop on the data files .......... +C + ENDDO +C + IF(ISOM.NE.0) THEN + JFF=1 + IF(ISPIN.EQ.0) THEN + IF(SPECTRO.NE.'XAS') THEN + CALL TREAT_AED(ISOM,NFICHLEC,JFF,NP) + ELSE +c CALL TREAT_XAS(ISOM,NFICHLEC,NP) + ENDIF + ELSEIF(ISPIN.EQ.1) THEN +c IF((SPECTRO.EQ.'PHD').OR.(SPECTRO.EQ.'AED')) THEN +c CALL TREAT_PHD_SP(ISOM,NFICHLEC,JFF,NP) +c ELSEIF(SPECTRO.EQ.'XAS') THEN +c CALL TREAT_XAS_SP(ISOM,NFICHLEC,NP) +c ENDIF + continue + ENDIF + ENDIF +C +CST IF((ISOM.NE.0).OR.(NFICHLEC.EQ.1)) CLOSE(IUO1) + IF(ISOM.NE.0) CLOSE(IUO2) +CST STOP + GOTO 999 +C + 1 WRITE(IUO1,60) + STOP + 2 WRITE(IUO1,61) + STOP + 55 WRITE(IUO1,65) + STOP + 56 WRITE(IUO1,64) + STOP + 74 WRITE(IUO1,75) + STOP + 99 WRITE(IUO1,100) + STOP + 180 WRITE(IUO1,181) + STOP + 182 WRITE(IUO1,183) + STOP + 184 WRITE(IUO1,185) + STOP + 504 WRITE(IUO1,505) + STOP + 510 WRITE(IUO1,511) IUI4 + STOP + 514 WRITE(IUO1,515) + STOP + 516 WRITE(IUO1,517) + STOP + 518 WRITE(IUO1,519) + WRITE(IUO1,889) + STOP + 520 WRITE(IUO1,521) + STOP + 540 WRITE(IUO1,541) + STOP + 550 WRITE(IUO1,551) + STOP + 570 WRITE(IUO1,571) + STOP + 580 WRITE(IUO1,581) + STOP + 590 WRITE(IUO1,591) + STOP + 600 WRITE(IUO1,601) + STOP + 602 WRITE(IUO1,603) + STOP + 604 WRITE(IUO1,605) + STOP + 606 WRITE(IUO1,607) + STOP + 608 WRITE(IUO1,609) + STOP + 610 WRITE(IUO1,611) + STOP + 614 WRITE(IUO1,615) NB_AT + STOP + 620 WRITE(IUO1,621) LE_MAX + STOP + 630 WRITE(IUO1,631) + STOP + 890 WRITE(IUO1,891) + STOP + 895 WRITE(IUO1,896) JA1,JA2 +C + 3 FORMAT(5(5X,I4)) + 7 FORMAT(3X,F9.4,1X,F9.4,5X,F12.9,5X,F12.9) +CST 9 FORMAT(3X,F9.4,1X,F9.4,5X,E12.6,5X,E12.6) + 9 FORMAT(3X,F9.4,1X,F9.4,E18.6,E18.6) + 17 FORMAT(12X,'ATOM NUMBER ',I4,10X,'CORRESPONDING TRANSLATIONS ', + 1': (',I3,',',I3,',',I3,')') + 18 FORMAT(' ',/) + 20 FORMAT(/,7X,'ATOM OF TYPE ',I2,' AND OF NUMBER ',I5) + 21 FORMAT(17X,'COORDINATES IN THE TOTAL CLUSTER : (',F7.3,',', + 1 F7.3,',',F7.3,')') + 22 FORMAT(22X,'THIS ATOM HAS BEEN SUPRESSED IN THE REDUCED CLUSTER') + 23 FORMAT(17X,'COORDINATES IN THE REDUCED CLUSTER :(',F7.3,',', + 1 F7.3,',',F7.3,')',5X,'NEW NUMBER : ',I4) + 24 FORMAT(///,29X,'CONTENTS OF THE REDUCED CLUSTER :',/) + 26 FORMAT(28X,I4,' ATOMS OF TYPE ',I2) + 29 FORMAT(/,20X,'THE Z POSITION OF PLANE ',I3,' IS : ',F6.3) + 30 FORMAT(///,23X,'THE ABSORBING ATOMS ARE OF TYPE :',/) + 31 FORMAT(38X,10(I2,3X),//) + 34 FORMAT(//,2X,'PLANE No ',I3,3X,'THE ABSORBER OF TYPE ', + 1I2,' IS POSITIONED AT (',F7.3,',',F7.3,',',F7.3,')') + 35 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####',/////) + 36 FORMAT(/////,'########## BEGINNING ', + 1'OF THE EXAFS CALCULATION ##########',/////) + 37 FORMAT(/////,'++++++++++++++++++++', + 1' NUMBERING OF THE ATOMS GENERATED +++++++++++++++++++') + 38 FORMAT(///,30X,'TRANSLATION LEVEL : ',I2,///) + 39 FORMAT(///,'++++++++++++++++++++++++++++++++++++++++++++++++', + 1'++++++++++++++++++++++++++++++++',/////) + 40 FORMAT(/////,'======================', + 1' CONTENTS OF THE REDUCED CLUSTER ======================', + 2 ///) + 41 FORMAT(///,'====================================================', + 1'============================',/////) + 43 FORMAT(14X,'TH_LIGHT = ',F6.2,' DEGREES',5X,'PHI_LIGHT = ', + 1 F6.2,' DEGREES') + 44 FORMAT(/////,'########## BEGINNING ', + 1'OF THE POLAR PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####',/////) + 45 FORMAT(14X,' (WHEN THE DETECTOR IS ALONG ', + 1 'THE NORMAL TO THE SURFACE)') + 49 FORMAT(/////,'########## END OF THE ', + 1'POLAR PHOTOELECTRON DIFFRACTION CALCULATION ##########') + 50 FORMAT(///,22X,'THE CLUSTER IS COMPOSED OF ',I2,' PLANES :') + 51 FORMAT(/////,'########## END OF THE ', + 1'EXAFS CALCULATION ##########') + 52 FORMAT(/////,'########## END OF THE ', + 1'AZIMUTHAL PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####') + 57 FORMAT(///,27X,'CALCULATION OF THE SCATTERING FACTOR DONE') + 58 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FINE STRUCTURE OSCILLATIONS CALCULATION #####', + 2'#####',/////) + 59 FORMAT(/////,'########## END OF THE ', + 1'FINE STRUCTURE OSCILLATIONS CALCULATION #####', + 2'#####') + 60 FORMAT(///,'<<<<<<<<<< (NAT,NE,NEMET) > (NATP_M,NE_M,', + 1 'NEMET_M) - CHECK THE DIMENSIONING >>>>>>>>>>') + 61 FORMAT(///,22X,' <<<<<<<<<< THIS STRUCTURE DOES NOT EXIST ', + 1' >>>>>>>>>>') + 64 FORMAT(///,4X,' <<<<<<<<<< NIV IS TOO SMALL, THE REDUCED ', + 1'CLUSTER HAS NOT CONVERGED YET >>>>>>>>>>') + 65 FORMAT(///,4X,' <<<<<<<<<< ONLY ONE OF THE VALUES IPHI,ITHETA ', + 1'ET IE CAN BE EQUAL TO 1 >>>>>>>>>>') + 75 FORMAT(///,8X,' <<<<<<<<<< CHANGE THE DIMENSIONING OF PCREL ', + 1'IN MAIN ET READ_DATA >>>>>>>>>>') + 79 FORMAT(//,18X,'INITIAL STATE L = ',I1,5X,'FINAL STATES L = ', + 1I1,',',I1,/) + 80 FORMAT(15X,'(SPIN-ORBIT COMPONENT OF THE INITIAL CORE STATE : ', + 1 A3,')',//) + 81 FORMAT(18X,'(BOTH SPIN-ORBIT COMPONENTS TAKEN INTO ACCOUNT)') + 82 FORMAT(//,21X,'INITIAL STATE L = ',I1,5X,'FINAL STATE L = ',I1) + 83 FORMAT(//,32X,'(SPHERICAL WAVES)') + 84 FORMAT(//,34X,'(PLANE WAVES)') + 85 FORMAT(//,26X,'(PLANE WAVES - ATOMIC CASE)') + 86 FORMAT(//,24X,'(SPHERICAL WAVES - ATOMIC CASE)') + 87 FORMAT(24X,'+ LINEARLY POLARIZED LIGHT +') + 88 FORMAT(24X,'+ NON POLARIZED LIGHT +') + 89 FORMAT(24X,'+ CIRCULARLY POLARIZED LIGHT +') + 90 FORMAT(////,31X,'POSITION OF THE LIGHT :',/) + 91 FORMAT(24X,'+',35X,'+') + 92 FORMAT(24X,'+++++++++++++++++++++++++++++++++++++') + 94 FORMAT(//,2X,'PLANE No ',I3,3X,'NO ABSORBER OF TYPE ',I2, + 1' IS PRESENT IN THIS PLANE') + 95 FORMAT(////,31X,'AUGER LINE :',A6,//) + 97 FORMAT(///,19X,'(PLANE WAVES MULTIPLE SCATTERING - ORDER ',I1, + 1 ')') + 98 FORMAT(///,17X,'(SPHERICAL WAVES MULTIPLE SCATTERING - ORDER ', + 1 I1,')') + 100 FORMAT(///,8X,'<<<<<<<<<< WRONG NAME FOR THE INITIAL STATE', + 1 ' >>>>>>>>>>') + 101 FORMAT(24X,I3,24X,I3) + 102 FORMAT(A1) + 103 FORMAT(31X,F7.2) + 104 FORMAT(29X,F8.5,4X,F8.5,7X,F8.5,4X,F8.5) + 105 FORMAT(1X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,E12.5,1X,E12.5, + 1 2X,E12.5,1X,E12.5,2X,E12.5,1X,E12.5,4X,A9) + 106 FORMAT(12X,I3,12X,I3,12X,I3) + 107 FORMAT(5X,I2,5X,I2,5X,I2) + 108 FORMAT(19X,I2,8X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5) + 109 FORMAT(5X,I2,12X,I2,11X,I2) + 110 FORMAT(16X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ',I2, + 1 ' :',/,22X,'(THE SPIN DOUBLET IS GIVEN AS : OUT/IN)',//) + 111 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ', + 1 I2,' : (',F8.5,',',F8.5,')',/,59X,'(',F8.5,',',F8.5,')') + 112 FORMAT(6X,'RADIAL MATRIX ELEMENTS FOR THE ABSORBER OF TYPE ', + 1 I2,' : ',/,8X,'(LE : ALLOWED VALUES FOR ESCAPING AUGER', + 2 ' ELECTRON)',/, + 2 8X,'(L : INTERNAL VALUE THAT WILL BE SUMMED ON)',//) + 113 FORMAT(6X,'RADIAL MATRIX ELEMENT FOR THE ABSORBER OF ', + * 'TYPE ',I2,' : (',F8.5,',',F8.5,')') + 114 FORMAT(/) + 115 FORMAT(15X,'L = ',I2,5X,'(',F8.5,',',F8.5,')',5X, + 1 '(',F8.5,',',F8.5,')') + 117 FORMAT(12X,I2,5X,I2) + 118 FORMAT(/,37X,'AUGER ELECTRON DIFFRACTION',/) + 119 FORMAT(10X,'LE = ',I2,11X,'DIRECT INTEGRAL',8X, + 1 'EXCHANGE INTEGRAL') + 120 FORMAT(///,15X,'(SPHERICAL WAVES MULTIPLE SCATTERING - MATRIX ', + 1 'INVERSION)') + 122 FORMAT(///,17X,'(PLANE WAVES MULTIPLE SCATTERING - MATRIX ', + 1 'INVERSION)') + 125 FORMAT(11X,A2,5X,I2,3F10.4,12X,I4) + 154 FORMAT(///,20X,'CALCULATION MADE FOR THE FULL AUGER LINE', + 1 ' ',/,' ',/,' ') + 155 FORMAT(///,20X,'CALCULATION MADE FOR THE ',A3,' MULTIPLET ', + 1 'LINE',' ',/,' ',/,' ') + 181 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + 1 'AND PHASE SHIFTS FILES >>>>>>>>>>') + 183 FORMAT(///,'<<<<<<<<<< NAT OR NE DIFFERENT BETWEEN THE INPUT ', + 1 'AND RADIAL MATRIX ELEMENTS FILES >>>>>>>>>>') + 185 FORMAT(///,'<<<<<<<<<< LMAX > NL_M-1 IN THE PHASE SHIFTS ', + 1 'FILE >>>>>>>>>>') + 234 FORMAT(' -----> TEST CALCULATION : NO EXCITATION ', + 1 'MATRIX ELEMENTS TAKEN INTO ACCOUNT <-----',///) + 235 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 236 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 237 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 238 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 239 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 240 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 244 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 245 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 246 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE PHOTOELECTRON DIFFRACTION CALCULATION ', + 2'##########',/////) + 247 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE AUGER DIFFRACTION CALCULATION ', + 2'##########',/////) + 248 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE APECS DIFFRACTION CALCULATION ', + 2'##########',/////) + 249 FORMAT(/////,'########## END OF THE ', + 1'FULL ANGLE PHOTOELECTRON DIFFRACTION CALCULATION #####', + 2'#####') + 250 FORMAT(/////,'########## END ', + 1'OF THE FULL ANGLE AUGER DIFFRACTION CALCULATION #####', + 2'#####',/////) + 251 FORMAT(/////,'########## END ', + 1'OF THE FULL ANGLE APECS DIFFRACTION CALCULATION #####', + 2'#####',/////) + 252 FORMAT(/////,'########## BEGINNING ', + 1'OF THE AZIMUTHAL LEED CALCULATION #####', + 2'#####',/////) + 253 FORMAT(/////,'########## END ', + 1'OF THE AZIMUTHAL LEED CALCULATION #####', + 2'#####',/////) + 254 FORMAT(/////,6X,'########## BEGINNING ', + 1'OF THE POLAR LEED CALCULATION #####', + 2'#####',/////) + 255 FORMAT(/////,6X,'########## END ', + 1'OF THE POLAR LEED CALCULATION #####', + 2'#####',/////) + 256 FORMAT(/////,5X,'########## BEGINNING ', + 1'OF THE ENERGY LEED CALCULATION #####', + 2'#####',/////) + 257 FORMAT(/////,5X,'########## END ', + 1'OF THE ENERGY LEED CALCULATION #####', + 2'#####',/////) + 258 FORMAT(/////,'########## BEGINNING ', + 1'OF THE FULL ANGLE LEED CALCULATION ', + 2'##########',/////) + 259 FORMAT(/////,'########## END OF THE ', + 1'FULL ANGLE LEED CALCULATION #####', + 2'#####') + 260 FORMAT(////,31X,'POSITION OF THE INITIAL BEAM :',/) + 261 FORMAT(14X,'TH_BEAM = ',F6.2,' DEGREES',5X,'PHI_BEAM = ', + 1 F6.2,' DEGREES') + 334 FORMAT(24X,'+ COMPLEX POTENTIAL CALCULATION +') + 335 FORMAT(24X,'+ STANDARD +') + 336 FORMAT(24X,'+ SPIN-POLARIZED +') + 337 FORMAT(24X,'+ WITH +') + 338 FORMAT(24X,'+ IN DICHROIC MODE +') + 339 FORMAT(24X,'+ REAL POTENTIAL CALCULATION +') + 418 FORMAT(///,9X,'------------------------ FIRST ELECTRON : ', + 1 '------------------------') + 419 FORMAT(///,9X,'------------------------ SECOND ELECTRON : ', + 1 '------------------------') + 420 FORMAT(///,9X,'----------------------------------------------', + 1 '----------------------') + 444 FORMAT(12X,'PHASE SHIFTS FOR THE ABSORBER OF TYPE ',I2,' : ', + 1 '(',F8.5,',',F8.5,')',/,56X,'(',F8.5,',',F8.5,')') + 445 FORMAT(12X,'PHASE SHIFT FOR THE ABSORBER OF TYPE ',I2,' : (', + 1 F8.5,',',F8.5,')') + 505 FORMAT(///,'<<<<<<<<<< LI IS LARGER THAN LI_M - ', + 1 'CHECK THE DIMENSIONING >>>>>>>>>>') + 511 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT ', + 1 'CONSISTENT WITH THE NUMBER OF ATOMS READ FROM UNIT ',I2, + 2 ' >>>>>>>>>>') + 515 FORMAT(///,'<<<<<<<<<< INCOMPATIBILITY BETWEEN THE VALUES OF ', + 1 'NAT IN THE DATA AND CLUSTER FILES >>>>>>>>>>') + 517 FORMAT(///,'<<<<<<<<<< THERE ARE MISSING VALUES FOR THFWD AND ', + 1 'IBWD >>>>>>>>>>') + 519 FORMAT(///,'<<<<<<<<<< NATCLU_M IN THE .inc FILE IS NOT', + 1 ' CONSISTENT WITH THE NUMBER OF ATOMS GENERATED BY THE ', + 2 'CODE >>>>>>>>>>') + 521 FORMAT(///,'<<<<<<<<<< SPIN-ORBIT COMPONENT NOT CONSISTENT WITH', + 1 ' THE VALUE OF LI >>>>>>>>>>') + 530 FORMAT(3X,F9.4,3X,F9.4,3X,F9.4) + 535 FORMAT(29X,F8.5,1X,F8.5) + 541 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES THFWD DOES NOT ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 543 FORMAT(5X,F12.9,5X,F12.9) + 549 FORMAT(//,14X,' No ',10X,'COORDINATES',9X,'TYPE',2X, + 2 'SNo',2X,'SYM',/) + 551 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES UJ2 DOES NOT ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 555 FORMAT(4(7X,I2)) + 556 FORMAT(28X,4(I2,5X)) + 557 FORMAT(13X,I4,3X,'(',F7.3,',',F7.3,',',F7.3,')',2X,I4,2X,I4, + 1 3X,A2) + 558 FORMAT(/////,18X,'CONTENTS OF THE CLUSTER READ FROM UNIT ', + 1 I2,' : ',/,20X,'READ IN ',A30,//,15X,'No',13X,'(X,Y,Z)', + 2 10X,'CLASS',1X,'ATOM',/) + 559 FORMAT(/////,25X,'CONTENTS OF THE CLUSTER GENERATED : ',//, + 1 14X,' No ',10X,'COORDINATES',9X,'TYPE',2X,'SNo',2X,'SYM',/) + 560 FORMAT(////,12X,'MAXIMAL VALUES OF L FOR THE ',I3, + 1 ' PROTOTYPICAL ATOMS : ',//) + 561 FORMAT(////,18X,'MAXIMAL VALUE OF L FOR THE ', + 1 'PROTOTYPICAL ATOM : ',//) + 562 FORMAT(///,'oooooooooooooooo',12X,'END OF THE INPUT DATA FILE', + 1 13X,'oooooooooooooooo',///) + 563 FORMAT(//,20X,'ENERGY POINT No ',I3,' :',/) + 571 FORMAT(///,'<<<<<<<<<< THE NUMBER OF LINES ATBAS DOES NOT ', + 1 'CORRESPOND TO NAT >>>>>>>>>>') + 581 FORMAT(///,'<<<<<<<<<< LI OR IMOD NOT CONSISTENT BETWEEN ', + 1 'PHD AND AED FOR COINCIDENCE CALCULATION >>>>>>>>>>') + 591 FORMAT(///,'<<<<<<<<<< THE EXTERNAL DIRECTIONS FILE IS ', + 1 'NOT CONSISTENT WITH THE INPUT DATA FILE >>>>>>>>>>') + 601 FORMAT(///,'<<<<<<<<<< NO_ST_M IS TOO SMALL IN THE .inc FILE ', + 1 '>>>>>>>>>>',//) + 603 FORMAT(///,'<<<<<<<<<< NSPIN_M OR NSPIN2_M IS TOO SMALL IN THE ', + 1 '.inc FILE >>>>>>>>>>',//) + 605 FORMAT(///,'<<<<<<<<<< NT_M IS TOO SMALL IN THE .inc FILE ', + 1 '>>>>>>>>>>',//) + 607 FORMAT(///,'<<<<<<<<<< THE INITIAL STATE LI IN THE INPUT DATA ', + 1 'FILE IS DIFFERENT FROM THAT IN THE RADIAL MATRIX ', + 2 'ELEMENTS FILE >>>>>>>>>>',//) + 609 FORMAT(///,'<<<<<<<<<< THE TWO TL FILE ARE NOT COMPATIBLE ', + 1 '>>>>>>>>>>',//) + 611 FORMAT(///,3X,'<<<<<<<<<< THE RADIAL FILE FOR THE AUGER ', + 1 'ELECTRON IS NOT COMPATIBLE >>>>>>>>>>',/, + 2 3X,'<<<<<<<<<< ',17X,'WITH THE INPUT DATA FILE ', + 3 16X,'>>>>>>>>>>',//) + 613 FORMAT(///,'<<<<<<<<<< NATP_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 615 FORMAT(///,'<<<<<<<<<< NAT_EQ_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 621 FORMAT(///,'<<<<<<<<<< LI_M SHOULD BE AT LEAST ',I3,' IN ', + 1 'THE DIMENSIONNING FILE >>>>>>>>>>',//) + 631 FORMAT(///,'<<<<<<<<<< EXCURSIONS OF ANGLES SHOULD ', + 1 ' BE IDENTICAL >>>>>>>>>>',/,'<<<<<<<<<< ', + 2 'FOR BOTH ELECTRONS IN CLUSTER ROTATION MODE', + 3 ' >>>>>>>>>>',//) + 776 FORMAT(I2) + 777 FORMAT(A24) + 778 FORMAT(30X,I1) + 779 FORMAT(11X,A2,5X,I2,3F10.4,I5) + 782 FORMAT(/////,22X,'THE CLUSTER GENERATED CONSISTS OF : ',I4, + 1 ' ATOMS') + 889 FORMAT(/////,'<<<<<<<<<< DECREASE NIV OR INCREASE', + 1 ' NATCLU_M >>>>>>>>>>') + 891 FORMAT(/////,'<<<<<<<<<< WRONG NAME FOR THE COORDINATES ''', + 1 'UNITS >>>>>>>>>>') + 896 FORMAT(///,10X,'<<<<<<<<<< ERROR IN THE COORDINATES OF THE', + 1 ' ATOMS >>>>>>>>>>',/,10X,'<<<<<<<<<< ATOMS ',I4, + 2 ' AND ',I4,' ARE IDENTICAL >>>>>>>>>>') +C + 999 END diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/plotfd_a.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/plotfd_a.f new file mode 100644 index 0000000..86812f0 --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/plotfd_a.f @@ -0,0 +1,106 @@ +C +C======================================================================= +C + SUBROUTINE PLOTFD_A(A,LMX,ITL,NL,NAT,NE) +C +C This routine prepares the output for a plot of the scattering factor +C + USE DIM_MOD +C + USE APPROX_MOD + USE FDIF_MOD + USE INIT_L_MOD, L => LI, I2 => INITL, I3 => NNL, I4 => LF1, + & I5 => LF2, I10 => ISTEP_LF + USE INIT_J_MOD + USE OUTFILES_MOD + USE PARCAL_A_MOD, N3 => NPHI_A, N4 => NE_A, N5 => NTHETA_A, + & NFTHET => NFTHET_A + USE TYPCAL_A_MOD, IPHI => IPHI_A, IE => IE_A, ITHETA => ITHETA_A, + & IFTHET => IFTHET_A, IMOD => IMOD_A, + & I_CP => I_CP_A, I_EXT => I_EXT_A, + & I_TEST => I_TEST_A + USE VALIN_MOD, PHI00 => PHI0, THETA00 => THETA0, U1 => THLUM, + & U2 => PHILUM, U3 => ELUM, N7 => NONVOL + USE VALFIN_MOD, PHI11 => PHI1, THETA11 => THETA1 + USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A, + & PHI1 => PHI1_A, THETA1 => THETA1_A +C + DIMENSION LMX(NATM,NE_M) +C + COMPLEX FSPH,VKE +C + DATA PI,CONV/3.141593,0.512314/ +C + OPEN(UNIT=IUO3, FILE=OUTFILE3, STATUS='UNKNOWN') + IF(ISPHER.EQ.0) THEN + L=0 + LMAX=0 + ELSE + LMAX=L + ENDIF + PHITOT=360. + THTOT=360.*ITHETA*(1-IPHI)+180.*ITHETA*IPHI + NPHI=(NFTHET+1)*IPHI+(1-IPHI) + NTHT=(NFTHET+1)*ITHETA*(1-IPHI)+(NFTHET/2+1)*ITHETA*IPHI+ + * (1-ITHETA) + NE=NFTHET*IE + (1-IE) + WRITE(IUO3,1) ISPHER,NL,NAT,L,NTHT,NPHI,NE,E0,EFIN + DO 10 JT=1,NTHT + DTHETA=THETA1+FLOAT(JT-1)*THTOT/FLOAT(MAX0(NTHT-1,1)) + RTHETA=DTHETA*PI/180. + TEST=SIN(RTHETA) + IF(TEST.GE.0.) THEN + POZ=PI + EPS=1. + ELSE + POZ=0. + EPS=-1. + ENDIF + BETA=RTHETA*EPS + IF(ABS(TEST).LT.0.0001) THEN + NPHIM=1 + ELSE + NPHIM=NPHI + ENDIF + DO 20 JP=1,NPHIM + DPHI=PHI1+FLOAT(JP-1)*PHITOT/FLOAT(MAX0(NPHI-1,1)) + RPHI=DPHI*PI/180. + GAMMA=POZ-RPHI + DO 30 JE=1,NE + IF(NE.EQ.1) THEN + ECIN=E0 + ELSE + ECIN=E0+FLOAT(JE-1)*(EFIN-E0)/FLOAT(NE-1) + ENDIF + IF(ITL.EQ.0) VKE=SQRT(ECIN-ABS(VINT))*CONV*A*(1.,0.) + DO 40 JAT=1,NAT + IF(L.GT.LMX(JAT,JE)) GOTO 90 + DO 50 M=-LMAX,LMAX + CALL FACDIF1_A(VKE,R1,R2,THETA0,PHI0,BETA,GAMMA,L,M, + 1 FSPH,JAT,JE,*60) + GOTO 70 + 60 WRITE(IUO1,80) + STOP + 70 REFTH=REAL(FSPH) + XIMFTH=AIMAG(FSPH) + WRITE(IUO3,5) JE,JAT,L,M,REFTH,XIMFTH,DTHETA,DPHI,ECIN + 50 CONTINUE + GOTO 40 + 90 WRITE(IUO1,100) JAT + STOP + 40 CONTINUE + 30 CONTINUE + 20 CONTINUE + 10 CONTINUE + CLOSE(IUO3) + 1 FORMAT(5X,I1,2X,I2,2X,I4,2X,I2,2X,I3,2X,I3,2X,I3,2X,F8.2,2X,F8.2) + 5 FORMAT(1X,I3,1X,I4,1X,I2,1X,I3,1X,F6.3,1X,F6.3,1X,F6.2, + 1 1X,F6.2,1X,F8.2) + 80 FORMAT(15X,'<<<<< WRONG VALUE OF THETA0 : THE DENOMINATOR ', + 1 'IS ZERO >>>>>') + 100 FORMAT(15X,'<<<<< THE VALUE OF L EST IS TOO LARGE FOR ATOM', + 1 ' : ',I2,' >>>>>') +C + RETURN +C + END diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/treat_aed.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/treat_aed.f new file mode 100644 index 0000000..ec7820e --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/treat_aed.f @@ -0,0 +1,791 @@ +C +C======================================================================= +C + SUBROUTINE TREAT_AED(ISOM,NFICHLEC,JFICH,NP) +C +C This routine sums up the calculations corresponding to different +C absorbers or different planes when this has to be done +C (parameter ISOM in the input data file). +C +C Last modified : 24 Jan 2013 +C + USE DIM_MOD +C + USE OUTUNITS_MOD + USE TYPEXP_MOD, DUMMY => SPECTRO + USE VALEX_A_MOD, PHI0 => PHI0_A, THETA0 => THETA0_A, + & PHI1 => PHI1_A, THETA1 => THETA1_A + USE VALIN_MOD, P0 => PHI0, T0 => THETA0 + USE VALFIN_MOD, P1 => PHI1, T1 => THETA1 +C + PARAMETER(N_HEAD=5000,N_FILES=1000) +C + CHARACTER*3 SPECTRO + CHARACTER*13 OUTDATA + CHARACTER*72 HEAD(N_HEAD,N_FILES) +C + REAL TAB(NDIM_M,4) + REAL ECIN(NE_M),DTHETA(NTH_M),DPHI(NPH_M) +C + DATA JVOL,JTOT/0,-1/ +C + REWIND IUO2 +C +C Reading and storing the headers: +C + NHEAD=0 + DO JLINE=1,N_HEAD + READ(IUO2,888) HEAD(JLINE,JFICH) + NHEAD=NHEAD+1 + IF(HEAD(JLINE,JFICH)(1:6).EQ.' ') GOTO 333 + ENDDO +C + 333 CONTINUE +C + READ(IUO2,15) SPECTRO,OUTDATA + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE, + 1 IPH_1,I_EXT +C + IF(I_EXT.EQ.2) THEN + IPH_1=0 + ENDIF +C + IF(ISOM.EQ.0) THEN +C +C........ ISOM = 0 : case of independent input files ................. +C + READ(IUO2,1) NPLAN,NEMET,NTHETA,NPHI,NE +C + IF(IPH_1.EQ.1) THEN + N_FIXED=NPHI + FIX0=PHI0 + FIX1=PHI1 + N_SCAN=NTHETA + ELSE + N_FIXED=NTHETA + FIX0=THETA0 + FIX1=THETA1 + IF(STEREO.EQ.'YES') THEN + NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/ + 1 (THETA1-THETA0)+0.0001)+1 + IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 + ENDIF + N_SCAN=NPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + N_SCAN=2*N_SCAN + ENDIF +C + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + NDP=NEMET*NTHETA*NPHI*NE + ELSEIF(I_EXT.EQ.-1) THEN + NDP=NEMET*NTHETA*NPHI*NE*2 + ELSEIF(I_EXT.EQ.2) THEN + NDP=NEMET*NTHETA*NE + N_FIXED=NTHETA + N_SCAN=NPHI + IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 + ENDIF +C + NTT=NPLAN*NDP + IF(NTT.GT.NDIM_M) GOTO 5 +C + DO JPLAN=1,NPLAN + DO JEMET=1,NEMET + DO JE=1,NE +C + DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + XINCRF=FLOAT(J_FIXED-1)* + 1 (FIX1-FIX0)/FLOAT(N_FIXED-1) + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(IPH_1.EQ.1) THEN + JPHI=J_FIXED + ELSE + THETA=THETA0+XINCRF + JTHETA=J_FIXED + IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 11 + ENDIF + IF(STEREO.EQ.' NO') THEN + N_SCAN_R=N_SCAN + ELSE + RTHETA=THETA*0.017453 + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + ENDIF +C + DO J_SCAN=1,N_SCAN_R + IF(IPH_1.EQ.1) THEN + JTHETA=J_SCAN + ELSE + JPHI=J_SCAN + ENDIF +C + JLIN=(JPLAN-1)*NDP + + 1 (JEMET-1)*NE*N_FIXED*N_SCAN + + 2 (JE-1)*N_FIXED*N_SCAN + + 3 (JTHETA-1)*NPHI + JPHI +C + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF +C + READ(IUO2,2) JPL + IF(JPLAN.EQ.JPL) THEN + BACKSPACE IUO2 + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2), + 2 TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TAB(JLIN2,1),TAB(JLIN2,2), + 2 TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ELSE + BACKSPACE IUO2 + DO JL=JLIN,JPLAN*NDP + TAB(JL,1)=0.0 + TAB(JL,2)=0.0 + TAB(JL,3)=0.0 + TAB(JL,4)=0.0 + ENDDO + GOTO 10 + ENDIF + ENDDO + ENDDO + 11 CONTINUE + ENDDO + ENDDO + 10 CONTINUE + ENDDO +C + REWIND IUO2 +C +C Skipping the NHEAD lines of headers before rewriting: +C + DO JLINE=1,NHEAD + READ(IUO2,888) HEAD(JLINE,JFICH) + ENDDO +C + WRITE(IUO2,15) SPECTRO,OUTDATA + WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM +C + DO JE=1,NE + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R + TOTDIF_1=0. + TOTDIR_1=0. + VOLDIF_1=0. + VOLDIR_1=0. + TOTDIF_2=0. + TOTDIR_2=0. + VOLDIF_2=0. + VOLDIR_2=0. + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=0. + TOTDIR2_1=0. + VOLDIF2_1=0. + VOLDIR2_1=0. + TOTDIF2_2=0. + TOTDIR2_2=0. + VOLDIF2_2=0. + VOLDIR2_2=0. + ENDIF +C + DO JPLAN=1,NPLAN +C + SF_1=0. + SR_1=0. + SF_2=0. + SR_2=0. + IF(I_EXT.EQ.-1) THEN + SF2_1=0. + SR2_1=0. + SF2_2=0. + SR2_2=0. + ENDIF +C + DO JEMET=1,NEMET + JLIN=(JPLAN-1)*NDP + + 1 (JEMET-1)*NE*NTHETA*NPHI + + 2 (JE-1)*NTHETA*NPHI + + 3 (JTHETA-1)*NPHI + JPHI + SF_1=SF_1+TAB(JLIN,2) + SR_1=SR_1+TAB(JLIN,1) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=SF2_1+TAB(JLIN2,2) + SR2_1=SR2_1+TAB(JLIN2,1) + ENDIF + IF(IDICHR.GE.1) THEN + SF_2=SF_2+TAB(JLIN,4) + SR_2=SR_2+TAB(JLIN,3) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=SF2_2+TAB(JLIN2,4) + SR2_2=SR2_2+TAB(JLIN2,3) + ENDIF + ENDIF + ENDDO + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR2_1,SF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + IF(JPLAN.GT.NONVOL(JFICH)) THEN + VOLDIF_1=VOLDIF_1+SF_1 + VOLDIR_1=VOLDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_1=VOLDIF2_1+SF2_1 + VOLDIR2_1=VOLDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + VOLDIF_2=VOLDIF_2+SF_2 + VOLDIR_2=VOLDIR_1+SR_2 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_2=VOLDIF2_2+SF2_2 + VOLDIR2_2=VOLDIR2_1+SR2_2 + ENDIF + ENDIF + ENDIF + TOTDIF_1=TOTDIF_1+SF_1 + TOTDIR_1=TOTDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=TOTDIF2_1+SF2_1 + TOTDIR2_1=TOTDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + TOTDIF_2=TOTDIF_2+SF_2 + TOTDIR_2=TOTDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_2=TOTDIF2_2+SF2_2 + TOTDIR2_2=TOTDIR2_2+SR2_2 + ENDIF + ENDIF + ENDDO + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 VOLDIR_1,VOLDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 VOLDIR2_1,VOLDIF2_1 + ENDIF + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 TOTDIR_1,TOTDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 TOTDIR2_1,TOTDIF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 VOLDIR2_1,VOLDIF2_1,VOLDIR2_2,VOLDIF2_2 + ENDIF + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 TOTDIR2_1,TOTDIF2_1,TOTDIR2_2,TOTDIF2_2 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +C + ELSE +C +C........ ISOM not= 0 : multiple input files to be summed up .......... +C + READ(IUO2,7) NTHETA,NPHI,NE +C + IF(IPH_1.EQ.1) THEN + N_FIXED=NPHI + FIX0=PHI0 + FIX1=PHI1 + N_SCAN=NTHETA + ELSE + N_FIXED=NTHETA + FIX0=THETA0 + FIX1=THETA1 + IF(STEREO.EQ.'YES') THEN + NPHI=INT((PHI1-PHI0)*FLOAT(NTHETA-1)/ + 1 (THETA1-THETA0)+0.0001)+1 + IF(NTHETA*NPHI.GT.NPH_M) GOTO 37 + ENDIF + N_SCAN=NPHI + ENDIF +C + IF(I_EXT.EQ.-1) THEN + N_SCAN=2*N_SCAN + ENDIF +C + IF((I_EXT.EQ.0).OR.(I_EXT.EQ.1)) THEN + NDP=NTHETA*NPHI*NE + ELSEIF(I_EXT.EQ.-1) THEN + NDP=NTHETA*NPHI*NE*2 + ELSEIF(I_EXT.EQ.2) THEN + NDP=NTHETA*NE + N_FIXED=NTHETA + N_SCAN=NPHI + IF((N_FIXED.GT.NTH_M).OR.(N_FIXED.GT.NPH_M)) GOTO 35 + ENDIF +C + NTT=NFICHLEC*NDP + IF(NTT.GT.NDIM_M) GOTO 5 +C + IF(ISOM.EQ.1) THEN + NPLAN=NP + NF=NP + ELSEIF(ISOM.EQ.2) THEN + NEMET=NFICHLEC + NF=NFICHLEC + NPLAN=1 + ENDIF +C + DO JF=1,NF +C +C Reading the headers for each file: +C + IF(JF.GT.1) THEN + DO JLINE=1,NHEAD + READ(IUO2,888) HEAD(JLINE,JF) + ENDDO + ENDIF +C + DO JE=1,NE +C + DO J_FIXED=1,N_FIXED + IF(N_FIXED.GT.1) THEN + XINCRF=FLOAT(J_FIXED-1)* + 1 (FIX1-FIX0)/FLOAT(N_FIXED-1) + ELSEIF(N_FIXED.EQ.1) THEN + XINCRF=0. + ENDIF + IF(IPH_1.EQ.1) THEN + JPHI=J_FIXED + ELSE + THETA=THETA0+XINCRF + JTHETA=J_FIXED + IF((ABS(THETA).GT.90.).AND.(I_EXT.NE.2)) GOTO 12 + ENDIF + IF(STEREO.EQ.' NO') THEN + N_SCAN_R=N_SCAN + ELSE + RTHETA=THETA*0.017453 + FIX_STEP=(FIX1-FIX0)/FLOAT(N_FIXED-1) + N_SCAN_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + ENDIF +C + DO J_SCAN=1,N_SCAN_R + IF(IPH_1.EQ.1) THEN + JTHETA=J_SCAN + ELSE + JPHI=J_SCAN + ENDIF +C + JLIN=(JF-1)*NDP + (JE-1)*N_FIXED*N_SCAN + + 1 (JTHETA-1)*NPHI + JPHI + + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF +C + IF(ISOM.EQ.1) THEN + READ(IUO2,2) JPL + IF(JF.EQ.JPL) THEN + BACKSPACE IUO2 + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2), + 2 TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA), + 1 DPHI(JPHI2),ECIN(JE), + 2 TAB(JLIN2,1),TAB(JLIN2,2), + 3 TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ELSE + BACKSPACE IUO2 + DO JLINE=1,NHEAD + BACKSPACE IUO2 + ENDDO + DO JL=JLIN,JF*NDP + TAB(JL,1)=0.0 + TAB(JL,2)=0.0 + TAB(JL,3)=0.0 + TAB(JL,4)=0.0 + ENDDO + GOTO 13 + ENDIF + ELSEIF(ISOM.EQ.2) THEN + IF(IDICHR.EQ.0) THEN + READ(IUO2,2) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,25) TAB(JLIN2,1),TAB(JLIN2,2) + ENDIF + ELSE + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TAB(JLIN,1),TAB(JLIN,2), + 2 TAB(JLIN,3),TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + READ(IUO2,22) JPL,JEM,DTHETA(JTHETA), + 1 DPHI(JPHI2),ECIN(JE), + 2 TAB(JLIN2,1),TAB(JLIN2,2), + 3 TAB(JLIN2,3),TAB(JLIN2,4) + ENDIF + ENDIF + ENDIF + ENDDO + 12 CONTINUE + ENDDO + ENDDO + 13 CONTINUE + ENDDO +C + REWIND IUO2 +C +C Writing the headers: +C + DO JLINE=1,2 + WRITE(IUO2,888) HEAD(JLINE,1) + ENDDO + DO JF=1,NFICHLEC + DO JLINE=3,6 + WRITE(IUO2,888) HEAD(JLINE,JF) + ENDDO + WRITE(IUO2,888) HEAD(2,JF) + ENDDO + DO JLINE=7,NHEAD + WRITE(IUO2,888) HEAD(JLINE,1) + ENDDO +C + WRITE(IUO2,15) SPECTRO,OUTDATA + WRITE(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM +C + IF(ISOM.EQ.1) THEN +C + DO JE=1,NE +C + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R +C + TOTDIF_1=0. + TOTDIR_1=0. + VOLDIF_1=0. + VOLDIR_1=0. + TOTDIF_2=0. + TOTDIR_2=0. + VOLDIF_2=0. + VOLDIR_2=0. + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=0. + TOTDIR2_1=0. + VOLDIF2_1=0. + VOLDIR2_1=0. + TOTDIF2_2=0. + TOTDIR2_2=0. + VOLDIF2_2=0. + VOLDIR2_2=0. + ENDIF +C + DO JPLAN=1,NPLAN + JF=JPLAN +C + JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI + + 1 (JTHETA-1)*NPHI + JPHI +C + SR_1=TAB(JLIN,1) + SF_1=TAB(JLIN,2) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=TAB(JLIN2,2) + SR2_1=TAB(JLIN2,1) + ENDIF + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR2_1,SF2_1 + ENDIF + ELSE + SR_2=TAB(JLIN,3) + SF_2=TAB(JLIN,4) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=TAB(JLIN2,4) + SR2_2=TAB(JLIN2,3) + ENDIF + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + IF(NONVOL(JPLAN).EQ.0) THEN + VOLDIF_1=VOLDIF_1+SF_1 + VOLDIR_1=VOLDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_1=VOLDIF2_1+SF2_1 + VOLDIR2_1=VOLDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + VOLDIF_2=VOLDIF_2+SF_2 + VOLDIR_2=VOLDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + VOLDIF2_2=VOLDIF2_2+SF2_2 + VOLDIR2_2=VOLDIR2_1+SR2_2 + ENDIF + ENDIF + ENDIF + TOTDIF_1=TOTDIF_1+SF_1 + TOTDIR_1=TOTDIR_1+SR_1 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_1=TOTDIF2_1+SF2_1 + TOTDIR2_1=TOTDIR2_1+SR2_1 + ENDIF + IF(IDICHR.GE.1) THEN + TOTDIF_2=TOTDIF_2+SF_2 + TOTDIR_2=TOTDIR_2+SR_2 + IF(I_EXT.EQ.-1) THEN + TOTDIF2_2=TOTDIF2_2+SF2_2 + TOTDIR2_2=TOTDIR2_2+SR2_2 + ENDIF + ENDIF + ENDDO +C + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 VOLDIR_1,VOLDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JVOL,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),VOLDIR2_1,VOLDIF2_1 + ENDIF + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 TOTDIR_1,TOTDIF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JTOT,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TOTDIR2_1,TOTDIF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 VOLDIR_1,VOLDIF_1,VOLDIR_2,VOLDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JVOL,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),VOLDIR2_1,VOLDIF2_1, + 3 VOLDIR2_2,VOLDIF2_2 + ENDIF + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2),ECIN(JE), + 1 TOTDIR_1,TOTDIF_1,TOTDIR_2,TOTDIF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JTOT,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),TOTDIR2_1,TOTDIF2_1, + 3 TOTDIR2_2,TOTDIF2_2 + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO + ELSEIF(ISOM.EQ.2) THEN + DO JE=1,NE +C + DO JTHETA=1,NTHETA + IF(STEREO.EQ.' NO') THEN + NPHI_R=NPHI + ELSE + RTHETA=DTHETA(JTHETA)*0.017453 + FIX_STEP=(THETA1-THETA0)/FLOAT(NTHETA-1) + NPHI_R=INT((PHI1-PHI0)*SIN(RTHETA)/FIX_STEP+0.0001)+1 + NPHI=INT((PHI1-PHI0)/FIX_STEP+0.0001)+1 + ENDIF + DO JPHI=1,NPHI_R +C + SF_1=0. + SR_1=0. + SF_2=0. + SR_2=0. + IF(I_EXT.EQ.-1) THEN + SF2_1=0. + SR2_1=0. + SF2_2=0. + SR2_2=0. + ENDIF +C + DO JEMET=1,NEMET + JF=JEMET +C + JLIN=(JF-1)*NDP + (JE-1)*NTHETA*NPHI + + 1 (JTHETA-1)*NPHI + JPHI +C + SF_1=SF_1+TAB(JLIN,2) + SR_1=SR_1+TAB(JLIN,1) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_1=SF2_1+TAB(JLIN2,2) + SR2_1=SR2_1+TAB(JLIN2,1) + ENDIF + IF(IDICHR.GE.1) THEN + SF_2=SF_2+TAB(JLIN,4) + SR_2=SR_2+TAB(JLIN,3) + IF(I_EXT.EQ.-1) THEN + JLIN2=NTT+JLIN + SF2_2=SF2_2+TAB(JLIN2,4) + SR2_2=SR2_2+TAB(JLIN2,3) + ENDIF + ENDIF + ENDDO + IF(I_EXT.LE.0) THEN + IF(STEREO.EQ.' NO') THEN + JPHI2=JPHI + ELSE + JPHI2=(JTHETA-1)*NPHI+JPHI + ENDIF + ELSE + JPHI2=JTHETA + ENDIF + IF(IDICHR.EQ.0) THEN + WRITE(IUO2,3) JPL,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR_1,SF_1 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,3) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR2_1,SF2_1 + ENDIF + ELSE + WRITE(IUO2,23) JPL,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR_1,SF_1,SR_2,SF_2 + IF(I_EXT.EQ.-1) THEN + WRITE(IUO2,23) JPLAN,DTHETA(JTHETA),DPHI(JPHI2), + 1 ECIN(JE),SR2_1,SF2_1,SR2_2,SF2_2 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +C + GOTO 6 +C + 5 WRITE(IUO1,4) + STOP + 35 WRITE(IUO1,36) N_FIXED + STOP + 37 WRITE(IUO1,38) NTHETA*NPHI + STOP +C + 1 FORMAT(2X,I3,2X,I2,2X,I4,2X,I4,2X,I4) + 2 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6, + 1 2X,E12.6) + 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ', + 1 'IN THE TREAT_AED SUBROUTINE - INCREASE NDIM_M ', + 2 '>>>>>>>>>>') + 7 FORMAT(I4,2X,I4,2X,I4) + 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 9 FORMAT(9(2X,I1),2X,I2) + 15 FORMAT(2X,A3,11X,A13) + 22 FORMAT(2X,I3,2X,I2,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6, + 1 2X,E12.6,2X,E12.6,2X,E12.6) + 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6, + 1 2X,E12.6,2X,E12.6) + 25 FORMAT(37X,E12.6,2X,E12.6) + 36 FORMAT(//,4X,'<<<<<<<<<< DIMENSION OF NTH_M OR NPH_M TOO SMALL ', + 1 'IN THE INCLUDE FILE >>>>>>>>>>',/,4X, + 2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6, + 3 ' >>>>>>>>>>') + 38 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF NPH_M TOO SMALL ', + 1 'IN THE INCLUDE FILE >>>>>>>>>>',/,8X, + 2 '<<<<<<<<<< SHOULD BE AT LEAST ',I6, + 3 ' >>>>>>>>>>') + 888 FORMAT(A72) +C + 6 RETURN +C + END diff --git a/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/weight_sum.f b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/weight_sum.f new file mode 100644 index 0000000..0db9ffc --- /dev/null +++ b/src/msspec/spec/fortran/aed_mi_mu_noso_nosp_nosym/weight_sum.f @@ -0,0 +1,335 @@ +C +C======================================================================= +C + SUBROUTINE WEIGHT_SUM(ISOM,I_EXT,I_EXT_A,JEL) +C +C This subroutine performs a weighted sum of the results +C corresponding to different directions of the detector. +C The directions and weights are read from an external input file +C +C JEL is the electron undetected (i.e. for which the outgoing +C directions are integrated over the unit sphere). It is always +C 1 for one electron spectroscopies (PHD). For APECS, It can be +C 1 (photoelectron) or 2 (Auger electron) or even 0 (no electron +C detected) +C +C Last modified : 31 Jan 2007 +C + USE DIM_MOD + USE INFILES_MOD + USE INUNITS_MOD + USE OUTUNITS_MOD +C +C + PARAMETER(N_MAX=5810,NPM=20) +C + REAL*4 W(N_MAX),W_A(N_MAX),ECIN(NE_M) + REAL*4 DTHETA(N_MAX),DPHI(N_MAX),DTHETAA(N_MAX),DPHIA(N_MAX) + REAL*4 SR_1,SF_1,SR_2,SF_2 + REAL*4 SUMR_1(NPM,NE_M,N_MAX),SUMR_2(NPM,NE_M,N_MAX) + REAL*4 SUMF_1(NPM,NE_M,N_MAX),SUMF_2(NPM,NE_M,N_MAX) +C + CHARACTER*3 SPECTRO,SPECTRO2 + CHARACTER*5 LIKE + CHARACTER*13 OUTDATA +C +C +C +C + DATA JVOL,JTOT/0,-1/ + DATA LIKE /'-like'/ +C + REWIND IUO2 +C + READ(IUO2,15) SPECTRO,OUTDATA + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + SPECTRO2='XAS' + ELSE + READ(IUO2,9) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + READ(IUO2,9) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A,I + &THETA_A,IE_A + READ(IUO2,8) NPHI,NTHETA,NE,NPLAN,ISOM + READ(IUO2,8) NPHI_A,NTHETA_A + IF(JEL.EQ.1) THEN + SPECTRO2='AED' + ELSEIF(JEL.EQ.2) THEN + SPECTRO2='PHD' + ELSEIF(JEL.EQ.0) THEN + SPECTRO2='XAS' + ENDIF + ENDIF +C + IF(NPLAN.GT.NPM) THEN + WRITE(IUO1,4) NPLAN+2 + STOP + ENDIF +C +C Reading the number of angular points +C + IF(SPECTRO.NE.'APC') THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + N_POINTS_A=1 + ELSE + IF(JEL.EQ.1) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT_A.EQ.0) THEN + N_POINTS_A=NTHETA_A*NPHI_A + ELSE + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA_A + NPHI0=NPHI_A + ELSEIF(JEL.EQ.2) THEN + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI9,1) N_POINTS_A + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + IF(I_EXT.EQ.0) THEN + N_POINTS=NTHETA*NPHI + ELSE + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + NTHETA0=NTHETA + NPHI0=NPHI + ELSEIF(JEL.EQ.0) THEN + OPEN(UNIT=IUI6, FILE=INFILE6, STATUS='OLD') + OPEN(UNIT=IUI9, FILE=INFILE9, STATUS='OLD') + READ(IUI6,1) N_POINTS + READ(IUI9,1) N_POINTS_A + READ(IUI6,5) I_DIM,N_DUM1,N_DUM2 + READ(IUI9,5) I_DIM,N_DUM1,N_DUM2 + ENDIF + ENDIF +C + IF(SPECTRO.NE.'APC') THEN + NANGLE=1 + ELSE + IF(JEL.EQ.1) THEN + NANGLE=N_POINTS_A + ELSEIF(JEL.EQ.2) THEN + NANGLE=N_POINTS + ELSEIF(JEL.EQ.0) THEN + NANGLE=1 + ENDIF + ENDIF +C +C Initialization of the arrays +C + DO JE=1,NE + DO JANGLE=1,NANGLE + DO JPLAN=1,NPLAN+2 + SUMR_1(JPLAN,JE,JANGLE)=0. + SUMF_1(JPLAN,JE,JANGLE)=0. + IF(IDICHR.GT.0) THEN + SUMR_2(JPLAN,JE,JANGLE)=0. + SUMF_2(JPLAN,JE,JANGLE)=0. + ENDIF + ENDDO + ENDDO + ENDDO +C +C Reading of the data to be angle integrated +C + DO JE=1,NE +C + DO JANGLE=1,N_POINTS + IF(I_EXT.NE.0) READ(IUI6,2) TH,PH,W(JANGLE) + DO JANGLE_A=1,N_POINTS_A + IF((I_EXT_A.NE.0).AND.(JANGLE.EQ.1)) THEN + READ(IUI9,2) THA,PHA,W_A(JANGLE_A) + ENDIF +C + DO JPLAN=1,NPLAN+2 +C + IF(IDICHR.EQ.0) THEN + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,3) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE) + &,SR_1,SF_1 + ELSE + READ(IUO2,13) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1 + ENDIF + ELSE + IF(SPECTRO.NE.'APC') THEN + READ(IUO2,23) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),SR_1,SF_1,SR_2,SF_2 + ELSE + READ(IUO2,24) JDUM,DTHETA(JANGLE),DPHI(JANGLE),ECIN(JE + &),DTHETAA(JANGLE_A),DPHIA(JANGLE_A),SR_1,SF_1,SR_2,SF_2 + ENDIF + ENDIF +C + IF(JEL.EQ.1) THEN + SUMR_1(JPLAN,JE,JANGLE_A)=SUMR_1(JPLAN,JE,JANGLE_A)+SR_1 + &*W(JANGLE) + SUMF_1(JPLAN,JE,JANGLE_A)=SUMF_1(JPLAN,JE,JANGLE_A)+SF_1 + &*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_1(JPLAN,JE,JANGLE)=SUMR_1(JPLAN,JE,JANGLE)+SR_1*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,JANGLE)=SUMF_1(JPLAN,JE,JANGLE)+SF_1*W_A + &(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_1(JPLAN,JE,1)=SUMR_1(JPLAN,JE,1)+SR_1*W(JANGLE)*W_A + &(JANGLE_A) + SUMF_1(JPLAN,JE,1)=SUMF_1(JPLAN,JE,1)+SF_1*W(JANGLE)*W_A + &(JANGLE_A) + ENDIF + IF(IDICHR.GT.0) THEN + IF(JEL.EQ.1) THEN + SUMR_2(JPLAN,JE,JANGLE_A)=SUMR_2(JPLAN,JE,JANGLE_A)+SR + &_2*W(JANGLE) + SUMF_2(JPLAN,JE,JANGLE_A)=SUMF_2(JPLAN,JE,JANGLE_A)+SF + &_2*W(JANGLE) + ELSEIF(JEL.EQ.2) THEN + SUMR_2(JPLAN,JE,JANGLE)=SUMR_2(JPLAN,JE,JANGLE)+SR_2*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,JANGLE)=SUMF_2(JPLAN,JE,JANGLE)+SF_2*W + &_A(JANGLE_A) + ELSEIF(JEL.EQ.0) THEN + SUMR_2(JPLAN,JE,1)=SUMR_2(JPLAN,JE,1)+SR_2*W(JANGLE)*W + &_A(JANGLE_A) + SUMF_2(JPLAN,JE,1)=SUMF_2(JPLAN,JE,1)+SF_2*W(JANGLE)*W + &_A(JANGLE_A) + ENDIF + ENDIF +C + ENDDO +C + ENDDO + IF(I_EXT_A.NE.0) THEN + REWIND IUI9 + READ(IUI9,1) NDUM + READ(IUI9,1) NDUM + ENDIF + ENDDO +C + IF(I_EXT.NE.0) THEN + REWIND IUI6 + READ(IUI6,1) NDUM + READ(IUI6,1) NDUM + ENDIF + ENDDO +C + CLOSE(IUI6) + CLOSE(IUI9) + REWIND IUO2 +C + WRITE(IUO2,16) SPECTRO2,LIKE,SPECTRO,OUTDATA + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,19) ISPIN,IDICHR,I_SO,ISFLIP + WRITE(IUO2,18) NE,NPLAN,ISOM + ELSEIF(JEL.EQ.1) THEN + WRITE(IUO2,20) ISPIN_A,IDICHR_A,I_SO_A,ISFLIP_A,ICHKDIR_A,IPHI_A + &,ITHETA_A,IE_A + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ELSEIF(JEL.EQ.2) THEN + WRITE(IUO2,20) ISPIN,IDICHR,I_SO,ISFLIP,ICHKDIR,IPHI,ITHETA,IE + WRITE(IUO2,21) NPHI0,NTHETA0,NE,NPLAN,ISOM + ENDIF +C + DO JE=1,NE + DO JANGLE=1,NANGLE + IF(SPECTRO.EQ.'APC') THEN + IF(JEL.EQ.1) THEN + THETA=DTHETAA(JANGLE) + PHI=DPHIA(JANGLE) + ELSEIF(JEL.EQ.2) THEN + THETA=DTHETA(JANGLE) + PHI=DPHI(JANGLE) + ENDIF + ENDIF +C + DO JPLAN=1,NPLAN + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE) + ELSE + WRITE(IUO2,34) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JPLAN,ECIN(JE),SUMR_1(JPLAN,JE,JANGLE),SU + &MF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPLAN,JE,JANG + &LE) + ELSE + WRITE(IUO2,44) JPLAN,THETA,PHI,ECIN(JE),SUMR_1(JPLAN,JE, + &JANGLE),SUMF_1(JPLAN,JE,JANGLE),SUMR_2(JPLAN,JE,JANGLE),SUMF_2(JPL + &AN,JE,JANGLE) + ENDIF + ENDIF + ENDDO +C + IF(IDICHR.EQ.0) THEN + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,33) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,33) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE) + ELSE + WRITE(IUO2,34) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE) + WRITE(IUO2,34) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE) + ENDIF + ELSE + IF((SPECTRO.NE.'APC').OR.(JEL.EQ.0)) THEN + WRITE(IUO2,43) JVOL,ECIN(JE),SUMR_1(NPLAN+1,JE,JANGLE),SUM + &F_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2(NPLAN+1,JE + &,JANGLE) + WRITE(IUO2,43) JTOT,ECIN(JE),SUMR_1(NPLAN+2,JE,JANGLE),SUM + &F_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2(NPLAN+2,JE + &,JANGLE) + ELSE + WRITE(IUO2,44) JVOL,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+1,JE,J + &ANGLE),SUMF_1(NPLAN+1,JE,JANGLE),SUMR_2(NPLAN+1,JE,JANGLE),SUMF_2( + &NPLAN+1,JE,JANGLE) + WRITE(IUO2,44) JTOT,THETA,PHI,ECIN(JE),SUMR_1(NPLAN+2,JE,J + &ANGLE),SUMF_1(NPLAN+2,JE,JANGLE),SUMR_2(NPLAN+2,JE,JANGLE),SUMF_2( + &NPLAN+2,JE,JANGLE) + ENDIF + ENDIF +C + ENDDO + ENDDO +C + 1 FORMAT(13X,I4) + 2 FORMAT(15X,F8.3,3X,F8.3,3X,E12.6) + 3 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 4 FORMAT(//,8X,'<<<<<<<<<< DIMENSION OF THE ARRAYS TOO SMALL ','IN + &THE WEIGHT_SUM SUBROUTINE - INCREASE NPM TO ',I3,'>>>>>>>>>>') + 5 FORMAT(6X,I1,1X,I3,3X,I3) + 8 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 9 FORMAT(9(2X,I1),2X,I2) + 13 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6) + 15 FORMAT(2X,A3,11X,A13) + 16 FORMAT(2X,A3,A5,1X,A3,2X,A13) + 18 FORMAT(I4,2X,I3,2X,I1) + 19 FORMAT(4(2X,I1)) + 20 FORMAT(8(2X,I1)) + 21 FORMAT(I4,2X,I4,2X,I4,2X,I3,2X,I1) + 23 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) + 24 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,F6.2,2X,F6.2,2X,E12.6,2X,E + &12.6,2X,E12.6,2X,E12.6) + 33 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6) + 34 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6) + 43 FORMAT(2X,I3,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X,E12.6) + 44 FORMAT(2X,I3,2X,F6.2,2X,F6.2,2X,F8.2,2X,E12.6,2X,E12.6,2X,E12.6,2X + &,E12.6) +C + RETURN +C + END diff --git a/tests/aed/test.py b/tests/aed/test.py new file mode 100644 index 0000000..ed6a679 --- /dev/null +++ b/tests/aed/test.py @@ -0,0 +1,83 @@ +# coding: utf8 + +import numpy as np +from ase.build import bulk +from ase.lattice.tetragonal import SimpleTetragonalFactory +from msspec.calculator import MSSPEC, XRaySource +from msspec.utils import hemispherical_cluster, get_atom_index +import logging + +logging.basicConfig(level=logging.INFO) + + +do_ped = False + +# Define a Rocksalt Factory class (to tetragonalize the unit cell) +class RocksaltFactory(SimpleTetragonalFactory): + bravais_basis = [[0, 0, 0], [0.5, 0.5, 0], [0.5, 0, 0.5], [0, 0.5, 0.5], + [0, 0, 0.5], [0.5, 0, 0], [0, 0.5, 0], [0.5, 0.5, 0.5]] + element_basis = (0, 0, 0, 0, 1, 1, 1, 1) +Rocksalt = RocksaltFactory() + + +a0 = 4.09 +a_perp = 4.25 +MgO = Rocksalt(('Mg', 'O'), + latticeconstant={'a': a0, 'c/a': a_perp/a0}, + size=(1,1,1)) + + +for atom in MgO: + atom.set('mean_square_vibration', 0.01) + atom.set('forward_angle', 20.) + if atom.symbol == 'Mg': + atom.tag = 1 + atom.set('mt_radius', 0.63) + else: + atom.tag = 2 + atom.set('mt_radius', 1.415) + + +#cluster = hemispherical_cluster(MgO, emitter_tag=1, emitter_plane=1, planes=4, diameter=4.5*a0) +cluster = hemispherical_cluster(MgO, emitter_tag=1, emitter_plane=1, planes=2) +cluster.absorber = get_atom_index(cluster, 0, 0, 0) +#cluster.edit() +#exit() + +if do_ped: + calc = MSSPEC(spectroscopy='PED', algorithm='inversion') +else: + calc = MSSPEC(spectroscopy='AED', algorithm='inversion') +calc.set_atoms(cluster) + +calc.muffintin_parameters.ionicity = {'Mg': 0.1, 'O': -0.1} + +calc.tmatrix_parameters.exchange_correlation = 'hedin_lundqvist_complex' +calc.tmatrix_parameters.lmax_mode = 'true_ke' +#calc.tmatrix_parameters.tl_threshold = 1e-6 + +calc.source_parameters.energy = XRaySource.AL_KALPHA +calc.source_parameters.theta = -55. +calc.source_parameters.phi = -55. + +calc.detector_parameters.angular_acceptance = 2. +calc.detector_parameters.average_sampling = 'high' + +calc.calculation_parameters.scattering_order = 4 +calc.calculation_parameters.RA_cutoff = 2 +calc.calculation_parameters.path_filtering = 'forward_scattering' +calc.calculation_parameters.off_cone_events = 1 +calc.calculation_parameters.vibrational_damping = 'averaged_tl' +calc.calculation_parameters.vibration_scaling = 3. + +if do_ped: + calc.muffintin_parameters.interstitial_potential = 14 + data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5), + level='2p', + kinetic_energy=1200) +else: + data = calc.get_theta_scan(phi=0, theta=np.arange(-5, 60.5, 0.5), + edge='KL2L2', multiplet='1D2', + kinetic_energy=1200) + +data.save('results.hdf5')