C N. R. BADNELL PROGRAM XPEPPI UoS v1.5 04/06/10 C PROGRAM XPEPPI IMPLICIT REAL*8(A-H,O-Z) C C ADD RESONANT (XPExxx) CONTRIBUTION TO NON-RESONANT (XDPIxxx) C TO FORM COMPLETE COMBINED (XPIxxx) PHOTOIONIZATION CROSS SECTIONS, C WHERE xxx EQUALS TOT AND/OR PAR. C C *** INTERPOLATES RESONANT ONTO EXISTING DIRECT (IF BPEONPI=.TRUE.) *** C OR VICE VERSA IF USER SETS BPEONPI=.FALSE. BELOW C *** THE NON-INTERPOLATED EXISTING ENERGY MESH MUST BE FINE ENOUGH TO C DESCRIBE THE FEATURES BEING INTERPOLATED ONTO IT. C E.G. THE DIRECT MUST BE TABULATED ON A FINER MESH THAN IT NEEDS C ITSELF SO THAT THE (CONVOLUTED) RESONANCE DATA IS REPRODUCED. C IF INTERPOLATING DIRECT ONTO RESONANCE THEN THIS IS NOT LIKELY A C PROBLEM, BUT NOW ONE MUST CHECK INSTEAD THAT THE EDGES ARE C REPRODUCED ACCURATELY ENOUGH. C C THIS IS NOT MEANT FOR OPACITY STYLE PROBLEMS, USE THE ADF38/39 C FILES INSTEAD THEN. C C THE NEXT THEREE PARAMETER DIMENSIONS SHOULD NOT BE INFLATED BECAUSE OF C REAL*8 ARRAY (MXENG0,MXLEV,MXLEVP) PARAMETER (MXLEVP=10) !NO OF PHOTON TARGETS PARAMETER (MXLEV=30) !NO OF ELECTRON TARGETS, =1 IF TOT ONLY PARAMETER (MXENG0=25000) !NO OF PI XSCTN ENERGIES C C THIS CAN BE AS LARGE AS DESIRED (WITHIN REASON) PARAMETER (MXENG1=500000) !NO OF PE XSCTN ENERGIES C PARAMETER (ZERO=0.0D0) PARAMETER (DONE=1.0D0) C CHARACTER LAB0*43,LAB1*45,LAB2*15,LAB3*17,LAB4*9 CHARACTER FILE0*7,FILE1*6,FILET*6,EXT*3 C LOGICAL BPAR,BTOT,EX0,EX1,BPEONPI,BPIONPE C DIMENSION ENERGP(MXLEVP),ENERG(MXLEV) DIMENSION ENERG0(MXENG0),PCS0(MXENG0,MXLEV,MXLEVP) !DIRECT DIMENSION ENERG1(MXENG1),PCS1(MXENG1) !RESONANT C COMMON /LAG/NLAG,NPH1,NPH2 C C C**** USER SWITCH FOR INTERPOLATION OF PE ONTO PI, OR VICE VERSA ******* C C BPEONPI=.TRUE. !PE ONTO PI BPEONPI=.FALSE. !PI ONTO PE C C*********************************************************************** C NLAG=2 !2 or 4 POINT INTERPOLATION NPH2=NLAG/2 NPH1=NPH2-1 C BPIONPE=.NOT.BPEONPI C IF(BPIONPE.AND.NLAG.EQ.4) XWRITE(0,*)'4-POINT INTERPOLATION NOT RECOMMENDED FOR PI ONTO PE!' C C C *** COMMON CODE TO PROCESS PARTIAL AND TOTAL FILES *** C C TOTAL FIRST C BTOT=.TRUE. C 1 BPAR=.NOT.BTOT C IF(BTOT)EXT='TOT' IF(BPAR)EXT='PAR' C FILE0='XDPI'//EXT FILE1='XPE'//EXT FILET='XPI'//EXT C INQUIRE(FILE=FILE0,EXIST=EX0) INQUIRE(FILE=FILE1,EXIST=EX1) C IF(.NOT.EX0.OR..NOT.EX1)THEN IF(.NOT.EX0)WRITE(0,*)'FILE ',FILE0,' NOT PRESENT, SKIPPING...' IF(.NOT.EX1)WRITE(0,*)'FILE ',FILE1,' NOT PRESENT, SKIPPING...' WRITE(0,*)'NO DIRECT-PLUS-RESONANCE FILE ',FILET,' WRITTEN' GO TO 1000 ENDIF C OPEN(7,FILE=FILE1,STATUS='OLD') !XPE OPEN(8,FILE=FILE0,STATUS='OLD') !XDPI OPEN(9,FILE=FILET,STATUS='UNKNOWN') !XTOT C C READ-IN ENTIRE CONTENTS OF XDPIxxx AS THEY ARE NOT TARGET ORDERED. C CHECK HEADER AGAINST THAT IN XPExxx C READ(8,100)LAB1,LBIN,LAB2,LMAX,LAB3 100 FORMAT(A45,I5,A15,3X,I5,A17) C IF(BTOT)WRITE(9,100)LAB1,LBIN,LAB2 IF(BPAR)WRITE(9,100)LAB1,LBIN,LAB2,LMAX,LAB3 C READ(7,100)LAB1,L,LAB2,LL,LAB3 C IF(L.NE.LBIN)THEN WRITE(0,*)'PHOTON TARGET MIS-MATCH BETWEEN ',FILE1,' AND ',FILE0 X ,':',L,LBIN WRITE(9,100)LAB1,L,LAB2 STOP'PHOTON TARGET MIS-MATCH BETWEEN DIRECT AND RESONANCE FILES' ENDIF C IF(LBIN.GT.MXLEVP)THEN WRITE(0,*)'INCREASE MXLEVP TO',LBIN STOP 'INCREASE MXLEVP' ENDIF C IF(LL.NE.LMAX)THEN WRITE(0,*)'ELECTRON TARGET MIS-MATCH BETWEEN ',FILE1,' AND ' X ,FILE0,':',LL,LMAX WRITE(9,100)LAB1,L,LAB2,LL,LAB3 STOP X 'ELECTRON TARGET MIS-MATCH BETWEEN DIRECT AND RESONANCE FILES' ENDIF C IF(LMAX.GT.MXLEV)THEN WRITE(0,*)'INCREASE MXLEV TO',LMAX STOP 'INCREASE MXLEV' ENDIF LMAX=MAX(LMAX,1) C READ(8,101)LAB0,NENG0,LAB4 101 FORMAT(A43,I7,A9) C WRITE(9,101)LAB0,NENG0,LAB4 C IF(NENG0.GT.MXENG0)THEN WRITE(0,*)'INCREASE MXENG0 TO',NENG0 STOP 'INCREASE MXENG0' ENDIF C ENERGP(1)=DONE ENERG(1)=DONE C DO L0=1,LBIN DO L=1,LMAX C READ(8,102)EP0,EE0,LP,LE 102 FORMAT(1X,2E18.8,2I5) LE=MAX(1,LE) C IF(LE.GT.L)THEN !ELECTRON TARGET SKIPPED C BACKSPACE(8) C DO N=1,NENG0 PCS0(N,L,LP)=DZERO ENDDO C ENERG(L)=DZERO C ELSE C ENERGP(LP)=EP0 ENERG(LE)=EE0 C C N.B. ENERG0 IS INDEPENDENT OF TRANSITION, JUST WRITTEN FOR CONVENIENCE DO N=1,NENG0 C READ(8,*)ENERG0(N),PCS0(N,LE,LP) C ENDDO C ENDIF C ENDDO ENDDO C DEEP=ENERG(1)-ENERGP(1) !PHOTON GROUND TO ELECTRON GROUND C IF(ENERGP(1).GE.ZERO)THEN WRITE(0,*)'***PHOTON TARGET GROUND STATE MISSING' DEEP=ZERO ENDIF C IF(ENERG(1).GE.ZERO)THEN WRITE(0,*)'***ELECTRON TARGET GROUND STATE MISSING' DEEP=ZERO ENDIF C C READ-IN RESONANCE XSCTNS ONE TRANSITION AT A TIME, SINCE TARGET C ORDERED, AND ADD TO DIRECT. C READ(7,101)LAB1,NENG1,LAB4 C IF(NENG1.GT.MXENG1)THEN WRITE(0,*)'INCREASE MXENG1 TO',NENG1 STOP 'INCREASE MXENG1' ENDIF C DO L0=1,LBIN DO L=1,LMAX C READ(7,102)EP0,E00,LP,LE LE=MAX(1,LE) C IF(BTOT)WRITE(9,103)EP0,E00,LP IF(BPAR)WRITE(9,103)EP0,E00,LP,LE 103 FORMAT('#',1P,2E18.8,2I5) c if(lp.ne.l0)then write(*,*)btot,l0,lp stop 'l0,lp mis-match' endif if(le.ne.l)stop 'le,l mis-match' C IF(L0.EQ.1)THEN DEP1=ZERO TOLP=1.D-4 ELSE DEP1=ENERGP(L0) TOLP=1.D-5 ENDIF C IF(L.EQ.1)THEN DE1=ZERO TOLE=1.D-5 ELSE DE1=ENERG(L) TOLE=3.D-6 ENDIF C IF(ENERG(L).NE.DZERO)THEN DEEL=ENERG(L)-E00 !THESE CAN AND SHOULD MATCH T=MAX(TOLE*ABS(E00),2.D-6) !CASE FORMATTED op FILES IF(ABS(DEEL).GT.T)THEN WRITE(0,*)'MIS-MATCH OF ELECTRON TARGET ENERGIES FOR STATE' X ,L,ENERG(L),E00 IF(ABS(DEEL).GT.1000*T) X STOP'MIS-MATCH OF ELECTRON TARGET ENERGIES' ENDIF ELSE IF(L.GT.1)DE1=E00 ENDIF C DEPL=ENERGP(L0)-EP0 !NL-MIX WITH CORR. GIVES SLIGHT DIFF T=MAX(TOLP*ABS(EP0),2.D-6) !CASE FORMATTED op FILES IF(ABS(DEPL).GT.T)THEN WRITE(0,*)'MIS-MATCH OF PHOTON TARGET ENERGIES FOR STATE',L0 X ,ENERGP(L0),EP0 IF(ABS(DEPL).GT.1000*T) X STOP'MIS-MATCH OF PHOTON TARGET ENERGIES' ENDIF C C N.B. ENERG1 IS INDEPENDENT OF TRANSITION, JUST WRITTEN FOR CONVENIENCE DO N=1,NENG1 C READ(7,*)ENERG1(N),PCS1(N) C ENERG1(N)=ENERG1(N)-DEPL !COMPENSATE A SLIGHT MIS-MATCH C ENDDO C C COMBINE AND WRITE: C BOTH ENERGY MESHES ARE RELATIVE TO THE (COMMON) INITIAL PHOTON TARGET C C INTERPOLATE RESONANT ONTO DIRECT IF(BPEONPI)CALL XADD(DE1,DEP1,DEEP,NENG0,ENERG0,PCS0(1,L,L0) X ,NENG1,ENERG1,PCS1) C INTERPOLATE DIRECT ONTO RESONANT IF(BPIONPE)CALL XADD(DE1,DEP1,DEEP,NENG1,ENERG1,PCS1 X ,NENG0,ENERG0,PCS0(1,L,L0)) C ENDDO ENDDO C C CLOSE(7) CLOSE(8) CLOSE(9) C WRITE(0,*) 'PI XSCTN IN ',FILET C 1000 IF(BPAR)STOP 'ALL DONE' C C ELSE NOW PROCESS PARTIALS C BTOT=.FALSE. C GO TO 1 C END C C*********************************************************************** C SUBROUTINE XADD(DE1,DEP1,DEEP,NENG0,ENERG0,PCS0,NENG1,ENERG1,PCS1) C C ADD (INTERPOLATE) PCS1 (ON)TO PCS0 C IMPLICIT REAL*8(A-H,O-Z) C PARAMETER (ZERO=0.0D0) PARAMETER (DONE=1.0D0) C LOGICAL EX1 C DIMENSION ENERG0(*),PCS0(*),ENERG1(*),PCS1(*) C COMMON /LAG/NLAG,NPH1,NPH2 C DO N1=1,NENG1 IF(ENERG1(N1).LT.ENERG0(1))THEN EP=ENERG1(N1) !PHOTON ENERGY REL TO INITIAL XINT=PCS1(N1) EP=EP+DEP1 !PHOTON ENERGY REL TO GROUND E0=EP-DEEP !ELECTRON ENERGY REL TO GROUND E=E0-DE1 !ELECTRON ENERGY REL TO FINAL WRITE(9,104)EP,ENERG1(N1),E0,E,XINT ELSE GO TO 5 ENDIF ENDDO C 5 N11=N1 DO N0=1,NENG0 C EP=ENERG0(N0) !PHOTON ENERGY REL TO INITIAL XINT=PCS0(N0) C IF(ENERG1(1).GT.ENERG0(N0))GO TO 20 DO N1=N11,NENG1 !FIND STARTING POINT IF(ENERG1(N1).GT.ENERG0(N0))GO TO 10 ENDDO GO TO 20 C 10 NP2=MIN(N1+NPH1,NENG1) NP1=MAX(1,N1-NPH2) C EX1=.FALSE. DO N=NP1,NP2 IF(PCS1(N).NE.ZERO)EX1=.TRUE. ENDDO C IF(EX1)THEN DO J=NP1,NP2 DD=DONE DO M=NP1,NP2 IF(J.NE.M)THEN DD=DD*(EP-ENERG1(M)) DD=DD/(ENERG1(J)-ENERG1(M)) ENDIF ENDDO XINT=XINT+DD*PCS1(J) ENDDO ENDIF C 20 EP=EP+DEP1 !PHOTON ENERGY REL TO GROUND E0=EP-DEEP !ELECTRON ENERGY REL TO GROUND E=E0-DE1 !ELECTRON ENERGY REL TO FINAL WRITE(9,104)EP,ENERG0(N0),E0,E,XINT 104 FORMAT(1P,4E16.8,E14.4) C WRITE(9,104)EP,XINTT C 104 FORMAT(1P,E16.8,E14.4) C N11=N1 ENDDO C DO N1=N11,NENG1 EP=ENERG1(N1) !PHOTON ENERGY REL TO INITIAL XINT=PCS1(N1) EP=EP+DEP1 !PHOTON ENERGY REL TO GROUND E0=EP-DEEP !ELECTRON ENERGY REL TO GROUND E=E0-DE1 !ELECTRON ENERGY REL TO FINAL WRITE(9,104)EP,ENERG1(N1),E0,E,XINT ENDDO C C RETURN END