C N. R. BADNELL PROGRAM MDRCS UoS v13.7 28/06/21 C C*********************************************************************** C C POST-PROCESSOR FOR ** AUTOSTRUCTURE ** C *************************************** C C GENERATES DR, RTEX, RTEXX, RE, REDA, RTEA ENERGY-EVERAGED CROSS C SECTIONS AND CONVOLUTES THEM WITH GAUSSIAN, MAXWELLIAN, COMPTON, C LORENTZIAN OR MERGED-BEAMS VELOCITY DISTRIBUTIONS. C CAN ALSO SOLVE THE CAPTURE-CASCADE EQUATIONS, ACCOUNT FOR INTERFERENCE C BETWEEN DR AND RR ALLOW FOR ANISOTROPIC RADIATION OR ELECTRON EMISSION C OR GENERATE ARRAY-AVERAGED TRANSITION PROBABILITIES - TOAST OPTIONAL. C C*********************************************************************** C PROGRAM MAIN C SUN TIME REAL*4 TARRY(2) C CHARACTER*4 CMBLNK COMMON /BLANK/MBLNK DATA CMBLNK/' '/ C C OPEN(5,FILE='drcsin') !STDIN OPEN(6,FILE='drcsout') !STDOUT OPEN(3,FILE='expdat') !EXP DATA, SEVERAL FORMATS POSS. OPEN(4,FILE='dcasc') !ADD. INPUT FOR CAP.-CASC. EQNS. OPEN(7,FILE='ocs') !I/O BINNED CROSS SECTIONS OPEN(8,FILE='ocsx') !I/O LORENTZIAN DATA OPEN(9,FILE='ombg') !NON-RES. CONTRIB. RR OR EXCITN. OPEN(10,FILE='ombgu',FORM='UNFORMATTED') !DITTO - UNFORMATTED OPEN(11,FILE='dncor') ! N-DEP. XN FACTORS E.G. FIELDS OPEN(12,FILE='omega') !R-MATRIX (I.E. RESONANCES) OMEGA OPEN(13,FILE='doutgnu') !E.V.XN OUTPUT FOR GNUPLOT OPEN(16,FILE='doutgnur') !R-MATRIX E.V.XN OUTPUT FOR GNUPLOT OPEN(14,FILE='ombgi') !DIRECT+EA XN FOR REDA (.OR. UNIT9) OPEN(15,FILE='ayld') !AUGER YIELDS FOR ombg/omega OPEN(40,FILE='o0') !AUTOS FILE FOR 2ND AUGER YLD IN REDA OPEN(41,FILE='o0u',FORM='UNFORMATTED') ! " " " " (UNFORM) C OPEN(42,FILE='opn') !RR DATA FOR DR+RR +/- INTERFERENCE C OPEN(42,FILE='opnu',FORM='UNFORMATTED') !RR DATA FOR DR+RR - UNFORM C OPEN(70,FILE='on') !AUTOS DATA FILE (FORMATTED) n=1,2,3... C OPEN(70,FILE='onu',FORM='UNFORMATTED') !AUTOS DATA FILE (UNFORM)n=1,2,3... OPEN(80,FILE='fnl') ! n,l SPECIFIC DETECTION EFFICIENCIES (READ) OPEN(81,FILE='xnl') ! n,l SPECIFIC CROSS SECTIONS (WRITE) C OPEN(24,FILE='tape24',FORM='UNFORMATTED') !INTERNAL I/O OPEN(25,FILE='tape25',FORM='UNFORMATTED') !INTERNAL I/O OPEN(26,FILE='tape26',FORM='UNFORMATTED') !INTERNAL I/O OPEN(94,FILE='discg') !ADD WARNING & ERROR MESSAGES C C FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS C TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY C OPEN(99,STATUS='SCRATCH',FORM='FORMATTED') C WRITE(99,1111)CMBLNK 1111 FORMAT(A4) BACKSPACE(99) READ(99,1111)MBLNK CLOSE(99) C C NCARGKS COMPUTER GRAPHICS METAFILE USES UNIT=95? C C***********ATTENTION: ALL USER UNIT5 INPUT IS DETAILED IN THE FOLLOWING C*********** SUBROUTINE, POSTP. C CALL POSTP C C*********** C*********** C C SUN TIME DUM=DTIME(TARRY) TIME=TARRY(1) C C CRAY TIME CCRAY CALL SECOND(TIME) C TIME=TIME/60.0 WRITE(6,999)TIME 999 FORMAT(//1X,'CPU TIME=',F9.3,' MIN') C CLOSE(6) CLOSE(3) CLOSE(4) CLOSE(7) CLOSE(8) CLOSE(9) CLOSE(10) CLOSE(11) CLOSE(12) CLOSE(13) CLOSE(14) CLOSE(15) CLOSE(16) CLOSE(40) CLOSE(41) CLOSE(42) CLOSE(70) CLOSE(80) CLOSE(81) CLOSE(24) CLOSE(25) CLOSE(26) CLOSE(94) STOP END C*********************************************************************** SUBROUTINE AMODX(AA,NUMA,JCA,LMX,QLB,QN,N,L,NZ,NE) IMPLICIT REAL*8 (A-H,O-Z) C EVAULATED UNITARISED AA PARAMETER (HBAR=4.837769E-17,NDIM14=200) INTEGER QN,QLB DIMENSION AA(*),JCA(*),LMX(*),QN(*),QLB(NDIM14,10) IF(N*NUMA.EQ.0)RETURN TPI=2.0*ACOS(-1.0) EN=N DE=QDT(QD0,NZ,NE,N,L) DE=-2.0*DE/(EN-QD0) T=DE/(HBAR*TPI) DO 1 I=1,NUMA K=JCA(I) J=LMX(K) M=QLB(K,J) IF(QN(M).EQ.N)GO TO 1 TA=ABS(AA(I)/T) IF(TA.GT.1.0E-4)THEN TA=T*(1.0-EXP(-TA)) AA(I)=SIGN(TA,AA(I)) ENDIF 1 CONTINUE RETURN END C**************************************************************** SUBROUTINE AYIELD(NV0,LV0,IPRINT) IMPLICIT REAL*8 (A-H,O-Z) INTEGER SS,QS0,QL0,QL,QN LOGICAL BFORM,BLOR,BFEAR,BBACK C C EVALUATE AUGER YIELD FOR REDA C PARAMETER (NDIM0=108) PARAMETER (NDIM1=10001) PARAMETER (NDIM2=36) PARAMETER (NDIM3=100001) PARAMETER (NDIM4=9999) PARAMETER (NDIM5=150) PARAMETER (NDIM7=20000000) PARAMETER (NDIM8=100) PARAMETER (NDIM9=12) PARAMETER (NDIM10=5) PARAMETER (NDIM11=99999) PARAMETER (NDIM12=9000000) PARAMETER (NDIM13=95000) PARAMETER (NDIM14=200) PARAMETER (NDIM15=501) PARAMETER (NDIM16=50) PARAMETER (NDIM17=800) PARAMETER (NDIM25=15) PARAMETER (NDIM26=75) PARAMETER (NDIM27=150) PARAMETER (JTEMP=10) C COMMON/XX/ICA(NDIM12),JCA(NDIM12),ITA(NDIM12),AA(NDIM12) X, EION(NDIM12),JTA(NDIM12),IWA(NDIM12),EC(NDIM12) X, JTR(NDIM7),ICR(NDIM7),JCR(NDIM7),JDUM1(NDIM7) X, IWR(NDIM7),DEL(NDIM7),ITR(NDIM7),AR(NDIM7),EATOM(NDIM7) X, IK(NDIM13),IT(NDIM13),SS(NDIM13),LL(NDIM13),JJ(NDIM13) X, JK(NDIM13),LCF(NDIM13) X, ENERG(NDIM13),DUM1(NDIM5),NG(NDIM14) COMMON /JCF/JCFA,JCFR,JCFJ,JCFY,JCFE,JPAR,LSPI,J2PI,BLOR,BFEAR X,MAX2J COMMON /YLD/AYLD(NDIM4),EII(NDIM4),EFN,EFMIN X,IYLD(NDIM13),LSPJ(NDIM4),NYLD COMMON /STOR/QS0(10),QL0(10),QN(30),QL(30),SUMRD(NDIM4) X,EI(NDIM4),NUMR !/CSTOR/ NOT USED ELSEWHERE COMMON /CORR/ACORN(NDIM1),ACORL(NDIM25),NNCOR,NLCOR X,ACORA(NDIM26),ICOR(NDIM26),NACOR,JYLD COMMON /ECOR/ E1C(NDIM8),E1X(NDIM8),ECORT,TOLB COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) C C POSSIBLE UNIT NOS TO BE CHECKED FOR DATA MR=40 MRU=41 BFORM=.FALSE. READ(MR,38,END=331)MDUM1,MDUM2 BACKSPACE(MR) BFORM=.TRUE. C C 331 IF(BFORM)READ(MR,38,END=911)NV,LV IF(.NOT.BFORM)READ(MRU,END=911)NV,LV C 38 FORMAT(5X,I5,5X,I5) IF(NV.EQ.0.AND.LV.EQ.0)RETURN IF(LV.GE.0.AND.LV0.GE.0)THEN IF(LV.NE.LV0.OR.NV.NE.NV0)THEN WRITE(6,1234)NV,LV,NV0,LV0 1234 FORMAT(' SR.AYIELD: MISMATCH IN NL BLOCKS, NV LV 1 & 2',4I5) ENDIF ENDIF WNP0=-1.0 C C READ HEADER, AND MAYBE ORBITAL CODE C IF(BFORM)READ(MR,101) NCF,NZ0,NE,(QN(I),QL(I),I=1,30) IF(.NOT.BFORM)READ(MRU,ERR=300) NCF,NZ0,NE,(QN(I),QL(I),I=1,30) 101 FORMAT(I3,12X,I2,6X,I2,4X,30(I3,I2)) 300 IF(NCF.GT.NDIM14)THEN WRITE(6,136)NCF 136 FORMAT(' DIMENSION EXCEEDED IN SR.AYIELD, INCREASE NDIM14 TO',I5) STOP 50 ENDIF IF(NCF.EQ.0)RETURN C C READ CONFIGURATION DATA C DO 102 I=1,NCF IF(BFORM)READ(MR,179)II,NGR,MA0,MB0,(QS0(J),QL0(J),J=1,10) IF(.NOT.BFORM)READ(MRU)II,NGR,MA0,MB0,(QS0(J),QL0(J),J=1,10) 179 FORMAT(2I5,2X,I3,I2,1X,10(I2,A1)) IN=IABS(II) NG(IN)=NGR 102 CONTINUE C IF(BFORM)READ(MR,103) IF(.NOT.BFORM)READ(MRU)NZTEST,NDUME IF(BFORM)READ(MR,103) 103 FORMAT(A1) I=0 111 I=I+1 C C READ AUTOIONIZATION RATES AND ENERGIES C IF(BFORM)READ(MR,112)ICA(I),ITA(I),IWA(I),JCA(I),JTA(I),AA(I),EC(I X),EION(I) IF(.NOT.BFORM)READ(MRU)ICA(I),ITA(I),IWA(I),JCA(I),JTA(I),AA(I),EC X(I),EION(I) 112 FORMAT(5I5,5X,1PE15.5,2(0PF15.6)) I=I-1 IF(ICA(I+1).GT.JCFY)GO TO 111 I=I+1 AA(I)=ABS(AA(I)) IF(ITA(I).NE.0) GO TO 111 EFMIN=EION(I) NUMA=I-1 IF(NUMA.GE.NDIM12)STOP 333 C IF(BFORM)READ(MR,121) NENG,ECORE IF(.NOT.BFORM)READ(MRU) NENG,ECORE 121 FORMAT(10X,I5,45X,F15.6) IF(NENG.EQ.0)THEN IF(NUMR*NYLD.EQ.0)RETURN GO TO 239 ENDIF IF(BFORM)READ(MR,105)MTEST IF(.NOT.BFORM)READ(MRU)MTEST 105 FORMAT(26X,A4) IF(NENG.LT.NDIM13)GO TO 157 WRITE(6,369)NENG 369 FORMAT(' NUMBER OF LEVELS EXCEEDS STORAGE,INCREASE NDIM13 TO',I6) STOP 444 C C READ ENERGIES C 157 NYLD=0 DO 122 I=1,NENG IF(BFORM)READ(MR,123)IK(I),ITTTT,SS(I),LL(I),JJ(I),LCF(I),ENERG(I) IF(.NOT.BFORM)READ(MRU)IK(I),ITTTT,SS(I),LL(I),JJ(I),LCF(I),ENERG( XI) 123 FORMAT(5X,6I5,F15.6) M=IK(I) M=IABS(M) IYLD(M)=0 C C SET-UP AUGER BINS AND INDEXING C IF((ECORE+ENERG(I)).LT.EFMIN)GO TO 122 IF(LCF(I).LT.0)GO TO 122 IF(LCF(I).GT.JCFY)GO TO 122 IF(IK(I).LT.0)GO TO 122 IF(ENERG(I).GE.(WNP0+TOLB))THEN ! SET TOLB=0.0 TO RESOLVE DEGENERATE STATES NYLD=NYLD+1 IF(NYLD.GT.NDIM4)THEN WRITE(6,777) 777 FORMAT(' SR.AYIELD: INCREASE NDIM4') STOP 777 ENDIF ELSE T=0.9*(ENERG(I)-WNP0) WRITE(6,124)NYLD,IK(I-1),WNP0,IK(I),ENERG(I),T 124 FORMAT(/' SR.AYIELD: WARNING, ENERGY DEGENERACY,', X' STATES COMBINED'/I5,2(I5,F15.6)/ X' TRY DECREASING TOLB IN NAMELIST TWO TO',F15.8,' RY') C STOP 788 ENDIF IYLD(M)=NYLD LSPJ(NYLD)=100*LL(I)+10000*IABS(SS(I)) LSPJ(NYLD)= JJ(I)+LSPJ(NYLD) IF(SS(I).LT.0)LSPJ(NYLD)=-LSPJ(NYLD) WNP0=ENERG(I) EII(NYLD)=ECORE+ENERG(I) 122 CONTINUE C C EII ARE N-ELECTRON RESONANCE ENERGIES, EI ARE CORRESPONDING ENERGY BINS IF(NYLD.GT.0)THEN EII(NYLD+1)=EII(NYLD)+EII(NYLD)-EII(NYLD-1) EI(1)=EII(1)-0.5*(EII(2)-EII(1)) DO 18 M=1,NYLD EI(M+1)=EII(M+1)-0.5*(EII(M+1)-EII(M)) 18 CONTINUE ENDIF C STATES BELOW EFMIN ARE BOUND, ABOVE ARE AUTOIONIZING C EFMIN=EFMIN+0.5*(EII(1)-EFMIN) !KEEP AS EXACT I.P. C EFN IS N-ELECTRON GROUND-STATE, CORRESPONDS TO EIONMN OF N+1 PROBLEM. EFN=ECORE+ENERG(1) C IF(BFORM)READ(MR,104)NZTEST IF(.NOT.BFORM)READ(MRU)NZTEST,NDUME 104 FORMAT(66X,I2) IF(NZTEST.LT.1)THEN NUMR=0 ELSE IF(BFORM)READ(MR,103) C C READ RADIATIVE RATES AND ENERGIES C I=0 C 131 I=I+1 IF(BFORM)READ(MR,132) ICR(I),ITR(I),IWR(I),JCR(I),JTR(I),AR(I),DEL X0,EATOM0 IF(.NOT.BFORM)READ(MRU) ICR(I),ITR(I),IWR(I),JCR(I),JTR(I),JWR,AR( XI),DEL0,EATOM0 132 FORMAT(5I5,5X,1PE15.5,2(0PF15.6)) AR(I)=ABS(AR(I)) IF(ITR(I).NE.0) GO TO 131 NUMR=I-1 IF(JCFA.LT.0)NUMR=0 ENDIF IF(NUMR.GE.NDIM7) STOP 555 C IF(NYLD.EQ.0)RETURN IF(NUMR.EQ.0.AND.JYLD.EQ.1)THEN DO 1 I=1,NYLD AYLD(I)=1.0 1 CONTINUE GO TO 166 ENDIF DO 238 I=1,NYLD SUMRD(I)=0.0 238 CONTINUE IF(NUMR.GT.0)THEN DO 242 I=1,NUMR MS=IYLD(ITR(I)) IF(MS.EQ.0)GO TO 242 SUMRD(MS)=SUMRD(MS)+AR(I) 242 CONTINUE ENDIF C C FORM AUGER YIELDS C 239 DO 2 I=1,NYLD AYLD(I)=0.0 2 CONTINUE IF(NUMA.EQ.0)RETURN DO 240 I=1,NUMA MS=IYLD(ITA(I)) IF(MS.EQ.0)GO TO 240 AYLD(MS)=AYLD(MS)+AA(I) 240 CONTINUE DO 244 I=1,NYLD IF(AYLD(I).EQ.0.0)THEN IF(NUMR.GT.0.AND.SUMRD(I).EQ.0.0.AND.NZ0-NE.LT.25)AYLD(I)=1.0 ELSE T=SUMRD(I)/AYLD(I) AYLD(I)=1.0/(1.0+T) ENDIF C TEST-PRINT IF(IPRINT.GE.0)WRITE(6,900)I,LSPJ(I),EII(I),AYLD(I) 244 CONTINUE 166 IF(NACOR.GT.0)THEN DO 255 I=1,NACOR J=ICOR(I) AYLD(J)=ACORA(I) 255 CONTINUE ENDIF C C WRITE AUGER YIELDS C REWIND(15) READ(15,*,END=922)IDUM RETURN 922 WRITE(15,933)NYLD,EFMIN-ECORE DO 3 I=1,NYLD WRITE(15,900)I,LSPJ(I),EII(I)-ECORE,AYLD(I) 3 CONTINUE C IF(BBACK)THEN WRITE(6,*)' SR.AYIELD: AUGER YIELDS NOW CALCULATED FOR SR.BEXA' X,' NOW RE-RUN TO GET E-A' STOP' SR.AYIELD: AUGER YIELDS NOW CALCULATED FOR SR.BEXA' ENDIF C 911 RETURN 900 FORMAT(I5,I10,2F12.6) 933 FORMAT(I5,F12.6) END C*********************************************************************** SUBROUTINE BEX(NBINR,NBINM,LMAX,JCFA) IMPLICIT REAL*8 (A-H,O-Z) C C READ-IN N-STATE DW "OMEGA" FILE FOR NON-RESONANT EXCITATION, C OR RADIATIVE RECOMBINATION. C PARAMETER(NDIM2=36,NDIM3=100001,NDIM5=150,NDIM6=05,NDIM44=501 X,NDIM33=501,NTMS=100,NDIM47=NDIM33+NDIM44+501) C CHARACTER*4 CAR C LOGICAL BLAS,BSEL,BBACK,BLASD C DIMENSION CC(5),UE(NDIM33) DIMENSION DWOM(NDIM2,NDIM33),OMEGAD(NDIM47),EMSH(NDIM44) C COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /EB/EBCOR COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG DIMENSION CON(NDIM5),ISAT(NTMS),LAT(NTMS),ENAT(NTMS) X,IMX0(NDIM5,NTMS) C EQUIVALENCE (PCS(1),EMSH(1)) C C L IS THE TRANSITION INDEX IN THE NTAR1*NTAR2 MATRIX, DEPENDS C ON WHETHER ELASTIC ARE INCLUDED OR NOT (BLAS)! C N.B. NBINM=NTAR1, NBINRM=NTAR2. C C ITYPE=1,2 LEAST SQUARES FIT. C ITYPE=3,4 SPLINE (=4, CONVOLG,X ONLY). C ITYPE=1,4 ASSUMES BACKGROUND INDEPENDENT OF CONVOLUTION ENERGY. C ITYPE=2,3 EXPLICITLY INTEGRATES BACKGROUND CONVOLUTION. C BBACK=.FALSE. LMAX=NBINM NBINRM=NBINR-1 C IF(JCFA.EQ.0)THEN READ(9,105,END=75)CAR 105 FORMAT(A4) REWIND(9) IF(CAR.EQ.' NV')RETURN DO 43 I=1,NBINM IREV(I,1)=I IREV(I,2)=0 43 CONTINUE BLASD=.TRUE. GO TO 45 ENDIF C BSEL=IABS(JCFA).LT.100 IF(BSEL)THEN DO 25 I=1,NBINM IREV(I,1)=I IREV(I,2)=IABS(JCFA) 25 CONTINUE ELSE BLAS=IABS(JCFA).EQ.100 DO 44 I=1,NDIM5 IREV(I,1)=0 IREV(I,2)=0 44 CONTINUE K=0 DO 27 I=1,NBINM IF(BLAS)THEN J1=I ELSE J1=I+1 ENDIF IMX(I,I)=0 IF(J1.GT.NBINRM)GO TO 27 DO 28 J=J1,NBINRM IMX(J,I)=0 K=K+1 IF(K.GT.NDIM2)THEN IMX(I,J)=0 ELSE IREV(K,1)=I IREV(K,2)=J IMX(I,J)=K ENDIF 28 CONTINUE 27 CONTINUE IF(K.GT.NDIM2)THEN WRITE(6,101)K 101 FORMAT(//' SR.BEX, INCREASE NDIM2 TO AT LEAST ',I3,' TO GET' X,' ALL TRANSITIONS REQUESTED') K=NDIM2 ENDIF LMAX=K ENDIF C C C DEFAULT, NO ELASTIC OMEGAS FROM DW OMEGA FOR IONS. C BLASD=.FALSE. C 45 READ(9,*,END=75)NZED,NELC C BBACK=.TRUE. C IF(NZED.EQ.NELC)THEN BLASD=.TRUE. TAZ=1.0 ELSE TAZ=NZED-NELC TAZ=TAZ*TAZ ENDIF C READ(9,*)NAST,MXE,NOMWRT C IF(NAST.GT.NTMS)THEN WRITE(6,100)NAST 100 FORMAT(//' SR.BEX, INCREASE NTMS TO AT LEAST ',I3) STOP 38 ENDIF C READ(9,*)(ISAT(I),LAT(I),I=1,NAST) READ(9,*)(ENAT(I),I=1,NAST) C 710 FORMAT(5E16.6) C IF(.NOT.BLASD)NOMT=(NAST*(NAST-1))/2 IF(BLASD)NOMT=(NAST*(NAST+1))/2 IF(NOMWRT.GT.0)NOMT=NOMWRT IF(NOMT.GT.NDIM47)THEN WRITE(6,103)NOMT 103 FORMAT(//' SR.BEX, INCREASE NDIM47 TO AT LEAST ',I5) BBACK=.FALSE. RETURN ENDIF C N=0 DO 7 I=1,NAST ENAT(I)=ENAT(I)*TAZ IF(I.GT.NBINM)GO TO 7 IF(ISAT(I).NE.0)THEN W=ABS(ISAT(I))*(2*LAT(I)+1) ELSE W=ABS(LAT(I)) ! B.P. LAT=2*J+1 ENDIF CON(I)=87.9735/W IMX0(I,I)=0 IP=I+1 IF(BLASD)IP=I IF(IP.GT.NAST)GO TO 7 DO 8 J=IP,NAST N=N+1 IMX0(I,J)=N 8 CONTINUE 7 CONTINUE C IF(MXE.GT.NDIM33)THEN WRITE(6,*)' SR.BEX: MXE REDUCED TO ',NDIM33,' INCREASE NDIM33 TO ' X,MXE,' TO RETAIN ALL INPUT ENERGIES' MXE=NDIM33 ENDIF IF(MXE.GT.NDIM44)THEN WRITE(6,*)' SR.BEX: MXE REDUCED TO ',NDIM44,' INCREASE NDIM44 TO ' X,MXE,' TO RETAIN ALL INPUT ENERGIES' MXE=NDIM44 ENDIF C DO 1 IE=1,MXE C READ(9,*)EMSH(IE),(OMEGAD(N),N=1,NOMT) C 700 FORMAT(E11.5,6(E11.3)/(11X,6(E11.3))) C EMSH(IE)=EMSH(IE)*TAZ C DO 9 L=1,LMAX J=IREV(L,2) IF(J.GT.0)THEN IF(J.GT.NAST)GO TO 9 I=IREV(L,1) N=IMX0(I,J) ELSE N=L ENDIF IF(N.GT.0)DWOM(L,IE)=OMEGAD(N) 9 CONTINUE 1 CONTINUE C IF(ITYPE.LE.0)ITYPE=3 IFIT=6 IF(ITYPE.GE.3)IFIT=4 C I0=1 IF(EMSH(1).EQ.0.0)I0=2 DO 2 L=1,LMAX I=IREV(L,1) J=IREV(L,2) IF(J.GT.0)THEN IF(J.GT.NAST)GO TO 2 DE=ENAT(J)-ENAT(I) IXTRP(L)=2 ! DEFAULT ASSUME CONSTANT OMEGA IF(ISAT(I)*ISAT(J).NE.0)THEN IF(ISAT(I).EQ.ISAT(J))THEN IF(IABS(LAT(I)-LAT(J)).EQ.1)THEN IXTRP(L)=1 ELSE IXTRP(L)=2 ENDIF ELSE IXTRP(L)=3 ENDIF ENDIF ELSE IXTRP(L)=4 DE=-1.0 ENDIF C NE=1 UE(1)=1.0 ENERG(1)=DE DO 3 IE=I0,MXE IF(EMSH(IE)-ENAT(I).GT.DE)THEN NE=NE+1 OMEGAD(NE)=DWOM(L,IE) ENERG(NE)=EMSH(IE)-ENAT(I) IF(ITYPE.LT.3)UE(NE)=ENERG(NE)/DE ENDIF 3 CONTINUE IF(I0.EQ.2)THEN OMEGAD(1)=DWOM(L,1) ELSE OMEGAD(1)=OMEGAD(2) ENDIF IF(NZED.EQ.NELC)OMEGAD(1)=0.0 C IF(NE.LT.IFIT) THEN BBACK=.FALSE. WRITE(6,115)IFIT,NE 115 FORMAT(' REQUIRE AT LEAST',I2,' ENERGIES TO FIT BACKGROUND, INPUT= X',I3) RETURN ENDIF C C IF(ITYPE.GE.3)GO TO 78 C C PERFORM LEAST SQUARES FIT ON THE BACKGROUND OMEGAS C IF(J.EQ.I)STOP ' ELASTIC TRANSITION FOR OMEGFIT??' IDIP=0 IF(IXTRP(L).EQ.1)IDIP=1 C CALL OMEGFIT(OMEGAD,UE,NE,CC,IDIP,IFAIL) C IF(IFAIL.NE.0) STOP 18 DO 72 IE=1,5 SIGMA(L,IE)=CON(I)*CC(IE) 72 CONTINUE C ALL ENERGIES IN PP ARE RELATIVE TO INITIAL STATE ENAT(I), NOT ENAT(1). SIGMA(L,6)=0.0 SIGMA(L,7)=DE DO 13 IE=1,NE T=CC(1)+CC(2)/UE(IE)+CC(3)/UE(IE)**2+CC(4)*LOG(UE(IE)) X+CC(5)*LOG(UE(IE))/UE(IE) TT=T/OMEGAD(IE) IF(ABS(TT-1.0).GT.0.05)WRITE(6,114)UE(IE),OMEGAD(IE),T,TT 114 FORMAT(' WARNING:SR.BEX ACCURACY ON LEAST-SQUARES FIT',1P4E15.5) 13 CONTINUE GO TO 2 C C PERFORM SPLINE FIT TO BACKGROUND OMEGA'S C 78 SIGMA(L,6)=0.0 SIGMA(L,7)=-1.0 NXNG(L)=NE NENG=NE DO 79 IE=1,NE OMEGAD(IE)=OMEGAD(IE)*CON(I) 79 CONTINUE CALL SPLYN(NE,ENERG,OMEGAD,3,T,3,T,SP1,SP2,SP3,SP4,SP5) ! T DUMMY IF(NE.LE.NDIM44)THEN DO 80 IE=1,NE SPY(L,IE,1)=SP1(IE) SPY(L,IE,2)=SP2(IE) SPY(L,IE,3)=SP3(IE) SPY(L,IE,4)=SP4(IE) SPY(L,IE,5)=ENERG(IE) 80 CONTINUE ELSE IF(LMAX.GT.1)WRITE(6,157)NE 157 FORMAT(' ****SR.BEX, INCREASE NDIM44 TO AT LEAST',I5) LMAX=1 ENDIF C 2 CONTINUE C 75 RETURN END C************************************************************************ SUBROUTINE BEXA(NBINR,NBINM,JCFA,LMAX) IMPLICIT REAL*8 (A-H,O-Z) C C READ-IN N-STATE DW OMEGA FILE FOR NON-RESONANT EXCITATION- C AUTOIONIZATION. FINAL STATES ARE MULTIPLIED BY AUGER YIELD C AND SUMMED TO GET TOTAL E-A CONTRIBUTION FROM INITIAL STATE L. C PARAMETER(NDIM2=36,NDIM3=100001,NDIM5=150,NDIM6=05,NDIM44=501 X,NDIM33=501,NTMD=1000,NDIM47=NDIM33+NDIM44+501) C LOGICAL BBACK,BLASD C DIMENSION AYLD(NTMD),LSPJ(NTMD),EII(NTMD) DIMENSION DWOM(NDIM6,NTMD,NDIM33),OMEGAD(NDIM47),EMSH(NDIM44) C COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /EB/EBCOR COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG DIMENSION CON(NDIM6),ISAT(NTMD),LAT(NTMD),ENAT(NTMD) X,IMX0(NDIM6,NTMD) C EQUIVALENCE (PCS(1),EMSH(1)) C C L IS THE TRANSITION INDEX IN THE NTAR1*NTAR2 MATRIX, DEPENDS C ON WHETHER ELASTIC ARE INCLUDED OR NOT (BLAS)! C N.B. NBINM=NTAR1, NBINRM=NTAR2. C C ITYPE=3,4 SPLINE FIT (=4, CONVOLG,X ONLY). C ITYPE=3 EXPLICITLY INTEGRATES BACKGROUND CONVOLUTION. C ITYPE=4 ASSUMES BACKGROUND INDEPENDENT OF CONVOLUTION ENERGY. C BBACK=.FALSE. LMAX=NBINM NBINRM=NBINR-1 C IF(LMAX.GT.NDIM6)THEN WRITE(6,*)' SR.BEXA: NO OF INITIAL STATES HAS BEEN REDUCED' X,' TO ',NDIM6,' INCREASE NDIM6 TO AT LEAST ',LMAX LMAX=NDIM6 ENDIF C ITYPE=3 DO 26 I=1,NBINM IREV(I,1)=I IREV(I,2)=0 26 CONTINUE READ(9,*,END=76)MDUM REWIND(9) C NYLD=0 EAUTO=0.0 READ(15,*,END=5)NYLD,EAUTO IF(JCFA.LT.0)NYLD=0 IF(NYLD.GT.NTMD)THEN WRITE(6,*) ' SR.BEXA: INCREASE NTMD FROM ',NTMD,' TO ',NYLD X,' TO OBTAIN NON-UNITY AUGER YIELDS FOR REMAINING STATES' NYLD=NTMD ENDIF DO 4 I=1,NYLD READ(15,*)II,LSPJ(II),EII(II),AYLD(II) 4 CONTINUE C C C DEFAULT, NO ELASTIC OMEGAS FROM DW OMEGA FOR IONS. C 5 BLASD=.FALSE. C READ(9,*)NZED,NELC C BBACK=.TRUE. C IF(NZED.EQ.NELC)THEN BLASD=.TRUE. TAZ=1.0 ELSE TAZ=NZED-NELC TAZ=TAZ*TAZ ENDIF C READ(9,*)NAST,MXE,NOMWRT C IF(NAST.GT.NTMD)THEN WRITE(6,100)NAST 100 FORMAT(//' SR.BEXA, INCREASE NTMD TO AT LEAST ',I3) STOP 38 ENDIF C READ(9,*)(ISAT(I),LAT(I),I=1,NAST) READ(9,*)(ENAT(I),I=1,NAST) C 710 FORMAT(5E16.6) C WRITE(6,106) 106 FORMAT(//' MATCHING OF STATES FOR EXCITATION-AUTOIONIZATION'/ X,' II',6X,'LSPJ',7X,'EII',7X,'N',5X,'LTEST',6X,'ENAT') EAUTO=EAUTO/TAZ NYLD0=0 DO 6 N=1,NAST IF(ENAT(N).LE.EAUTO)THEN NYLD0=N ELSE II=N-NYLD0 IF(II.GT.NYLD)GO TO 3 IF(ISAT(N).NE.0)THEN LTEST=100*LAT(N)+10000*IABS(ISAT(N)) IF(ISAT(N).LT.0)LTEST=-LTEST IF(LTEST.NE.LSPJ(II))THEN WRITE(6,*)' SR.BEXA: MIS-MATCH OF STATES FOR E-A, ' X,II,LSPJ(II),N,LTEST STOP ENDIF ELSE LTEST=ABS(LAT(N))-1 IF(LAT(N).LT.0)LTEST=-LTEST L1=IABS(LSPJ(II)) L2=L1/10000 L2=L1-L2*10000 L3=L2/100 L3=L2-L3*100 IF(LSPJ(II).LT.0)L3=-L3 IF(LTEST.NE.L3)THEN WRITE(6,*)' SR.BEXA: MIS-MATCH OF STATES FOR E-A, ' X,II,LSPJ(II),N,LTEST STOP ENDIF ENDIF WRITE(6,105)II,LSPJ(II),EII(II),N,LTEST,ENAT(N)*TAZ 105 FORMAT(I3,I10,F12.5,3X,I3,I10,F12.5) ENDIF 6 CONTINUE C 3 IF(.NOT.BLASD)NOMT=(NAST*(NAST-1))/2 IF(BLASD)NOMT=(NAST*(NAST+1))/2 IF(NOMWRT.GT.0)NOMT=NOMWRT IF(NOMT.GT.NDIM47)THEN WRITE(6,103)NOMT 103 FORMAT(//' SR.BEXA, INCREASE NDIM47 TO AT LEAST ',I5) BBACK=.FALSE. RETURN ENDIF C N=0 DO 7 I=1,NAST ENAT(I)=ENAT(I)*TAZ IF(I.GT.LMAX)GO TO 7 IF(ISAT(I).NE.0)THEN W=ABS(ISAT(I))*(2*LAT(I)+1) ELSE W=ABS(LAT(I)) ! B.P. LAT=2*J+1 ENDIF CON(I)=87.9735/W IMX0(I,I)=0 IP=I+1 IF(BLASD)IP=I IF(IP.GT.NAST)GO TO 7 DO 8 J=IP,NAST N=N+1 IMX0(I,J)=N 8 CONTINUE 7 CONTINUE C IF(MXE.GT.NDIM33)THEN WRITE(6,*)' SR.BEXA: MXE REDUCED TO ',NDIM33,' INCREASE NDIM33 TO X',MXE,' TO RETAIN ALL INPUT ENERGIES' MXE=NDIM33 ENDIF IF(MXE.GT.NDIM44)THEN WRITE(6,*)' SR.BEXA: MXE REDUCED TO ',NDIM44,' INCREASE NDIM44 TO X',MXE,' TO RETAIN ALL INPUT ENERGIES' MXE=NDIM44 ENDIF C K0=NYLD0+1 DO 1 IE=1,MXE C READ(9,*)EMSH(IE),(OMEGAD(N),N=1,NOMT) C 700 FORMAT(E11.5,6(E11.3)/(11X,6(E11.3))) C EMSH(IE)=EMSH(IE)*TAZ C DO 9 L=1,LMAX I=L !=IREV(L,1) DO 10 K=K0,NAST II=K-NYLD0 T=0.0 N=IMX0(I,K) IF(N.GT.0)T=OMEGAD(N) IF(II.LE.NYLD)T=T*AYLD(II) DWOM(L,II,IE)=T 10 CONTINUE C 9 CONTINUE 1 CONTINUE C IF(ITYPE.LE.2)ITYPE=3 C I0=1 IF(EMSH(1).EQ.0.0)I0=2 DO 2 L=1,LMAX I=L IXTRP(L)=1 C NE=NDIM44 EMAX=EMSH(MXE)-ENAT(I) EMIN=ENAT(K0)+1.0E-6-ENAT(I) DE=(EMAX-EMIN)/(NE-1) DO 14 IE=1,NE ENERG(IE)=EMIN+(IE-1)*DE OMEGAD(IE)=0.0 14 CONTINUE C DO 15 K=K0,NAST II=K-NYLD0 DE=ENAT(K)-ENAT(I) NV=1 EVEC(1)=DE DO 16 IE=I0,MXE IF(EMSH(IE).GT.ENAT(K))THEN NV=NV+1 VEC(NV)=DWOM(L,II,IE) EVEC(NV)=EMSH(IE)-ENAT(I) ENDIF 16 CONTINUE IF(I0.EQ.2)THEN VEC(1)=DWOM(L,II,1) ELSE VEC(1)=VEC(2) ENDIF IF(NZED.EQ.NELC)VEC(1)=0.0 C IF(NV.LT.4) THEN BBACK=.FALSE. WRITE(6,116)NV,L,K 116 FORMAT(' REQUIRE AT LEAST FOUR ENERGIES TO FIT BACKGROUND, INPUT=' X,I3,' FOR TRANSITION ',2I3) RETURN ENDIF C CALL SPLYN(NV,EVEC,VEC,3,T,3,T,SP1,SP2,SP3,SP4,SP5) ! T DUMMY J1=0 DO 17 IE=1,NE IF(ENERG(IE).GT.DE)THEN OMEGAD(IE)=OMEGAD(IE)+ X SPVAL(NV,EVEC,VEC,SP1,SP2,SP3,SP4,ENERG(IE),J1) ENDIF 17 CONTINUE C 15 CONTINUE C C C PERFORM SPLINE FIT TO BACKGROUND OMEGA'S C SIGMA(L,6)=0.0 SIGMA(L,7)=-1.0 NXNG(L)=NE NENG=NE DO 79 IE=1,NE OMEGAD(IE)=OMEGAD(IE)*CON(I) 79 CONTINUE CALL SPLYN(NE,ENERG,OMEGAD,3,T,3,T,SP1,SP2,SP3,SP4,SP5) ! T DUMMY IF(NE.LE.NDIM44)THEN DO 80 IE=1,NE SPY(L,IE,1)=SP1(IE) SPY(L,IE,2)=SP2(IE) SPY(L,IE,3)=SP3(IE) SPY(L,IE,4)=SP4(IE) SPY(L,IE,5)=ENERG(IE) 80 CONTINUE ELSE IF(LMAX.GT.1)WRITE(6,157)NE LMAX=1 ENDIF 2 CONTINUE RETURN C C ALTERNATIVE READ OF DIRECT + EXN-AUTOZN BACKGRD FOR REDA C MITCH'S FILE. C 76 ENATI=0.0 L=1 READ(14,*,END=75)NENG,UNITS C NEED ENATI IF LAMX .GT. 1 IF(NENG.GT.NDIM44)THEN WRITE(6,*)' SR.BEXA: NENEG REDUCED TO ',NDIM44,' INCREASE NDIM44' X,' TO',NENG,' TO RETAIN ALL INPUT ENERGIES' NENG=NDIM44 ENDIF IF(LMAX.GT.1.AND.ENATI.EQ.0.0)THEN WRITE(6,117) 117 FORMAT(' SR.BEXA: WARNING, ENATI=0.0 FOR METASTABLE!!') LMAX=1 ENDIF C BBACK=.TRUE. IF(ITYPE.LE.2)ITYPE=3 C ASSUME DIPOLE-LIKE BEHAVIOUR FOR EXTRAPOLATION FOR NOW IXTRP(L)=1 ISM=0 SIGMA(L,6)=0.0 SIGMA(L,7)=-1.0 NXNG(L)=NENG READ(14,*)(ENERG(I),I=1,NENG) READ(14,*)(PCS(I),I=1,NENG) C ENERG=ENERG-ENATI IF NOT RELATIVE TO ENATI DO 77 I=1,NENG ENERG(I)=ENERG(I)/UNITS PCS(I)=ENERG(I)*PCS(I) ENERG(I)=ENERG(I)-EBCOR 77 CONTINUE CALL SPLYN(NENG,ENERG,PCS,3,T,3,T,SP1,SP2,SP3,SP4,SP5) IF(NENG.LE.NDIM44)THEN DO 81 I=1,NENG SPY(L,I,1)=SP1(I) SPY(L,I,2)=SP2(I) SPY(L,I,3)=SP3(I) SPY(L,I,4)=SP4(I) SPY(L,I,5)=ENERG(I) 81 CONTINUE ELSE IF(LMAX.GT.1)WRITE(6,157)NENG 157 FORMAT(' ****SR.BEXA, INCREASE NDIM44 TO AT LEAST',I5) LMAX=1 ENDIF C 75 RETURN END C************************************************************************ SUBROUTINE BRR(NBINM,LMAX,NCUT,LCUT,IWT,EI,NCUTR,NCUTRR,NECOR X ,IPRINT,IMODE,NMN,LMN) C C RADIATIVE RECOMBINATION C IMPLICIT REAL*8 (A-H,O-Z) C LOGICAL BJUMP,BINT,BPRNT0,BPRNT1,BPRNT2,BBACK,BLOR,BFEAR,BFORM X,BFORMP,EX C CHARACTER FILNAM*5 C PARAMETER (NDIM2=36) PARAMETER (NDIM3=100001) PARAMETER (NDIM5=150) PARAMETER (NDIM8=100) PARAMETER (NDIM15=501) PARAMETER (NDIM16=50) PARAMETER (NDIM24=50000) PARAMETER (NDIM33=501) PARAMETER (NDIM44=501) C DIMENSION IWT(*),EI(*),NCUTR(*),TC(NDIM2,NDIM33) X,TCS(NDIM2,NDIM33),TCL(NDIM2,NDIM33),UB(NDIM2,NDIM16,NDIM33) X,NS(NDIM16),CC(5) C COMMON /ECOR/ E1C(NDIM8),E1X(NDIM8),ECORT,TOLB COMMON /DIP/ RSUM(NDIM15),CP(NDIM15),CM(NDIM15),JDUM(NDIM15) X/JCF/JCFA,JCFR,JCFJ,JCFY,JCFE,JPAR,LSPI,J2PI,BLOR,BFEAR,MAX2J COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /MIX/CIRN,CIRD,TCOOL,TFLITE,NFLITE,NFNLMX,FNL(NDIM24) COMMON /PHOTON/EBDMIN,EBDMAX,EPHMIN,EPHMAX C BBACK=.FALSE. DO I=1,NBINM IREV(I,1)=I IREV(I,2)=0 ENDDO IF(LMAX.EQ.0)LMAX=NBINM C C DETERMINE UNIT CONTAINING BACKGROUND C BFORMP=.FALSE. MR=9 !ombg BFORM=.TRUE. READ(MR,38,END=43,ERR=43)MDUM,MDUM GO TO 41 43 MR=10 !ombgu BFORM=.FALSE. READ(MR,END=44,ERR=44)MDUM,MDUM GO TO 41 44 BFORMP=.TRUE. MR=42 IFILE=1 C FILNAM='op1' INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)THEN BFORM=.TRUE. OPEN(MR,FILE=FILNAM) READ(MR,38,END=43)MDUM,MDUM ELSE FILNAM='op1u' INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)THEN BFORM=.FALSE. OPEN(MR,FILE=FILNAM,FORM='UNFORMATTED') READ(MR,END=44)MDUM,MDUM ELSE MR=0 GO TO 42 ENDIF ENDIF C 41 IF(BFORM)READ(MR,101)NENG0,NZ0,NE IF(.NOT.BFORM)READ(MR)NENG0,NZ0,NE REWIND(MR) C IF(NENG0.GT.NDIM33)STOP 'INCREASE NDIM33' IF(NENG.LE.0)NENG=NENG0 NENG=MIN(NENG,NENG0) DZ=NZ0-NE+1 DZ=DZ*DZ C C DETERMINE RR N CUT-OFF (NCUTRR.LT.0 NO CUT-OFF; .EQ. 0 DETERMINE FROM C TARGET (OBSERVED) ENERGIES - *DEFAULT*; .GT.0 WERE READ-IN.) C IF(NBINM.GT.1.AND.NCUTRR.EQ.0)THEN IF(-NECOR.LT.NBINM)THEN WRITE(6,*)'***BRR ERROR: UNABLE TO DETERMINE RR N CUT-OFF' WRITE(6,*)'READ-IN TARGET ENERGIES OR CUT-OFF EXPLICITLY' STOP '***BRR ERROR: UNABLE TO DETERMINE RR N CUT-OFF' ELSE DO I=2,NBINM NCUTR(I)=SQRT(DZ/E1X(I)) ENDDO ENDIF ENDIF NCUTRR0=NCUTRR C C ITYPE=1,2 LEAST SQUARES FIT. C ITYPE=3,4 SPLINE (=4, CONVOLG,X ONLY). C ITYPE=1,4 ASSUMES BACKGROUND INDEPENDENT OF CONVOLUTION ENERGY. C ITYPE=2,3 EXPLICITLY INTEGRATES BACKGROUND CONVOLUTION. IF(ITYPE.LT.0)ITYPE=3 C BPRNT0=IPRINT.GE.0 BPRNT1=IPRINT.GE.-1 BPRNT2=IPRINT.GE.-2 IF(BPRNT0)WRITE(6,33) IF(BPRNT2)WRITE(6,90) C IWTOT=0 DO L=1,LMAX IWTOT=IWTOT+IWT(L) DO I=1,NENG TCS(L,I)=0.0 ENDDO ENDDO TWTOT=IWTOT C NVINT=100 IF(NCUT.NE.100000.AND.NVINT.LT.NCUT)NVINT=NCUT ISM=0 LV00=-1 C 331 NMIN=0 !=NV00 NV0=100000 LV0=-1 C 31 IF(BFORM)READ(MR,38,END=911)NV,LV IF(.NOT.BFORM)READ(MR,END=911)NV,LV C IF(LV.LT.0.AND.LV00.GE.0)THEN WRITE(6,*)'***ERROR: RE-ORDER INPUT FILES opn(u) ETC SO THAT' X ,' EQUIVALENT ELECTRON FILES COME FIRST***' STOP '***ERROR: RE-ORDER INPUT FILES opn(u)' ENDIF C IF(NMIN.EQ.0)NMIN=NV IF(NV0.EQ.100000)GO TO 70 IF(NV.GT.0.AND.LV.EQ.LV0)GO TO 37 91 IF(IC.EQ.1)GO TO 71 C C SUM HIGH N OF OLD L USING INTERPOLATION AND THEN SIMPSONS RULE C DO I=3,IC,2 I0=I T1=NS(I-2) T2=NS(I-1) T3=NS(I) V1=T1**3 V2=T2**3 V3=T3**3 385 N1=NS(I0-2) N2=NS(I0-1) TN1=N1*N1 N1=N1+1 DO N=N1,N2 IF(N.GT.NCUT)GO TO 71 TN=N S1=V1*(T2-TN)*(T3-TN)/((T2-T1)*(T3-T1)) S2=V2*(T1-TN)*(T3-TN)/((T1-T2)*(T3-T2)) S3=V3*(T1-TN)*(T2-TN)/((T1-T3)*(T2-T3)) TN2=N*N DO L=1,LMAX IF(N.LE.NCUTR(L))THEN DO J=1,NENG TT=S1*UB(L,I-2,J)+S2*UB(L,I-1,J)+S3*UB(L,I,J) TT=TT/(TN*TN2) TCL(L,J)=TCL(L,J)+TT ENDDO ENDIF ENDDO ENDDO I0=I0+1 IF((I0-1).EQ.I)GO TO 385 IC0=I IF((I+1).LT.IC.AND.N2.GT.NVINT)GO TO 384 ENDDO GO TO 71 C 384 DO J=1,NENG DO L=1,LMAX TCL(L,J)=TCL(L,J)-0.5*UB(L,IC0,J) ENDDO ENDDO IC0=IC0+2 DO I=IC0,IC,2 T1=NS(I-2)*NS(I-2) T3=NS(I)*NS(I) H=(T3-T1)/(T1*T3) H=H/12.0 T=NS(I-2) T1=T1*T T2=NS(I-1)**3 T=NS(I) T3=T3*T DO L=1,LMAX IF(NS(I-1).LE.NCUTR(L))THEN TT=0.0 DO J=1,NENG T=T1*UB(L,I-2,J)+4.0*T2*UB(L,I-1,J)+T3*UB(L,I,J) IF(I.EQ.IC)TT=UB(L,IC,J)*0.5 T=T*H+TT TCL(L,J)=TCL(L,J)+T ENDDO ENDIF ENDDO ENDDO C 71 IF(BPRNT2.AND.NV0.GE.0)WRITE(6,36)LV0,(TCL(1,I),I=1,NENG) DO I=1,NENG DO L=1,LMAX TCS(L,I)=TCS(L,I)+TCL(L,I) ENDDO ENDDO IF(LV.GT.LCUT)GO TO 1001 IF(NV.EQ.0)GO TO 1000 C C START A NEW L C 70 LV0=LV NV0=NV-1 LV00=LV0-1 C DO I=1,NENG DO L=1,LMAX TCL(L,I)=0.0 ENDDO ENDDO IC=1 C C START A NEW N C 37 DO I=1,NENG DO L=1,LMAX TC(L,I)=0.0 ENDDO ENDDO BJUMP=NV.GT.NV0+1 BINT=.FALSE. IF(NV.LE.NCUT.AND.NV.GE.NMN.AND.LV.GE.LMN)GO TO 85 ICT=IC-mod(ic-1,2) cold IF(ICT.GT.1)ICT=ICT-1 IF(BJUMP.AND.NS(ICT).LT.NCUT.AND.NV.GE.NMN.AND.LV.GE.LMN)GO TO 85 BINT=.TRUE. IF(LV.LT.LCUT.OR.NV.LT.NMN)GO TO 75 LV=LV+1 GO TO 91 85 IF(BPRNT0.AND.NV.GE.0)WRITE(6,34)NV,LV IF(BJUMP)IC=IC+1 IF(IC.GT.NDIM16)STOP 19 NS(IC)=NV 75 NV0=NV IF(NFNLMX.GT.0)THEN !N,L SPECIFIC DETECTION PROBABILITIES IF(NV.GT.0.AND.NV.LE.NFNLMX)THEN IFNL=(NV*(NV-1))/2+LV+1 FNLV=FNL(IFNL) ELSE FNLV=0.0 ENDIF ELSE FNLV=1.0D0 ENDIF C IF(BFORM)READ(MR,101) NENG0,NZ0,NE,EIONMN IF(.NOT.BFORM)READ(MR) NENG0,NZ0,NE,EIONMN C IF(NENG0.EQ.0)GO TO 42 BBACK=.TRUE. C IF(BFORM)THEN READ(MR,102)(ENERG(I),I=1,NENG0) READ(MR,103) READ(MR,103) ELSE READ(MR)(ENERG(I),I=1,NENG0) READ(MR) READ(MR) ENDIF 2 IF(BFORM)READ(MR,104,end=30)ICP,ITP,IWP,JCP,JTP,L,PCS(1),EI0,EC IF(.NOT.BFORM)READ(MR,end=30)ICP,ITP,IWP,JCP,JTP,L,PCS(1),EI0,EC C IF(ITP.EQ.0)GO TO 3 IF(NENG0.GT.1)THEN IF(BFORM)READ(MR,102)(PCS(I),I=1,NENG0) IF(.NOT.BFORM)READ(MR)(PCS(I),I=1,NENG0) ENDIF C IF(EI0.GT.EIONMN)GO TO 2 IF(ICP.GT.JCFJ)GO TO 2 IF(PCS(1).EQ.0.0)GO TO 2 IF(EIONMN-EI0.LT.EBDMIN.OR.EIONMN-EI0.GT.EBDMAX)GO TO 2 C T=EC-EI+ENERG(ITEST) C IF(T.LT.EPHMIN.OR.T.GT.EPHMAX)GO TO 2 C C NEED TO USE EI(I) OF TARGET IF WANT IC AVERAGED-OVER C TARGET FINE-STRUCTURE SINCE ENERGY ORDER LABEL L IS BY C LEVEL IN IC. C L=0 C CTEMP DF IF(IMODE.EQ.-4.AND.L.EQ.0)L=1 CTEMP DF C IF(L.EQ.0)THEN DO L=1,LMAX IF(EC.GE.EI(L).AND.EC.LT.EI(L+1))GO TO 27 ENDDO GO TO 2 ENDIF C 27 IF(L.GT.LMAX.OR.BINT)GO TO 2 TW=IWT(L) T=IWP TW=T/TW TT=EC-EI0 DO I=1,NENG PCS(I)=ABS(PCS(I)) T=TT IF(TT.GT.0.0)T=TT+ENERG(I) ! ELSE TT IS -PHOTON ENERGY ALREADY T=T*T T=1.33128D13*TW*T PCS(I)=T*PCS(I)*FNLV TC(L,I)=TC(L,I)+PCS(I) ENDDO IF(BPRNT0)THEN IF(IMODE.EQ.-4)THEN JTP=ITP ITP=ICP ENDIF WRITE(6,105)ITP,JTP,(PCS(I),I=1,NENG) ENDIF GO TO 2 C 30 WRITE(6,1107) 1107 FORMAT(/' ******WARNING, UNEXPECTED END OF DATA IN SR.BRR !!!!'/) C 3 IF(BINT)GO TO 31 C T=NV**3 DO I=1,NENG DO L=1,LMAX UB(L,IC,I)=TC(L,I) IF(.NOT.BJUMP)TCL(L,I)=TCL(L,I)+TC(L,I) C TC(L,I)=TC(L,I)*T ENDDO ENDDO IF(BPRNT1.AND.NV.GE.0)WRITE(6,106)NV,LV,(TC(1,I),I=1,NENG) GO TO 31 C C GO READ A NEW FILE C 1000 IF(.NOT.BFORMP)GO TO 1001 C CLOSE(MR) IFILE=IFILE+1 IC1=IFILE/10 IC2=IFILE-10*IC1 IC0=ICHAR('0') IC1=IC1+IC0 IC2=IC2+IC0 C IF(BFORM)THEN FILNAM='op'//CHAR(IC2) IF(IFILE.GE.10)FILNAM='op'//CHAR(IC1)//CHAR(IC2) INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)OPEN(MR,FILE=FILNAM) ELSE FILNAM='op'//CHAR(IC2)//'u' IF(IFILE.GE.10)FILNAM='op'//CHAR(IC1)//CHAR(IC2)//'u' INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)OPEN(MR,FILE=FILNAM,FORM='UNFORMATTED') ENDIF C IF(EX)GO TO 331 C 911 LV0=LV00+1 C 1001 CONTINUE C C ADD-IN HYDROGENIC CONTRIBUTION FOR HIGH-L (L.GT.LV0) SAME N UP TO NCUT LCUT C IF(LV0.GE.LCUT)GO TO 160 IF(LCUT.EQ.100000)GO TO 160 C IF(LCUT.GE.NDIM15)STOP 'TOO MANY A.M., INCREASE NDIM15 TO LCUT+1' ICMAX=IC IC=1 BJUMP=.FALSE. DO I=1,NENG DO L=1,LMAX TCL(L,I)=0.0 ENDDO ENDDO N=NMIN IF(LV0.LT.0)N=N+1 LV=LCUT+1 LVMIN=LV0+1 LV0=LCUT 10 IF(LVMIN.GE.N)GO TO 6 LVMAX=MIN0(LCUT,N-1) LPMAX=LVMAX+1 TN=N*N IF(NFNLMX.GT.0.AND.N.GT.NFNLMX)FNLV=0.0 C DO I=1,NENG DE=DZ/TN+ENERG(I) E2=ENERG(I)/DZ CALL DIPOL(1,N,0,E2,LPMAX,CP,CM,JDUM) RSUM0=0.0 DO L=LVMIN,LVMAX IF(N.LE.NFNLMX)THEN !N,L SPECIFIC DETECTION PROBABILITIES IFNL=(N*(N-1))/2+L+1 FNLV=FNL(IFNL) ENDIF LP=L+1 TL=L+L TLP=LP+LP RSUM(LP)=FNLV*TLP*CP(LP)*1.0D10**JDUM(LP) IF(L.GT.0)RSUM(LP)=RSUM(LP)+FNLV*TL*CM(L)*1.0D10**JDUM(L) IF(BPRNT0)RSUM(LP)=1.13953D-5*RSUM(LP)*DE**3/(DZ*DZ) RSUM0=RSUM0+RSUM(LP) ENDDO IF(.NOT.BPRNT0)RSUM0=1.13953D-5*RSUM0*DE**3/(DZ*DZ) IF(BPRNT0)WRITE(6,126)I,N,(L,L=LVMIN,LVMAX) IF(BPRNT0)WRITE(6,127)(RSUM(L+1),L=LVMIN,LVMAX) DO L=1,LMAX IF(N.LE.NCUTR(L))THEN TC(L,I)=RSUM0 IF(.NOT.BJUMP)TCL(L,I)=TCL(L,I)+RSUM0 UB(L,IC,I)=RSUM0 ENDIF ENDDO ENDDO IF(BPRNT1)WRITE(6,128)N,(TC(1,I),I=1,NENG) 6 IF(N.GE.NCUT.AND.IC.EQ.1)GO TO 91 N=N+1 IF(N.LE.NS(1).OR.NMIN.EQ.NS(1))GO TO 10 IF(IC.EQ.ICMAX)GO TO 91 BJUMP=.TRUE. IC=IC+1 N=NS(IC) GO TO 10 C C AVERAGE-OVER TARGET STATES C 160 WRITE(6,109)(TCS(1,I),I=1,NENG) WRITE(6,122)(ENERG(I),I=1,NENG) DO I=1,NENG TC(1,I)=0.0 ENDDO DO L=1,LMAX T=IWT(L) T=T/TWTOT DO I=1,NENG TC(1,I)=TC(1,I)+T*TCS(L,I) ENDDO ENDDO WRITE(6,123)(TC(1,I),I=1,NENG) NEMIN=6 IF(ITYPE.GE.3)NEMIN=3 IF(NENG.LT.NEMIN) THEN C BBACK=.FALSE. C WRITE(6,115)NEMIN,NENG C115 FORMAT(' REQUIRE AT LEAST',I3,' ENERGIES TO FIT BACKGROUND, INPUT= C X',I3) C GO TO 42 C ENDIF C C IF(NENG.LE.1)THEN IF(ITYPE.GT.1)ITYPE=2 DO L=1,LMAX DO I=2,6 SIGMA(L,I)=0.0 ENDDO SIGMA(L,1)=TCS(L,1) SIGMA(L,7)=-1.0 ENDDO GO TO 42 ENDIF C C INITIALIZE FOR SIMPLE LAGRANGE INTERPOLATION IN GLNAG. C IF(ITYPE.EQ.0)THEN DO L=1,LMAX IXTRP(L)=4 DO I=1,NENG PCS(I)=TCS(L,I) ENDDO ENDDO GO TO 42 ENDIF C IF(ITYPE.GE.3)GO TO 19 C C PERFORM LEAST SQUARES FIT TO RR 'OMEGA' C DZ=1.0 DO I=1,NENG ENERG(I)=ENERG(I)/DZ + 1.0 ENDDO IFAIL=0 DO L=1,LMAX IXTRP(L)=4 DO I=1,NENG PCS(I)=TCS(L,I) ENDDO CALL OMEGFIT(PCS,ENERG,NENG,CC,0,IFAIL) IF(IFAIL.NE.0)STOP '***BRR: FAILURE IN LEAST-SQUARES OMEGFIT' DO I=1,5 SIGMA(L,I)=CC(I) ENDDO SIGMA(L,6)=0.0 SIGMA(L,7)=-DZ C WRITE(6,114)CC(1),CC(2),CC(3) DO I=1,NENG T=CC(1)+CC(2)/ENERG(I)+CC(3)/ENERG(I)**2 TT=T/PCS(I) IF(ABS(TT-1.0).GT.0.1)WRITE(6,114)ENERG(I),PCS(I),T,TT ENDDO ENDDO GO TO 42 C C PERFORM SPLINE FIT TO RR 'OMEGA' C 19 DO L=1,LMAX IXTRP(L)=4 SIGMA(L,6)=0.0 SIGMA(L,7)=-1.0 NXNG(L)=NENG DO I=1,NENG PCS(I)=TCS(L,I) ENDDO CALL SPLYN(NENG,ENERG,PCS,3,T,3,T,SP1,SP2,SP3,SP4,SP5) DO I=1,NENG SPY(L,I,1)=SP1(I) SPY(L,I,2)=SP2(I) SPY(L,I,3)=SP3(I) SPY(L,I,4)=SP4(I) SPY(L,I,5)=ENERG(I) ENDDO ENDDO C 42 IF(MR.GT.0)REWIND(MR) RETURN C 33 FORMAT(4X,'J',4X,'I',1X,8(4X,'E*CROSS(MB)')) 34 FORMAT(I5,I3) 36 FORMAT(2X,'SUM',I3,3X,1P8E15.5/(11X,8E15.5)) 38 FORMAT(5X,I5,5X,I5) 90 FORMAT(4X,'N L',3X,8(4X,'E*CROSS(MB)')) 101 FORMAT(I3,12X,I2,6X,I2,35X,F15.6) 102 FORMAT(5E15.5) 103 FORMAT(A1) 104 FORMAT(6I5,E15.5,2F15.6) 105 FORMAT(2I5,1X,1P8E15.5/(11X,8E15.5)) 106 FORMAT(I5,I3,3X,1P8E15.5/(11X,8E15.5)) 109 FORMAT(/1X,'TOTAL',5X,1P8E15.5/(11X,8E15.5)) 114 FORMAT(' WARNING SR.BRR, ACCURACY OF LEAST-SQUARES FIT',1P4E15.7) 122 FORMAT(//' INCIDENT ELECTRON ENERGIES (RYD)'/(11X,1P8E15.5)) 123 FORMAT(//' TOTAL RR CROSS SECTION(MB) * E(RYD), AVERAGED OVER ' X,'TARGET STATES'/(11X,1P8E15.5)) 126 FORMAT(I3,I5,3X,8(6X,I3,6X)/(11X,8(6X,I3,6X))) 127 FORMAT(11X,1P8E15.5/(11X,8E15.5)) 128 FORMAT(I5,6X,1P8E15.5/(11X,8E15.5)) END C*********************************************************************** SUBROUTINE CASC(TEMP,JTEMP,E12,DMIN,NCF,NAZ,NG,JCORW,TOLR,ECORE X,MTEST,NLEVEL,ENERG,JORIG,IORIG,JTERM,KUES,KUEL,KUEJ,KUECF,AR X,SBIN,LMAX,EWIDTH,IZ,IPRINT,NV) C C EVALUATE DR LINE INTENSITIES INCLUDING CASCADE (BADNELL 1988) C C NXTRP = PRINCIPAL QUANTUM NUMBER TO BE EXTRAPOLATED: C JCON CONFIGURATION NUMBERS TO BE EXTRAPOLATED C NXTRP=0 OR JCON .LT. 1 MEANS NO EXTRAPOLATION CARRIED OUT. C ECUT: LEVELS .GT. ECUT RYD ABOVE GROUND CONTINUUM (DMIN) ARE OMITTED C FROM EXTRAPOLATION; LEVELS SPECIFIED BY CONFIGURATION NO. JC . C MULTS .LT. 0 SUM OVER DOUBLY EXCITED STATES IS RESTRICTED TO THOSE C OF SPIN MULTIPLICITY (2S+1)=!MULTS! C .EQ. 0 SUM INCLUDES ALL S C .GT. 0 TOTAL INCLUDES ALL S BUT LINE COEFFICIENTS SORTED C AND PRINTED FOR (2S+1)=MULTS ONLY C SELECTED ACCORDING TO AMIN(K) K=1,2,3 C JSUM .GT.0 LOWEST LEVELS/TERMS EFFECTIVE DR COEFFICIENTS C SUMMED-OVER. C JSUM .LT. 0 ONLY THE ENERGY ORDERED TERM=-JSUM OUTPUT C IN IC, IF JSUM .GT. 0 LINE COEFFICIENTS ARE SUMMED OVER J,J' , C SELECTED ACCORDING TO AMIN(K)*AMULT C JSUM IS NOT USED IF KCORR .NE. 0 C KCORR .EQ. 0 UNCORRELATED CASCADE C .NE. 0 |KCORR| CORRELATED CASCADES (K-K) C .GT. 0 Ka-Ka, Ka-Kb, Ka-Kc, Kb-Kb C .LT. 0 " " " , Kbc-Kbc C THEN TL1, TL2, TL3 SET-UP ENERGY BIN FOR Ka,b,c RADIATION (RYD) C C STORAGE RESTRICTIONS SET UP BY PARAMETER STATEMENTS C C MAXLEV=MAX NO. OF LEVELS/TERMS C MAXIND=MAXLEV*(MAXLEV-1)/2 .EQ. MAX NO. OF INDEXES INDR(I) C MAXCF=MAX NO. OF CONFIGURATIONS C NDIM33=MAXTEM=MAX NO. OF TEMPERATURES C MAXTM=MAX NO. OF TERMS WHEN SUMMING OVER J (IC ONLY) C MAXCFX=MAX NO. OF CONFIGURATIONS TO BE EXTRAPOLATED C MAXLDR=MAX NO. OF LINE COEFFICIENTS STORED FOR RE-ORDERING IN C DESCENDING WAVELENGTH, OVERFLOW IS PRINTED AS CALCULATED. C IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BXTRP,BLSCUP,BIA,BIB,BMULT,BJSUM,BLOG,BCORR,BIAR,BPRINT PARAMETER(MAXLEV=1,MAXIND=1,MAXCF=1,NDIM33=2,MAXCFX=1,MAXLDR=1 X,MAXTM=1,NDIM1=10001,NDIM2=36,NCORR=4) C PARAMETER(MAXLEV=1235,MAXIND=761995,MAXCF=250,NDIM33=501 C X,MAXCFX=50,MAXLDR=0001,MAXTM=528,2001,NDIM2=36,NCORR=4) C 2001 DIMENSION INDR(MAXIND),KUES(*),KUEL(*),KUEJ(*) X,KUECF(*),ADR(MAXLEV,NDIM33,NCORR),AR(*),TEMP(NDIM33),JC(MAXCF), XNAD(MAXCF),NG(*),ENERG(*),JORIG(*),COEF(NDIM33),ALDR(NDIM33,NCORR) X,ADX(MAXCFX,NDIM33),IORIG(*),MDR(NDIM33),ASX(NDIM33),LSI(MAXLDR) X,LSJ(MAXLDR),EZ(10),SBIN(NDIM2,NDIM1), XTLAM(MAXLDR),ASLDR(MAXLDR,NDIM33),JTERM(*),ETERM(MAXTM),WGT(MAXTM) COMMON /BLANK/MBLNK DATA DKCM/109737.31/,ZERO/0.0/ X,(EZ(I),I=1,10)/1.14,1.81,0.40,0.69,0.0,0.83,0.0,0.0,0.0,1.59/ NAMELIST/CASK/NXTRP,JCON,JSUM,MULTS,ECUT,AMIN1,AMIN2,AMIN3,AMULT X,TL1,TL2,TL3,TL4,KCORR,RMIN C C REWIND(4) C NXTRP=0 JCON=0 JSUM=2 BPRINT=IPRINT.GT.-2 MULTS=0 ECUT=0.0 AMULT=1.0 TL1=912.0 TL2=3000.0 TL3=0.0 TL4=0.0 KCORR=0 RMIN=0.0 IF(EWIDTH.LT.0.0)THEN AMIN1=1.0E-14 AMIN2=1.0E-14 AMIN3=1.0E-14 TTEST=1.0E-30 ELSE AMIN1=-1.0E-25 AMIN2=-1.0E-25 AMIN3=-1.0E-25 TTEST=-1.0D-40 ENDIF C C READ(4,CASK) C BMULT=MULTS.LT.0 IMULTS=-MULTS BCORR=KCORR.NE.0 IF(BPRINT)THEN IF(.NOT.BCORR)WRITE(6,172)KCORR,NXTRP,JCON,JSUM,MULTS,ECUT,AMIN1 X,AMIN2,AMIN3,AMULT,RMIN IF(BCORR)WRITE(6,171)KCORR,NXTRP,JCON,JSUM,MULTS,ECUT,TL1,TL2,TL3 X,TL4,RMIN ENDIF KXMX=1 IF(BCORR)KXMX=4 IF(KXMX.GT.NCORR)STOP 29 TA=TEMP(2)-TEMP(1) TB=TEMP(JTEMP)-TEMP(JTEMP-1) T=TB/TA T=ABS(T-1.0) BLOG=T.GT.1.0E-2 TOLA=E12-DMIN IF(JTEMP.GT.NDIM33)THEN WRITE(6,150)JTEMP,NDIM33 STOP 30 ENDIF IF(TEMP(1).EQ.0.0)TEMP(1)=0.001*TEMP(2) DO 41 J=1,JTEMP IF(EWIDTH)85,88,86 86 IF(IZ.EQ.0)GO TO 87 COEF(J)=6.68505E-36/SQRT(TEMP(J)) GO TO 41 87 COEF(J)=1.33704E-32 GO TO 41 88 COEF(J)=1.4624E-24 GO TO 41 85 TEMP(J)=1.5789E5*TEMP(J) TJ=SQRT(TEMP(J)) COEF(J)=2.0707E-16/(TJ*TEMP(J)) 41 CONTINUE IF(NCF.GT.MAXCF)THEN WRITE(6,152)NCF,MAXCF STOP 31 ENDIF DO 1 IA=1,NCF NAD(IA)=0 1 CONTINUE C C SET-UP EXTRAPOLATION IF REQUIRED C IF(NXTRP.EQ.0.OR.JCON.LT.1)GO TO 42 IF(NV.GT.0.AND.NXTRP.NE.NV)GO TO 42 ZA=NAZ ZZ=ZA*ZA*0.15789E6 TNX=NXTRP AV=ZZ/(TNX*TNX) IF(ECUT.LE.0.0)ECUT=1.0E20 IF(JCON.GT.MAXCFX)THEN WRITE(6,147)JCON,MAXCFX STOP 34 ENDIF C READ(4,*)(JC(I),I=1,JCON) IF(BPRINT)WRITE(6,*)(JC(I),I=1,JCON) C T=TNX DO 39 I=1,JCON J=JC(I) NAD(J)=I DO 24 M=1,JTEMP IF(EWIDTH)90,91,91 90 TI=AV/TEMP(M) TJ=1.0 IF(TI.LT.75.0 )TJ=TJ-EXP(-TI) T=TJ*TNX/TI T=T+1.0 ADX(I,M)=1.0 91 IF(T.GT.2.0 )ADX(I,M)=0.5 *T 24 CONTINUE 39 CONTINUE C C INITIALIZE AND POSSIBLY SUM OVER FINE-STRUCTURE ENERGIES C 42 IF(NLEVEL.GT.MAXLEV)THEN WRITE(6,151)NLEVEL,MAXLEV STOP 32 ENDIF MX=NLEVEL*(NLEVEL-1) MX=MX/2 IF(MX.GT.MAXIND)THEN WRITE(6,148)MX,MAXIND STOP 33 ENDIF DO 7 I=1,MX INDR(I)=0 7 CONTINUE BLSCUP=MTEST.EQ.MBLNK BJSUM=.NOT.BLSCUP.AND.JSUM.GT.0 IF(BJSUM)THEN DO 53 M=1,MAXTM ETERM(M)=0.0 WGT(M)=0.0 53 CONTINUE ENDIF DO 9 I=1,NLEVEL IF(EWIDTH.LT.0.0)ENERG(I)=ENERG(I)*DKCM IF(.NOT.BJSUM)GO TO 61 JT=JTERM(I) IF(JT.LE.MAXTM)GO TO 52 BJSUM=.FALSE. WRITE(6,146)JT,MAXTM GO TO 61 52 T=KUEJ(I)+1 ETERM(JT)=ETERM(JT)+T*ENERG(I) WGT(JT)=WGT(JT)+T 61 DO 6 J=1,JTEMP DO 8 K=1,KXMX ADR(I,J,K)=0.0 8 CONTINUE 6 CONTINUE 9 CONTINUE IF(BJSUM)THEN JT=JTERM(1) T=ETERM(JT)/WGT(JT) DO 63 I=1,MAXTM IF(WGT(I).GT.0.0 )ETERM(I)=ETERM(I)/WGT(I) ETERM(I)=ETERM(I)-T 63 CONTINUE ENDIF C 62 READ(24)JCC,JSS,JWS,MC,KS,ASUM,DD,EE IF(ASUM.LT.RMIN)GO TO 62 C IF(BMULT)THEN I=IORIG(JSS) IS=KUES(I) IF(IABS(IS).NE.IMULTS)GO TO 62 ENDIF J=0 J0=1 JMAX=-1 JS=JSS A=ASUM 50 IF(MC.GT.0)GO TO 44 IF((EE-DMIN).GT.TOLA)GO TO 5 TI=JCORW A=A/TI DO 45 M=1,JTEMP IF(EWIDTH)80,81,82 82 IF(IZ.EQ.0)GO TO 84 T=SQRT(TEMP(M)) T=0.5/T Q=(DD+EZ(IZ)-TEMP(M))*T TI=A*COMPTON(IZ,Q)/DD GO TO 83 84 A0=1.66511/EWIDTH T=A0*(TEMP(M)-DD) T=T*T TI=0.0 IF(T.LT.75.0)TI=A*EXP(-T)*A0*0.5641895/DD GO TO 83 81 TI=2.0*A*DITTNER(ZERO,DD,TEMP(M))/(DD*DD) GO TO 83 80 DK=-0.15789D6*DD T=DK/TEMP(M) TI=0.0 IF(T.GT.-75.0 )TI=A*EXP(T) 83 ADR(JS,M,1)=ADR(JS,M,1)+TI 45 CONTINUE GO TO 5 44 J=J+1 AR(J)=A IF(KS.LT.JS)GO TO 17 IS=KS KS=JS JS=IS 17 MX=(JS-1)*(JS-2) MX=MX/2 MX=MX+KS INDR(MX)=J C 5 READ(24,END=2)JCC,JS,JW,MC,KS,A,DD,EE IF(A.LT.RMIN)GO TO 5 C IF(JS-JSS)2,3,4 3 ASUM=ASUM+A GO TO 50 4 IF(BMULT)THEN I=IORIG(JS) IS=KUES(I) IF(IABS(IS).NE.IMULTS)GO TO 5 ENDIF 26 TJ=JWS DO 47 M=1,JTEMP ADR(JSS,M,1)=ADR(JSS,M,1)*COEF(M)*TJ 47 CONTINUE IF(J0.LE.J)THEN DO 15 I=J0,J AR(I)=AR(I)/ASUM 15 CONTINUE ENDIF IF(J.EQ.JMAX)GO TO 99 J0=J+1 JSS=JS JWS=JW ASUM=A GO TO 50 2 JMAX=J GO TO 26 C C SOLVE CAPTURE-CASCADE EQUATIONS AND SORT AND STORE LINE DR C 99 K=0 KF0=0 KS=1 KF=1 BMULT=MULTS.GT.0 JTEST=JTEMP/2 JTEST=JTEST+1 ETEST=DMIN-ECORE IF(EWIDTH.LT.0.0)THEN ECUT=ECUT*DKCM ETEST=ETEST*DKCM TOLR=TOLR*DKCM ENDIF N1=NLEVEL-1 DO 18 IP=1,N1 I=NLEVEL-IP IF(KUECF(I).LT.0)GO TO 18 II=JORIG(I) IF(II.LT.0)GO TO 18 IC=KUECF(I) BIA=(ENERG(I)-ETEST).GT.TOLR BIAR=BIA C COMMENT-OUT TO SWITCH-OFF RADIATION THROUGH AUTOIONIZING STATES X .AND.NAD(IC).GT.0 I1=I+1 DO 19 J=I1,NLEVEL IF(KUECF(J).LT.0)GO TO 19 JJ=JORIG(J) IF(JJ.LT.0)GO TO 19 IF(.NOT.BCORR.AND.ADR(JJ,JTEST,1).LT.TTEST)GO TO 19 JS=MIN0(II,JJ) IS=MAX0(II,JJ) MX=(IS-1)*(IS-2) MX=MX/2 MX=MX+JS JA=INDR(MX) IF(JA.EQ.0)GO TO 19 BIB=(ENERG(J)-ETEST).GT.TOLR TL=ENERG(J)-ENERG(I) IF(.NOT.BCORR)THEN C C UNCORRELATED CASCADE C ITEST=0 IF(BJSUM)THEN MI=JTERM(I) MJ=JTERM(J) IF(MI.EQ.MJ)GO TO 19 TL=ETERM(MJ)-ETERM(MI) ENDIF AMIN=AMIN2 IF(EWIDTH.LT.0.0)THEN TL=1.0E8/TL IF(TL.LT.TL1)AMIN=AMIN3 IF(TL.GT.TL2)AMIN=AMIN1 ENDIF DO 20 M=1,JTEMP ALDR(M,1)=AR(JA)*ADR(JJ,M,1) IF(ALDR(M,1).GT.AMIN)ITEST=1 20 CONTINUE IF(ITEST.EQ.0)GO TO 21 IF(.NOT.BMULT)GO TO 31 JS=KUES(J) IF(IABS(JS).NE.MULTS)GO TO 21 31 IF(EWIDTH)89,21,21 89 IF(K.LT.MAXLDR)GO TO 38 IF(.NOT.BJSUM)GO TO 65 KF0=MAXLDR+1 GO TO 21 C C PRINT OVERFLOW LINE DR C 65 MI=ENERG(I)+0.5 MJ=ENERG(J)+0.5 DO 49 M=1,JTEMP ASX(M)=0.0 MDR(M)=0 IF(ALDR(M,1).LT.1.0D-70)GO TO 49 MDR(M)=LOG10(ALDR(M,1))-1.0 ASX(M)=ALDR(M,1)/10.0**MDR(M) IF(ASX(M).LT.9.995)GO TO 49 ASX(M)=1.0 MDR(M)=MDR(M)+1 49 CONTINUE IF(BPRINT)THEN IF(BLSCUP)WRITE(6,157)TL,KUES(I),KUEL(I),KUES(J),KUEL(J),MI,MJ X,(ASX(M),MDR(M),M=1,JTEMP) IF(.NOT.BLSCUP)WRITE(6,167)TL,KUES(I),KUEL(I),KUEJ(I),KUES(J) X,KUEL(J),KUEJ(J),MI,MJ,(ASX(M),MDR(M),M=1,JTEMP) ENDIF GO TO 21 C C STORE LINE DR C 38 KP=K+1 IF(K.EQ.0)GO TO 48 IF(.NOT.BJSUM)GO TO 57 MI=LSI(K) MJ=LSJ(K) M=K IF(JTERM(I).EQ.JTERM(MI).AND.JTERM(J).EQ.JTERM(MJ))GO TO 60 57 IF(TL.LT.TLAM(K))GO TO 48 IF(K.EQ.1)GO TO 33 DO 43 MM=2,K M=KP-MM IF(.NOT.BJSUM)GO TO 56 MI=LSI(M) MJ=LSJ(M) IF(JTERM(I).EQ.JTERM(MI).AND.JTERM(J).EQ.JTERM(MJ))GO TO 60 56 IF(TL.LT.TLAM(M))GO TO 40 43 CONTINUE 33 M=0 40 KP=M+1 KM=K-M DO 32 MM=1,KM M=K+1-MM LSI(M+1)=LSI(M) LSJ(M+1)=LSJ(M) TLAM(M+1)=TLAM(M) DO 37 MT=1,JTEMP ASLDR(M+1,MT)=ASLDR(M,MT) 37 CONTINUE 32 CONTINUE 48 K=K+1 LSI(KP)=I LSJ(KP)=J TLAM(KP)=TL KF0=K DO 46 M=1,JTEMP ASLDR(KP,M)=ALDR(M,1) 46 CONTINUE GO TO 21 60 DO 51 MT=1,JTEMP ASLDR(M,MT)=ASLDR(M,MT)+ALDR(MT,1) 51 CONTINUE GO TO 21 ELSE C C CORRELATED CASCADE C IF(TL.LT.TL1)THEN KX=1 ELSE IF(TL.LT.TL2)THEN KX=2 ELSE IF(TL.LT.TL3)THEN KX=3 ELSE IF(TL.LT.TL4)THEN IF(BIB)THEN KX=3 ELSE KX=4 ENDIF ELSE KX=4 ENDIF ENDIF ENDIF ENDIF IF(I.EQ.1)GO TO 72 IF(KX.GT.1)THEN DO 10 M=1,JTEMP ALDR(M,KX)=AR(JA)*ADR(JJ,M,1) 10 CONTINUE KS=KX KF=KX ELSE DO 11 M=1,JTEMP DO 12 KK=1,4 ALDR(M,KK)=AR(JA)*ADR(JJ,M,KK) 12 CONTINUE 11 CONTINUE KS=1 KF=4 ENDIF GO TO 21 72 IF(KX.EQ.2)THEN KS=1 KF=3 DO 14 M=1,JTEMP DO 16 KK=KS,KF ALDR(M,KK)=AR(JA)*ADR(JJ,M,KK+1) 16 CONTINUE 14 CONTINUE ELSE KS=2 KF=4 DO 23 M=1,JTEMP ALDR(M,2)=0.0 ALDR(M,3)=0.0 ALDR(M,KX-1)=AR(JA)*ADR(JJ,M,2) 23 CONTINUE IF(KCORR.GT.0)THEN IF(KX.EQ.3)THEN DO 27 M=1,JTEMP ALDR(M,4)=AR(JA)*ADR(JJ,M,3) 27 CONTINUE ELSE KF=3 ENDIF ELSE DO 28 M=1,JTEMP ALDR(M,4)=0.0 DO 29 KK=3,4 ALDR(M,4)=ALDR(M,4)+AR(JA)*ADR(JJ,M,KK) 29 CONTINUE 28 CONTINUE ENDIF ENDIF ENDIF C C STORE EFFECTIVE DR COEFFICIENT AND INCLUDE EXTRAPOLATION IF REQUIRED C 21 IF(BIAR)GO TO 19 JF=KUECF(J) BXTRP=BIB.AND.NAD(JF).GT.0.AND.(ENERG(J)-ETEST).LT.ECUT L=NAD(JF) DO 22 M=1,JTEMP DO 13 KK=KS,KF T=ALDR(M,KK) IF(BXTRP)T=T*ADX(L,M) ADR(II,M,KK)=ADR(II,M,KK)+T 13 CONTINUE 22 CONTINUE 19 CONTINUE 18 CONTINUE C C PRINT RESULTS C IF(BPRINT)WRITE(6,165) DO 25 M=1,JTEMP IF(BPRINT)THEN IF(.NOT.BCORR)THEN WRITE(6,166)TEMP(M), ADR(JORIG(1),M,1) , ADR(JORIG(2),M,1) X, ADR(JORIG(3),M,1) , ADR(JORIG(4),M,1) , ADR(JORIG(5),M,1) X, ADR(JORIG(6),M,1) , ADR(JORIG(7),M,1) , ADR(JORIG(8),M,1) ELSE WRITE(6,166)TEMP(M),(ADR(JORIG(1),M,I),I=1,4) ENDIF ENDIF TEMP(M)=LOG10(TEMP(M)) 25 CONTINUE C C SKIP IF NO LINE DR TO PRINT C IF(KF0.EQ.0.OR..NOT.BPRINT)GO TO 36 AMIN=-1.0 WRITE(6,180)KF0,MAXLDR IF(.NOT.BJSUM)GO TO 64 AMIN1=AMIN1*AMULT AMIN2=AMIN2*AMULT AMIN3=AMIN3*AMULT IF(KF0.LE.MAXLDR)GO TO 64 WRITE(6,175) KF=MAXLDR 64 IF(BLSCUP.OR.BJSUM)WRITE(6,173)(TEMP(M),M=1,JTEMP) IF(.NOT.BLSCUP.AND..NOT.BJSUM)WRITE(6,174)(TEMP(M),M=1,JTEMP) DO 35 K=1,KF0 I=LSI(K) J=LSJ(K) TL=TLAM(K) IF(BJSUM)THEN JT=JTERM(J) IT=JTERM(I) MI=ETERM(IT)+0.5 MJ=ETERM(JT)+0.5 ITEST=0 AMIN=AMIN2 IF(TL.LT.TL1)AMIN=AMIN3 IF(TL.GT.TL2)AMIN=AMIN1 ELSE MI=ENERG(I)+0.5 MJ=ENERG(J)+0.5 ENDIF DO 34 M=1,JTEMP MDR(M)=0 ASX(M)=0.0 IF(ASLDR(K,M).LT.1.0E-30)GO TO 34 IF(ASLDR(K,M).GT.AMIN)ITEST=1 MDR(M)=LOG10(ASLDR(K,M))-1.0 ASX(M)=ASLDR(K,M)/1.0E1**MDR(M) IF(ASX(M).LT.9.995)GO TO 34 ASX(M)=1.0 MDR(M)=MDR(M)+1 34 CONTINUE IF(BLSCUP.OR.BJSUM.AND.ITEST.GT.0)WRITE(6,157)TL,KUES(I),KUEL(I) X,KUES(J),KUEL(J),MI,MJ,(ASX(M),MDR(M),M=1,JTEMP) IF(.NOT.BLSCUP.AND..NOT.BJSUM)WRITE(6,167)TL,KUES(I),KUEL(I) X,KUEJ(I),KUES(J),KUEL(J),KUEJ(J),MI,MJ,(ASX(M),MDR(M),M=1,JTEMP) 35 CONTINUE C C PRINT SUMS C 36 IF(BCORR)THEN KCORR=IABS(KCORR) IF(KCORR.GT.4)KCORR=4 LMAX=KCORR ISUM=KCORR ELSE LMAX=1 ISUM=IABS(JSUM) IF(ISUM.EQ.0)GO TO 66 IF(BPRINT)THEN IF(BLSCUP)WRITE(6,178)(TEMP(M),M=1,JTEMP) IF(.NOT.BLSCUP)WRITE(6,179)(TEMP(M),M=1,JTEMP) ENDIF ENDIF DO 68 I=1,ISUM IF(BCORR)THEN J=JORIG(1) DO 55 M=1,JTEMP SBIN(I,M)=SBIN(I,M)+ADR(J,M,I) 55 CONTINUE ELSE IF(JSUM.LT.0.AND.I.NE.-JSUM)GO TO 68 J=JORIG(I) DO 67 M=1,JTEMP MDR(M)=0 ASX(M)=0.0 IF(ADR(J,M,1).LT.1.0D-70)GO TO 67 SBIN(1,M)=SBIN(1,M)+ADR(J,M,1) IF(BPRINT)THEN MDR(M)=LOG10(ADR(J,M,1))-1.0 ASX(M)=ADR(J,M,1)/1.0E1**MDR(M) IF(ASX(M).LT.9.995)GO TO 67 ASX(M)=1.0 MDR(M)=MDR(M)+1 ENDIF 67 CONTINUE IF(BPRINT)THEN MI=ENERG(I)+0.5 IF(BLSCUP)WRITE(6,176)KUES(I),KUEL(I),MI X,(ASX(M),MDR(M),M=1,JTEMP) IF(.NOT.BLSCUP)WRITE(6,177)KUES(I),KUEL(I),KUEJ(I),MI X,(ASX(M),MDR(M),M=1,JTEMP) ENDIF ENDIF 68 CONTINUE DO 71 M=1,JTEMP DO 54 L=1,LMAX IF(BLOG)SBIN(L,M)=LOG10(SBIN(L,M)) 54 CONTINUE IF(EWIDTH.LT.0.0)TEMP(M)=TEMP(M)-5.19835 IF(.NOT.BLOG)TEMP(M)=10.0**TEMP(M) 71 CONTINUE 66 RETURN 146 FORMAT('0',' *****ERROR, NTERM=',I5,'.GT. MAXTM=',I5) 147 FORMAT('0',' *****ERROR, JCON=',I5,'.GT. MAXCFX=',I5) 148 FORMAT('0',' *****ERROR, MX=',I8,'.GT. MAXIND=',I8) 150 FORMAT('0',' *****ERROR, JTEMP=',I5,'.GT. MAXTEMP=',I5 X,' INCREASE NDIM33') 151 FORMAT('0',' *****ERROR, NLEVEL=',I5,'.GT. MAXLEVEL=',I5) 152 FORMAT('0',' *****ERROR, NCONFIG=',I5,'.GT. MAXCF=',I5) 157 FORMAT(' ',F7.1,1X,2I3,2X,2I3,1X,2I7,1X,11(1X,F4.2,I3)) 162 FORMAT(13X,'DMIN=',F15.6,3X,'TOLA=',1PE12.5,3X,'TOLR=',D12.5,3X X,'JCORW=',I3,15X,'JSUM=',I3) 165 FORMAT('0',3X,'T ',5X,'EFFECTIVE DR COEFF FOR LOWEST' X,' FEW TERMS/LEVELS'/) 166 FORMAT(1PE10.3,8E15.3) 167 FORMAT(' ',F7.1,1X,3I3,2X,3I3,1X,2I7,1X,11(1X,F4.2,I3)) 171 FORMAT('0','KCORR=',I2,3X,'NXTRP=',I2,3X,'JCON=',I2,3X,'JSUM=',I2, X3X,'MULTS=',I2,3X,'ECUT=',1PE9.3,3X,'TL(RYD)=',4E9.3,3X,'RMIN=' X,E9.3) 172 FORMAT('0','KCORR=',I2,3X,'NXTRP=',I2,3X,'JCON=',I2,3X,'JSUM=',I2, X3X,'MULTS=',I2,3X,'ECUT=',1PE9.3,3X,'AMIN=',4E9.1,3X,'RMIN=' X,E9.3) 173 FORMAT('1 ','LAMDA',1X,'2S+1',1X,'L',2X,'2S+1',1X,'L',4X,'EI',5X X,'EK',1X,'Log(T)',F4.1,10F8.1) 174 FORMAT('1 ','LAMDA',1X,'2S+1',1X,'L',1X,'2J',2X,'2S+1',1X,'L',1X X,'2J',4X,'EI',5X,'EK',1X,'Log(T)',F4.1,10F8.1) 175 FORMAT(' ***********, WARNING: STORAGE EXCEEDED IN MAXLDR SO', X' SHORTEST WAVELENGTHS HAVE BEEN DROPPED') 176 FORMAT(1X,2I3,1X,I7,1X,14(1X,F4.2,I3)) 177 FORMAT(1X,3I3,1X,I7,1X,14(1X,F4.2,I3)) 178 FORMAT('0','2S+1',1X,'L',2X,'EI',1X,'Log(T)',14(F6.3,2X)) 179 FORMAT('0','2S+1',1X,'L',1X,'2J',2X,'EI',1X,'Log(T)',14(F6.3,2X)) 180 FORMAT('0KF0=',I5,3X,'MAXLDR=',I5) END c c ****************************************************************** c subroutine choldc(a,n,np,p,ifail) integer n,np real*8 a(np,np),p(n),sum integer i,j,k,ifail c c Given a positive definite symmetric matrix a(1:n,1:n), with c physical dimension np, this routine constructs its Cholesky c decomposition A=L.L^T. On input, only the upper triangle of A c needs to be given; it is not modified. the Cholesky factor L c is returned in the lower triangle of A, except for its diagonal c elements which are returned in p(1:n) c ifail=0 do 13 i=1,n do 12 j=i,n sum=a(i,j) do 11 k=i-1,1,-1 sum=sum-a(i,k)*a(j,k) 11 continue if(i.eq.j) then if(sum.le.0) then write(6,*) 'choldec failed:sum= ',sum write(6,*) 'i=',i,' j=',j ifail=1 return endif p(i)=sqrt(sum) else a(j,i)=sum/p(i) endif 12 continue 13 continue return end c c **************************************************************** c subroutine cholsl(a,n,np,p,b,x) integer n,np real*8 a(np,np),b(n),p(n),x(n),sum integer i,k c c Solves the set of n linear equations Ax=b, where A is a positive c definite symmetric matrix with physical dimension np. A and p c are input as the output of the routine choldc. Only the lower c triangle of A is accessed. b(1:n) is input as the right-hand c side vector. The solution vector is returned in x(1:n). A, n, c np, and p are not modified and can be left in place for c successive calls with different right-hand sides b. b is not c modified unless you identify b and x in the calling sequence, c which is allowed. c do 12 i=1,n sum=b(i) do 11 k=i-1,1,-1 sum=sum-a(i,k)*x(k) 11 continue x(i)=sum/p(i) 12 continue do 14 i=n,1,-1 sum=x(i) do 13 k=i+1,n sum=sum-a(k,i)*x(k) 13 continue x(i)=sum/p(i) 14 continue return end C*********************************************************************** REAL*8 FUNCTION COMPTON(IZ,Q) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(5),B(5),DQ(32),DJ(10,32) C TABULATED COMPTON PROFILE FROM BIGGS ET AL (1975) DATA (DQ(I),I=1,32)/-0.05,0.0,0.05,0.1,0.15,0.2,0.3,0.4,0.5,0.6 X,0.7,0.8,1.0,1.2,1.4,1.6,1.8,2.0,2.4,3.0,4.0,5.0,6.0,7.0,8.0,10.0 X,15.0,20.0,30.0,40.0,60.0,100.0/ DATA (DJ(2,I),I=1,32)/1.07,1.07,1.07,1.06,1.04,1.02,.956,.878,.791 X,.700,.611,.527,.382,.271,.191,.134,9.52E-2,6.80E-2,3.58E-2,1.48E- X2,4.13E-3,1.40E-3,5.47E-4,2.40E-4,1.16E-4,3.3E-5,3.2E-6,5.8E-7,5.2 XE-8,9.3E-9,8.6E-10,7.8E-11/ DATA (DJ(3,I),I=1,32)/2.53,2.59,2.53,2.34,2.08,1.78,1.24,.884,.693 X,.598,.546,.508,.439,.372,.308,.251,.203,.164,.105,5.41E-2,1.92E-2 X,7.53E-3,3.27E-3,1.55E-3,7.88E-4,2.4E-4,2.5E-5,4.8E-6,4.4E-7,7.9E- X8,7.1E-9,3.6E-10/ DATA (DJ(4,I),I=1,32)/3.11,3.16,3.11,2.98,2.77,2.52,1.95,1.43,1.03 X,.766,.600,.503,.409,.363,.327,.292,.257,.224,.166,.102,4.52E-2,2. X06E-2,9.94E-3,5.07E-3,2.73E-03,9.1E-04,1.0E-4,2.1E-5,1.9E-6,3.6E-7 X,3.2E-8,1.5E-9/ DATA (DJ(6,I),I=1,32)/2.88,2.89,2.88,2.85,2.80,2.73,2.54,2.29,2.02 X,1.74,1.48,1.24,.881,.641,.490,.394,.331,.286,.226,.165,9.76E-2,5. X69E-2,3.32E-2,1.96E-2,1.19E-2,4.6E-3,6.6E-4,1.4E-4,1.5E-5,2.8E-6,2 X.5E-7,1.2E-8/ DATA (DJ(10,I),I=1,32)/2.72,2.73,2.72,2.72,2.71,2.70,2.65,2.59,2.5 X1,2.41,2.30,2.17,1.89,1.61,1.35,1.12,.927,.771,.544,.346,.194,.124 X,8.51E-2,5.97E-2,4.24E-2,2.2E-2,4.8E-3,1.3E-3,1.6E-4,3.3E-5,3.3E-6 X,1.6E-7/ SUM=0.0 ITT=IZ-2 IF(ITT)1,2,3 C HYDROGEN MOLECULE, LEE(1977) 1 A(1)=1.0012 A(2)=0.5383 B(1)=0.9896 B(2)=1.5566 IN=2 GO TO 4 C HELIUM ATOM, LEE(1977) 2 A(1)=-0.0957 A(2)=0.0514 A(3)=0.1342 A(4)=0.7316 A(5)=0.2426 B(1)=2.1828 B(2)=4.1598 B(3)=3.5200 B(4)=2.3948 B(5)=1.5732 IN=5 4 DO 5 I=1,IN T=Q/B(I) T=T*T+1.0 SUM=SUM+A(I)/T**(I+2) 5 CONTINUE GO TO 6 3 Q=ABS(Q) DO 7 I=3,31 IF(Q.LT.DQ(I))GO TO 8 7 CONTINUE GO TO 6 8 I3=I-3 DO 9 J=1,4 JJ=I3+J T=1.0 DO 10 K=1,4 KK=I3+K IF(J.EQ.K)GO TO 10 T=T*(Q-DQ(KK)) T=T/(DQ(JJ)-DQ(KK)) 10 CONTINUE SUM=SUM+T*DJ(IZ,JJ) 9 CONTINUE 6 COMPTON=SUM*1.0E3 RETURN END C*********************************************************************** REAL*8 FUNCTION CONVOL(E,EWIDTH,ZET,ZST,NT,L) C SUN : SINGLE PRECISION FIX FOR NCAR GRAPHICS ON SUN (ET,ST ARE S.P.) CNCAR IMPLICIT REAL*4(Z) IMPLICIT REAL*8(Z) IMPLICIT REAL*8 (A-H,O-Y) C CONVOLUTE LORENTZIAN WITH GAUSSIAN OR DITTNER INSTEAD OF USING C ENERGY-AVERAGED, FOR USE WHEN RESOLUTION COMPARABLE WITH NATURAL WIDTH LOGICAL BBACK PARAMETER(NDIM2=36,NDIM3=100001,NDIM5=150,NDIM44=501,NDIM33=501) DIMENSION ZST(NDIM3),ZET(NDIM3) COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /DITT/A00,B00 COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG C IF(EWIDTH)1,2,3 1 CONVOL=0.0 RETURN C C ESTIMATE WIDTH OF COOLER DISTRIBUTION....... C 2 A0=100.0 IF(A00.GT.0.0)A0=A00 B0=10. IF(B00.GT.0.0)B0=B00 T=15.0/B0**2 A=1.0E6 IF(E.GT.1.0E-10)A=0.5*A0/SQRT(E) PIE=ACOS(-1.0) EMIN=MIN(E-PIE/A,E-T) EMAX=MAX(E+PIE/A,E+T) EMESH=ZET(2)-ZET(1) N1=EMIN/EMESH N2=EMAX/EMESH IF(N2.GT.NT)N2=NT IF(N1.LT.2)N1=2 NPTS=N2-N1+1 IF(NPTS.LT.4)STOP 27 DUM=-999. J=0 DO 6 I=N1,N2 J=J+1 EVEC(J)=ZET(I) VEC(J)=ZST(I)*DITTNER(DUM,EVEC(J),E)/EVEC(J) 6 CONTINUE C=10.938*2.0 GO TO 5 C C GAUSSIAN C 3 IF(EWIDTH.LT.200.0)THEN A=1.6651092/EWIDTH ELSE C HEIDELBERG (SEE CONVOLG) A0=58.3 IF(A00.GT.0.0)A0=A00 A=0.5*A0/SQRT(E) ENDIF C PIE=ACOS(-1.0) EMAX=E+PIE/A EMIN=E-PIE/A EMESH=ZET(2)-ZET(1) N1=EMIN/EMESH N2=EMAX/EMESH IF(N2.GT.NT)N2=NT IF(N1.LT.2)N1=2 NPTS=N2-N1+1 IF(NPTS.LT.4)STOP 27 J=0 DO 4 I=N1,N2 J=J+1 T=A*(ZET(I)-E) T=T*T VEC(J)=ZST(I)*EXP(-T) EVEC(J)=ZET(I) 4 CONTINUE C=A*0.5641895 C C 5 IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVEC,VEC,NPTS,ANS,ER,IFAIL) CDP CALL D01GAF(EVEC,VEC,NPTS,ANS,ER,IFAIL) IF(IFAIL.NE.0)STOP 22 ELSE ANS=TRAP(EVEC,VEC,NPTS) ENDIF C C NOTE BACKGROUND JUST ADDED, BUT NOT CONVOLUTED TT=0.0 IF(BBACK)THEN IF(ITYPE.EQ.3)THEN JSP=0 IF(E.LE.ENERG(NENG))THEN IF(E.GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,E,JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,E,IXTRP(L)) ENDIF ELSE U=E/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U IF(U.GE.1.0)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U ENDIF ENDIF TT=TT/(E-SIGMA(L,6)) IF(EWIDTH.EQ.0.0)TT=2.0*10.938*SQRT(E)*TT ENDIF C CONVOL=C*ANS+TT RETURN END C*********************************************************************** REAL*8 FUNCTION CONVOLC(E,IZ,EBIN,TBIN,NBIN,L) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BBACK PARAMETER(NDIM2=36,NDIM3=100001,NDIM5=150,NDIM44=501,NDIM33=501) DIMENSION ET(10),EBIN(*),TBIN(*) COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG DATA (ET(I),I=1,10)/1.14,1.81,0.40,0.69,0.0,0.83,0.0,0.0,0.0,1.59/ C COMPTON PROFILE SUM=0.0 TE=SQRT(E) TT=0.0 IF(TE.LT.1.0D-40)GO TO 2 TE=0.5/TE IF(NBIN.LT.0)GO TO 3 DO 10 I=2,NBIN TT=(EBIN(I)-EBIN(I-1))*TE Q=(EBIN(I)+ET(IZ)-E)*TE SUM=SUM+TT*TBIN(I-1)*COMPTON(IZ,Q) 10 CONTINUE 3 IF(BBACK)THEN GO TO (4,5,5),ITYPE 4 U=E/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U IF(U.GE.1.0)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U TN=IZ IF(IZ.EQ.1)TN=IZ+1 TN=TN*1.0E3 SUM=SUM+TT*TN/(E-SIGMA(L,6)) ENDIF GO TO 6 5 QMAX=3*IZ TT=2.0*SQRT(E)*QMAX EMAX=E+TT EMIN=E-TT IF(EMIN.LT.SIGMA(L,7))EMIN=SIGMA(L,7) IF(EMIN.LE.0.0)EMIN=1.0E-20 EMESH=EBIN(2)-EBIN(1) NPTS=(EMAX-EMIN)/EMESH + 1 IF(NPTS.LT.4)NPTS=4 IF(NPTS.GT.NDIM3)NPTS=NDIM3 EMESH=NPTS-1 EMESH=(EMAX-EMIN)/EMESH TS=0.0 JSP=0 DO 1 I=1,NPTS T=I-1 EVEC(I)=EMIN+T*EMESH Q=(EVEC(I)+ET(IZ)-E)*TE TT=0.0 IF(ITYPE.EQ.3)THEN IF(EVEC(I).LE.ENERG(NENG))THEN IF(EVEC(I).GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,EVEC(I),JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,EVEC(I),IXTRP(L)) ENDIF ELSE U=EVEC(I)/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U ENDIF TT=TT/(EVEC(I)-SIGMA(L,6)) VEC(I)=TT*COMPTON(IZ,Q) 1 CONTINUE IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVEC,VEC,NPTS,TS,ER,IFAIL) CDP CALL D01GAF(EVEC,VEC,NPTS,TS,ER,IFAIL) IF(IFAIL.NE.0)STOP 21 ELSE TS=TRAP(EVEC,VEC,NPTS) ENDIF SUM=SUM+TS*TE 6 CONTINUE ENDIF 2 CONVOLC=SUM RETURN END C*********************************************************************** REAL*8 FUNCTION CONVOLG(E,EWIDTH,EBIN,SBIN,NBIN,L0) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BBACK PARAMETER(NDIM2=36,NDIM3=100001,NDIM5=150,NDIM44=501,NDIM33=501) DIMENSION EBIN(*),SBIN(*) COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /DITT/A00,B00 COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /LOTZ/TLOTZ(5,5),ELOTZ(5,5),NLOTZ C C GAUSSIAN DISTRIBUTION C IF(ABS(EWIDTH).LT.200.0)THEN A=1.6651092/EWIDTH ELSEIF(EWIDTH.GT.0.)THEN C HEIDELBERG SCALING (A0=A=1.0/SQRT(kTpar(Ryd)) NEGLECT B (kTperp) OF C OF DOUBLE MAXWELLIAN). EWIDTH=3.33*SQRT(E*kTpar) A0=58.3 IF(A00.GT.0.0)A0=A00 A=0.5*A0/SQRT(E) ELSE C LOW-T LIMIT B0=5.8 IF(B00.GT.0.0)B0=B00 A=0.5*B0*B0*4/SQRT(LOG(2.)) ENDIF C PIE=ACOS(-1.0) SUM=0.0 IF(NBIN.LT.0)GO TO 3 NBIN1=NBIN-1 DO 10 I=1,NBIN1 XI=EBIN(I) XI1=EBIN(I+1) IF(SBIN(I).EQ.0.0) GO TO 10 SUM=SUM+SBIN(I)*(ERF(A*(E-XI))-ERF(A*(E-XI1)))/2.0 10 CONTINUE C 3 L1=L0+ISM DO 6 L=L0,L1 C TL=0.0 DO 33 N=1,NLOTZ IF(TLOTZ(L,N).GT.0.0)THEN IF(E.GT.ELOTZ(L,N))TL=TL+TLOTZ(L,N)*LOG(E/ELOTZ(L,N))/E ENDIF 33 CONTINUE SUM=SUM+TL C IF(BBACK)THEN GO TO (4,5,5,9),ITYPE C 4 U=E/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U IF(U.GE.1.0)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U SUM=SUM+TT/(E-SIGMA(L,6)) ENDIF GO TO 6 C 9 TT=0.0 JSP=0 IF(E.LE.ENERG(NENG))THEN IF(E.GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,E,JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,E,IXTRP(L)) ENDIF SUM=SUM+TT/(E-SIGMA(L,6)) GO TO 6 C 5 SUM=SUM-TL EMAX=E+PIE/A EMIN=E-PIE/A C IF(EMIN.LT.SIGMA(L,7))EMIN=SIGMA(L,7) IF(EMIN.LE.0.0)EMIN=1.0E-20 EMESH=EBIN(2)-EBIN(1) NPTS=(EMAX-EMIN)/EMESH + 1 IF(NPTS.LT.4)NPTS=4 IF(NPTS.GT.NDIM3)NPTS=NDIM3 EMESH=NPTS-1 EMESH=(EMAX-EMIN)/EMESH TS=0.0 JSP=0 DO 1 I=1,NPTS T=I-1 EVEC(I)=EMIN+T*EMESH T=(E-EVEC(I))*A T=T*T TT=0.0 IF(ITYPE.EQ.3)THEN IF(EVEC(I).LE.ENERG(NENG))THEN IF(EVEC(I).GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,EVEC(I),JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,EVEC(I),IXTRP(L)) ENDIF ELSE U=EVEC(I)/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U IF(U.GE.1.0)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U ENDIF ENDIF TT=TT/(EVEC(I)-SIGMA(L,6)) DO 34 N=1,NLOTZ IF(EVEC(I).GT.ELOTZ(L,N))THEN TL=TLOTZ(L,N)*LOG(EVEC(I)/ELOTZ(L,N))/EVEC(I) TT=TT+TL ENDIF 34 CONTINUE VEC(I)=TT*EXP(-T) 1 CONTINUE IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVEC,VEC,NPTS,TS,ER,IFAIL) CDP CALL D01GAF(EVEC,VEC,NPTS,TS,ER,IFAIL) IF(IFAIL.NE.0)STOP 21 ELSE TS=TRAP(EVEC,VEC,NPTS) ENDIF SUM=SUM+TS*A*0.5641895 ENDIF 6 CONTINUE C CONVOLG=SUM RETURN END C*********************************************************************** REAL*8 FUNCTION CONVOLL(EE0,L) IMPLICIT REAL*8 (A-H,O-Z) C LORENTZIAN PROFILE LOGICAL BBACK PARAMETER(NDIM3=100001,NDIM2=36,NDIM11=99999 X ,NDIM44=501,NDIM33=501) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /LOREN/EREZ(NDIM11),GSIG(NDIM11),GAM(NDIM11),ITRAN(NDIM11), XJYMAX PI=ACOS(-1.0) T=0.0 EE=EE0 IF(EE.EQ.0.0)EE=1.0E-20 IF(JYMAX.EQ.0)GO TO 2 IF(JYMAX.LT.NDIM11)THEN DO 3 I=1,JYMAX IF(ITRAN(I).EQ.L)THEN FLR=GAM(I)/((EE-EREZ(I))**2+0.25*GAM(I)**2) T=T+GSIG(I)*FLR/EE ENDIF 3 CONTINUE GO TO 2 ELSE REWIND(8) 1 READ(8,*,END=2)EREZ0,GSIG0,GAM0,LT,L1,L2 IF(LT.EQ.L)THEN FLR=GAM0/((EE-EREZ0)**2+0.25*GAM0**2) T=T+GSIG0*FLR/EE ENDIF GO TO 1 ENDIF 2 T=T/(2.0*PI) TT=0.0 IF(BBACK)THEN IF(ITYPE.EQ.3)THEN JSP=0 IF(EE.LE.ENERG(NENG))THEN IF(EE.GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,EE,JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,EE,IXTRP(L)) ENDIF ELSE U=EE/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U IF(U.GE.1.0)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U ENDIF ENDIF TT=TT/(EE-SIGMA(L,6)) ENDIF CONVOLL=T+TT RETURN END C*********************************************************************** REAL*8 FUNCTION CONVOLM(E,EBIN,TBIN,NBIN,L0) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BLOG,BBACK PARAMETER(NDIM2=36,NDIM3=100001,NDIM5=150,NDIM44=501) PARAMETER(IMAX=9) !NO SETS OF GAUSS-LAGUERRE POINTS PARAMETER(MMAX=15) !MAX NO OF ITERATIONS OF MIDPOINT RULE. C DIMENSION OF D (BELOW) SHOULD BE MAX(IMAX,MMAX) C DIMENSION D(0:MMAX) DIMENSION EBIN(*),TBIN(*) DIMENSION N(IMAX),WLAG(180),XLAG(180) !see data COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /TRANS1/B,JSP,L C C NAG BAXD01,D01BAX CSP EXTERNAL BAXD01, GLNAG CDP EXTERNAL D01BAX, GLNAG C DATA IFAIL/0/ DATA (N(I),I=1,IMAX)/16,20,24,32,48,64,96,128,180/ C C MAXWELLIAN DISTRIBUTION L=L0 TA=EBIN(2)-EBIN(1) TB=EBIN(NBIN)-EBIN(NBIN-1) T=TB/TA T=ABS(T-1.0) BLOG=T.GT.1.0E-2 TT=1.0 SUM=0.0 DO 1 I=2,NBIN T=EXP(-EBIN(I)/E) !HISTORIC C T=(EXP(-EBIN(I-1)/E)+EXP(-EBIN(I)/E))/2 !TRAP IS BETTER cf adasdr IF(.NOT.BLOG)TT=EBIN(I)*TA SUM=SUM+T*TBIN(I-1)*TT 1 CONTINUE T=SQRT(E) C IF(BBACK)THEN B=1.0/E D(0)=1.0D50 IF(INAG.LT.0)GO TO 5 C NMAX=IMAX IF(INAG.GT.0)NMAX=6 !NAG ONLY GOES TO 64 IFAIL=0 DO 2 I=1,NMAX JSP=0 IF(INAG.GT.0)THEN C NAG D01BAE,F BAXD01,D01BAX CSP D(I)=D01BAE(BAXD01,0.0,B,N(I),GLNAG,IFAIL) CDP D(I)=D01BAF(D01BAX,0.0D0,B,N(I),GLNAG,IFAIL) IF(IFAIL.NE.0)WRITE(6,101)IFAIL 101 FORMAT(' SR.CONVOLM: FAILURE IN NAG:D01BAE, IFAIL=',I3) ELSE D(I)=GAUSSQ(N(I),WLAG,XLAG,B) ENDIF IF(ABS(D(I)/D(I-1)-1.0).LT.0.01)GO TO 3 2 CONTINUE IF(IFIRST.EQ.0)THEN WRITE(6,*)'G-L FIRST FAILS AT ENERGY (RYD)=',E IFIRST=1 ENDIF I=NMAX WRITE(6,100)(N(J),D(J),J=1,I) 100 FORMAT(' SR.CONVOLM:GAUSS-LAGUERRE FAILURE; N(I),D(I)=',9(I4,1PE10 X.3)) GO TO 3 C C TRY MID-EXP 5 OST=0.0 DO 4 I=1,MMAX CALL MIDEXP(I,B,ST) S=(9.D0*ST-OST)/8.0D0 D(I)=S IF(ABS(D(I)/D(I-1)-1.0).LT.0.005)GO TO 3 OST=ST 4 CONTINUE I=MMAX WRITE(6,102)(J,D(J),J=1,I) 102 FORMAT(' SR.CONVOLM: MIDEXP FAILURE; I,D(I)=', X10(I4,1PE10.3)) C 3 SUM=SUM+D(I) ENDIF C SUM=24.6854*SUM/(T*E) CONVOLM=SUM C RETURN END C*********************************************************************** REAL*8 FUNCTION CONVOLX(E,EBIN,SBIN,NBIN,L) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BBACK PARAMETER(NDIM2=36,NDIM3=100001,NDIM5=150,NDIM44=501,NDIM33=501) DIMENSION EBIN(*),SBIN(*) COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /DITT/A00,B00 COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /LOTZ/TLOTZ(5,5),ELOTZ(5,5),NLOTZ DATA DUM/-999./,EZERO/0.01/ C C COOLER DISTRIBUTION C SUM=0.0 C C ESTIMATE WIDTH OF COOLER DISTRIBUTION....... C A0=100.0 IF(A00.GT.0.0)A0=A00 B0=10. IF(B00.GT.0.0)B0=B00 T=15.0/B0**2 A=1.0E6 IF(E.GT.1.0E-10)A=0.5*A0/SQRT(E) PIE=ACOS(-1.0) EMIN=MIN(E-PIE/A,E-0.8*T) EMAX=MAX(E+PIE/A,E+T) C IF(NBIN.LT.0)GO TO 3 NBIN1=NBIN-1 DO 10 I=1,NBIN1 XI=EBIN(I) XI1=EBIN(I+1) IF(XI1.LT.EMIN)GO TO 10 IF(XI.GT.EMAX)GO TO 10 IF(SBIN(I).EQ.0.0) GO TO 10 SUM=SUM+SBIN(I)*DITTNER(XI,XI1,E) 10 CONTINUE C 3 TL=0.0 DO 33 N=1,NLOTZ IF(TLOTZ(L,N).GT.0.0)THEN IF(E.GT.ELOTZ(L,N))TL=TL+TLOTZ(L,N)*LOG(E/ELOTZ(L,N))/E ENDIF 33 CONTINUE SUM=SUM+TL C IF(BBACK)THEN GO TO (4,5,5,9),ITYPE C 4 U=E/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U TT=TT/(E-SIGMA(L,6)) TT=TT*SQRT(E) SUM=SUM+2.0*TT GO TO 6 C 9 TT=0.0 JSP=0 IF(E.LE.ENERG(NENG))THEN IF(E.GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,E,JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,E,IXTRP(L)) ENDIF TT=TT/(E-SIGMA(L,6)) TT=TT*SQRT(E) SUM=SUM+2.0*TT GO TO 6 C 5 SUM=SUM-TL IF(EMIN.LT.SIGMA(L,7))EMIN=SIGMA(L,7) IF(EMIN.LE.0.0)EMIN=1.0E-20 EMESH=EBIN(2)-EBIN(1) C IF(E.EQ.0.0)EMESH=EMESH*0.25 NPTS=(EMAX-EMIN)/EMESH + 1 IF(NPTS.LT.4)NPTS=4 IF(NPTS.GT.NDIM3)NPTS=NDIM3 EMESH=NPTS-1 C IF(E.LT.EZERO)THEN C C TRANSFORM U=SQRT(E) TO AVOID SINGULARITY AT E=0 C EMAX=SQRT(EMAX) EMIN=SQRT(EMIN) ENDIF C EMESH=(EMAX-EMIN)/EMESH JSP=0 TS=0.0 DO 1 I=1,NPTS T=I-1 TE=EMIN+T*EMESH C IF(E.LT.EZERO)THEN EVEC(I)=TE EU=TE*TE ELSE EVEC(I)=SQRT(TE) EU=TE ENDIF C TT=0.0 IF(ITYPE.EQ.3)THEN IF(EU.LE.ENERG(NENG))THEN IF(EU.GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,EU,JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,EU,IXTRP(L)) ENDIF ELSE U=EU/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U IF(U.GE.1.0)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4)*LOG(U) X+SIGMA(L,5)*LOG(U)/U ENDIF ENDIF TT=TT/(EU-SIGMA(L,6)) DO 34 N=1,NLOTZ IF(EVEC(I).GT.ELOTZ(L,N))THEN TL=TLOTZ(L,N)*LOG(EVEC(I)/ELOTZ(L,N))/EVEC(I) TT=TT+TL ENDIF 34 CONTINUE VEC(I)=TT*DITTNER(DUM,EU,E)/EVEC(I) 1 CONTINUE IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVEC,VEC,NPTS,TS,ER,IFAIL) CDP CALL D01GAF(EVEC,VEC,NPTS,TS,ER,IFAIL) IF(IFAIL.NE.0)STOP 7 ELSE TS=TRAP(EVEC,VEC,NPTS) ENDIF C TS=TS+TS C SUM=SUM+2.0*TS ENDIF 6 CONTINUE C CONVOLX=SUM*10.938 RETURN END C*********************************************************************** SUBROUTINE CROSSX(ITHETA,ISP,IMODE,NBIN1,NBINM,NR1,NR2,NCUT,LCUT, XNECOR,NRSLMX,ECORI,EI,IWT,NBINR,ILOG,UNITS,IPRINT,TOLR,ACOR,RCOR, XEBIN,SBIN,EWIDTH,IZ,LMAX,IWS,IWL,ERSOL,NMN,LMN,IUP,IPARNT,TOLE) C IMPLICIT REAL*8 (A-H,O-Z) C INTEGER SS,QS0,QL0,QSB,QLB,QL,QN C LOGICAL BPRNT0,BPRNT1,BPRNT2,BJUMP,BCFM,BCFP,BRAD,BOLD,BINT,BLOR X,BSEL,BBIN,BPASS1,BFEAR,BSORT,BFORM,BREDA,BRYLD,BMODA,BMODR,BPAR X,BLS,BIC,BFASTR,EX C PARAMETER (NDIM0=108) PARAMETER (NDIM1=10001) PARAMETER (NDIM2=36) PARAMETER (NDIM3=100001) PARAMETER (NDIM4=9999) PARAMETER (NDIM5=150) PARAMETER (NDIM7=20000000) PARAMETER (NDIM8=100) PARAMETER (NDIM9=12) PARAMETER (NDIM10=5) PARAMETER (NDIM11=99999) PARAMETER (NDIM12=9000000) PARAMETER (NDIM13=95000) PARAMETER (NDIM14=200) PARAMETER (NDIM15=501) PARAMETER (NDIM16=50) PARAMETER (NDIM17=800) PARAMETER (NDIM24=50000) PARAMETER (NDIM25=15) PARAMETER (NDIM26=75) PARAMETER (NDIM27=150) PARAMETER (NDIM66=99) PARAMETER (JTEMP=10) PARAMETER (MXLIT=30) C PARAMETER (CONAOM=7.599E-17) !HBAR*PI/2 PARAMETER (ZERO=0.0) PARAMETER (ONE=1.0) C CHARACTER LAB5*5,FILNAM*4,CMSTAR*4 CHARACTER*1 CLIT(MXLIT) C DIMENSION IWT(NDIM5),IWS(NDIM5),IWL(NDIM5),LIT(MXLIT) X,EBIN(NDIM1),SBIN(NDIM2,NDIM1),EI(NDIM5),ECORI(NDIM8,NDIM8) X,RYLD(NDIM4),IRRV(NDIM4),IBN(NDIM27),BN(NDIM2,NDIM27) X,ESWT(NDIM5,NDIM5),SSWT(NDIM5,NDIM5),ECA(NDIM5),EIONA(NDIM5) X,ESWTN(NDIM27,NDIM5,NDIM5),SSWTN(NDIM27,NDIM5,NDIM5) X,JFIRST(NDIM13),JLAST(NDIM13),KFIRST(NDIM13),KLAST(NDIM13) X,IAUTO(NDIM13) C DIMENSION IPAR(NDIM13),ITAR(NDIM13) CP X, IPARC(NDIM13),IPARS(NDIM13),IPARL(NDIM13),IPARJ(NDIM13) C COMMON/XX/ICA(NDIM12),JCA(NDIM12),ITA(NDIM12),AA(NDIM12) X, EION(NDIM12),JTA(NDIM12),IWA(NDIM12),EC(NDIM12) X, JTR(NDIM7),ICR(NDIM7),JCR(NDIM7),JWR(NDIM7) X, IWR(NDIM7),DEL(NDIM7),ITR(NDIM7),AR(NDIM7),EATOM(NDIM7) X, IK(NDIM13),IT(NDIM13),SS(NDIM13),LL(NDIM13),JJ(NDIM13) X, JK(NDIM13),LCF(NDIM13) X, ENERG(NDIM13),SUMAN(NDIM5),NG(NDIM14) C COMMON /YLD/AYLD(NDIM4),EF(NDIM4),EFN,EFMIN X,IYLD0(NDIM13),LSPJ(NDIM4),NYLD COMMON /ECOR/ E1C(NDIM8),E1X(NDIM8),ECORT,TOLB COMMON /CROSS/ EF0(NDIM4),EII(NDIM5) X, TCN(NDIM2),TC(NDIM2),TCL(NDIM2),TCS(NDIM2) X, NS(NDIM16),UB(NDIM2,NDIM16,NDIM1),TNU(NDIM2,NDIM16) X,QS0(10),QL0(10),QSB(NDIM14,10),QLB(NDIM14,10),QL(30) X,QN(30),LMX(NDIM14) COMMON /DIP/ RSUMC(NDIM15),CP(NDIM15),CM(NDIM15),JDUM(NDIM15) COMMON /MIX/CIRN,CIRD,TCOOL,TFLITE,NFLITE,NFNLMX,FNL(NDIM24) COMMON /JCF/JCFA,JCFR,JCFJ,JCFY,JCFE,JPAR,LSPI,J2PI,BLOR,BFEAR X,MAX2J COMMON /CORR/ACORN(NDIM1),ACORL(NDIM25),NNCOR,NLCOR X,ACORA(NDIM26),ICOR(NDIM26),NACOR,JYLD COMMON /LOREN/EREZ(NDIM11),GSIG(NDIM11),GAM(NDIM11),ITRAN(NDIM11), XJYMAX COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /CDGEN/NASTD,NLEV(NDIM5) COMMON /PHOTON/EBDMIN,EBDMAX,EPHMIN,EPHMAX common /bug/ibug COMMON /BLANK/MBLNK C DATA CLIT /'1','2','3','4','5','6','7','8','9','A','B','C','D','E' X,'F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U'/ DATA CMSTAR/'****'/ C C C FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS C TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY C OPEN(99,STATUS='SCRATCH',FORM='FORMATTED') WRITE(99,1111)CMSTAR,(CLIT(I),I=1,MXLIT) 1111 FORMAT(A4,80A1) BACKSPACE(99) READ(99,1111)MSTAR,(LIT(I),I=1,MXLIT) CLOSE(99) C C BPAR=.FALSE. IF(NECOR.GE.0.OR.IPARNT.LT.0)THEN JPAR=0 ELSEIF(IPARNT.GT.0)THEN IF(IWS(1).NE.0)THEN INQUIRE(FILE='parentls',EXIST=BPAR) OPEN(17,FILE='parentls') ELSE INQUIRE(FILE='parentic',EXIST=BPAR) OPEN(17,FILE='parentic') ENDIF ENDIF C WIDEX=-ONE BMODA=IMODE.EQ.-10.OR.IMODE.EQ.-12 BMODR=IMODE.EQ.-11.OR.IMODE.EQ.-12 BREDA=IMODE.EQ.-9 BRYLD=TOLR.GT.1.0E-4.AND.TOLR.LT.1.0E3 TOLR=ABS(TOLR) C NBINRM=NBINR-1 NR20=NR2 IF(NR2.LT.NR1)NR2=MAX(NFLITE,NDIM66) IF(IUP.GE.0)THEN TUP=ONE T0=(NR1-1)**3 DO N=NR1,NR20 T=N TUP=TUP+T0/T**3 ENDDO ENDIF BSORT=IMODE.GT.-3 !OLD .GE. TOLN=ZERO C NBIN=NBIN1+1 BBIN=EI(1).GE.ZERO NVINT=100 IF(NCUT.NE.100000.AND.NVINT.LT.NCUT)NVINT=NCUT NS(1)=0 BPASS1=.TRUE. BOLD=.FALSE. JYMAX=0 IFLAGE=0 IABNE=IABS(NECOR) C NBINC=NECOR C IF(NECOR.LT.0)NBINC=NBINRM NBINC=MAX0(IABNE,NBINRM) IF(NBINC.GE.NDIM5)THEN WRITE(6,*)' INCREASE NDIM5 TO AT LEAST',NBINC+1 STOP ' INCREASE NDIM5' ENDIF IF(.NOT.BBIN)NBINC=NBINRM BSEL=IABS(JCFA).LT.100 MMAX=NBINM IF(JCFA.NE.0)MMAX=NBINRM COLD IF(IMODE.EQ.-4)TOLR=1.0E40 BPRNT0=IPRINT.EQ.0 BPRNT1=IPRINT.GE.-1 BPRNT2=IPRINT.GE.-2 BRAD=NR1.LE.NR2.AND.NR1.GT.0.AND.JCFA.GE.0 IF(BRAD)THEN NR0=NR1-1 ELSE NR0=NDIM66 ENDIF C IWTOT=0 N=0 L0=0 DO L=1,LMAX IWTOT=IWTOT+IWT(IREV(L,1)) TCS(L)=ZERO DO I=1,NDIM27 BN(L,I)=ZERO ENDDO ENDDO TWTOT=IWTOT IB0=NDIM25 DO I=1,IB0 IBN(I)=I ENDDO IC=0 C IF(BPRNT0)THEN OPEN(66,FILE='ocsnl',STATUS='UNKNOWN') MSNMAX=0 LSNMAX=0 DO K=1,NDIM5 DO J=1,NDIM5 DO I=1,NDIM27 ESWTN(I,J,K)=ZERO SSWTN(I,J,K)=ZERO ENDDO ENDDO ENDDO ENDIF C IF(JCFA.NE.0)THEN JCFR=-IABS(JCFA)+200 IF(JCFR.GT.0)JCFR=0 ENDIF JCFAB=IABS(JCFA) JCFRB=IABS(JCFR) C C C POSSIBLE UNIT NOS TO BE CHECKED FOR DATA C MR=70 MRU=MR IFILE=1 C FILNAM='o1' INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)THEN BFORM=.TRUE. OPEN(MR,FILE=FILNAM) ELSE FILNAM='o1u' INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)THEN BFORM=.FALSE. OPEN(MRU,FILE=FILNAM,FORM='UNFORMATTED') ELSE WRITE(6,*)'*** ERROR: NO LEVEL INPUT DATA ON FILE o1 OR o1u' STOP'*** ERROR: NO LEVEL INPUT DATA ON FILE o1 OR o1u' ENDIF ENDIF C LV0=-1 331 TSUM=ZERO NV00=0 NV0=100000 C 31 NV=0 c ccat if "complete" files are catted together then need to skip normal ccat terminator and rely on EOF as a normal "graceful" exit... cpb ccat ccat if(bform)read(mr,38)nv,lv ccat if(.not.bform)read(mru)nv,lv ccat if(nv.gt.lv)goto 332 c IF(BFORM)READ(MR,38,END=911)NV,LV IF(.NOT.BFORM)READ(MRU,END=911)NV,LV 38 FORMAT(5X,I5,5X,I5) ccat 332 continue if(ibug.ne.0)write(*,*)'nv,lv=',nv,lv C BCFM=JCFR.LT.0.AND.LV.GE.0 BCFP=JCFR.GT.0.AND.LV.GE.0 C BCFM=JCFR.LT.0 C BCFP=JCFR.GT.0 C IF(LV0.LT.0.OR.LV.LT.0)THEN WNP0=-ONE KFPM=0 EMIN0=ZERO IF(BBIN)EI(1)=ONE IF(BREDA)THEN DO I=1,NBINC IYLD0(I)=0 ENDDO ENDIF ENDIF IF(NV00.EQ.0)NV00=NV IF(NV0.EQ.100000)GO TO 70 BPASS1=.FALSE. IF(NV.GT.0.AND.LV.EQ.LV0)GO TO 37 IF(IMODE.GT.-3)GO TO 420 91 IF(IC.LE.1)GO TO 71 C C SUM HIGH N OF OLD L USING INTERPOLATION AND THEN SIMPSONS RULE C DO I=1,IC IF(NS(I).GE.NMN)THEN IF(NMN.GT.0.AND.NS(I).NE.NMN.AND.I.GT.1) X WRITE(6,*)' **** POSSIBLE INACCURACY:', X ' NMIN SHOULD BE ONE OF THE CALCULATED N' N11=0 IF(NS(I).EQ.0)THEN I00=I+3 ELSE I00=I+2 IF(I.EQ.1)N11=1 ENDIF GO TO 397 ENDIF ENDDO WRITE(6,*)'NMIN .GT. THE MAX N ON FILE, XSCTN=0!',NMN,' =NMIN' STOP 'NMIN .GT. THE MAX N ON FILE, XSCTN=0!' C C INTERPOLATION 397 DO I=I00,IC,2 I0=I T1=NS(I-2) T2=NS(I-1) T3=NS(I) V1=T1**3 V2=T2**3 V3=T3**3 385 N1=NS(I0-2) N2=NS(I0-1) TN1=N1*N1 TN2=N2*N2 N1=N1+N11 DO N=N1,N2 IF(N.GT.NCUT)GO TO 71 IF(N.GE.NMN)THEN TN=N S1=V1*(T2-TN)*(T3-TN)/((T2-T1)*(T3-T1)) S2=V2*(T1-TN)*(T3-TN)/((T1-T2)*(T3-T2)) S3=V3*(T1-TN)*(T2-TN)/((T1-T3)*(T2-T3)) TNN=N*N DE=DZ*(TNN-TN2)/(TN2*TNN) DO L=1,LMAX TC(L)=ZERO IF(TNU(L,I0-1).NE.ZERO)THEN TT=S1*TNU(L,I-2)+S2*TNU(L,I-1)+S3*TNU(L,I) IF(TT.GT.ZERO)THEN TT=TT/(TN*TNN) TT=TT/TNU(L,I0-1) c write(6,'(i5,1p,4e12.4)')n,tt,TNU(L,I-2),TNU(L,I-1),TNU(L,I) DO J=1,NBIN1 IF(UB(L,I0-1,J).GT.ZERO)THEN ERES=EBIN(J+1)-EBIN(J) NDE=DE/ERES K=J+NDE IF(K.GT.0.AND.K.LE.NBIN1)THEN TS=UB(L,I0-1,J)*TT IF(ILOG.GE.0)TS=TS*EBIN(J+1)/EBIN(K+1) SBIN(L,K)=SBIN(L,K)+TS TC(L)=TC(L)+TS ENDIF ENDIF ENDDO TCL(L)=TCL(L)+TC(L) c write(6,35)n,lv-1,tc(1) ENDIF ENDIF ENDDO ENDIF ENDDO N11=1 I0=I0+1 IF((I0-1).EQ.I)GO TO 385 IC0=I DE=DZ*(TN2-TN1)/(TN2*TN1) NDE=DE/(EBIN(NBIN1+1)-EBIN(NBIN1)) IF(NDE.EQ.0.AND.(I+1).LT.IC.AND.N2.GT.NVINT)GO TO 384 c IF(N2.GT.NVINT)GO TO 384 ENDDO GO TO 71 C C SIMPSON 384 DO J=1,NBIN1 DO L=1,LMAX SBIN(L,J)=SBIN(L,J)-0.5*UB(L,IC0,J) TCL(L)=TCL(L)-0.5*UB(L,IC0,J) ENDDO ENDDO IC0=IC0+2 DO I=IC0,IC,2 T1=NS(I-2)*NS(I-2) T3=NS(I)*NS(I) H=(T3-T1)/(T1*T3) H=H/12.0 T=NS(I-2) T1=T1*T T2=NS(I-1)**3 T=NS(I) T3=T3*T DO L=1,LMAX TC(L)=ZERO ENDDO TT=ZERO DO J=1,NBIN1 DO L=1,LMAX T=T1*UB(L,I-2,J)+4.0*T2*UB(L,I-1,J)+T3*UB(L,I,J) IF(I.EQ.IC)TT=UB(L,IC,J)*0.5 T=T*H+TT SBIN(L,J)=SBIN(L,J)+T TC(L)=TC(L)+T ENDDO ENDDO DO L=1,LMAX TCL(L)=TCL(L)+TC(L) ENDDO ENDDO C 71 IF(BPRNT2.AND.NV0.GE.0)WRITE(6,36)LV0,(TCL(L),L=1,LMAX) 36 FORMAT(2X,'SUM',I3,3X,1P,4(E15.4,13X)/(11X,4(E15.4,13X))) DO L=1,LMAX TCS(L)=TCS(L)+TCL(L) ENDDO 420 IF(NV.EQ.0)GO TO 1000 IF(LV.GT.LCUT)GO TO 1000 C C START A NEW L C 70 LV0=LV LVV0=MAX(LV,1) NV0=NV-1 NV00=NV ISW=1 DO L=1,LMAX TCL(L)=ZERO ENDDO IC=1 IF(NECOR.LT.0.AND.BPAR)THEN !PARENT FILE EXISTS, SO READ BPAR=.FALSE. READ(17,34,END=37)NVPAR,LVPAR BPAR=.TRUE. IF(LVPAR.NE.LV)THEN WRITE(6,*)'MIS-MATCH BETWEEN LV AND PARENT FILE LP:',LV,LVPAR STOP 'MIS-MATCH BETWEEN LV AND PARENT FILE LVPAR:' ENDIF DO I=1,NDIM13 IPAR(I)=0 ENDDO DO I=1,NDIM13 READ(17,34)KP,MP,IP,NP,LP,JP IF(KP.EQ.0)GO TO 37 IPAR(KP)=MP CP IPARC(KP)=IP CP IPARS(KP)=NP CP IPARL(KP)=LP CP IPARJ(KP)=JP ENDDO ENDIF C C START A NEW N C 37 DO L=1,LMAX TC(L)=ZERO ENDDO IF(BPRNT0)THEN MSMAX=0 LSMAX=0 DO J=1,NDIM5 DO I=1,NDIM5 ESWT(I,J)=ZERO SSWT(I,J)=ZERO ENDDO ENDDO ENDIF C BJUMP=NV.GT.NV0+1 BINT=.FALSE. IF(NV.LE.NCUT.AND.NV.GE.NMN.AND.LV.GE.LMN)GO TO 85 ICT=IC-mod(ic-1,2) cold IF(ICT.GT.1)ICT=ICT-1 IF(BJUMP.AND.NS(ICT).LT.NCUT.AND.NV.GE.NMN.AND.LV.GE.LMN)GO TO 85 BINT=.TRUE. IF(LV.LT.LCUT.OR.NV.LT.NMN)GO TO 75 LV=LV+1 GO TO 91 C 85 IF(BJUMP)IC=IC+1 IF(IC.GT.NDIM16)STOP '***INCREASE NDIM16' DO L=1,LMAX TNU(L,IC)=ZERO ENDDO DO J=1,NBIN1 DO L=1,LMAX UB(L,IC,J)=ZERO ENDDO ENDDO NS(IC)=NV DO I=1,IB0 IF(NV.EQ.IBN(I))GO TO 186 ENDDO IB0=IB0+1 I=IB0 IF(I.GT.NDIM27)STOP 'SR.CROSSX TOO MANY N-STATES, INCREASE NDIM27' IBN(I)=NV 186 IB=I 75 NV0=NV C C CALCULATE FINAL STATE AUGER YIELD FOR REDA C IF(BREDA)CALL AYIELD(NV,LV,IPRINT) C C READ HEADER AND ORBITAL CODE C IF(BFORM)THEN READ(MR,101,END=1002) NCF,NZ0,NE,(QN(I),QL(I),I=1,30) ELSE READ(MRU,END=1002,ERR=300) NCF,NZ0,NE,(QN(I),QL(I),I=1,30) ENDIF 101 FORMAT(I3,12X,I2,6X,I2,4X,30(I3,I2)) C 300 IF(NCF.GT.NDIM14)THEN WRITE(6,136)NCF 136 FORMAT('DIMENSION EXCEEDED IN SR.CROSSX, INCREASE NDIM14 TO',I5) STOP '*** INCREASE NDIM14' ENDIF IF(NCF.EQ.0)RETURN C NZ=NZ0-NE+1 DZ=NZ*NZ TV=NV*NV DEN=QDT(QD0,NZ0,NE,NV,LV) C C READ CONFIGURATION DATA C DO I=1,NCF IF(BFORM)READ(MR,179,END=1002)II,NGR,MA0,MB0,(QS0(J),QL0(J), X J=1,10) IF(.NOT.BFORM)READ(MRU,END=1002)II,NGR,MA0,MB0,(QS0(J),QL0(J), X J=1,10) 179 FORMAT(2I5,2X,I3,I2,1X,10(I2,A1)) IN=IABS(II) NG(IN)=NGR C C DECODE CONFIGURATIONS FOR MQDT C (NEED MORE GENERALLY NOW) C cold IF(BMODA.OR.BMODR.OR.LV.EQ.999.OR.IUP.GE.0.OR.NECOR.LT.0)THEN DO 16 J=1,10 QSB(I,J)=MBLNK IF(QL0(J).EQ.MBLNK)GO TO 16 LMX(I)=J M=MOD(QS0(J),10) IF(M.GT.0)QSB(I,J)=LIT(M) DO K=1,30 IF(QL0(J).EQ.LIT(K))GO TO 19 ENDDO QLB(I,J)=0 GO TO 16 19 QLB(I,J)=K 16 CONTINUE IF(II.LT.0)THEN J=LMX(I) LMX(I)=J-1 QSB(I,J)=MBLNK ENDIF cold ENDIF ENDDO C IF(BFORM)READ(MR,103,END=1002) IF(.NOT.BFORM)READ(MRU,END=1002)NZTEST,NDUME IF(BFORM)READ(MR,103,END=1002) 103 FORMAT(A1) C TC1=ZERO IF(NECOR.LT.0)THEN !.AND.LV.GE.0 TC1=E1C(1) E1C(1)=ZERO ENDIF I=0 111 I=I+1 C C *** READ AUTOIONIZATION RATES AND ENERGIES *** C IF(BFORM)READ(MR,112,END=1002)I1,I2,I3,I4,I5,T1,T2,T3 IF(.NOT.BFORM)READ(MRU,END=1002)I1,I2,I3,I4,I5,T1,T2,T3 112 FORMAT(5I5,5X,1PE15.5,2(0PF15.6)) C IF(I2.EQ.0) GO TO 113 IF(I.LT.NDIM12)THEN ICA(I)=I1 ITA(I)=I2 IWA(I)=I3 JCA(I)=I4 JTA(I)=I5 AA(I)=T1 EC(I)=T2 EION(I)=T3 ELSE GO TO 111 ENDIF I=I-1 C**** C EXCLUDE AUTOIONIZING CONFIGS (E.G. TO AVOID MULTIPLE COUNTING OF NON-RYDBERG) IF(ICA(I+1).GT.JCFJ.AND..NOT.BRYLD)GO TO 111 C EXCLUDE CONTINUUM CONFIGS (E.G. RYDBERG FOR REDA) C IF(-JCA(I+1).GT.JCFJ)GO TO 111 C**** IF(BCFM.AND.JCFRB.NE.ICA(I+1))GO TO 111 IF(AA(I+1).EQ.ZERO)GO TO 111 C I=I+1 IF(IMODE.EQ.-4)THEN JTA(I)=ITA(I) ITA(I)=ICA(I) ICA(I)=0 JCA(I)=0 ENDIF IF(NLCOR.LE.0)THEN AA(I)=AA(I)*ACOR ELSE IF(LV+1.GT.0.AND.LV.LT.NDIM25)AA(I)=AA(I)*ACORL(LV+1) ENDIF C AA(I)=ABS(AA(I)) !DONE IN FEARS/M IF(NECOR.EQ.0)GO TO 111 C C APPLY ENERGY CORRECTIONS C EION(I)=EION(I)+TC1 EC(I)=EC(I)-TC1 IF(BBIN.AND.KFPM.EQ.0)THEN IF(EC(I).LT.ZERO)I=I-1 GO TO 111 ENDIF DO M=1,NBINC IF(EION(I).GE.EI(M).AND.EION(I).LT.EI(M+1))GO TO 371 ENDDO GO TO 111 C 371 J=0 C ITAR(JTA(I))=M !NOT USED YET IF(M.GE.IABNE)GO TO 372 IF(BPAR.AND.NV.LT.NVPAR)THEN !PARENT INDEX FROM FILE J=IPAR(ITA(I)) IF(J.EQ.0)GO TO 372 c if(iparc(ita(i)).ne.ica(i))then c write(65,*)nv,lv,'cfs:',iparc(ita(i)),ica(i) c endif if(j.le.m)then if(ec(i).gt.zero) x write(66,*)nv,lv,ita(i),'parents:',m,j,ec(i) endif J=0 GO TO 372 ENDIF IF(NECOR.GT.0)THEN J=1 EC(I)=EC(I)-ECORI(M,J) GO TO 372 ENDIF C DEN0=DEN !PARENT BASED ON ENERGY IF(LV.EQ.999)THEN MM=QLB(ICA(I),LMX(ICA(I))) IF(MM.GT.0)THEN DEN0=QDT(QD0,NZ0,NE,QN(MM),QL(MM)) ELSE DEN0=QDT(QD0,NZ0,NE,NV,LV) ENDIF ELSE IF(LV.LT.0)GO TO 111 ENDIF TE=EC(I)-DEN0 JM=IABNE-1 DO J=M,JM IF(ABS(TE-E1C(J)+E1C(M)).LT.ABS(TE-E1C(J+1)+E1C(M)))GO TO 372 ENDDO J=IABNE !USE LAST CORRECTION AS REPRESENTAIVE OF ALL HIGHER c if(m.eq.1.and.ica(i).eq.3)write(6,*)ica(i),ec(i),aa(i) C J=0 !UNCORRECTED - THEN NEED NECOR+1 TO DETECT NECOR'TH 372 IF(JPAR.GT.0.AND.J.NE.JPAR)THEN !J.gt.JPAR I=I-1 GO TO 111 ENDIF C ITAR(ITA(I))=J !NOT USED YET IF(J.GT.M)EC(I)=EC(I)-ECORI(M,J) IF(EC(I).LT.ZERO)THEN I=I-1 GO TO 111 ENDIF GO TO 111 C C *** END OF AUTOIONIZATION READS C 113 NUMA=I-1 if(ibug.ne.0)write(*,*)'numa=',numa IF(NUMA.GE.NDIM12)THEN WRITE(6,73)NUMA 73 FORMAT(' SR.CROSSX: NUMBER OF AUTOIONIZATION RATES EXCEEDS' X, ' STORAGE, INCREASE NDIM12 TO',I10) STOP 'INCREASE NDIM12' ENDIF EION(I)=T3 C C UNITARISE AA C IF(BMODA)CALL AMODX(AA,NUMA,JCA,LMX,QLB,QN,NV,LV,NZ0,NE) C IF(NECOR.LT.0.AND.LV.GE.0)THEN E1C(1)=TC1 EION(I)=EION(I)+E1C(1) ENDIF E00=EION(I) EIONMN=E00 IF(EMIN0.LT.EIONMN)EIONMN=EMIN0 EMIN0=EIONMN EMIN=EIONMN C C NOT FOR GENERAL USE WITH ECORI .LT. ZERO, DANGEROUS FOR HIGH-N. C FOR SPECIAL CASES USE TOLR .LT. ZERO WITH CARE - DISABLED FOR NOW c IF(NECOR.GT.0.AND.ECORI(1,1).GT.ZERO)EIONMN=EIONMN+ECORI(1,1) c IF(NECOR.LT.0.AND.ECORI(1,2).GT.ZERO)EIONMN=EIONMN+ECORI(1,2) C IF(BFORM)READ(MR,121,END=1002) NENG,ECORE IF(.NOT.BFORM)READ(MRU,END=1002) NENG,ECORE 121 FORMAT(10X,I5,45X,F15.6) C IF(NENG.GE.NDIM13)THEN WRITE(6,369)NENG 369 FORMAT('NUMBER OF LEVELS EXCEEDS STORAGE,INCREASE NDIM13 TO',I6) STOP ' NUMBER OF LEVELS EXCEEDS STORAGE,INCREASE NDIM13' ENDIF C IF(NENG.EQ.0)GO TO 124 NENG0=NENG ECORE0=ECORE DEN0=DEN C IF(BFORM)READ(MR,105,END=1002)MTEST IF(.NOT.BFORM)READ(MRU,END=1002)MTEST 105 FORMAT(26X,A4) C BLS=MTEST.EQ.MBLNK BIC=MTEST.NE.MBLNK C C ***READ LEVEL INFO *** C WNP0=-ONE NYLD0=0 MLEV=1 NASTD0=0 NAUTO=0 C DO 122 I=1,NENG C IF(BFORM)THEN READ(MR,123,END=1002,ERR=150)IK(I),IT(I),SS(I),LL(I) X ,JJ(I),LCF(I),ENERG(I) GO TO 151 150 BACKSPACE(MR) READ(MR,155)LAB5,IT(I),SS(I),LL(I) X ,JJ(I),LCF(I),ENERG(I) 155 FORMAT(5X,A5,5I5,F15.6) IF(LAB5.EQ.'*****')THEN !ASSUME CORRELATION IK(I)=-NDIM13 ELSE WRITE(6,*)'*** ILLEGAL CHARACTER IN FIELD:',LAB5 ENDIF ELSE READ(MRU,END=1002)IK(I),IT(I),SS(I),LL(I),JJ(I) X ,LCF(I),ENERG(I) ENDIF 123 FORMAT(5X,6I5,F15.6) C 151 M=IK(I) M=IABS(M) JK(M)=I IF(BRYLD)IYLD0(M)=0 JFIRST(M)=0 JLAST(M)=-1 KFIRST(M)=0 KLAST(M)=-1 IF(NECOR.LT.0.AND.LCF(I).LT.0.AND.LV.GE.0)ENERG(I)=ENERG(I) X +E1C(1) TE=ECORE+ENERG(I) IF(LCF(I).GT.0.AND.LCF(I).LE.JCFJ.AND.TE.GE.EIONMN-TOLE-TOLN) X THEN NAUTO=NAUTO+1 IAUTO(NAUTO)=M !=IABS(IK(I)) ENDIF C C SET-UP TARGET BINS AND INDEXING C IF(KFPM.LE.NBINC.OR.BRYLD)THEN IF(LCF(I).LT.0)THEN IF(EMIN.EQ.ZERO)EMIN=TE IF(ENERG(I).GT.(WNP0+TOLB))THEN C IF(MLEV.LE.NASTD)THEN NASTD0=NASTD0+1 IF(NASTD0.EQ.NLEV(MLEV))THEN MLEV=MLEV+1 NASTD0=0 ELSE WNP0=ENERG(I) GO TO 122 ENDIF ENDIF C IF(BREDA.AND.IK(I).GT.0)THEN IF(TE.GT.EFMIN)THEN NYLD0=NYLD0+1 IF(NYLD0.GT.NDIM4)THEN WRITE(6,558) 558 FORMAT(' ******INCREASE NDIM4 FOR REDA OPERATION') STOP '***INCREASE NDIM4 FOR REDA OPERATION' ENDIF IYLD0(KFPM+1)=NYLD0 EF0(NYLD0)=TE ENDIF ENDIF WNP0=ENERG(I) IF(KFPM.GT.NBINC )GO TO 122 C .OR.-LCF(I).GT.JCFE KFPM=KFPM+1 IF(BBIN)EII(KFPM)=TE C IF(lv.ge.0)THEN !CHECK TARGET ENERGIES (SKIP LAST) T=TE-EII(1) T0=E1C(KFPM) IF(KFPM.EQ.1)THEN IF(IPRINT.GE.0)WRITE(6,374)TOLB*UNITS 374 FORMAT(3X,'IE',10X,'E(N)',14X,'E(N+1)',2X,'TOLB=' X ,1PE10.3) T0=T0-E1C(1) ENDIF MMM=MBLNK IF(ABS(T-T0).GT.TOLB)THEN MMM=MSTAR if(kfpm.le.-necor)then DO K=KFPM+1,IABNE ECORI(KFPM,K)=ECORI(KFPM,K)-(T-T0) ENDDO DO K=1,KFPM-1 ECORI(K,KFPM)=ECORI(K,KFPM)+(T-T0) ENDDO else if(e1c(kfpm).eq.dzero)then mmm=mblnk iflage=iflage-1 endif endif IFLAGE=IFLAGE+1 E1C(KFPM)=T ENDIF IF(IPRINT.GE.0..OR.MMM.NE.MBLNK) X WRITE(6,373)KFPM,T0*UNITS,T*UNITS,MMM 373 FORMAT(I5,2F18.8,3X,A4) ENDIF C ENDIF WNP0=ENERG(I) !ALLOW FOR ANY DRIFT OF CONTINUUM ENERGIES IF(KFPM.EQ.2)TOLN=MAX(TOLN,4.D-4*DZ-(EII(2)-EII(1))) ELSE IF(BRYLD.AND.TE.GT.EMIN.AND.TE.LT.EMIN+TOLR)THEN NYLD0=NYLD0+1 IF(NYLD0.GT.NDIM4)THEN WRITE(6,559) 559 FORMAT(' ******* INCREASE NDIM4 FOR TWO-STEP RADIATION', X ' STABILIZATION') STOP 'INCREASE NDIM4 FOR TWO-STEP RADIATION' ENDIF IYLD0(M)=NYLD0 ENDIF ENDIF ENDIF 122 CONTINUE c C *** END READS OF LEVEL INFO C IF(BBIN.AND.EI(1).GE.ZERO)THEN IF(KFPM.LE.NBINC)EII(KFPM+1)=0.8*EII(NBINC) EI(1)=1.2*EII(1) DO M=1,NBINC EI(M+1)=EII(M+1)-0.5*(EII(M+1)-EII(M)) ENDDO ENDIF KFPM=NENG C C WRITE PARENT INFO C IF(NECOR.LT.0.AND.IPARNT.GT.0.AND..NOT.BPAR.AND.NV.EQ.NCUT)THEN WRITE(17,34)NV,LV TC1=E1C(1) E1C(1)=ZERO T0=ECORE-E00 DO M=1,NENG I=LCF(M) IF(I.GT.0)THEN J=LMX(I) K=QLB(I,J) IF(NV.EQ.QN(K))THEN DEN0=QDT(QD0,NZ0,NE,QN(K),QL(K)) TE=ENERG(M)-DEN0+T0 DO J=1,IABNE-1 IF(ABS(TE-E1C(J)).LT.ABS(TE-E1C(J+1)))GO TO 125 ENDDO J=0 125 IF(J.GT.0)THEN WRITE(17,34)IK(M),J,I,SS(M),LL(M),JJ(M) ENDIF ENDIF ENDIF ENDDO E1C(1)=TC1 IO=0 WRITE(17,34)I0,I0,I0,I0,I0,I0 !TERMINATOR ENDIF C C DETERMINE REDA SET-UP C IF(BREDA.AND.NYLD.NE.NYLD0)THEN WRITE(6,322)NYLD0,NYLD,2.*TOLB,ECORE 322 FORMAT(/' SR.CROSSX: MIS-MATCH OF CONTINUUM FOR 2ND AUGER IN RE' X ,'DA',2I5/' TRY INCREASING TOLB IN NAMELIST TWO TO',F15.8,' RY' X //' NYLD ITAR',9X,'ENERGY NYLD',5X,'EIONMN=',F15.6) DO I=1,NYLD0 WRITE(6,323)I,IYLD0(I),EF(I)-EIONMN 323 FORMAT(2I6,F15.6) ENDDO STOP 'MIS-MATCH OF CONTINUUM FOR 2ND AUGER IN REDA' ENDIF NYLD=NYLD0 C IF(BPASS1)THEN IF(BREDA)THEN T1=EF0(1) T2=EF(1) WRITE(6,555)T1,T2 555 FORMAT(/' NYLD EF01=',F12.5,3X,'EF1=',F12.5,13X,'AYIELD'/) DO M=1,NYLD0 EF0(M)=EF0(M)-T1 EF(M)=EF(M)-T2 WRITE(6,557)M,LSPJ(M),EF0(M),EF(M),AYLD(M) 557 FORMAT(I5,I9,F10.5,2F19.5) ENDDO WRITE(6,560) 560 FORMAT(//) ENDIF C C WRITE HEADERS C IF(BPRNT2)WRITE(6,90) 90 FORMAT(4X,'N L',8X,'CROSS(MB)',4X,'CROSS*N**3',5X,'CROSS(MB)' X ,4X,'CROSS*N**3',5X,'CROSS(MB)',4X,'CROSS*N**3',5X,'CROSS(MB)' X ,4X,'CROSS*N**3') IF(IPRINT.GE.1)THEN IF(JCFA.NE.0)THEN IF(BREDA)THEN WRITE(6,30) 30 FORMAT('CF',4X,'J IP WI JP WJ',8X,'EBINJ',9X,'AA*SEC' X ,9X,'SUMAD',10X,'SUMRD',10X,'DAYLD',8X,'CROSS(MB)') ELSE WRITE(6,456) 456 FORMAT('CF',4X,'J IP WI JP WJ',8X,'EBINJ',9X,'AA*SEC' X ,9X,'SUMAN',10X,'SUMAD',10X,'SUMRD',8X,'CROSS(MB)') ENDIF ELSE WRITE(6,33) 33 FORMAT('CF',4X,'J IP WI JP WJ',8X,'EBINJ',9X,'AA*SEC' X ,9X,'SUMAD',10X,'SUMRN',10X,'SUMRD',8X,'CROSS(MB)') ENDIF ENDIF IF(BPRNT0)THEN IF(JCFA.EQ.0)THEN WRITE(66,329)(EBIN(2)-EBIN(1))*UNITS,UNITS 329 FORMAT('BIN WIDTH =',1PE12.4,5X,'ENERGY UNITS = ',0PF7.4/) WRITE(66,330) 330 FORMAT(' N L I J',10X,'ESWT',7X,'SSWT(MB)') ELSE WRITE(66,334)UNITS 334 FORMAT('ENERGY UNITS = ',F7.4/) WRITE(66,335) 335 FORMAT(' N L I J WJ',5X,'EAWT',7X,'AAWT(SEC)', X 5X,'OMEGA') ENDIF ENDIF ENDIF C IF(IPRINT.GE.0.AND.NV.GE.0)THEN WRITE(6,34)NV,LV IF(BPRNT0)WRITE(66,34)NV,LV 34 FORMAT(I5,I3,I3,1X,I4,I3,I3) ENDIF C IF(BFORM)READ(MR,104,END=1002)NZTEST IF(.NOT.BFORM)READ(MRU,END=1002)NZTEST,NDUME 104 FORMAT(66X,I2) C IF(NZTEST.LT.1)THEN NUMR=1 ITR(1)=0 GO TO 383 ENDIF C C *** READ RADIATIVE RATES AND ENERGIES *** C IF(BFORM)READ(MR,103,END=1002) I=0 131 I=I+1 IF(BFORM)READ(MR,132,END=1002) I1,I2,I3,I4,I5,I6,T1,T2,T3 IF(.NOT.BFORM)READ(MRU,END=1002) I1,I2,I3,I4,I5,I6,T1,T2,T3 132 FORMAT(6I5,1PE15.5,2(0PF15.6)) C IF(I2.EQ.0) GO TO 133 IF(I.LT.NDIM7)THEN ICR(I)=I1 ITR(I)=I2 IWR(I)=I3 JCR(I)=I4 JTR(I)=I5 JWR(I)=I6 AR(I)=T1 DEL(I)=T2 EATOM(I)=T3 ELSE GO TO 131 ENDIF I=I-1 C**** C IF(JCR(I+1).GT.JCFJ)GO TO 131 C**** IF(AR(I+1).EQ.ZERO)GO TO 131 I=I+1 C AR(I)=ABS(AR(I)) !DONE IN FEARS/M IF(IMODE.EQ.-4)THEN JWR(I)=IWR(I) JTR(I)=ICR(I) IWR(I)=JCR(I) TW=JWR(I) T=IWR(I) TW=TW/T AR(I)=AR(I)*TW EATOM(I)=EATOM(I)-DEL(I) ICR(I)=0 JCR(I)=0 ENDIF GO TO 131 C C *** END OF RADIATION READS C 133 NUMR=I-1 383 if(ibug.ne.0)write(*,*)'numr=',numr IF(NUMR.GE.NDIM7) THEN WRITE(6,74)NUMR 74 FORMAT(' SR.CROSSX: NUMBER OF RADIATIVE RATES EXCEEDS STORAGE,', X ' INCREASE NDIM7 TO',I10) STOP '*** TOO MANY RADIATIVE RATES: INCREASE NDIM7' ENDIF C C IMPOSE MQDT DR ON AR C IF(BMODR)CALL RMODX(AR,NUMR,JCR,LMX,QLB,QN,NV,LV,NZ0,NE) C C EVALUATE SECOND STEP OF RADIATIVE STABILIZATION C IF(BRYLD)THEN IF(BPASS1.AND.IPRINT.GT.0)WRITE(6,587) 587 FORMAT(/41X,'NYLD',4X,'J',8X,'SUMAD',10X,'SUMRN',10X,'SUMRD' X ,11X,'RYIELD') C CALL RYIELD(RYLD,IRRV,ECORE,EMIN,NUMA,NUMR,NV,LV,NR0,NZ0,NE X ,IPRINT) C IF(IPRINT.LE.0)THEN IF(BPASS1)WRITE(6,586) 586 FORMAT(/51X,'NYLD',4X,'J',4X,'RYIELD') IF(NYLD*ISW.GT.0)THEN ISW=-1 DO I=1,NYLD WRITE(6,583)I,IRRV(I),RYLD(I) 583 FORMAT(50X,2I5,F10.5) ENDDO ENDIF ENDIF ENDIF C C ATTEMPT TO EVALUATE UNIFIED RECOMBINATION CROSS SECTION C 124 IF(IMODE.EQ.-14)THEN CALL FEARS(MTEST,EI,IWT,NBINM,NV,LV,NENG0,NUMA,NUMR X ,ICA,ITA,IWA,JCA,JTA,AA,EC,EION,IK,IT,SS,LL,JJ,LCF,ENERG,EIONMN X ,ICR,ITR,IWR,JCR,JTR,AR,DEL,EATOM,SBIN,EBIN,NBIN1,IMODE,IPRINT) ELSE CALL FEARM(MTEST,EI,IWT,NBINM,NBINRM,NV,LV,NENG0,NUMA,NUMR X ,ICA,ITA,IWA,JCA,JTA,AA,EC,EION,IK,IT,SS,LL,JJ,LCF,ENERG,EIONMN X ,ICR,ITR,IWR,JCR,JTR,AR,DEL,EATOM,SBIN,EBIN,NBIN1,IMODE,IPRINT) ENDIF IF(BFEAR)GO TO 31 C IF(.NOT.BSORT)GO TO 415 C C SORT RATES INTO ASCENDING TERM/LEVEL NUMBER C REWIND(24) JTB=0 DO J=1,NENG0 DO I=1,NUMA IF(ITA(I).EQ.J)WRITE(24)ICA(I),ITA(I),IWA(I),JCA(I),JTA(I) X ,AA(I),EC(I),EION(I) ENDDO DO I=1,NUMR IF(ITR(I).EQ.J)WRITE(24)ICR(I),ITR(I),IWR(I),JCR(I),JTR(I) X ,AR(I),DEL(I),EATOM(I) ENDDO ENDDO WRITE(24)JTB,JTB,JTB,JTB,JTB,ZERO,ZERO,ZERO REWIND(24) C IF(IMODE.LT.-2)GO TO 415 IF(IMODE+1)417,416,415 C C EVALUATE ARRAY AVERAGED TRANSITION PROBABILITIES C 416 IF(NV.GT.0)WRITE(6,430)NV,LV 430 FORMAT(//1X,'NV=',I4,3X,'LV=',I3) C CALL DRAY(ICA,ITA,IWA,JCA,AA,EC,EION,ICR,ITR,IWR,JCR,AR,DEL,EATOM X,NUMA,NUMR,NCF,NENG0,EI(2),TOLR,IWT(1),NG,EIONMN) GO TO 31 C C SOLVE CAPTURE-CASCADE EQUATIONS C 417 IF(BINT)GO TO 31 IF(NV.GT.0)WRITE(6,430)NV,LV C CALL CASC(EBIN,NBIN,EI(2),EIONMN,NCF,NZ,NG,IWT(1),TOLR,ECORE0,MTES XT,NENG0,ENERG,IK,JK,IT,SS,LL,JJ,LCF,AR,SBIN,LMAX,EWIDTH,IZ,IPRINT X,NV) GO TO 31 C 415 IF(NUMA.EQ.0.OR.BINT)GO TO 31 IF(NUMR.EQ.0.AND.JCFA.EQ.0.AND..NOT.BRAD)GO TO 31 C C EVALUATE HYDROGENIC RADIATIVE RATES FOR VALENCE ELECTRON C RSUMN=ZERO RSUMD=ZERO TLIF3=1.0D0 IF(.NOT.BRAD)GO TO 160 IF(BINT)GO TO 160 !**** .OR.NV.EQ.999 IF(LV.LT.0.OR.LV.EQ.999.OR.LV.LE.IUP)GO TO 160 C NMIN=MAX0(NR1,LV) NMAX=MIN0(NR2,NV-1) IF(NMIN.GT.NMAX)GO TO 160 LP=LV+1 TL=LV TLP=LP C DO N=NMIN,NMAX T=N*N DE=DZ*(TV-T)/(TV*T) c denm=qdt(qd0,nz0,ne,n,lp) c denp=qdt(qd0,nz0,ne,n,lv-1) c de1=den-denm c de2=den-denp DE1=DE DE2=DE C CALL DIPOL(-1,N,NV,ZERO,LP,CP,CM,JDUM) C T1=TLP*CM(LP)*1.0D10**JDUM(LP) T2=ZERO IF(LV.GT.0)T2=TL*CP(LV)*1.0D10**JDUM(LV) T=(T1*DE1**3+T2*DE2**3)/(TL+TLP) T0=2.6775D9/DZ T=T*T0 IF(IPRINT.GT.1)WRITE(6,870)N,T c write(83,*)lv,nv,n,de1,de2,de,t1,t2,t 870 FORMAT(I10,1PE15.4) IF(N.LE.NFLITE)RSUMN=RSUMN+T RSUMD=RSUMD+T IF(N.LE.NDIM15)RSUMC(N)=T ENDDO C C TEST LIFETIME C if(rsumn.lt.zero)stop 'negative radiative width in ToF' IF(RSUMN.GT.ZERO.AND.TFLITE.GE.ZERO)THEN TLIF1=ONE/RSUMN C ASSUME RADIATIVE DECAY TIME = TOTAL DECAY TIME IF(NV.GT.NFLITE)THEN TLIF3=EXP(-TFLITE*RSUMN) IF(TCOOL.GT.ZERO)THEN T=TCOOL/(2*RSUMN) TLIF3=TLIF3*(EXP(T)-EXP(-T))/(T*2) ENDIF TLIF3=ONE-TLIF3 ENDIF T=NV TLIF2=TLIF1*DZ*DZ/(T*TV) IF(LV.GT.0)TLIF2=TLIF2/TL**1.7 WRITE(6,830)TLIF1,TLIF2,TLIF3 ENDIF C C N,L SPECIFIC DETECTION PROBABILITIES C 160 IF(NFNLMX.GT.0)THEN IF(NV.GT.0.AND.NV.LE.NFNLMX)THEN IFNL=(NV*(NV-1))/2+LV+1 FNLV=FNL(IFNL) C WRITE (*,*) NV,LV,FNLV ELSE FNLV=ZERO ENDIF ELSE FNLV=ONE ENDIF C C DETERMINE TARGETS C IFIRST=1 DO 360 I=1,NENG KK=IABS(IK(I)) ITAR(KK)=9999 !NOTE OPPOSITE SIGN USE FROM ADASDR IF(LCF(I).LT.0)THEN !CONTINUUM TE=ENERG(I)+ECORE DO M=IFIRST,MMAX IF(TE.GE.EI(M).AND.TE.LT.EI(M+1))THEN ITAR(KK)=M IF(M.GT.IFIRST)IFIRST=M GO TO 360 ENDIF ENDDO ENDIF 360 CONTINUE C C INITIALIZE C DO I=1,NUMA IF(JFIRST(ITA(I)).EQ.0)JFIRST(ITA(I))=I JLAST(ITA(I))=I ENDDO IF(NENG.GT.0)THEN DO I=1,NUMR IF(KFIRST(ITR(I)).EQ.0)KFIRST(ITR(I))=I KLAST(ITR(I))=I ENDDO ENDIF C BFASTR=EPHMIN.LT.ZERO.AND.EPHMAX.GT.1.D5.AND. X EBDMIN.LT.ZERO.AND.EBDMAX.GT.1.D5.AND. X ABS(RCOR-ONE).LT.0.01.AND. X IUP.LT.0.AND.JCFR.EQ.0.AND.ITHETA.LT.0.AND..NOT.BRYLD EMIN=EIONMN+TOLR C C LOOP THRU AUTOIONIZING LEVELS C DO 1410 IA=1,NAUTO C ITAI=IAUTO(IA) ITT=JK(ITAI) C IF(BLS)THEN IF(LSPI.GT.0)THEN LSPT=10000*IABS(SS(ITT))+100*LL(ITT) IF(SS(ITT).LT.0)LSPT=LSPT+1 IF(LSPT.NE.LSPI)GO TO 1410 ENDIF IWGTJ=IABS(SS(ITT))*(2*LL(ITT)+1) ENDIF IF(BIC)THEN IF(J2PI.GE.0)THEN J2PT=100*JJ(ITT) IF(SS(ITT).LT.0)J2PT=J2PT+1 IF(J2PT.NE.J2PI)GO TO 1410 ENDIF IF(JJ(ITT).GT.MAX2J)GO TO 1410 IWGTJ=JJ(ITT)+1 ENDIF C C PERFORM RELEVANT SUMS OF AUGER RATES C DO M=1,MMAX SUMAN(M)=ZERO ENDDO SUMAD=ZERO MSMX=0 C DO 141 J=JFIRST(ITAI),JLAST(ITAI) C IF(ITAI.NE.ITA(J))GO TO 141 C SUMAD=SUMAD+AA(J) C MS=JTA(J) IF(MS.LE.0)GO TO 141 !LOSS TERM ONLY MS=ITAR(MS) IF(MS.GT.MMAX )GO TO 141 !TARGET NOT WANTED C .OR.-JCA(J).GT.JCFE C IF(EC(J).LT.EBIN(1).OR.EC(J).GT.EBIN(NBIN))GO TO 141 !SKIP AT BIN STATGE C SUMAN(MS)=SUMAN(MS)+AA(J) ECA(MS)=EC(J) MSMX=MAX(MSMX,MS) C 141 CONTINUE C IF(SUMAD.EQ.ZERO)GO TO 1410 C IF(IPRINT.GE.0)THEN TE=ENERG(ITT)+ECORE0-DEN0 !ASSUMES DEN0 SET BY NECORE.NE.0 DO MS=MSMX+1,NBINC IF(TE.GE.EI(MS).AND.TE.LT.EI(MS+1))GO TO 147 ENDDO IF(JPAR.LT.0)THEN MS=-JPAR ELSEIF(JPAR.EQ.0)THEN IF(BPRNT0)GO TO 1410 !ASSUME NOT REQUIRED MS=0 ELSE WRITE(6,*)'AUTOIONIZING PARENT NOT FOUND, INCREASE NTAR2?' STOP 'AUTOIONIZING PARENT NOT FOUND' ENDIF 147 MSS=MS ENDIF C IF(SUMAN(1).NE.ZERO)THEN TE=E00+ECA(1)-DEN0 !OBS. PARENT ENERGY REL. TO GROUND ELSE TE=ENERG(ITT)+ECORE0-DEN0 !UNADJUSTED ENDIF C IF(JCFA.LT.0)GO TO 421 !NO RADIATION WANTED C C PROCESS RADIATIVE DATA C IF(NR20.LT.NR1.AND.BRAD)THEN C DETERMINE FINAL STABLE STATES INTERNALLY SUMRN=ZERO IF(NMIN.GT.NMAX)GO TO 333 DO K=NMIN,NMAX T=QDT(QD0,NZ0,NE,K,LVV0) !lv->lv00 c.f.adasdr c write(6,*)te,t,te+t,eionmn IF((TE+T).GT.EIONMN)GO TO 333 SUMRN=SUMRN+RSUMC(K) ENDDO ELSE SUMRN=RSUMN ENDIF 333 SUMRD=RSUMD C IF(NUMR.EQ.0)GO TO 421 C C PERFORM RELEVANT SUMS OF RADIATIVE RATES C DO 243 K=KFIRST(ITAI),KLAST(ITAI) C IF(ITR(K).NE.ITAI)GO TO 243 !FOR LS AS < 17.3 C IF(BFASTR)THEN IF(EATOM(K).LT.EMIN)SUMRN=SUMRN+AR(K) SUMRD=SUMRD+AR(K) ELSE TAR=AR(K) MM=QLB(JCR(K),LMX(JCR(K))) IF(MM.GT.0)THEN IF(LV.LE.IUP.AND.QN(MM).EQ.NR1-1)TAR=TAR*TUP IF(QN(MM).EQ.NV.AND.LV.GE.0)TAR=TAR*RCOR c tar=tar*rcor ENDIF SUMRD=SUMRD+TAR IF(JCFA.NE.0)GO TO 243 C IF(EIONMN-EATOM(K).LT.EBDMIN.OR.EIONMN-EATOM(K).GT.EBDMAX) X GO TO 243 IF(DEL(K).LT.EPHMIN.OR.DEL(K).GT.EPHMAX)GO TO 243 IF(BCFP.AND.JCFR.EQ.JCR(K))GO TO 41 C IF(EATOM(K).GE.EMIN)THEN IF(JCFR.GT.100)SUMRD=SUMRD-TAR GO TO 243 ELSE IF(BRYLD)THEN NY=IYLD0(JTR(K)) IF(NY.GT.0)TAR=TAR*RYLD(NY) ENDIF ENDIF C 41 IF(ITHETA.GE.0)THEN !ANISOTROPY M=ITR(K) M=JK(M) JT=JJ(M)+1 LT=LL(M) MST=SS(M) MST=IABS(MST) M=JTR(K) M=JK(M) JP=JJ(M)+1 LP=LL(M) TAR=TAR*THETR(ITHETA,ISP,MST,LT,LP,JT,JP,BOLD) ENDIF SUMRN=SUMRN+TAR ENDIF 243 CONTINUE C SUMRN=SUMRN*TLIF3*FNLV !SURVIVAL C 421 IF(SUMRN.EQ.ZERO.AND.JCFA.EQ.0)GO TO 1410 C C BIN CROSS SECTIONS C TJ=IWGTJ IF(NNCOR*NV.GT.0)TJ=TJ*ACORN(NV) IF(NLCOR.LT.0.AND.LV+1.GT.0.AND.LV.LT.NDIM25)TJ=TJ*ACORL(LV+1) DO 143 LS=1,NBINM !INITIAL METASTABLES IF(SUMAN(LS).EQ.ZERO)GO TO 143 T=ECA(LS)-ECORT IF(T.LT.EBIN(1).OR.T.GE.EBIN(NBIN))GO TO 143 !EXCLUDED ENERGY C CROSSN=TJ*SUMAN(LS) C TI=IWT(LS) CROSSD=SUMAD IF(JCFA.GE.0.AND.JCFR.LE.200)CROSSD=CROSSD+SUMRD CROSSD=CROSSD*TI TEC=ECA(LS)*UNITS C IF(BPRNT0)THEN MSMAX=MAX(MSS,MSMAX) LSMAX=MAX(LS,LSMAX) IF(JCFA.NE.0)THEN WT=SUMAN(LS)*TJ/((4*LV+2)*IWT(MSS)) ESWT(LS,MSS)=ESWT(LS,MSS)+TEC*WT SSWT(LS,MSS)=SSWT(LS,MSS)+WT ENDIF ENDIF C M1=0 M2=0 L=LS IF(JCFA.EQ.0)THEN !PHOTON EMISSION CROSSN=CROSSN*SUMRN ELSE !ELECTRON EMISSION IF(BREDA)THEN CREDA: ASSUME SAME ENERGY-ORDERED CONTINUA (SUM OVER ALL FINAL CONTINUA) TYLD=ZERO DO MS=1,MSMX NY=IYLD0(MS) IF(NY.GT.0)TYLD=TYLD+SUMAN(MS)*AYLD(NY) IF(NY*IPRINT.GT.0)WRITE(6,517)ITAI,MS,NY,SUMAN(MS) X ,AYLD(NY),SUMAN(MS)*AYLD(NY) 517 FORMAT(35X,3I5,3(1PE15.4)) ENDDO CROSSN=CROSSN*TYLD ELSE C RE IF(BSEL)THEN !SELECT RE TRANSITION CROSSN=CROSSN*SUMAN(JCFAB) IF(ITHETA.GE.0)THEN ! DIFFERENTIAL LT=LL(ITT) CROSSN=CROSSN*THETA(ITHETA,LT) ENDIF ELSE !ALL M1=1 M2=MSMX ENDIF ENDIF ENDIF C CDETERMINE LARGEST RESONANCE WIDTH FOR COMPARISON WITH CONVOLUTION WIDTH C WIDE=CROSSD*4.83777D-17/TI IF(WIDE.GT.WIDEX)THEN WIDEX=WIDE ECX=ECA(LS) NVX=NV LVX=LV JVX=ITAI KVX=ITT ENDIF C C DETERMINE BIN ENERGY C DO I=1,NBIN1 IF(T.GE.EBIN(I).AND.T.LT.EBIN(I+1))GO TO 434 ENDDO WRITE(6,*) 'SHOULD HAVE EXCLUDED BIN ENERGY ALREADY' STOP 'SHOULD HAVE EXCLUDED BIN ENERGY ALREADY' C 434 DO 435 MS=M1,M2 C IF(MS.GT.0)THEN !FIND RE TRANSITION L=IMX(LS,MS) IF(L.EQ.0)GO TO 435 !UNWANTED ENDIF C CROSS=CROSSN/CROSSD C IF(CROSS.LE.ZERO)GO TO 435 C IF(ILOG.GE.0.OR.EWIDTH.GE.ZERO)THEN ERES=EBIN(I+1)-EBIN(I) CROSS=CROSS/(ERES*EBIN(I+1)) !OLD ECA(LS) ENDIF C CROSS=CROSS*1.33704D-14 TC(L)=TC(L)+CROSS UB(L,IC,I)=UB(L,IC,I)+CROSS TNU(L,IC)=TNU(L,IC)+CROSS IF(.NOT.BJUMP)SBIN(L,I)=SBIN(L,I)+CROSS C IF(BPRNT0.AND.JCFA.EQ.0)THEN IF(ILOG.GE.0.OR.EWIDTH.GE.ZERO)CROSS=CROSS*EBIN(I+1) X /ECA(LS) ESWT(LS,MSS)=ESWT(LS,MSS)+TEC*CROSS SSWT(LS,MSS)=SSWT(LS,MSS)+CROSS ENDIF C IF (NFNLMX.GT.0.AND.IPRINT.GE.0) X WRITE(81,'(4(1X,I5),6(1P,1X,E14.6))') X NV,LV,IWT(LS),IWA(J),EBIN(I+1),SUMAN(LS),SUMAD,SUMRN,SUMRD,CROSS C N L GI GD EBIN AA SUMAA SUMAR1 SUMAR2 C CROSS = CONST*GD/GI/ERES*EBIN(I+1)*AA*SUMAR1/(SUMAA+SUMAR2) C IF(IPRINT.GE.1)THEN IF(JCFA.NE.0)THEN IF(BREDA)THEN TT=TYLD/(SUMAD+SUMRD) WRITE(6,32) LCF(ITT),ITAI,LS,IWT(LS),MSS,IWGTJ,TEC X ,SUMAN(LS),SUMAD,SUMRD,TT,CROSS ELSE WRITE(6,32) LCF(ITT),ITAI,LS,IWT(LS),MSS,IWGTJ,TEC X ,SUMAN(LS),SUMAN(MS),SUMAD,SUMRD,CROSS ENDIF ELSE WRITE(6,32) LCF(ITT),ITAI,LS,IWT(LS),MSS,IWGTJ,TEC X ,SUMAN(LS),SUMAD,SUMRN,SUMRD,CROSS 32 FORMAT(I2,I5,2I3,I4,I3,6(1PE15.4)) ENDIF ENDIF C C WRITE DATA FOR USE OF LORENTZIAN C IF(BLOR)THEN CROSS=CROSSN/CROSSD !NO ENERGY FACTORS CROSS=CROSS*1.33701D-14 WRITE(8,830)ECA(LS),CROSS,WIDE,L,LS,MS 830 FORMAT(1P3D15.7,3I5) JYMAX=JYMAX+1 IF(JYMAX.LT.NDIM11)THEN EREZ(JYMAX)=ECA(LS) GSIG(JYMAX)=CROSS GAM(JYMAX)=WIDE ITRAN(JYMAX)=L ENDIF ENDIF C 435 CONTINUE !END LOOP OVER FINAL ELECTRON TARGETS C 143 CONTINUE !END LOOP OVER INITIAL ELECTRON TARGET C 1410 CONTINUE C C END LOOP OVER AUTOIONIZING LEVELS C C T=NV**3 IF(BPRNT0)THEN MSNMAX=MAX(MSNMAX,MSMAX) LSNMAX=MAX(LSNMAX,LSMAX) DO LS=1,LSMAX DO MS=LS+1,MSMAX IF(SSWT(LS,MS).GT.ZERO)THEN ESWTN(IB,LS,MS)=ESWTN(IB,LS,MS)+ESWT(LS,MS) SSWTN(IB,LS,MS)=SSWTN(IB,LS,MS)+SSWT(LS,MS) ESWT(LS,MS)=ESWT(LS,MS)/SSWT(LS,MS) WRITE(6,327)LS,MS,ESWT(LS,MS),SSWT(LS,MS) 327 FORMAT(7X,I3,I7,3X,F15.4,60X,1PE15.4) IF(JCFA.EQ.0)THEN WRITE(66,328)LS,MS,ESWT(LS,MS),SSWT(LS,MS) 328 FORMAT(8X,2I5,F15.4,1PE15.4) ELSE JWT=(4*LV+2)*IWT(MS) OMEGA=JWT*SSWT(LS,MS)*CONAOM*NV**3/NZ**2 WRITE(66,325)LS,MS,JWT,ESWT(LS,MS),SSWT(LS,MS),OMEGA 325 FORMAT(8X,3I5,F10.4,1PE15.4,0PF11.5) ENDIF ENDIF ENDDO ENDDO ENDIF DO L=1,LMAX IF(.NOT.BJUMP)TCL(L)=TCL(L)+TC(L) TCN(L)=TC(L)*T BN(L,IB)=BN(L,IB)+TC(L) ENDDO IF(BPRNT1.AND.NV.GE.0)WRITE(6,35)NV,LV,(TC(L),TCN(L),L=1,LMAX) 35 FORMAT(I5,I3,3X,1P,4(E15.4,E13.4)/(11X,4(E15.4,E13.4))) IF(TC(1).EQ.ZERO)NV00=0 C C GO AND READ NEW NL BLOCK C GO TO 31 C C ABORT 1002 NV=0 IC=IC-1 WRITE(6,1107) 1107 FORMAT(/' ******WARNING, UNEXPECTED END OF DATA IN SR.CROSSX !!!!' X,/) GO TO 91 C 1000 IF(BFEAR)RETURN IF(IMODE.GT.-3)GO TO 927 C WRITE(6,88)(TCS(L),L=1,LMAX) 88 FORMAT(/1X,'TOTAL',5X,1P,4(E15.4,13X)/(11X,4(E15.4,13X))) DO L=1,LMAX LS=IREV(L,1) T=IWT(LS) TSUM=TSUM+T*TCS(L)/TWTOT ENDDO IF(TSUM.GT.ZERO.AND.NV0.GT.0)WRITE(6,39)TSUM 39 FORMAT(//1X, 'TOTAL DR CROSS SECTION, AVERAGED OVER TARGET STATES X =',1PE15.4,' MB'//) C CLOSE(MR) !MRU=MR IFILE=IFILE+1 IC1=IFILE/10 IC2=IFILE-10*IC1 IC0=ICHAR('0') IC1=IC1+IC0 IC2=IC2+IC0 C IF(BFORM)THEN FILNAM='o'//CHAR(IC2) IF(IFILE.GE.10)FILNAM='o'//CHAR(IC1)//CHAR(IC2) INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)OPEN(MR,FILE=FILNAM) ELSE FILNAM='o'//CHAR(IC2)//'u' IF(IFILE.GE.10)FILNAM='o'//CHAR(IC1)//CHAR(IC2)//'u' INQUIRE(FILE=FILNAM,EXIST=EX) IF(EX)OPEN(MRU,FILE=FILNAM,FORM='UNFORMATTED') ENDIF C IF(EX)GO TO 331 911 IF(IFILE.EQ.1)GO TO 91 C DO I=1,IB0 IF(IBN(I).GE.NMN)THEN IB00=I GO TO 912 ENDIF ENDDO GO TO 927 C C WRITE WEIGHTED ENERGIES AND RESONANCE STRENGTHS C 912 IF(BPRNT0.AND.JCFA.EQ.0)THEN WRITE(6,1117)((LS,MS,MS=LS+1,MSNMAX),LS=1,LSNMAX) DO I=IB00,IB0 DO LS=1,LSNMAX DO MS=LS+1,MSNMAX IF(SSWTN(I,LS,MS).GT.ZERO) X ESWTN(I,LS,MS)=ESWTN(I,LS,MS)/SSWTN(I,LS,MS) ENDDO ENDDO WRITE(6,1118)IBN(I),((ESWTN(I,LS,MS) X ,SSWTN(I,LS,MS),MS=LS+1,MSNMAX),LS=1,LSNMAX) ENDDO 1117 FORMAT(//4X,'N',4X,'ESWT(N)',4X,'SSWT(N)'/(5(15X,I2,'-',I2,4X))) 1118 FORMAT(I5,5(0PF11.4,1PE13.4)/(5X,5(0PF11.4,1PE13.4))) DO LS=1,LSNMAX DO MS=LS+1,MSNMAX ESWT(LS,MS)=ESWTN(IB00,LS,MS)*SSWTN(IB00,LS,MS) SSWT(LS,MS)=SSWTN(IB00,LS,MS) ENDDO ENDDO DO IB=IB00+1,IB0 IF(IBN(IB).GT.IBN(IB-1)+1)GO TO 197 DO LS=1,LSNMAX DO MS=LS+1,MSNMAX ESWT(LS,MS)=ESWT(LS,MS)+ESWTN(IB,LS,MS)*SSWTN(IB,LS,MS) SSWT(LS,MS)=SSWT(LS,MS)+SSWTN(IB,LS,MS) ENDDO ENDDO ENDDO GO TO 199 197 IB=IB-1 DO I=1,IC IF(NS(I).GE.NMN)THEN IF(NMN.GT.0.AND.NS(I).NE.NMN.AND.I.GT.1) X WRITE(6,*)' **** POSSIBLE INACCURACY:', X ' NMIN SHOULD BE ONE OF THE CALCULATED N' IC0=I+2 GO TO 198 ENDIF ENDDO 198 DO I=IC0,IC,2 IB=IB+2 T1=NS(I-2) T2=NS(I-1) T3=NS(I) V1=T1**3 V2=T2**3 V3=T3**3 N1=NS(I-2) N2=NS(I) TN1=N1*N1 N1=N1+1 DO N=N1,N2 IF(N.GT.NCUT)GO TO 199 TN=N S1=V1*(T2-TN)*(T3-TN)/((T2-T1)*(T3-T1)) S2=V2*(T1-TN)*(T3-TN)/((T1-T2)*(T3-T2)) S3=V3*(T1-TN)*(T2-TN)/((T1-T3)*(T2-T3)) TN2=N*N DO LS=1,LSNMAX DO MS=LS+1,MSNMAX TTS=S1*SSWTN(IB-2,LS,MS)+S2*SSWTN(IB-1,LS,MS) X +S3*SSWTN(IB,LS,MS) TTS=TTS/(TN*TN2) SSWT(LS,MS)=SSWT(LS,MS)+TTS TTE=S1*ESWTN(IB-2,LS,MS)+S2*ESWTN(IB-1,LS,MS) X +S3*ESWTN(IB,LS,MS) TTE=TTE/(TN*TN2) ESWT(LS,MS)=ESWT(LS,MS)+TTE*TTS ENDDO ENDDO ENDDO ENDDO 199 DO LS=1,LSNMAX DO MS=LS+1,MSNMAX IF(SSWT(LS,MS).GT.0.0)ESWT(LS,MS)=ESWT(LS,MS)/SSWT(LS,MS) ENDDO ENDDO WRITE(6,1119)((ESWT(LS,MS),SSWT(LS,MS),MS=LS+1 X ,MSNMAX),LS=1,LSNMAX) 1119 FORMAT(/' SUM',5(0PF11.4,1PE13.4)/(5X,5(0PF11.4,1PE13.4))) WRITE(6,1120) 1120 FORMAT(//'TOTAL') DO LS=1,LSNMAX SSWT(LS,1)=ZERO ESWT(LS,1)=ZERO DO MS=LS+1,MSNMAX SSWT(LS,1)=SSWT(LS,1)+SSWT(LS,MS) ESWT(LS,1)=ESWT(LS,1)+ESWT(LS,MS)*SSWT(LS,MS) ENDDO IF(SSWT(LS,1).GT.0.0)ESWT(LS,1)=ESWT(LS,1)/SSWT(LS,1) WRITE(6,1121)LS,ESWT(LS,1),SSWT(LS,1) 1121 FORMAT(I5,0PF11.4,1PE13.4) ENDDO ENDIF C C END WEIGHTED WRITES C IF(IFLAGE.NE.0)WRITE(6,1006)IFLAGE 1006 FORMAT(//'NOTE: ',I4,' UNIT5 TARGET ENERGIES DID NOT MATCH WITH' X,' THOSE PRESENT IN THE RATE FILE, SEE ABOVE "***" !'/11X X,'ENERGY CORRECTIONS ARE BASED ON THOSE IN THE RATE FILE...') WRITE(6,1004) 1004 FORMAT(/' N',5X,'B(N)',6X,'B(N)*N**3') DO I=IB00,IB0 WRITE(6,1001)IBN(I),(BN(L,I),BN(L,I)*IBN(I)**3,L=1,LMAX) ENDDO 1001 FORMAT(I5,1P,10E12.3/(5X,10E12.3)) C 927 WRITE(6,1005)WIDEX*UNITS,KVX,ECX*UNITS,NVX,LVX,JVX 1005 FORMAT(//' LARGEST RESONANCE WIDTH =',F9.6/ X ' IS AT K, ECONTINUUM =',I5,F11.6/ X ' FOR N, L, LEVEL =', I3,I2,I5) C RETURN C END C*********************************************************************** SUBROUTINE DELTA2(A,B,C,T,J) IMPLICIT REAL*8 (A-H,O-Z) C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE. C LAST CHANGED ON 17 JAN 80. DIMENSION GAM(500),JGAM(500) COMMON /AB10/GAM,JGAM DATA ZERO, EPS, ONEH,I/ 1 0.0E0,1.0E-3,1.501E0,1/ A1=A+B-C+EPS IF(A1)5,1,1 1 A2=A-B+C+EPS IF(A2)5,2,2 2 A3=B-A+C+EPS IF(A3)5,3,3 3 J1=A1 J2=A2 J3=A3 J4=J1+J2+J3+I J5=A1+A2+A3+ONEH IF(J4-J5)5,4,5 4 T=GAM(J1+I)*GAM(J2+I)*GAM(J3+I)/GAM(J4+I) J=JGAM(J1+I)+JGAM(J2+I)+JGAM(J3+I)-JGAM(J4+I) RETURN 5 T=ZERO J=0 RETURN END C*********************************************************************** SUBROUTINE DIPOL(JSW,N1,N2,E2,LMAX,CP,CM,JC) IMPLICIT REAL*8 (A-H,O-Z) C C ALAN BURGESS DAMTP CAMBRIDGE C C CALCULATES SQUARES OF HYDROGENIC DIPOLE LENGTH RADIAL MATRIX ELEMENTS C FOR BOUND-BOUND OR BOUND-FREE TRANSITIONS. C C BOUND STATES ARE NORMALISED TO UNITY. C FREE STATES ARE NORMALISED TO ASYMPTOTIC AMPLITUDE K**(-0.5). C C N.B. DIPOLE ACCELERATION MATRIX ELEMENT = (E12**2/4Z) * DIPOLE LENGTH C WHERE E12 = - N1**(-2) + N2**(-2) FOR BOUND-BOUND C = - N1**(-2) + E2 FOR BOUND-FREE C Z = REDUCED CHARGE C INPUT C FOR BOUND-BOUND,SET JSW=NEGATIVE C N1,N2=PRINCIPAL QUANTUM NUMBERS OF STATES C LMAX=RANGE OF ANGULAR MOMENTUM QUANTUM NUMBERS C FOR BOUND-FREE, SET JSW=POSITIVE C N1=BOUND STATE PRINCIPAL QUANTUM NUMBER C E2=FREE STATE ENERGY IN RYDBERGS (=K**2) C C OUTPUT C VECTOR CP(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR C MOMENTUM TRANSITIONS FROM L-1 TO L, C VECTOR CM(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR C MOMENTUM TRANSITIONS FROM L TO L-1, C IN BOTH CASES THE TRANSITION IS FROM LOWER TO HIGHER C ENERGY, INDEPENDANT OF THE SIGN OF N1-N2 FOR BOUND-BOUND C CASES. IF N1=N2 THEN CP(L)=CM(L). C VECTOR JC(L),L=1,LMAX WILL USUALLY BE ZERO AND MAY THEN BE IGNORED, C BUT FOR EXTREME INPUT VALUES THERE IS POSSIBILITY OF C OVER OR UNDERFLOW OF CP(L) OR CM(L),IN WHICH CASE THE C OUTPUT VALUES OF CP(L) AND CM(L) SHOULD BE MULTIPLIED C BY (1.0D10)**JC(L) TO OBTAIN TRUE VALUES. C FOR DOUBLE-PRECISION OPERATION,CHANGES ARE REQUIRED AT LINES NUMBER C 38 40 41 42 43 44 45 46 47 48 49 50 51 124 126 137 140 156 157 160 DIMENSION CP(LMAX),CM(LMAX),JC(LMAX) ZERO=0.0E0 ONE=1.0E0 PI=3.14159265359E0 S1=1.0E10 S2=1.0E-10 TEST1=1.0E-20 TEST2=1.0E20 TEST3=0.044E0 TEST4=0.1E0 TEST5=300.0E0 TEST6=1.0E-30 TEST7=1.0E30 N=N1 E=E2 IF (JSW.GT.0) GO TO 4 EN2=N2 N3=N2 IF(N2-N1)2,59,3 2 N=N2 EN2=N1 N3=N1 3 E=-ONE/(EN2*EN2) 4 EN=N ENN=EN*EN E1=-ONE/ENN JMAX=LMAX IF(N-LMAX)5,7,8 5 L1=N+1 DO 6 L=L1,LMAX CP(L)=ZERO CM(L)=ZERO JC(L)=0 6 CONTINUE 7 CP(N)=ONE CM(N)=ZERO JC(N)=0 JMAX=N-1 8 C1=ONE C2=ZERO JS=0 L=N+1 9 L=L-1 IF (L.LE.1) GO TO 15 EL=L ELL=EL*EL T1=ONE+ELL*E1 T2=ONE+ELL*E T3=L+L-1 T4=ONE/(T3+ONE) T5=(T3*T1*C2+T2*C1)*T4 C1=(T1*C2+T3*T2*C1)*T4 C2=T5 11 IF (C1*C1.LE.TEST2) GO TO 13 C1=S2*C1 C2=S2*C2 JS=JS+1 GO TO 11 13 IF (L.GT.LMAX+1) GOTO 9 CP(L-1)=C1 CM(L-1)=C2 JC(L-1)=JS GO TO 9 15 CONTINUE JS=0 T=4 T=ONE/(T*EN*ENN) IF (JSW.GT.0) GO TO 23 ENN2=EN2*EN2 T1=4 T1=T1*ENN*ENN2/(ENN2-ENN) T1=T1*T1 T=T*T1*T1/(EN2*ENN2) IF (N3.GT.30) GO TO 18 T=T*((EN2-EN)/(EN2+EN))**(N3+N3) GO TO 34 18 E21=E/E1 IF (E21.GT.TEST4) GO TO 21 T2=ZERO DO 20 J=1,11 T3=2*(11-J)+1 T2=ONE/T3+T2*E21 20 CONTINUE T2=T2+T2 GO TO 22 21 T3=EN/EN2 T2=LOG((ONE+T3)/(ONE-T3))/T3 22 T2=T2+T2 T1=T1*EXP(-T2) GO TO 34 23 T1=4 T1=T1*ENN/(ONE+ENN*E) T1=T1*T1 T=T*T1*T1 IF (E.GE.TEST3) GO TO 25 T3=2 T=T*(PI/T3) GO TO 29 25 CONTINUE T4=SQRT(E) IF (T4.GT.TEST5) GO TO 27 T3=(PI+PI)/T4 T3=ONE-EXP(-T3) T3=ONE/T3 GO TO 28 27 T4=PI/T4 T3=3 T3=(ONE+T4+T4*T4/T3)/(T4+T4) 28 T2=2 T=T*(PI*T3/T2) 29 T4=ENN*E IF (T4.GT.TEST4) GO TO 32 T2=ZERO DO 31 J=1,11 T3=2*(11-J)+1 T2=ONE/T3-T2*T4 31 CONTINUE GO TO 33 32 T3=SQRT(T4) T2=ATAN(T3)/T3 33 T2=T2+T2 T2=T2+T2 T1=T1*EXP(-T2) 34 DO 39 J=1,N TJ=J+J T2=TJ*(TJ-ONE) T2=T2*T2 T=T*T1/T2 35 IF (T.GT.TEST1) GO TO 37 T=T*S1 JS=JS-1 GO TO 35 37 IF (T.LT.TEST2) GO TO 39 T=T*S2 JS=JS+1 GO TO 37 39 CONTINUE J=0 40 J=J+1 IF (J.GT.JMAX) GO TO 50 TJ=J TJ=TJ*TJ T1=ONE+TJ*E1 T2=ONE+TJ*E T3=CP(J) T3=T2*T*T3*T3 T4=CM(J) T4=T1*T*T4*T4 L1=JC(J)+JC(J)+JS 42 IF(L1)43,47,45 43 IF (T4.LE.TEST6) GO TO 47 L1=L1+1 T3=T3*S2 T4=T4*S2 GO TO 42 45 IF (T3.GE.TEST7) GO TO 47 L1=L1-1 T3=T3*S1 T4=T4*S1 GO TO 42 47 CP(J)=T3 CM(J)=T4 JC(J)=L1 T=T*T1*T2 48 IF (T.LE.TEST2) GO TO 40 T=T*S2 JS=JS+1 GO TO 48 50 IF (N.GT.LMAX) GO TO 58 T2=ONE+ENN*E T3=CP(N) T3=T2*T*T3*T3 L1=JC(N)+JC(N)+JS 52 IF(L1)53,57,55 53 IF (T3.LE.TEST6) GO TO 57 L1=L1+1 T3=T3*S2 GO TO 52 55 IF (T3.GE.TEST7) GO TO 57 L1=L1-1 T3=T3*S1 GO TO 52 57 CP(N)=T3 JC(N)=L1 58 RETURN 59 JMAX=LMAX IF (N.GT.LMAX) GO TO 62 DO 61 L=N,LMAX CP(L)=ZERO CM(L)=ZERO JC(L)=0 61 CONTINUE JMAX=N-1 62 T1=9 T2=4 T3=(T1/T2) T1=EN2*EN2 T2=T1*T3 DO 63 J=1,JMAX TJ=J JC(J)=0 T=T2*(T1-TJ*TJ) CP(J)=T CM(J)=T 63 CONTINUE RETURN END C*********************************************************************** REAL*8 FUNCTION DITTNER(EL,EU,E0) IMPLICIT REAL*8 (A-H,O-Z) !DOUBLE c REAL*16 Z1,Z2,zm,zp,T0,T1,T2,T3,TE !QUAD C REAL*8 EL,EU,E0 !FOR QUAD C RYDBERG ATOMIC UNITS DIMENSION E(21),F(21) COMMON /DITT/A00,B00 C C QUAD PRECISION: THE !$PRAGMA IS PART OF THE COMMAND, ACCESSES C-LIB. c external erfl,erfcl !$PRAGMA C(ERFL,ERFCL) C C NMESH=21 NMESH=2 NMESH1=NMESH-1 FNMESH1=NMESH1 E(1)=EL IF(EL.LT.-99.)E(1)=0.0 EH=(EU-E(1))/FNMESH1 DO 10 I=2,NMESH E(I)=E(1)+(I-1)*EH 10 CONTINUE C C COOLER DISTRIBUTION IS CHARACTERIZED BY TWO "TEMPERATURES", THE C SPREAD OF THE BEAM PARALLEL AND PERPENDICULAR TO THE AXIS. C CURRENT (26/04/01) TYPICAL VALUES FOR C A=1.0/SQRT(KTpar(RYD)) B=1.0/SQRT(KTperp(RYD)) C A=368.8 B=116.6 C IF(A00*B00.GT.0.0)THEN A=A00 B=B00 ENDIF A2=A**2 B2=B**2 T0=A2-B2 C1=A*B2/SQRT(T0) T=E0/T0 C2=A2*B2*T Z2=A2*SQRT(T) IS=1 IF(EL.LT.-99.)THEN IS=2 F(1)=0.0 ENDIF DO 20 I=IS,NMESH T2=C2-B2*E(I) C IF(T2.GT.700.)GO TO 20 !SKIPPING GIVES MISLEADING RESULTS... T1=EXP(T2) TE=E(I) Z1=SQRT(TE*T0) ZP=Z1+Z2 IF(ZP.GT.0.5)THEN ZM=Z2-Z1 T2=ERFC(ZM) !SINGLE/DOUBLE T3=ERFC(ZP) !SINGLE/DOUBLE c T2=erfcl(zm) !QUAD c T3=erfcl(zp) !QUAD c write(36,*)e0,i,zm,zp,t1,t2,t3 T1=T1*(T2-T3) F(I)=SQRT(TE)*T1 ELSE ZM=Z1-Z2 T2=ERF(ZM) !SINGLE/DOUBLE T3=ERF(ZP) !SINGLE/DOUBLE c T2=erfl(zm) !QUAD c T3=erfl(zp) !QUAD c write(36,*)e0,-i,zm,zp,t1,t2,t3 T1=T1*(T2+T3) F(I)=SQRT(TE)*T1 ENDIF 20 CONTINUE SUM=EH*(F(1)+F(NMESH))/2.0 IF(NMESH1.GT.1)THEN DO 30 I=2,NMESH1 SUM=SUM+EH*F(I) 30 CONTINUE ENDIF DITTNER=C1*SUM RETURN END C*********************************************************************** SUBROUTINE DRAY(ICA,ITA,IWA,JCA,AA0,EC,EION,ICR,ITR,IWR,JCR,AR0 X,DEL,EATOM,NUMA,NUMR,NCF,NENG,EI2,TOLR,JCORW,NG,DMIN) C C SR.DRAY EVALUATES ARRAY AVERAGED TRANSITION PROBABILITIES C AA, AR AND F AS DEFINED BY MERTS ET AL (1976) EQ B.29, B.30, B.22 C IMPLICIT REAL*8 (A-H,O-Z) LOGICAL LTEST C PARAMETER(NDIM18=5000,NDIM19=500,NDIM20=50,NDIM21=100,NDIM22=200) PARAMETER(NDIM18=1,NDIM19=1,NDIM20=1,NDIM21=1,NDIM22=1) DIMENSION ASUM(NDIM18),JSS(NDIM18),JWS(NDIM18) X,AR(NDIM19,NDIM21),AA(NDIM19,NDIM20),JSR(NDIM19,NDIM21),JSA(NDIM19 X,NDIM20),NG(*),KCF(NDIM21) X,JCF(NDIM22),ICF(NDIM20),JRMAX(NDIM21),JAMAX(NDIM20),JWR(NDIM19,ND XIM21),JWA(NDIM19,NDIM20) DIMENSION ICA(*),ITA(*),IWA(*),JCA(*),AA0(*),EC(*),EION(*) X,ICR(*),ITR(*),IWR(*),JCR(*),AR0(*),DEL(*),EATOM(*) C C CURRENT DIMENSION STATEMENT PLACES FOLLOWING RESTRICTIONS C (CAN BE INCREASED AS DESIRED) :- C MAX TOTAL NUMBER OF DOUBLY EXCITED LEVELS/TERMS = NDIM18 C MAX NUMBER LEVELS/TERMS IN DOUBLY-EXCITED CONFIGURATIONS = NDIM19 C PER INITIAL OR FINAL CONFIGURATION C MAX NUMBER INITIAL (CONTINUUM) CONFIGURATIONS = NDIM20 PER DOUBLY EXCITED C CONFIGURATION C MAX NUMBER OF FINAL (SINGLY EXCITED) CONFIGURATIONS = NDIM21 PER DOUBLY C EXCITED CONFIGURATION C NO LIMIT TO NUMBER OF (DOUBLY-EXCITED) INTERMEDIATE CONFIGURATIONS; C HOWEVER .GT. NDIM22 REQUIRES INCREASE IN JCF, AND MAY REQUIRE INCREASE C IN NDIM14 OF NG(I) IN CROSSX. C REWIND(24) READ(24)JCC,JSS(1),JWS(1),MC,IDUM,ASUM(1),DD,EE C TOLA=EI2-DMIN JMAX=0 IF(JSS(1).EQ.0)GO TO 11 J=1 C 5 READ(24)JCC,JS,JW,MC,IDUM,A,DD,EE C IF(JS-JSS(J))2,3,4 3 ASUM(J)=ASUM(J)+A GO TO 5 C?? IF(J.EQ.JMAX)GO TO 11 4 J=J+1 JSS(J)=JS JWS(J)=JW ASUM(J)=A GO TO 5 2 JMAX=J 11 KMAX=0 IMAX=0 FSS=0.0 C REWIND(25) DO 40 N=1,NENG DO 41 I=1,NUMR IF(ITR(I).EQ.N)WRITE(25)ICR(I),ITR(I),IWR(I),JCR(I),AR0(I) X ,DEL(I),EATOM(I) 41 CONTINUE 40 CONTINUE DO 42 N=1,NENG DO 43 I=1,NUMA IF(ITA(I).EQ.N)WRITE(25)ICA(I),ITA(I),IWA(I),JCA(I),AA0(I) X ,EC(I),EION(I) 43 CONTINUE 42 CONTINUE C REWIND(25) DO 44 I=1,NUMR READ(25)ICR(I),ITR(I),IWR(I),JCR(I),AR0(I),DEL(I),EATOM(I) 44 CONTINUE DO 45 I=1,NUMA READ(25)ICA(I),ITA(I),IWA(I),JCA(I),AA0(I),EC(I),EION(I) 45 CONTINUE REWIND(25) C IDUM=0 ZERO=0.0 REWIND(26) DO 50 N=1,NCF DO 51 I=1,NUMR IF(ICR(I).EQ.N)WRITE(26)ICR(I),ITR(I),IWR(I),JCR(I),AR0(I) X ,DEL(I),EATOM(I) 51 CONTINUE WRITE(26)IDUM,IDUM,IDUM,IDUM,ZERO,ZERO,ZERO DO 52 I=1,NUMA IF(ICA(I).EQ.N)WRITE(26)ICA(I),ITA(I),IWA(I),JCA(I),AA0(I) X ,EC(I),EION(I) 52 CONTINUE WRITE(26)IDUM,IDUM,IDUM,IDUM,ZERO,ZERO,ZERO 50 CONTINUE REWIND(26) C DO 53 N=1,NCF DO 54 I=1,NUMR READ(26)ICA(I),ITA(I),IWA(I),JCA(I),AA0(I),EC(I),EION(I) IF(ICA(I).EQ.0)GO TO 55 54 CONTINUE 55 IM=I-1 IF(IM.EQ.0)GO TO 62 DO 56 M=1,NCF DO 57 I=1,IM IF(JCA(I).EQ.M)WRITE(25)ICA(I),ITA(I),IWA(I),JCA(I) X ,AA0(I),EC(I),EION(I) 57 CONTINUE 56 CONTINUE 62 DO 58 I=1,NUMA READ(26)ICA(I),ITA(I),IWA(I),JCA(I),AA0(I),EC(I),EION(I) IF(ICA(I).EQ.0)GO TO 59 58 CONTINUE 59 IM=I-1 IF(IM.EQ.0)GO TO 53 DO 60 M=1,NCF DO 61 I=1,IM IF(JCA(I).EQ.-M)WRITE(25)ICA(I),ITA(I),IWA(I),JCA(I) X ,AA0(I),EC(I),EION(I) 61 CONTINUE 60 CONTINUE 53 CONTINUE WRITE(25)IDUM,IDUM,IDUM,IDUM,ZERO,ZERO,ZERO REWIND(25) C 1 READ(25)JC,JS,JW,KC,A,DD,EE C IF(JC.EQ.0)RETURN TOL=TOLA IF(KC.GT.0)TOL=TOLR IF((EE-DMIN).GT.TOL)GO TO 1 JJ=1 JCF(1)=JC IF(KC.LT.0)GO TO 22 20 J=1 KK=1 JSR(1,1)=JS JWR(1,1)=JW KCF(1)=KC AR(1,1)=A C 13 READ(25)JC,JS,JW,KC,A,DD,EE C IF(JC.EQ.0)GO TO 9 TOL=TOLA IF(KC.GT.0)TOL=TOLR IF((EE-DMIN).GT.TOL)GO TO 13 IF(JC.NE.JCF(JJ))GO TO 9 IF(KCF(KK)-KC)7,8,9 7 JRMAX(KK)=J KK=KK+1 KCF(KK)=KC J=1 JSR(1,KK)=JS JWR(1,KK)=JW AR(1,KK)=A GO TO 13 8 IF(JS.GT.JSR(J,KK))GO TO 12 AR(J,KK)=AR(J,KK)+A GO TO 13 12 J=J+1 JSR(J,KK)=JS JWR(J,KK)=JW AR(J,KK)=A GO TO 13 9 KMAX=KK JRMAX(KK)=J C WRITE(6,150) C DO 30 K=1,KMAX AV=0.0D0 JM=JRMAX(K) DO 31 J=1,JM T=JWR(J,K) AV=T*AR(J,K)+AV 31 CONTINUE T=NG(JCF(JJ)) AV=AV/T C WRITE(6,151)JCF(JJ),KCF(K),AV C 30 CONTINUE IC=KC IF(JC-JCF(JJ))15,22,6 22 ICF(1)=KC II=1 J=1 JSA(1,1)=JS AA(1,1)=A JWA(1,1)=JW C 10 READ(25)JC,JS,JW,IC,A,DD,EE C IF(JC.EQ.0)GO TO 17 TOL=TOLA IF(IC.GT.0)TOL=TOLR IF((EE-DMIN).GT.TOL)GO TO 10 IF(JC.NE.JCF(JJ)) GO TO 17 16 IF(ICF(II).EQ.IC)GO TO 19 JAMAX(II)=J II=II+1 ICF(II)=IC J=1 JSA(1,II)=JS JWA(1,II)=JW AA(1,II)=A GO TO 10 19 IF(JS.GT.JSA(J,II))GO TO 21 AA(J,II)=AA(J,II)+A GO TO 10 21 J=J+1 JSA(J,II)=JS JWA(J,II)=JW AA(J,II)=A GO TO 10 17 IMAX=II JAMAX(II)=J C WRITE(6,152) C DO 32 I=1,IMAX AV=0.0D0 JM=JAMAX(I) DO 33 J=1,JM T=JWA(J,I) AV=T*AA(J,I)+AV 33 CONTINUE T=NG(JCF(JJ)) AV=AV/T C WRITE(6,151)JCF(JJ),ICF(I),AV C 32 CONTINUE IF(KMAX*JMAX.EQ.0)GO TO 23 FS=0.0 C WRITE(6,156) C DO 24 I=1,IMAX JX=JAMAX(I) DO 25 K=1,KMAX JK=1 L=(JSA(1,I)*JMAX)/JSS(JMAX) IF(L.GT.JMAX)L=JMAX IF(L.LT.1)L=1 F=0.0 LTEST=.FALSE. DO 26 J=1,JX 27 IF(JSA(J,I)-JSR(JK,K))38,28,29 29 JK=JK+1 IF(JK.GT.JRMAX(K))GO TO 37 GO TO 27 28 IF(JSA(J,I)-JSS(L))36,35,34 36 L=L-1 GO TO 28 34 L=L+1 GO TO 28 35 TJ=JWS(L) LTEST=.TRUE. F=F+TJ*AA(J,I)*AR(JK,K)/ASUM(L) JK=JK+1 IF(JK.GT.JRMAX(K))GO TO 37 38 IF(L.LT.JMAX)L=L+1 26 CONTINUE 37 IF(.NOT.LTEST)GO TO 25 TI=JCORW F=F/TI C WRITE(6,157)ICF(I),JCF(JJ),KCF(K),F C FS=FS+F 25 CONTINUE 24 CONTINUE C WRITE(6,154)JCF(JJ),FS C FSS=FSS+FS 23 IF(JC.LT.JCF(JJ))GO TO 15 6 JJ=JJ+1 KMAX=0 JCF(JJ)=JC KC=IC IF(KC.GT.0)GO TO 20 GO TO 22 C 15 WRITE(6,155)FSS C RETURN 150 FORMAT(/2X,'JCF',2X,'KCF',6X,'ARBAR*SEC') 151 FORMAT(2I5,1PE15.5) 152 FORMAT(/2X,'JCF',2X,'ICF',6X,'AABAR*SEC') 154 FORMAT(/1X,'JCF=',I5,5X,'FBAR(JCF)=',1PE15.5/) 155 FORMAT(/1X,'FBAR=',1PE15.5) 156 FORMAT(/2X,'ICF',2X,'JCF',2X,'KCF',2X,'FBAR(ICF,JCF,KCF)') 157 FORMAT(3I5,1PE15.5) C164 FORMAT(4I5,10X,1PE15.5,2(0PF15.6)) END C*********************************************************************** REAL*8 FUNCTION ERF(X) IMPLICIT REAL*8 (A-H,O-Z) C C FOR GREATER ACCURACY COULD USE THE INTRINSIC FUNCTION ERF(X). C HOWEVER, THIS MAybe SYSTEM DEPENDENT. C C ERROR FUNCTION ON PAGE 299 OF ABRAMOWITZ AND STEGUN C Y=ABS(X) A1=+0.254829592 A2=-0.284496736 A3=+1.421413741 A4=-1.453152027 A5=+1.061405429 P=0.3275911 T=1.0/(1.0+P*Y) SUM=1.0-(A1*T+A2*T**2+A3*T**3+A4*T**4+A5*T**5)*EXP(-Y**2) IF(X.GE.0.0) THEN ERF=SUM ELSE ERF=-SUM END IF RETURN END C*********************************************************************** REAL*8 FUNCTION ERFC(X) IMPLICIT REAL*8 (A-H,O-Z) C C FOR GREATER ACCURACY COULD USE THE INTRINSIC FUNCTION ERFC(X). C HOWEVER, THIS MAYBE SYSTEM DEPENDENT. C C ERROR FUNCTION ON PAGE 299 OF ABRAMOWITZ AND STEGUN C Y=ABS(X) A1=+0.254829592 A2=-0.284496736 A3=+1.421413741 A4=-1.453152027 A5=+1.061405429 P=0.3275911 T=1.0/(1.0+P*Y) SUM=(A1*T+A2*T**2+A3*T**3+A4*T**4+A5*T**5)*EXP(-Y**2) IF(X.GE.0.0) THEN ERFC=SUM ELSE ERFC=2.0-SUM END IF RETURN END C*********************************************************************** SUBROUTINE FEARM(MTEST,EI,IWT,NBINM,NBINRM,NVI,LVI,NLEV,NUMA,NUMR X,ICA,ITA,IWA,JCA,JTA,AA,EC,EION,IK,IT,SS,LL,JJ,LCF,ENERG,EIONMN X,ICR,ITR,IWR,JCR,JTR,AR,DELR,EATOM,SBIN,EBIN,NBIN1,IMODE,IPRINT) C C******************************************************************* C C THIS ROUTINE CALCULATES COMPLETE PHOTORECOMBINATION CROSS SECTION C I.E. DIELECTRONIC AND RADIATIVE RECOMBINATION PLUS INTERFERENCE. C EACH AUTOIONIZING STATE IS TREATED AS AN ISOLATED RESONANCE. C******* MULTIPLE ELECTRON AND PHOTON CONTINUA ALLOWED ************** C DR AND INTERFERENCE TERMS EVALUATED HERE, REQUIRES AUTOSTRUCTURE C PHOTOIONIZATION DATA ON UNIT42 FOR ALL FINAL RECOMBINATIONS. C THE BACKGROUND RR CONTRIBUTION IS CALCULATED BY SR.BRR USING C PHOTOIONIZATION DATA ON UNIT9, WHICH CAN BE DIFFERENT FROM THAT ON C UNIT42. *** ONLY THE FIRST opn FILE IS READ/USED ***. C NOTE: ASSUMES PSI=1.0=PSIP C C******************************************************************* C IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BFEAR,BLOR,BBACK,BMITCH,BFORM,EX INTEGER SS PARAMETER(NDIM1=10001,NDIM2=36,NDIM33=501,NDIM34=5000 X,NDIM35=400,NDIM36=501,NDIM44=501,NDIM3=100001,NDIM8=100) C DIMENSION EI(*),IWT(*),ICA(*),ITA(*),IWA(*),JCA(*),JTA(*),AA(*) X,EC(*),EION(*),IK(*),IT(*),SS(*),LL(*),JJ(*),LCF(*),ENERG(*) X,ICR(*),ITR(*),IWR(*),JCR(*),JTR(*),AR(*),DELR(*),EATOM(*),EBIN(*) X,SBIN(NDIM2,NDIM1) C DIMENSION IA(NDIM35),PCS(NDIM34,NDIM33),PENERG(NDIM33),IR(NDIM35) X,ICP(NDIM34),ITP(NDIM34),IWP(NDIM34),JCP(NDIM34),JTP(NDIM34) X,JWP(NDIM34),IP(NDIM36,NDIM36),EI0(NDIM34),ECP(NDIM34) C COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG0(NDIM44),PCS0(NDIM44),SPY(NDIM2,NDIM44,5),NXNG( XNDIM2),NENG0 COMMON /ECOR/ E1C(NDIM8),E1X(NDIM8),ECORT,TOLB COMMON /JCF/JCFA,JCFR,JCFJ,JCFY,JCFE,JPAR,LSPI,J2PI,BLOR,BFEAR X,MAX2J COMMON /PHOTON/EBDMIN,EBDMAX,EPHMIN,EPHMAX C SAVE BFORM DATA MR/0/ C C DATA MBLNK/' '/ C C TEST FOR INTERMEDIATE COUPLING DATA (IF REQUIRED) C IF(MTEST.EQ.MBLNK)GO TO 2000 C IF(NUMA*NUMR.EQ.0)GO TO 2000 ! NEED BOTH RATES IF(.NOT.BFEAR)GO TO 2000 C C EMPTY FILE, RETURN AND CARRY-OUT USUAL DR, OTHERWISE C READ HEADER AND CHECK COMPATIBLE WITH AUTOIONIZATION & RADIATIVE DATA C IF(MR.EQ.0)THEN MR=42 INQUIRE(FILE='op1',EXIST=EX) IF(EX)THEN BFORM=.TRUE. OPEN(MR,FILE='op1') ELSE INQUIRE(FILE='op1u',EXIST=EX) IF(EX)THEN BFORM=.FALSE. OPEN(MR,FILE='op1u',FORM='UNFORMATTED') ELSE GOTO 2000 ENDIF ENDIF ENDIF C IF(BFORM)READ(MR,105,END=2000)NV,LV IF(.NOT.BFORM)READ(MR,END=2000)NV,LV C IF(NV.NE.NVI)GO TO 2000 IF(LV.NE.LVI)GO TO 2000 C IF(.NOT.BLOR)THEN WRITE(6,*)'SR.FEARM: ENERGY-AVERAGED CROSS SECTIONS NOT AVAILABLE' GO TO 2000 ENDIF C C USE MITCH'S APPROX FORM? C BMITCH=.FALSE. C DO 30 I=1,NDIM36 DO 31 J=I,NDIM36 IP(I,J)=0 IP(J,I)=0 31 CONTINUE 30 CONTINUE C C READ TABULATED ENERGIES FOR PHOTOIONIZATION DATA C IF(BFORM)READ(MR,101) NENG,NZ0,NE IF(.NOT.BFORM)READ(MR) NENG,NZ0,NE C IF(NENG.EQ.0)GO TO 2000 IF(NENG.GT.NDIM33)STOP 'NCREASE NDIM33' C IF(BFORM)THEN READ(MR,102)(PENERG(I),I=1,NENG) READ(MR,103) READ(MR,103) ELSE READ(MR)(PENERG(I),I=1,NENG) READ(MR) READ(MR) ENDIF C C STORE INDEXING AND PHOTOIONIZATION CROSS SECTIONS C J=0 2 J=J+1 IF(BFORM)READ(MR,104)ICP(J),ITP(J),IWP(J),JCP(J),JTP(J),L X ,PCS(J,1),EI0(J),ECP(J) IF(.NOT.BFORM)READ(MR,104)ICP(J),ITP(J),IWP(J),JCP(J),JTP(J),L X ,PCS(J,1),EI0(J),ECP(J) C IF(ITP(J).EQ.0)GO TO 3 IF(NENG.GT.1)THEN IF(BFORM)READ(MR,102)(PCS(J,I),I=1,NENG) IF(.NOT.BFORM)READ(MR,102)(PCS(J,I),I=1,NENG) ENDIF C C CONVERT PHOTOIONIZATION TO E*RR C NEED TO USE EI(I) OF TARGET IF WANT IC AVERAGED-OVER C TARGET FINE-STRUCTURE SINCE ENERGY ORDER LABEL L IS BY C LEVEL IN IC. C L=0 C CTEMP DF IF(IMODE.EQ.-4.AND.L.EQ.0)L=1 CTEMP DF C J=J-1 IF(PCS(J+1,1).EQ.0.0)GO TO 2 IF(EIONMN-EI0(J+1).LT.EBDMIN.OR.EIONMN-EI0(J+1).GT.EBDMAX)GOTO 2 C T=ECP(J+1)-EI0(J+1)+PENERG(ITEST) C IF(T.LT.EPHMIN.OR.T.GT.EPHMAX)GO TO 2 IF(L.EQ.0)THEN DO 4 L=1,NBINRM IF(ECP(J+1).GE.EI(L).AND.ECP(J+1).LT.EI(L+1))GO TO 5 4 CONTINUE GO TO 2 ENDIF C REQUIRE PHOTOIONIZATION INTO INITIAL CONTINUA ONLY IF(L.GT.NBINRM)GO TO 2 5 J=J+1 IF(IMODE.EQ.-4)THEN JTP(J)=ITP(J) ITP(J)=ICP(J) ICP(J)=0 ENDIF IF(JTP(J).GT.NDIM36.OR.ITP(J).GT.NDIM36)THEN WRITE(6,*)'INCREASE NDIM36 TO: ',JTP(J),' OR ',ITP(J) STOP 32 ENDIF IP(JTP(J),ITP(J))=J JWP(J)=IWT(L) TW=IWT(L) T=IWP(J) TW=T/TW TW=1.33128E13*TW TT=ECP(J)-EI0(J) DO 1 I=1,NENG T=TT IF(TT.GT.0.0)T=TT+PENERG(I) ! ELSE TT IS -PHOTON ENERGY ALREADY T=T*T PCS(J,I)=T*TW*PCS(J,I) 1 CONTINUE IF(J.GE.NDIM34)STOP 67 GO TO 2 3 NUMP=J-1 IF(NUMP.EQ.0)GO TO 2000 CTEMP, TAKE CONSTANT PHOTOIONIZATION ENERGY IEP=NENG/2+1 C WRITE(6,200) C C SUM OVER ALL AUTOIONIZING LEVELS (ISOLATED RESONANCE) C DO 10 I=1,NUMA T=EC(I)-ECORT IF(T.LT.EBIN(1).OR.T.GT.EBIN(NBIN1+1))GO TO 10 ! SELECT WITH E-RANGE DO 15 L=1,NBINM IF(EION(I).GE.EI(L).AND.EION(I).LT.EI(L+1))GO TO 16 15 CONTINUE GO TO 10 16 TW=IWT(L) T=IWA(I) COEF=175.947*T/TW ! 2*pi*a0**2*wj/wi C C EVALUATE AUTOIONIZING WIDTH C K=0 GA=0.0 DO 11 J=1,NUMA IF(ITA(I).NE.ITA(J))GO TO 11 K=K+1 IA(K)=J GA=GA+ABS(AA(J)) 11 CONTINUE KMAX=K IF(KMAX.GT.NDIM35)STOP 'INCREASE NDIM35' C C FIND ALL POSSIBLE RADIATIVE TRANSITIONS FROM GIVEN AUTOIONIZING LEVEL C AND EVALUATE RADIATIVE WIDTH C M=0 GR=0.0 DO 17 J=1,NUMR IF(ITR(J).NE.ITA(I))GO TO 17 GR=GR+ABS(AR(J)) IF(EATOM(J).GT.EIONMN)GO TO 17 ! DROP RADIATION TO AUTOIONIZING STATES M=M+1 IR(M)=J 17 CONTINUE MMAX=M IF(MMAX.EQ.0)GO TO 10 IF(MMAX.GT.NDIM35)STOP 65 C C UNPERTURBED WIDTH C ETA=1.0+GR/GA DEL=0.0 C C PERTURBED C DO 33 M=1,MMAX T1=0.0 T2=0.0 T3=0.0 N2=JTR(IR(M)) DO 34 K=1,KMAX N1=JTA(IA(K)) NP=IP(N1,N2) IF(NP.EQ.0)GO TO 34 RRP=PCS(NP,IEP) TW=JWP(NP) T=IWA(IA(K)) TW=TW/T T=5.683523E-3*TW*RRP TT=AR(IR(M))/(AA(IA(K))*T) QFP=SQRT(ABS(TT)) IF(TT.LT.0.0)QFP=-QFP T1=T1+1.0/QFP T2=T2+1.0/(ABS(AA(IA(K)))*QFP**2) T3=T3+QFP**(-2) 34 CONTINUE IF(.NOT.BMITCH)THEN DEL=DEL+T1*ABS(AR(IR(M))) ETA=ETA+ABS(AR(IR(M)))*(T2-T1*T1/GA) ETA=ETA+ABS(AR(IR(M)))*T3*GR/GA**2 ENDIF 33 CONTINUE DEL=-2.0*DEL/GA T1=0.0 DO 38 K=1,KMAX N1=JTA(IA(K)) DO 39 M=1,MMAX N2=JTR(IR(M)) NP=IP(N1,N2) IF(NP.EQ.0)GO TO 39 RRP=PCS(NP,IEP) TW=JWP(NP) T=IWA(IA(K)) TW=TW/T T=5.683523E-3*TW*RRP TT=AR(IR(M))/(AA(IA(K))*T) QFP=SQRT(ABS(TT)) IF(TT.LT.0.0)QFP=-QFP T1=T1+ABS(AR(IR(M)))/QFP 39 CONTINUE IF(.NOT.BMITCH)ETA=ETA-(T1/GA)**2 38 CONTINUE C C SUM OVER ALL POSSIBLE FINAL RADIATIVE CONTINUA C DO 21 J=1,MMAX C IF(EIONMN-EATOM(IR(J)).LT.EBDMIN.OR.EIONMN-EATOM(IR(J)).GT.EBDMAX) XGO TO 21 IF(DELR(IR(J)).LT.EPHMIN.OR.DELR(IR(J)).GT.EPHMAX) XGO TO 21 C C DETERMINE RELEVANT PHOTOIONIZATION CROSS SECTION C N1=JTA(I) N2=JTR(IR(J)) N=IP(N1,N2) C IF(N.GT.0)THEN C C EVALUATE FANO Q PARAMETER C RR=PCS(N,IEP) TT=COEF*AR(IR(J))/(AA(I)*RR) QF=SQRT(ABS(TT)) IF(TT.LT.0.0)QF=-QF C IF(IPRINT.GT.0)WRITE(6,201)JTA(I),ITA(I),JTR(IR(J)),QF*QF C IF(IMODE.EQ.-16)QF=1.0E30 C ELSE QF=1.0D30 ! NO INTERFERENCE FOR THIS TRANSITION ENDIF C QI=0.0 DO 35 K=1,KMAX N1=JTA(IA(K)) NP=IP(N1,N2) IF(NP.EQ.0)GO TO 35 RRP=PCS(NP,IEP) TW=JWP(NP) T=IWA(IA(K)) TW=TW/T T=5.683523E-3*TW*RRP TT=AR(IR(J))/(AA(IA(K))*T) QFP=SQRT(ABS(TT)) IF(TT.LT.0.0)QFP=-QFP QI=QI+1.0/QFP 35 CONTINUE IF(BMITCH)QI=1.0/QF TA=1.0/QF-QI*ABS(AA(I))/GA C QI=0.0 N1=JTA(I) DO 36 M=1,MMAX N2=JTR(IR(M)) NP=IP(N1,N2) IF(NP.EQ.0)GO TO 36 RRP=PCS(NP,IEP) TT=COEF*AR(IR(M))/(AA(I)*RRP) QFP=SQRT(ABS(TT)) IF(TT.LE.0.0)QFP=-QFP QI=QI+(1.0/QF-1.0/QFP)*ABS(AR(IR(M))) 36 CONTINUE IF(BMITCH)QI=GR/QF TR=QI/GA C T0=4.13413E16/GA T1=ABS(AA(I))/GA T2=TA+TR DO 37 IE=1,NBIN1 XI=T0*(EBIN(IE+1)-EC(I)+ECORT) T=(XI/QF+T1)**2 + T2**2 T=T/((XI-DEL)**2 + ETA**2) C SUBTRACT OF RR BACKGROUND TO AVOID DOUBLE COUNTING T=T-1.0/QF**2 C T=COEF*T*ABS(AR(IR(J)))/(ABS(AA(I))*EBIN(IE+1)) SBIN(NBINM+L,IE)=SBIN(NBINM+L,IE)+T ! 37 CONTINUE C 21 CONTINUE C 10 CONTINUE C RETURN C C NO (SUITABLE) PHOTOIONIZATION DATA SO RETURN AND EVALUATE C USUAL ENERGY-AVERAGE CROSS SECTION C 2000 BFEAR=.FALSE. IF(NUMA.GT.0)THEN DO 90 I=1,NUMA AA(I)=ABS(AA(I)) 90 CONTINUE ENDIF IF(NUMR.GT.0)THEN DO 91 I=1,NUMR AR(I)=ABS(AR(I)) 91 CONTINUE ENDIF RETURN C 101 FORMAT(I3,12X,I2,6X,I2) 102 FORMAT(5E15.5) 103 FORMAT(A1) 104 FORMAT(6I5,E15.5,2F15.6) 105 FORMAT(5X,I5,5X,I5) 200 FORMAT(/' ************** PHOTORECOMBINATION CROSS SECTIONS ******' X,'********'//4X,'I',4X,'J',4X,'K',8X,'Q**2') 201 FORMAT(3I5,1PE15.5) C END C*********************************************************************** SUBROUTINE FEARS(MTEST,EI,IWT,NBINM,NVI,LVI,NLEV,NUMA,NUMR X,ICA,ITA,IWA,JCA,JTA,AA,EC,EION,IK,IT,SS,LL,JJ,LCF,ENERG,EIONMN X,ICR,ITR,IWR,JCR,JTR,AR,DEL,EATOM,SBIN,EBIN,NBIN1,IMODE,IPRINT) C******************************************************************* C C THIS ROUTINE CALCULATES COMPLETE PHOTORECOMBINATION CROSS SECTION C I.E. DIELECTRONIC AND RADIATIVE RECOMBINATION PLUS INTERFERENCE. C EACH AUTOIONIZING STATE TREATED AS AN ISOLATED RESONANCE. C RESTRICTED TO SINGLE ELECTRON CONTINUUM (NO SPIN OR PARTIAL WAVE SUM) C WITH MULTI PHOTON CONTINUA .OR. MULTI ELECTRON CONTINUA (SPIN AND C PARTIAL WAVE DEGENERACIES BUT NO EXCITED STATES) AND SINGLE PHOTON C CONTINUA. C DR AND INTERFERENCE TERMS EVALUATED HERE, REQUIRES AUTOSTRUCTURE C PHOTOIONIZATION DATA ON UNIT42 FOR ALL FINAL RECOMBINATIONS. C THE BACKGROUND RR CONTRIBUTION IS CALCULATED BY SR.BRR USING C PHOTOIONIZATION DATA ON UNIT9, WHICH CAN BE DIFFERENT FROM THAT ON C UNIT42. *** ONLY THE FIRST opn FILE IS READ/USED ***. C NOTE: SR.BRR ASSUMES PSI=1.0 FOR BACKGROUND RR . C C******************************************************************* IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BFEAR,BLOR,BFORM,EX INTEGER SS PARAMETER(NDIM1=10001,NDIM2=36,NDIM33=501,NDIM34=500,NDIM35=9 X,NDIM36=101,NDIM44=501) DIMENSION EI(*),IWT(*),ICA(*),ITA(*),IWA(*),JCA(*),JTA(*),AA(*) X,EC(*),EION(*),IK(*),IT(*),SS(*),LL(*),JJ(*),LCF(*),ENERG(*) X,ICR(*),ITR(*),IWR(*),JCR(*),JTR(*),AR(*),DEL(*),EATOM(*),EBIN(*) X,SBIN(NDIM2,NDIM1) DIMENSION IA(NDIM35),PCS(NDIM34,NDIM33),PENERG(NDIM33) X,ICP(NDIM34),ITP(NDIM34),IWP(NDIM34),JCP(NDIM34),JTP(NDIM34) X,IL(NDIM35),IQ(NDIM36),QF(NDIM36),EI0(NDIM34),ECP(NDIM34) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG0(NDIM44),PCS0(NDIM44),SPY(NDIM2,NDIM44,5),NXNG( XNDIM2),NENG0 COMMON /JCF/JCFA,JCFR,JCFJ,JCFY,JCFE,JPAR,LSPI,J2PI,BLOR,BFEAR X,MAX2J COMMON /PHOTON/EBDMIN,EBDMAX,EPHMIN,EPHMAX C COMMON /BLANK/MBLNK SAVE BFORM DATA MR/0/ C C TEST FOR INTERMEDIATE COUPLING DATA (IF REQUIRED) C IF(MTEST.EQ.MBLNK)GO TO 2000 C NEED BOTH RATES! IF(NUMA*NUMR.EQ.0)GO TO 2000 IF(.NOT.BFEAR)GO TO 2000 C C EMPTY FILE, RETURN AND CARRY-OUT USUAL DR, OTHERWISE C READ HEADER AND CHECK COMPATIBLE WITH AUTOIONIZATION & RADIATIVE DATA C IF(MR.EQ.0)THEN MR=42 INQUIRE(FILE='op1',EXIST=EX) IF(EX)THEN BFORM=.TRUE. OPEN(MR,FILE='op1') ELSE INQUIRE(FILE='op1u',EXIST=EX) IF(EX)THEN BFORM=.FALSE. OPEN(MR,FILE='op1u',FORM='UNFORMATTED') ELSE GOTO 2000 ENDIF ENDIF ENDIF C IF(BFORM)READ(MR,105,END=2000)NV,LV IF(.NOT.BFORM)READ(MR,END=2000)NV,LV C IF(NV.NE.NVI)GO TO 2000 IF(LV.NE.LVI)GO TO 2000 C C READ TABULATED ENERGIES FOR PHOTOIONIZATION DATA C IF(BFORM)READ(MR,101) NENG,NZ0,NE IF(.NOT.BFORM)READ(MR) NENG,NZ0,NE C IF(NENG.EQ.0)GO TO 2000 IF(NENG.GT.NDIM33)STOP 'NCREASE NDIM33' C IF(BFORM)THEN READ(MR,102)(PENERG(I),I=1,NENG) READ(MR,103) READ(MR,103) ELSE READ(MR)(PENERG(I),I=1,NENG) READ(MR) READ(MR) ENDIF C C STORE INDEXING AND PHOTOIONIZATION CROSS SECTIONS C J=1 2 IF(BFORM)READ(MR,104)ICP(J),ITP(J),IWP(J),JCP(J),JTP(J),L X ,PCS(J,1),EI0(J),ECP(J) IF(.NOT.BFORM)READ(MR,104)ICP(J),ITP(J),IWP(J),JCP(J),JTP(J),L X ,PCS(J,1),EI0(J),ECP(J) C IF(ITP(J).EQ.0)GO TO 3 IF(NENG.GT.1)THEN IF(BFORM)READ(MR,102)(PCS(J,I),I=1,NENG) IF(.NOT.BFORM)READ(MR,102)(PCS(J,I),I=1,NENG) ENDIF C C CONVERT PHOTOIONIZATION TO E*RR C NEED TO USE EI(I) OF TARGET IF WANT IC AVERAGED-OVER C TARGET FINE-STRUCTURE SINCE ENERGY ORDER LABEL L IS BY C LEVEL IN IC. C L=0 C IF(L.EQ.0)THEN DO 4 L=1,NBINM IF(ECP(J).GE.EI(L).AND.ECP(J).LT.EI(L+1))GO TO 5 4 CONTINUE GO TO 2 ENDIF C REQUIRE PHOTOIONIZATION INTO GROUND CONTINUUM ONLY 5 IF(L.NE.1)GO TO 2 IF(EIONMN-EI0(J).LT.EBDMIN.OR.EIONMN-EI0(J).GT.EBDMAX)GO TO 2 C T=ECP(J)-EI0(J)+PENERG(ITEST) C IF(T.LT.EPHMIN.OR.T.GT.EPHMAX)GO TO 2 TW=IWT(L) T=IWP(J) TW=T/TW TW=1.33128E13*TW TT=ECP(J)-EI0(J) DO 1 I=1,NENG T=TT IF(TT.GT.0.0)T=TT+PENERG(I) ! ELSE TT IS -PHOTON ENERGY ALREADY T=T*T PCS(J,I)=T*TW*PCS(J,I) 1 CONTINUE J=J+1 IF(J.GT.NDIM34)STOP 68 GO TO 2 3 NUMP=J-1 IF(NUMP.EQ.0)GO TO 2000 CTEMP, TAKE CONSTANT PHOTOIONIZATION ENERGY IEP=NENG/2+1 C WRITE(6,200) C C SUM OVER ALL AUTOIONIZING LEVELS (ISOLATED RESONANCE) C DO 10 I=1,NUMA DO 15 L=1,NBINM IF(EION(I).GE.EI(L).AND.EION(I).LT.EI(L+1))GO TO 16 15 CONTINUE GO TO 10 C DROP THIS AUTOIONIZING LEVEL IF IT CAN GO TO ALTERNATE CONTINUUM 16 IF(L.NE.1)GO TO 10 IF(ITA(I).LT.0)GO TO 12 C C SUM OVER SPIN AND PARTIAL WAVE DEGENERACIES C K=0 DO 11 J=I,NUMA IF(ITA(I).NE.ITA(J))GO TO 11 DO 13 L=1,NBINM IF(EION(J).GE.EI(L).AND.EION(J).LT.EI(L+1))GO TO 14 13 CONTINUE GO TO 10 C DROP THIS AUTOIONIZING LEVEL IF IT CAN GO TO ALTERNATE CONTINUUM 14 IF(L.NE.1)GO TO 10 C AVOID DOUBLE COUNTING, TAG THIS LEVEL AS DONE IF(J.GT.I)ITA(J)=-ITA(J) K=K+1 IA(K)=J 11 CONTINUE KMAX=K IF(KMAX.GT.NDIM35)STOP 69 DO 23 K=1,KMAX IL(K)=0 23 CONTINUE C C FIND ALL POSSIBLE RADITIVE TRANSITIONS FROM GIVEN AUTOIONIZING LEVEL C L=0 M=0 DO 17 J=1,NUMR IF(ITR(J).NE.ITA(I))GO TO 17 C IGNORE RADIATION TO AUTOIONIZING STATES IF(EATOM(J).GT.EIONMN)GO TO 17 IP=0 M=M+1 C FIND RELEVANT PHOTOIONIZATION CROSS SECTION FROM FINAL STATE DO 18 N=1,NUMP IF(ITP(N).NE.JTR(J))GO TO 18 C LOOK FOR SAME ELECTRON CONTINUUM AS AUTOIONIZATION DO 19 K=1,KMAX IF(JTP(N).EQ.JTA(IA(K)))GO TO 20 19 CONTINUE C NONE FOUND GO TO 18 C EVALUATE FANO Q PARAMETER 20 RR=PCS(N,IEP) IP=IP+1 L=L+1 IQ(L)=J IL(K)=L TW=IWT(1) T=IWA(I) TW=TW/T T=5.68352E-3*TW*RR K=IA(K) TT=AR(J)/(AA(K)*T) QF(L)=SQRT(ABS(TT)) IF(TT.LT.0.0)QF(L)=-QF(L) CTEST QF(L)=1.0E30 18 CONTINUE C C NO PHOTOIONIZATION CROSS SECTION FOUND, SO INITIALISE FOR C NO INTERFERENCE FOR THIS TRANSITION. C IF(IP.EQ.0)THEN L=L+1 IQ(L)=J QF(L)=1.0E30 ENDIF C 17 CONTINUE MMAX=M IF(MMAX.EQ.0)GO TO 10 LMAX=L IF(LMAX.GT.NDIM36)STOP 70 TW=IWT(1) T=IWA(I) COEF=1.33704E-14*T/TW EC0=EC(I) ITA1=ITA(I) C C SUM OVER ALL FINAL STATES C IF(KMAX.EQ.1)THEN C SINGLE ELECTRON MULTI PHOTON CONTINUA C I=IA(1) AA1=ABS(AA(I)) CALL SUMG(LMAX,IQ,QF,AR,AA1,EC0,EIONMN,IPRINT,ITA1,JTR,DEL X,EATOM,NBIN1,EBIN,SBIN,COEF) ELSE IF(MMAX.EQ.1)THEN C SINGLE PHOTON MULTI ELECTRON CONTINUA J=IQ(1) IF(EIONMN-EATOM(J).LT.EBDMIN.OR.EIONMN-EATOM(J).GT.EBDMAX)GO TO 12 IF(DEL(J).LT.EPHMIN.OR.DEL(J).GT.EPHMAX)GO TO 12 AR1=ABS(AR(J)) CALL SUME(KMAX,IL,QF,IA,AA,EC0,AR1,ITA1,IPRINT,NBIN1,EBIN,SBIN X,COEF) ELSE C MULTI PHOTON AND MULTI ELECTRON CONTINUA - FATAL WRITE(6,2001) STOP 'ERROR IN SR.FEARS: MULTIPLE PHOTON AND ELECTRON' ENDIF ENDIF 12 ITA(I)=IABS(ITA(I)) 10 CONTINUE C RETURN C C NO (SUITABLE) PHOTOIONIZATION DATA SO RETURN AND EVALUATE C USUAL ENERGY-AVERAGE CROSS SECTION C 2000 BFEAR=.FALSE. IF(NUMA.GT.0)THEN DO 90 I=1,NUMA AA(I)=ABS(AA(I)) 90 CONTINUE ENDIF IF(NUMR.GT.0)THEN DO 91 I=1,NUMR AR(I)=ABS(AR(I)) 91 CONTINUE ENDIF C RETURN C 101 FORMAT(I3,12X,I2,6X,I2) 102 FORMAT(5E15.5) 103 FORMAT(A1) 104 FORMAT(6I5,E15.5,2F15.6) 105 FORMAT(5X,I5,5X,I5) 200 FORMAT(/' ************** PHOTORECOMBINATION CROSS SECTIONS ******' X,'********'//4X,'I',4X,'J',7X,'E(RY)',9X,'CROSS(MB)',8X,'Q**2') 2001 FORMAT('0***** ERROR IN SR.FEARS: MULTIPLE PHOTON AND ELECTRON' X,' CONTINUA CANNOT BE DEALT WITH') END C*********************************************************************** SUBROUTINE GAMAF(NMAX) IMPLICIT REAL*8 (A-H,O-Z) C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE. C CALCULATES GAMMA(N), N=1,2...NMAX. C OUTPUT IS IN GAM(N), JGAM(N), WHERE GAMMA(N)=GAM(N)*1.0D6**JGAM(N). C LAST CHANGED ON 22 JAN 80. DIMENSION GAM(500),JGAM(500) COMMON /AB10/GAM,JGAM SC1=1.0E6 SC2=1.0E-6 GAM(1)=1.0E0 JGAM(1)=0 DO 4 N=2,NMAX N1=N-1 X=N1 X1=X*GAM(N1) J1=JGAM(N1) 1 IF(X1-SC1)3,2,2 2 X1=SC2*X1 J1=J1+1 GO TO 1 3 GAM(N)=X1 JGAM(N)=J1 4 CONTINUE RETURN END C*********************************************************************** FUNCTION gammln(xx) real*8 gammln,xx INTEGER j REAL*8 ser,stp,tmp,x,y,cof(6) SAVE cof,stp DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, *-.5395239384953d-5,2.5066282746310005d0/ x=xx y=x tmp=x+5.5d0 tmp=(x+0.5d0)*log(tmp)-tmp ser=1.000000000190015d0 do 11 j=1,6 y=y+1.d0 ser=ser+cof(j)/y 11 continue gammln=tmp+log(stp*ser/x) return END C*********************************************************************** C (C) Copr. 1986-92 Numerical Recipes Software .37. SUBROUTINE gaulag(x,w,n,alf) IMPLICIT NONE INTEGER n,MAXIT real*8 alf,w(n),x(n) REAL*8 EPS PARAMETER (EPS=3.D-12,MAXIT=20) CU USES gammln INTEGER i,its,j real*8 ai,gammln,TN REAL*8 p1,p2,p3,pp,z,z1 do 13 i=1,n if(i.eq.1)then z=(1.d0+alf)*(3.d0+.92d0*alf)/(1.d0+2.4d0*n+1.8d0*alf) else if(i.eq.2)then z=z+(15.d0+6.25d0*alf)/(1.d0+.9d0*alf+2.5d0*n) else ai=i-2 z=z+((1.d0+2.55d0*ai)/(1.9d0*ai)+1.26d0*ai*alf/ X(1.d0+3.5d0*ai))*(z-x(i-2))/(1.d0+.3d0*alf) endif do 12 its=1,MAXIT p1=1.d0 p2=0.d0 do 11 j=1,n p3=p2 p2=p1 p1=((2*j-1+alf-z)*p2-(j-1+alf)*p3)/j 11 continue pp=(n*p1-(n+alf)*p2)/z z1=z z=z1-p1/pp if(abs(z-z1).le.EPS)goto 1 12 continue WRITE(6,*) 'WARNING: too many iterations in gaulag',n,z,z1 1 x(i)=z TN=N w(i)=-1.0d0/(pp*n*p2) IF(ALF.NE.0.d0)w(i)=W(I)*exp(gammln(alf+n)-gammln(TN)) 13 continue return END C*********************************************************************** C (C) Copr. 1986-92 Numerical Recipes Software .37. C MODIFIED NRB 26/09/01 FOR REAL*8 AND OPT CASE ALF=0. REAL*8 FUNCTION GAUSSQ(NQ,W,X,B) IMPLICIT REAL*8(A-H,O-Z) C C GAUSSIAN QUADRATURE DRIVER C C NQ: NO OF QUADRATURE POINTS. C W: WEIGHTS C X: ZEROES C LAGUERRE CASE: B DEFINED BY EXP(-E*B), I.E. B=1/KT FOR MAXWELLIAN. C PARAMETER (TZERO=0.0) DIMENSION X(NQ), W(NQ) C CALL GAULAG(X,W,NQ,TZERO) C SUM=0.0 DO N=1,NQ T=X(N)/B SUM=SUM+W(N)*GLNAG(T)*EXP(X(N)) ENDDO C GAUSSQ=SUM/B C RETURN END C*********************************************************************** REAL*8 FUNCTION GLNAG(X) IMPLICIT REAL*8 (A-H,O-Z) C FUNCTION REQUIRED BY NAG D01BAE TO EVALUATE INTEGRAND FOR GAUSS-LAGUERRE LOGICAL BBACK PARAMETER (NDIM3=100001,NDIM2=36,NDIM44=501,NDIM33=501) PARAMETER (NLAG=4) PARAMETER (DZERO=0.0) PARAMETER (DONE=1.0) C COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /TRANS1/B,JSP,L DIMENSION TEMP(NDIM44) DATA IFLAG/1/ C TT=DZERO IF(ITYPE.EQ.3)THEN IF(X.LE.ENERG(NENG))THEN IF(X.GE.ENERG(1))THEN TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,X,JSP) ENDIF ELSE TT=SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,ENERG(NENG),JSP) TT=XTRP(ENERG(NENG),TT,X,IXTRP(L)) c2 P1=ENERG(NENG-1)*PCS(NENG-1) c2 P2=ENERG(NENG)*PCS(NENG) c0 P1=PCS(NENG-1) c0 P2=PCS(NENG) cc A2=ENERG(NENG-1)*ENERG(NENG)*(P1-P2)/(ENERG(NENG)-ENERG(NENG-1)) cc A1=P1-A2/ENERG(NENG-1) cc TT=A1+A2/X c2 TT=TT/X IF(B*X.LT.5.0.AND.IFLAG.EQ.1)THEN WRITE(6,100) 100 FORMAT(' SR.GLNAG: WARNING, SPLINE EXTRAPOLATED USING PCS(NENG)') IFLAG=0 ENDIF ENDIF ELSEIF(ITYPE.EQ.2)THEN IF(X.LE.ENERG(NENG))THEN U=X/SIGMA(L,7) IF(U.LE.DZERO)U=DONE-U IF(U.GE.DONE)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4) X *LOG(U)+SIGMA(L,5)*LOG(U)/U ENDIF ELSE U=ENERG(NENG)/SIGMA(L,7) IF(U.LE.DZERO)U=DONE-U IF(U.GE.DONE)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U)+SIGMA(L,4) X *LOG(U)+SIGMA(L,5)*LOG(U)/U ENDIF TT=XTRP(ENERG(NENG),TT,X,IXTRP(L)) ENDIF ELSEIF(ITYPE.EQ.0)THEN IF(NENG.LT.NLAG)STOP'REQUIRE AT LEAST NLAG ENERGIES' IF(X.GT.ENERG(NENG))THEN TT=XTRP(ENERG(NENG),PCS(NENG),X,IXTRP(L)) ELSE NP1=1 NP2=NLAG NPH=NP2/2 DO N=1,NENG IF(ENERG(N).GE.X)THEN NP=N GO TO 343 ENDIF ENDDO NP=NENG 343 NP2=NP+NPH-1 NP1=NP-NPH IF(NP1.LE.0)THEN NP2=NP2-NP1+1 NP1=1 ENDIF IF(NP2.GT.NENG)THEN NP1=NP1-NP2+NENG NP2=NENG ENDIF DO N=NP1,NP2 DD=DONE DO M=NP1,NP2 IF(N.NE.M)THEN DD=DD*(X-ENERG(M)) DD=DD/(ENERG(N)-ENERG(M)) ENDIF ENDDO TEMP(N)=DD ENDDO DO M=NP1,NP2 TT=TT+TEMP(M)*PCS(M) ENDDO ENDIF ENDIF C GLNAG=TT*EXP(-B*X) C RETURN END C*********************************************************************** SUBROUTINE LOADSP(L) IMPLICIT REAL*8 (A-H,O-Z) C LOAD APPROPRAITE SPLINE FIT INTO /CSPLYN/, SP5 & PCS NOT REQUIRED. PARAMETER(NDIM2=36,NDIM33=501,NDIM44=501) COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5),NXNG(ND XIM2),NENG C NENG=NXNG(L) DO 1 I=1,NENG SP1(I)=SPY(L,I,1) SP2(I)=SPY(L,I,2) SP3(I)=SPY(L,I,3) SP4(I)=SPY(L,I,4) ENERG(I)=SPY(L,I,5) 1 CONTINUE RETURN END C*********************************************************************** SUBROUTINE MIDEXP(N,B,S) IMPLICIT REAL*8(A-H,O-Z) C ADAPTATION OF NUMERICAL RECIPES ROUTINE, C FOR APPLICATION TO MAXWELLIAN INTEGRATION AT HIGH TEMP. C THEN B=1/KT. C IF(N.EQ.1)THEN X=0.5D0 T=-LOG(X)/B S=GLNAG(T)*EXP(B*T) S=S/B ELSE IT=3**(N-2) TNM=IT DEL=1/(3*TNM) DDEL=DEL+DEL X=DEL/2 T=-LOG(X)/B SUM=0. DO J=1,IT SUM=SUM+GLNAG(T)*EXP(B*T) X=X+DDEL T=-LOG(X)/B SUM=SUM+GLNAG(T)*EXP(B*T) X=X+DEL T=-LOG(X)/B ENDDO SUM=SUM/B S=(S+SUM/TNM)/3 ENDIF C RETURN END CNCAR CNCARC**************************************************************** CNCAR SUBROUTINE NCAR1(NPUB,ILOG) CNCAR IMPLICIT REAL*8 (A-H,O-Z) CNCAR CHARACTER*16 AGDSHN CNCARC CNCARC INITIALIZE NCARGKS CNCARC CNCARC NCARGKS cgmfile output to 'gmeta' unless reset by NCAR_GKS_OUTPUT CNCARC environment variable CNCARC CNCAR CALL OPNGKS CNCARC CNCARC DEFINE GRID SIZE WITHIN WINDOW CNCAR CALL AGSETF('GRID/L.',.25) CNCAR CALL AGSETF('GRID/R.',.81) CNCAR CALL AGSETF('GRID/B.',.17) CNCAR CALL AGSETF('GRID/T.',.73) CNCARC VARIABLE CHARACTER LENGTH TERMINATED BY $ CNCAR CALL AGSETI('LINE/MAXIMUM.',100) CNCARC NO GRACE CNCAR CALL AGSETI('WIN.',0) CNCAR IF(NPUB.EQ.1)CALL AGSETI('WIN.',1) CNCARC SET-UP DASHED LINES CNCAR CALL AGSETI('DASH/SELECTOR.',6) CNCAR CALL AGSETI('DASH/LENGTH.',6) CNCAR CALL AGSETC(AGDSHN(1),"$$$$$$") CNCAR CALL AGSETC(AGDSHN(2),"$'$'$'") CNCAR CALL AGSETC(AGDSHN(3),"$$$'''") CNCAR CALL AGSETC(AGDSHN(4),"$$''''") CNCAR CALL AGSETC(AGDSHN(5),"$$$$''") CNCAR CALL AGSETC(AGDSHN(6),"$'$$'$") CNCAR CALL AGSETC(AGDSHN(7),"$''$''") CNCARC SUPPRESS FRAME ADVANCE (I.E. CALL FRAME EXPLICITLY LATER TO ADVANCE) CNCAR CALL AGSETI('FRAME.',2) CNCARC SET-UP LABEL SIZE CNCAR IF(NPUB.EQ.1)THEN CNCAR CALL AGSETF('AXIS/B/NUMERIC/OFFSET.',.035) CNCAR CALL AGSETF('AXIS/L/WIDTH/MANT.',.033) CNCAR CALL AGSETF('AXIS/B/WIDTH/MANT.',.033) CNCAR ELSE CNCAR CALL AGSETF('AXIS/L/WIDTH/MANT.',.022) CNCAR CALL AGSETF('AXIS/B/WIDTH/MANT.',.022) CNCAR ENDIF CNCAR CALL AGSETF('AXIS/L/WIDTH/EXP.',.015) CNCAR CALL AGSETF('AXIS/B/WIDTH/EXP.',.015) CNCAR CALL AGSETI('AXIS/R/CONTROL.',-1) CNCAR CALL AGSETI('AXIS/T/CONTROL.',-1) CNCARC SET-UP TICKS CNCAR CALL AGSETI('X/NICE.',0) CNCAR CALL AGSETI('Y/NICE.',0) CNCAR CALL AGSETI('L/MINOR/SPACING.',1) CNCAR CALL AGSETI('B/MINOR/SPACING.',1) CNCARC SELECT DUPLEX ROMAN CNCAR IF(NPUB.EQ.1)CALL GSTXFP(-12,2) CNCARC CNCARC CNCAR RETURN CNCAR END CNCARC**************************************************************** CNCAR SUBROUTINE NCAR2( L,IMODE,NPUB,BLOR,NC,BSCALE,XSIZE,YSIZE,JCFA,ILO CNCAR XG,EMIN,EMESH,EMAX,SMIN1,SMESH1,SMAX1,EORIG,ESTEP,SORIG1,SCYCLE,TOR CNCAR XIG,TCYCLE,ET,ST,NT,EWIDTH,IZ,ITHETA,TPAR,TPER,UNITS,ISW,SMIN2,SMES CNCAR XH2,SMAX2,SORIG2,STC,EX,SX,ERSX,NX,LBMAX,STR,BRMDAT,ISYM,IGAUSS,IBA CNCAR XRN) CNCARC CNCARC SUN :SINGLE PRECISION FIX FOR NCAR GRAPHICS ON SUN CNCARC.....IMPLICIT REAL*4(A-H,O-Z) CNCARC IMPLICIT REAL*8 (A-H,O-Z) CNCAR CHARACTER*50 GLAB, XLAB, TLAB CNCAR PARAMETER(NDIM2=36,NDIM5=150) CNCAR LOGICAL BLOR,BSCALE,BRMDAT CNCAR DIMENSION ET(*),ST(*),STC(*),EX(*),SX(*),ERSX(*),STR(*) CNCAR X,X(2),Y(2) CNCAR COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG CNCARC CNCAR ZCAR=0.025 CNCAR IF(NPUB.EQ.1)ZCAR=0.035 CNCAR GO TO (1,2,3,4,5),ISW CNCAR 1 WRITE(TLAB,'(A)')'Temperature (K)$' CNCAR WRITE(XLAB,'(A)')'Energy (K)$' CNCAR GO TO 7 CNCAR 2 WRITE(TLAB,'(A)')'Temperature (/cm)$' CNCAR WRITE(XLAB,'(A)')'Energy (/cm)$' CNCAR GO TO 7 CNCAR 3 WRITE(TLAB,'(A)')'Temperature (eV)$' CNCAR WRITE(XLAB,'(A)')'Energy (eV)$' CNCAR GO TO 7 CNCAR 4 WRITE(TLAB,'(A)')'Temperature (Ry)$' CNCAR WRITE(XLAB,'(A)')'Energy (Ry)$' CNCAR GO TO 7 CNCAR 5 WRITE(TLAB,'(A)')'Temperature (a.u.)$' CNCAR WRITE(XLAB,'(A)')'Energy (a.u.)$' CNCARC CNCAR 7 I=IREV(L,1) CNCAR J=IREV(L,2) CNCAR IF(IMODE.EQ.-2.OR.NPUB.EQ.-2)GO TO 244 CNCAR IF(NPUB.EQ.3.OR.NPUB.EQ.1)GO TO 244 CNCAR IF(NPUB.NE.2)GO TO 239 CNCAR IF(L.EQ.1) GO TO 244 CNCAR GO TO 58 CNCARC CNCARC GRAPH1--PLOT OF RESONANCE CROSS SECTION VS. ENERGY CNCARC CNCAR 239 IF(BLOR.AND.IMODE.NE.-5.AND.NC.GT.0)GO TO 244 CNCAR IF(BSCALE)SMAX1=SMAX1*1.1 CNCAR IF(NPUB.NE.1)THEN CNCAR CALL AGSETC('LABEL/NAME.','T') CNCAR IF(IMODE.NE.-5)THEN CNCAR CALL AGSETI('LINE/NUMBER.',120) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR CALL AGSETC('LINE/TEXT.','Energy-averaged$') CNCAR ENDIF CNCAR IF(JCFA.EQ.0)THEN CNCAR WRITE(GLAB, 900)I CNCAR 900 FORMAT('Dielectronic recombination cross section (',I2,')$') CNCAR ELSE CNCAR WRITE(GLAB, 901)I,J CNCAR 901 FORMAT('Resonant excitation cross section (',I2,'-',I2,')$') CNCAR ENDIF CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR CALL AGSETC('LINE/TEXT.',GLAB) CNCAR IF(IMODE.EQ.-5)THEN CNCAR CALL AGSETI('LINE/NUMBER.',100) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR CALL AGSETC('LINE/TEXT.','Convoluted with Lorentzian profile$') CNCAR ENDIF CNCAR ENDIF CNCARC CNCAR CALL AGSETC('LABEL/NAME.','L') CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(JCFA.EQ.0)THEN CNCAR CALL AGSETC('LINE/TEXT.','DR Cross section (10**-18 cm**2)$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','RE Cross section (10**-18 cm**2)$') CNCAR ENDIF CNCARC CNCAR CALL AGSETC('LABEL/NAME.','B') CNCAR CALL AGSETI('LINE/NUMBER.',-100) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR CALL AGSETC('LINE/TEXT.',XLAB) CNCARC CNCAR CALL AGSETC('LABEL/NAME.','L') CNCAR CALL AGSETI('LINE/NUMBER.',100) CNCAR CALL AGSETC('LINE/TEXT.',' ') CNCAR IF(IMODE.NE.-5)THEN CNCAR CALL AGSETC('LABEL/NAME.','T') CNCAR CALL AGSETI('LINE/NUMBER.',100) CNCAR CALL AGSETC('LINE/TEXT.',' ') CNCAR ENDIF CNCARC CNCAR CALL AGSETF('Y/MAX.',SMAX1) CNCAR CALL AGSETF('X/MAX.',EMAX) CNCAR IF(ILOG)48,47,46 CNCARC CNCAR 46 CALL AGSETF('X/MIN.',EMIN) CNCAR CALL AGSETF('Y/MIN.',SMIN1) CNCAR IF(.NOT.BSCALE)THEN CNCAR CALL AGSETF('LEFT/MAJOR/BASE.',SMESH1) CNCAR CALL AGSETF('BOTTOM/MAJOR/BASE.',EMESH) CNCAR ENDIF CNCAR GO TO 49 CNCARC CNCAR 48 CALL AGSETF('X/MIN.',TORIG) CNCAR CALL AGSETI('X/LOG.',1) CNCAR CALL AGSETI('B/MINOR/SPACING.',8) CNCAR 47 CALL AGSETF('Y/MIN.',SORIG1) CNCAR CALL AGSETI('Y/LOG.',1) CNCAR CALL AGSETI('L/MINOR/SPACING.',8) CNCARC CNCAR 49 CALL AGSTUP(ET,1,0,NT,1,ST,1,0,NT,1) CNCAR CALL AGBACK CNCAR CALL AGCURV(ET,1,ST,1,NT,1) CNCAR CALL FRAME CNCARC CNCARC GRAPH2--PLOT OF CONVOLUTED CROSS SECTION VS. ENERGY CNCARC CNCAR 244 CONTINUE CNCARC IF(NPUB.NE.1)THEN CNCARC CALL PLOTIT(0,0,0) CNCARC CALL PLOTIT(32767,0,1) CNCARC CALL PLOTIT(32767,32767,1) CNCARC CALL PLOTIT(0,32767,1) CNCARC CALL PLOTIT(0,0,1) CNCARC ENDIF CNCAR IF(BSCALE)SMAX2=SMAX2*1.1 CNCAR IF(EWIDTH)265,255,247 CNCAR 247 IF(IZ.EQ.0)GO TO 245 CNCARC CNCARC GRAPH2--PLOT OF RTE CROSS SECTION VS. ENERGY CNCARC CNCAR IF(NPUB.NE.1)THEN CNCAR CALL AGSETC('LABEL/NAME.','T') CNCAR CALL AGSETI('LINE/NUMBER.',120) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(ITHETA.LT.0)THEN CNCAR CALL AGSETC('LINE/TEXT.','RTE Cross section .v. Energy*m/M$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','Differential RTE Cross section .v. Energ CNCAR Xy*m/M$') CNCAR ENDIF CNCAR ENDIF CNCARC CNCAR CALL AGSETC('LABEL/NAME.','L') CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(NPUB.NE.1)THEN CNCAR IF(ITHETA.LT.0)THEN CNCAR CALL AGSETC('LINE/TEXT.','RTE Cross section (10**-21 cm**2)$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','4PiDS/DW (10**-21 cm**2)$') CNCAR ENDIF CNCAR ELSE CNCAR IF(ITHETA.LT.0)THEN CNCAR CALL AGSETC('LINE/TEXT.','Cross section (Kb)$') CNCARC CALL AGSETC('LINE/TEXT.','Cross section (10**-21 cm**2)$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','Differential Cross-section (Kb)$') CNCARC CALL AGSETC('LINE/TEXT.','Differential Cross section (10**-21 cm** CNCARC X2)$') CNCAR ENDIF CNCAR ENDIF CNCAR GO TO 6 CNCARC CNCARC GRAPH2--PLOT OF CONVOLUTED CROSS SECTION VS. ENERGY CNCARC FOR GAUSSIAN ENERGY DISTRIBUTION CNCARC CNCAR 245 IF(NPUB.NE.1)THEN CNCAR CALL AGSETC('LABEL/NAME.','T') CNCAR CALL AGSETI('LINE/NUMBER.',120) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(JCFA.EQ.0)THEN CNCAR WRITE(GLAB, 910)I CNCAR 910 FORMAT('Dielectronic recombination cross section (',I2,')$') CNCAR ELSE CNCAR IF(ITHETA.LT.0)THEN CNCAR WRITE(GLAB, 911)I,J CNCAR 911 FORMAT('Resonant excitation cross section (',I2,'-',I2,')$') CNCAR ELSE CNCAR WRITE(GLAB, 912)I,J CNCAR 912 FORMAT('Differential RE cross section (',I2,'-',I2,')$') CNCAR ENDIF CNCAR ENDIF CNCAR CALL AGSETC('LINE/TEXT.',GLAB) CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(BLOR)THEN CNCAR CALL AGSETC('LINE/TEXT.','Convoluted with Lorentzian profile$') CNCAR ELSE CNCAR IF(EWIDTH.LT.200.0)THEN CNCAR T=EWIDTH*UNITS CNCAR WRITE(GLAB, 913)T CNCAR 913 FORMAT('Convoluted with ',F6.3,' FWHM Gaussian$') CNCAR ELSE CNCAR WRITE(GLAB, 914)TPAR CNCAR 914 FORMAT('Convoluted with Tpar= ',F7.5,' Gaussian$') CNCAR ENDIF CNCAR CALL AGSETC('LINE/TEXT.',GLAB) CNCAR ENDIF CNCAR ENDIF CNCARC CNCAR CALL AGSETC('LABEL/NAME.','L') CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(NPUB.NE.1)THEN CNCAR IF(JCFA.EQ.0)THEN CNCAR CALL AGSETC('LINE/TEXT.','DR Cross section (10**-18 cm**2)$') CNCAR ELSE CNCAR IF(ITHETA.LT.0)THEN CNCAR CALL AGSETC('LINE/TEXT.','RE Cross section (10**-18 cm**2)$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','4PiDS/DW (10**-18 cm**2)$') CNCAR ENDIF CNCAR ENDIF CNCAR ELSE CNCAR IF(ITHETA.LT.0)THEN CNCAR IF(IBARN.EQ.0)CALL AGSETC('LINE/TEXT.','Cross section (Mb)$') CNCAR IF(IBARN.EQ.6)CALL AGSETC('LINE/TEXT.','Cross section (b)$') CNCAR IF(IBARN.EQ.3)CALL AGSETC('LINE/TEXT.','Cross section (Kb)$') CNCARC CALL AGSETC('LINE/TEXT.','Cross section (10**-18 cm**2)$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','Differential cross section (Mb)$') CNCARC CALL AGSETC('LINE/TEXT.','Differential cross section (10**-18 cm** CNCARC X2)$') CNCAR ENDIF CNCAR ENDIF CNCAR GO TO 6 CNCARC CNCARC GRAPH2--PLOT OF CONVOLUTED CROSS SECTION VS. ENERGY CNCARC FOR ORNL/AARHUS/HEIDELBERG VELOCITY DISTRIBUTION CNCARC CNCAR 255 IF(NPUB.NE.1)THEN CNCAR CALL AGSETC('LABEL/NAME.','T') CNCAR CALL AGSETI('LINE/NUMBER.',120) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(TPAR*TPER.GT.0.0)THEN CNCAR CALL AGSETC('LINE/TEXT.','VS Convoluted with kTpar, kTper =$') CNCAR WRITE(GLAB, 960)TPAR,TPER,I CNCAR 960 FORMAT(F9.6,F8.4,' Distribution function (',I2,')$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','VS Convoluted with Aarhus$') CNCAR WRITE(GLAB, 961)I CNCAR 961 FORMAT('Electron distribution function (',I2,')$') CNCAR ENDIF CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR CALL AGSETC('LINE/TEXT.',GLAB) CNCAR ENDIF CNCARC CNCAR CALL AGSETC('LABEL/NAME.','L') CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(NPUB.NE.1)THEN CNCAR CALL AGSETC('LINE/TEXT.',' (10**-11 cm**3/s)$') CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','Rate coefficient$') CNCARC CALL AGSETC('LINE/TEXT.','Rate coefficient (10**-11 cm**3/s)$') CNCAR ENDIF CNCAR 6 CONTINUE CNCARC CNCAR CALL AGSETC('LABEL/NAME.','B') CNCAR CALL AGSETI('LINE/NUMBER.',-100) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR CALL AGSETC('LINE/TEXT.',XLAB) CNCAR GO TO 8 CNCARC CNCARC GRAPH2--PLOT OF DR RATE COEFFICIENT VS. ENERGY CNCARC FOR MAXWELLIAN ENERGY DISTRIBUTION CNCARC CNCAR 265 IF(NPUB.NE.1)THEN CNCAR CALL AGSETC('LABEL/NAME.','T') CNCAR CALL AGSETI('LINE/NUMBER.',120) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(JCFA.EQ.0)THEN CNCAR WRITE(GLAB, 970)I CNCAR 970 FORMAT('Dielectronic recombination rate coefficient (',I2,')$') CNCAR ELSE CNCAR WRITE(GLAB, 971)I,J CNCAR 971 FORMAT('Resonant excitation rate coefficient (',I2,'-',I2,')$') CNCAR ENDIF CNCAR CALL AGSETC('LINE/TEXT.',GLAB) CNCAR ENDIF CNCARC CNCAR CALL AGSETC('LABEL/NAME.','L') CNCAR CALL AGSETI('LINE/NUMBER.',110) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR IF(NPUB.NE.1)THEN CNCAR IF(JCFA.EQ.0)THEN CNCAR IF(IBARN.EQ.0) CNCAR XCALL AGSETC('LINE/TEXT.','DR Rate coefficient (10**-11 cm**3/s)$') CNCAR IF(IBARN.EQ.-11) CNCAR XCALL AGSETC('LINE/TEXT.','DR Rate coefficient (cm**3/s)$') CNCAR ELSE CNCAR IF(IBARN.EQ.0) CNCAR XCALL AGSETC('LINE/TEXT.','RE Rate coefficient (10**-11 cm**3/s)$') CNCAR IF(IBARN.EQ.-11) CNCAR XCALL AGSETC('LINE/TEXT.','RE Rate coefficient (cm**3/s)$') CNCAR ENDIF CNCAR ELSE CNCAR CALL AGSETC('LINE/TEXT.','Rate coefficient$') CNCARC CALL AGSETC('LINE/TEXT.','Rate coefficient (10**-11 cm**3/s)$') CNCAR ENDIF CNCARC CNCAR CALL AGSETC('LABEL/NAME.','B') CNCAR CALL AGSETI('LINE/NUMBER.',-100) CNCAR CALL AGSETF('LINE/CHAR.',ZCAR) CNCAR CALL AGSETC('LINE/TEXT.',TLAB) CNCARC CNCAR 8 CALL AGSETC('LABEL/NAME.','L') CNCAR CALL AGSETI('LINE/NUMBER.',100) CNCAR CALL AGSETC('LINE/TEXT.',' ') CNCAR CALL AGSETC('LABEL/NAME.','T') CNCAR CALL AGSETI('LINE/NUMBER.',100) CNCAR CALL AGSETC('LINE/TEXT.',' ') CNCARC CNCAR CALL AGSETF('Y/MAX.',SMAX2) CNCAR CALL AGSETF('X/MAX.',EMAX) CNCAR IF(ILOG)57,56,55 CNCARC CNCAR 55 CALL AGSETF('X/MIN.',EMIN) CNCAR CALL AGSETF('Y/MIN.',SMIN2) CNCAR IF(.NOT.BSCALE)THEN CNCAR CALL AGSETF('LEFT/MAJOR/BASE.',SMESH2) CNCAR CALL AGSETF('BOTTOM/MAJOR/BASE.',EMESH) CNCAR ENDIF CNCAR GO TO 58 CNCARC CNCAR 57 CALL AGSETF('X/MIN.',TORIG) CNCAR CALL AGSETI('X/LOG.',1) CNCAR CALL AGSETI('B/MINOR/SPACING.',8) CNCAR 56 CALL AGSETF('Y/MIN.',SORIG2) CNCAR CALL AGSETI('Y/LOG.',1) CNCAR CALL AGSETI('L/MINOR/SPACING.',8) CNCARC CNCAR 58 IF(NPUB.NE.-2)THEN CNCAR NPTS=NT/IGAUSS CNCAR CALL AGSTUP(ET,1,0,NPTS,IGAUSS,STC,1,0,NPTS,IGAUSS) CNCAR CALL AGBACK CNCAR CALL AGCURV(ET,IGAUSS,STC,IGAUSS,NPTS,1) CNCAR IF(BRMDAT)THEN CNCARC CALL AGSTUP(ET,1,0,NPTS,IGAUSS,STR,1,0,NPTS,IGAUSS) CNCAR CALL AGCURV(ET,IGAUSS,STR,IGAUSS,NPTS,2) CNCAR ENDIF CNCAR ENDIF CNCARC CNCARC CNCARC PLOT EXPERIMENTAL DATA CNCARC CNCAR IF(NX.GT.0) THEN CNCAR IF(NPUB.EQ.-2)THEN CNCAR CALL AGSTUP(EX,1,0,NX,1,SX,1,0,NX,1) CNCAR CALL AGBACK CNCAR ENDIF CNCAR T1=0.01 CNCAR T=T1*(SMAX2-SMIN2) CNCAR IF(IMODE.EQ.-7.OR.NX.LE.50)THEN CNCARCOLD CALL POINTS(EX,SX,NX,ISYM,0) CNCAR T2=T+T CNCAR CALL NGDOTS(EX,SX,NX,T2,ISYM) ! V3.2 CNCAR ELSE CNCAR IF(NX.GT.50)CALL AGCURV(EX,1,SX,1,NX,ISYM) CNCAR ENDIF CNCARC CNCARC PLOT ERROR BARS - SET UP FOR LIN-LIN CNCARC CNCAR IF(ILOG.GT.0.AND.NX.LE.50)THEN CNCAR DO 251 I=1,NX CNCAR X(1)=EX(I) CNCAR X(2)=X(1)*1.00001 CNCAR IF(IMODE.EQ.-7)THEN CNCAR Y(1)=SX(I)-T1*(SMAX2-SMIN2) CNCAR Y(2)=SX(I)+T1*(SMAX2-SMIN2) CNCAR CALL AGCURV(X,1,Y,1,2,1) CNCAR ELSE CNCAR IF(ERSX(I).EQ.0.0)GO TO 251 CNCAR Y(1)=SX(I)-ERSX(I) CNCAR Y(2)=SX(I)+ERSX(I) CNCAR CALL AGCURV(X,1,Y,1,2,1) CNCAR X(1)=EX(I)-T CNCAR X(2)=EX(I)+T CNCAR Y2=Y(2) CNCAR Y(2)=Y(1) CNCAR CALL AGCURV(X,1,Y,1,2,1) CNCAR Y(2)=Y2 CNCAR Y(1)=Y(2) CNCAR CALL AGCURV(X,1,Y,1,2,1) CNCAR ENDIF CNCAR 251 CONTINUE CNCAR ENDIF CNCARC CNCAR ENDIF CNCARC CNCAR IF(NPUB.NE.2.OR.L.EQ.LBMAX)THEN CNCAR CALL FRAME CNCAR ENDIF CNCAR RETURN CNCAR END CNCARC**************************************************************** CNCAR SUBROUTINE NCAR3 CNCAR IMPLICIT REAL*8 (A-H,O-Z) CNCARC CNCARC CLOSE NCARGKS CNCARC CNCAR CALL CLSGKS CNCARC CNCAR RETURN CNCAR END C************************************************************************ SUBROUTINE OMEGFIT(Q,U,NFIT,C,IDIPL,IFAIL) IMPLICIT REAL*8 (A-H,O-Z) C C SUBROUTINE TO PERFORM LEAST SQUARES FIT OF OMEGA TO E IN THRESHOLD C UNITS. IF DIPOLE USE OMEGA=C1+C2/U+C3/U**2+C4*LOG(U)+C5*LOG(U)/U. C IF NON-DIPOLE, USE OMEGA=C1+C2/U+C3/U**2 C C DIMENSION Q(NFIT),U(NFIT),C(5),P(5) DIMENSION FNA(5,5),FNB(5),W1(5),W2(5) ISZ=5 IF(IDIPL.EQ.0) ISZ=3 DO 110 I=1,5 FNB(I)=0.0 DO 100 J=1,5 FNA(I,J)=0.0 100 CONTINUE 110 CONTINUE FNA(1,1)=NFIT DO 120 N=1,NFIT FX1=1./U(N) FX2=0.0 IF(IDIPL.EQ.1) FX2=LOG(U(N)) FNA(1,2)=FNA(1,2)+FX1 FNA(1,3)=FNA(1,3)+FX1**2 FNA(1,4)=FNA(1,4)+FX2 FNA(1,5)=FNA(1,5)+FX2*FX1 FNA(2,2)=FNA(2,2)+FX1**2 FNA(2,3)=FNA(2,3)+FX1**3 FNA(2,4)=FNA(2,4)+FX1*FX2 FNA(2,5)=FNA(2,5)+FX2*FX1**2 FNA(3,3)=FNA(3,3)+FX1**4 FNA(3,4)=FNA(3,4)+FX1**2*FX2 FNA(3,5)=FNA(3,5)+FX2*FX1**3 FNA(4,4)=FNA(4,4)+FX2**2 FNA(4,5)=FNA(4,5)+FX2**2*FX1 FNA(5,5)=FNA(5,5)+FX2**2*FX1**2 FNB(1)=FNB(1)+Q(N) FNB(2)=FNB(2)+Q(N)*FX1 FNB(3)=FNB(3)+Q(N)*FX1**2 FNB(4)=FNB(4)+Q(N)*FX2 FNB(5)=FNB(5)+Q(N)*FX2*FX1 120 CONTINUE C NAG F04ASE,F CSP CALL F04ASE(FNA,5,FNB,ISZ,C,W1,W2,IFAIL) CDP CALL F04ASF(FNA,5,FNB,ISZ,C,W1,W2,IFAIL) C CALL CHOLDC(FNA,ISZ,5,P,IFAIL) C IF(IFAIL.NE.0) THEN WRITE(6,35) 35 FORMAT(//'UTILITY F04ASE USED TO SOLVE NORMAL EQUATIONS FAILED') END IF C CALL CHOLSL(FNA,ISZ,5,P,FNB,C) C IF(IDIPL.EQ.0) THEN C(4)=0.0 C(5)=0.0 END IF RETURN END C*********************************************************************** SUBROUTINE POSTP C IMPLICIT REAL*8 (A-H,O-Z) C LOGICAL BLOR,BFEAR,BSCALE,BBACK,BPLOT,BRMDAT,BLS,BIC C CHARACTER*4 NAME,RUN,RAD,ELAS,COREX !COD(20) C C SUN :SINGLE PRECISION FIX FOR NCAR GRAPHICS CNCAR REAL*4 XSIZE,YSIZE,SWIDTH,SUNIT CNCAR X,EMIN,EMESH,EMAX,SMIN1,SMESH1,SMAX1,EORIG,ESTEP,SORIG1,SCYCLE CNCAR X,TORIG,TCYCLE,ET,ST,TPAR,TPER,SMIN2,SMESH2 CNCAR X,SMAX2,SORIG2,STC,EX,SX,ERSX,STR C END PARAMETER (NDIM1=10001) PARAMETER (NDIM2=36) PARAMETER (NDIM3=100001) PARAMETER (NDIM4=9999) PARAMETER (NDIM5=150) PARAMETER (NDIM8=100) PARAMETER (NDIM9=12) PARAMETER (NDIM10=5) PARAMETER (NDIM11=99999) PARAMETER (NDIM12=9000000) PARAMETER (NDIM13=95000) PARAMETER (NDIM14=200) PARAMETER (NDIM15=501) PARAMETER (NDIM16=50) PARAMETER (NDIM17=800) PARAMETER (NDIM23=2001) PARAMETER (NDIM24=50000) PARAMETER (NDIM25=15) PARAMETER (NDIM26=75) PARAMETER (NDIM33=501) PARAMETER (NDIM43=300001) PARAMETER (NDIM44=501) PARAMETER (NDIM45=5) PARAMETER (NDIM46=NDIM43) PARAMETER (NTMR=100) C DIMENSION EBIN(NDIM1),SBIN(NDIM2,NDIM1) DIMENSION ET(NDIM3),ST(NDIM3),STC(NDIM3),STR(NDIM3) DIMENSION ERSX(NDIM23),WEX(1,NDIM2),EX(NDIM23),SX(NDIM23) X,EXX(1,NDIM23),SXX(1,NDIM23),ERSXX(1,NDIM23) DIMENSION TBIN(NDIM1),EI(NDIM5),ECORI(NDIM8,NDIM8) X,IWT(NDIM5),IWS(NDIM5),IWL(NDIM5),NCUTR(NDIM5) C COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) COMMON /CDGEN/NASTD,NLEV(NDIM5) COMMON /CORR/ACORN(NDIM1),ACORL(NDIM25),NNCOR,NLCOR X,ACORA(NDIM26),ICOR(NDIM26),NACOR,JYLD COMMON /CSPLYN/SP1(NDIM44),SP2(NDIM44),SP3(NDIM44),SP4(NDIM44) X,SP5(NDIM44),ENERG(NDIM44),PCS(NDIM44),SPY(NDIM2,NDIM44,5) X,NXNG(NDIM2),NENG COMMON /DITT/A00,B00 COMMON /EB/EBCOR COMMON /ECOR/ E1C(NDIM8),E1X(NDIM8),ECORT,TOLB COMMON /JCF/JCFA,JCFR,JCFJ,JCFY,JCFE,JPAR,LSPI,J2PI,BLOR,BFEAR X,MAX2J COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /LOREN/EREZ(NDIM11),GSIG(NDIM11),GAM(NDIM11),ITRAN(NDIM11) X,JYMAX COMMON /LOTZ/TLOTZ(5,5),ELOTZ(5,5),NLOTZ COMMON /MIX/CIRN,CIRD,TCOOL,TFLITE,NFLITE,NFNLMX,FNL(NDIM24) COMMON /PHOTON/EBDMIN,EBDMAX,EPHMIN,EPHMAX COMMON /QDTS/QDTS(0:30),NQDT COMMON /RMXQ/EMSHRX(NDIM43),OMEGA(NDIM46),RMXN(NDIM45,NDIM43) X ,EVECR(NDIM46),ENAT(NTMR),MXE common /bug/ibug C DATA E9999/9999.0/ C NAMELIST/ONE/NTAR1,NX,NTAR2,UNITS,NPUB,ILOG,IPRINT,NCUT,LCUT,NC X,ITHETA,ISP,IMODE,JCFA,JCFR,JCFJ,JCFY,JCFE,NPLOT,NRSLMX,ERSOL,RUN X,RAD,LSPI,J2PI,JPAR,NMIN,LMIN,NMAX,LMAX,ELAS,NASTD,MAX2J,IPARNT X,ITRG,ibug x,corex !enable read of suitable adasin C NAMELIST/TWO/NBIN,EMIN,EMAX,EWIDTH,TPAR,TPER,NP,NR1,NR2,NECOR X,JYLD,NACOR,NNCOR,NLCOR,ACOR,RCOR,TOLR,TOLB,ECORT,ITYPE,NLOTZ X,TLOTZ,ELOTZ,IGAUSS,NGAUSS,EBDMIN,EBDMAX,EPHMIN,EPHMAX,IOLD X,TCOOL,TFLITE,NFLITE,NFNLMX,IUP,ESWTCHX,NENG,INAG,NQDT C NAMELIST/THREE/EMESH,SMAX1,SMESH2,SMAX2,CONVRT,XSTEP,ECOR,XCOR X,SMIN1,SMIN2,SMESH1,XSIZE,YSIZE,YMULT,ISYM,EBCOR,IBARN X,SORGI1,SORIG2 C C WRITE(6,1001) !COD 1001 FORMAT(1X,50('-'),'MDRCS',50('-') !//1X,20A4 X//1X,49('-'),'(V13.7)',49('-')//) C C C**********************NAMELIST-ONE************************************* C C NTAR1= NO OF INITIAL STATES POPULATED. C NTAR2= NO OF FINAL STATES (.GE. NTAR1) FOR RE, REDA ETC; FOR DR C RESET INTERNALLY = NTAR1, OR = NECOR .GT. 0 FOR ENERGY C CORRECTIONS C NOTE: NBINI=NTAR1+1 AND NBINR=NTAR2+1. C C NASTD .GT. 0 FORM NASTD GROUPS OF LEVELS DEFINED BY NLEV(I),I=1, C NASTD. THEN, NTAR1, NTAR2, STAT. WEIGHTS ETC. C REFER TO THE GROUPS. C C EI(I)-- I=1,NBINI ARE THE TARGET ENERGY BINS (ONLY 2 FOR IMODE=-1) C OPTIONAL. *****NOT READ BY DEFAULT, SET ITRG=-1 TO READ. C DEFAULT (OMIT OR EI(1).GE.0.0) DETERMINES THEM INTERNALLY, C*****HOWEVER, NO ENERGY CORRECTIONS ARE MADE TO THE FIRST NL DATA BLOCK C ALSO, IN IC THE BIN IS BY TARGET LEVEL, TO AVEARAGE-OVER THE FINE- C STRUCTURE OF A GIVEN TARGET TERM (AS WE USUALLY DO) REQUIRES INPUT C EI(I) THAT PUT ALL LEVELS OF A GIVEN TERM IN THE SAME ENERGY BIN, C **OR** USE NASTD ABOVE. C C IWT(I): I=1,NTAR1 ARE THE TOTAL STATISTICAL WEIGHTS FOR THESE BINS C IWS(I)=2S+1, IWL=L IF IWS(I).NE.0 ELSE IWL(I)=IWT(I)=2J+1 IN IC C OR (2S+1)*(2L+1) IN LS; S,L AND J ARE TARGET MOMENTA OF COURSE. C C SET NTAR1=-NTAR1 TO READ ADASDR STYLE TARGET SYMMETRIES & ENERGIES C THEN 2J IS READ, SHOULD BE DIRECTLY AS WRITTEN TO TERMS AND LEVELS C FILES. C C NX .NE. 0 - THERE EXISTS EXPERIMENTAL DATA TO BE READ ON C UNIT3, HEADED BY NO. OF POINTS & ENERGY UNITS. C .LT.0 RESERVED FOR COINCIDENT EMISSION PROBLEM. C C UNITS=ENERGY UNITS C =0.5 FOR ATOMIC UNITS C =1.0 FOR RYDBERGS C =13.606 FOR EV C =109737 FOR /CM C =157890 FOR DEGREES K C C *** THE NCAR PLOTTING ROUTINES ARE COMMENTED-OUT *** OUTPUT IN FILE C doutgnu IS IN SUITABLE FORMAT FOR PLOTTING WITH GNUPLOT. C C NPUB .LT.-2 NO CONVOLUTED CROSS SECTIONS AND NO GRAPHS. C NPUB .EQ.-2 GRAPHS OF EXPERIMENTAL POINTS BUT NO THEORY. C NPUB .EQ.-1 CONVOLUTED CROSS SECTIONS BUT NO GRAPHS. C NPUB .EQ. 0 DEFAULT, EVERYTHING. C NPUB .EQ. 1 NO HEADER. C NPUB .EQ. 2 NO BINNED CROSS SECTION PLOTS, ALL CONVOLUTED CROSS C SECTIONS APPEAR ON SAME PLOT. C NPUB .EQ. 3 NO BINNED CROSS SECTION PLOTS C NPUB .GT. 3 DEFAULT C C ILOG .GT. 0 LIN-LIN PLOT SCALE C ILOG .EQ. 0 LOG-LIN PLOT SCALE C ILOG .LT. 0 LOG-LOG PLOT SCALE C C NPLOT .GT. 0 ONLY PLOT TRANSITION NUMBER NPLOT (IN STANDARD ORDER) C C IPRINT=PRINT LEVEL C .GE. 0, DETAILED PRINTOUT OF EACH PARTIAL CROSS SECTION C .EQ.-1, NL CROSS SECTIONS C .EQ.-2, L CROSS SECTIONS C .LE.-3, TOTAL CROSS SECTION ONLY. C C NCUT(NMAX) .GT. 0, IGNORES CONTRIBUTIONS FROM N .GT. NCUT(OR MAX) C IT DOES NOT HAVE TO BE ONE OF THE CALCULATED N. C LCUT(LMAX) .GE. 0, IGNORES CONTRIBUTIONS FROM L .GT. LCUT(OR MAX) C NMIN .GT. 0, IGNORES CONTRIBUTIONS FROM N .LT. NMIN C IT *MUST* BE ONE OF THE CALCULATED N. C LMIN .GE. 0, IGNORES CONTRIBUTIONS FROM L .LT. LMIN C C NC .LE. 0 WRITE BINNED CROSS SECTIONS IN MB C NC. GT. 0 READ NC SETS OF BINNED CROSS SECTIONS IN MB C C LSPI .GT. 0 INCLUDE PARTIAL WAVE LSPI=10000*(2S+1)+100*L+PI C J2PI .GE. 0 INCLUDE PARTIAL WAVE J2PI=100*(2*J)+PI C MAX2J .EQ. MAX 2*J OF AUTOIONIZING STATE RETAINED. C C JCF'S .EQ. 0 DEFAULT, RADIATIVE EMISSION C JCFA .GT. 0 ELECTRON EMISSION INTO ION BIN JCFA C JCFA .LT. 0 ELECTRON EMISSION INTO ION BIN -JCFA NEGLECT RAD DECAY C |JCFA| .GE. 100 ALL TRANSITIONS; .GT. 100 OMIT ELASTIC C .GT. 200 THRU CONFIGURATION JCFA+200 ONLY. C C JCFR .LT. 0 INCLUDES CAPTURE INTO CONFIGURATION NUMBER -JCFR C AS OUTPUT BY AUTOSTRUCTURE, FOR L (LV) .GE. 0 ONLY. C JCFR .GT. 0 ASSUMES ALL STATES OF FINAL CONFIGURATION JCFR STABLE C AGAINST AUTOIONIZATION. C .GT. 100 COMPLETELY IGNORES RADIATIVE DECAY INTO AUTOIONIZING C STATES. C .GT. 200 NEGLECTS RADIATIVE WIDTH C*** JCFE : OMITS CONFIGS .GT. JCFE FROM TARGET STATE LIST/BINS. C JCFE NOT ACTIVE. C JCFJ : NEGLECTS CAPTURE INTO CONFIGS .GT. JCFJ C JCFY : NEGLECTS 2ND AUGER FROM CONFIGS .GT. JCFY (REDA). C C IPARNT.GT.0 WRITE/READ PARENTS TO/FROM FILE, BASED ON HIGH-N LIMIT C DEFINITION (NCUT). C .LE.0 PARENTS DETERMINED AT EACH NL, DEFAULT=0. C .LT.0 SWITCHES-OFF ANY JPAR IN ADDITION. C C JPAR .GT. 0 (& NECOR .GT. 0) INCLUDE PARENTS .LE. JPAR (.LE. NECOR) ONLY C *** SOMETIMES CODED .EQ. JPAR TO SELECT A SINGLE PARENT. CHECK!! C .LT. 0 CASE IPRINT.EQ.0: ANY UNRESOLVED PARENT ASSIGNED TO C -JPAR, ELSE (=0) IGNORED. C C ITHETA .LT. 0 INTEGRATED CROSS SECTIONS C ITHETA .GE. 0 DIFFERENTIAL CROSS SECTION AT THETA=ITHETA DEGREES C IN PROJECTILE FRAME, FOR S-S TRANSITIONS ONLY C FOR ELECTRON EMISSION (RE, RTEA). SELECT WITH JCFA. C TARGET ION AN S-STATE FOR PHOTON EMISSION (DR, RTEX). C C ISP .EQ. 2I+1, I=NUCLEAR SPIN. C C C IMODE C .GE. 0 DEFAULT (SR.CROSSX) C .EQ.-1 CALLS SR.DRAY C .EQ.-2 CALLS SR.CASC (REQUIRES EXTRA INPUT) C .LE.-3 ENERGY-AVERAGED DR CROSS SECTIONS. (SR.CROSSX) C .EQ.-4 RESERVED FOR MITCH'S DIRAC-FOCK FORMAT C .EQ.-5 EVALUATES CONVOLUTED CROSS SECTIONS FROM C LORENTZIAN RATHER THAN ENERGY-AVERAGE CROSS SECTIONS. C OBSOLETE .EQ.-6 ATTEMPTS TO ESTIMATE MISSING RATES IF ECOR .LT. 0.0 C ***NO LONGER SUPPORTED*** SET ECORLS/IC .LT. 0 IN C AUTOS TO LOWER CONTINUUM THEN SET FIRST CALCULATED C ENERGY, E1C(1)=-ECORLS/IC TO SUBTRACT AT SAME TIME AS C APPLYING ECORR CORRECTION TO OBSERVED ENERGIES. C .EQ.-7 ALTERNATIVE TREATMENT OF EXPERIMENTAL DATA. C OBSOLETE .EQ.-8 GENERATES DR DATA IN JET FORMAT ON ADF09. (SR.CROSSJ) C ***NO LONGER SUPPORTED*** USE PROGRAM ADASDR INSTEAD C .EQ.-9 REDA C .EQ.-10 UNITARISED AUTOIONIZATION RATES. C .EQ.-11 MQDT DR FOR RADIATIVE RATES. ***IMPORTANT*** AR MUST C HAVE BEEN CALCULATED FOR EACH NL BLOCK (NRAD=1000 IN AS). C .EQ.-12 : COMBINES -10 AND -11 C .EQ.-13 UNIFIED PHOTORECOMBINATION (SEE NOTES IN SR.FEAR) C USE RUN='FEAR' IF REQUIRE SIMULTANEOUS ALTERNATE IMODE. C .EQ.-14 USES SR.FEARS (SINGLE ELECTRON OR PHOTON CONTINUUM) C ELSE SR.FEARM (MULTIPLE ELECTRON AND/OR PHOTON CONTINUUM) C OBSOLETE .EQ.-15 USES SR.CROSSJ (INSTEAD OF SR.CROSSX) FOR DR XSCTNS. C C RUN, RAD & ELAS CAN BE USED FOR USER FRIENDLY SPECIFICATION OF THE C MOST COMMONLY USED COMBINATIONS OF IMODE AND THE JCF'S, VIZ. C C RUN='DR','RE','REDA','CASC','FEAR' C RAD='YES','NO' C ELAS='YES','NO' C C****************************END-ONE************************************ C C BFEAR=.TRUE. NTAR1=1 NTAR2=1 NASTD=0 NX=0 UNITS=1.0 NPUB=77 ILOG=1 IPRINT=-1 NCUT=-66 LCUT=-77 NC=0 ITHETA=-19 ISP=0 IMODE=-19 JCFA=0 JCFR=0 JCFJ=0 JCFY=0 JCFE=0 NPLOT=0 NRSLMX=8 ERSOL=0.3 RUN='DR' RAD='YES' ELAS='NO' LSPI=0 J2PI=-1 JPAR=0 NMIN=-10 LMIN=-10 NMAX=-10 LMAX=-10 MAX2J=999 IPARNT=0 ITRG=-1 !flag terms/energy input format ibug=0 corex=' ' !for adasin C READ(5,ONE) c if(jcfa.ne.0)then write(6,*)'Electron Emission not tested (JCFA.ne.0) - Use MDRCS12' stop 'Electron Emission not tested (JCFA.ne.0) - Use MDRCS12' endif C IF(RUN.EQ.'EX'.OR.RUN.EQ.'RE'.OR.RUN.EQ.'REDA'.OR.RUN.EQ.'DI')THEN IF(JCFA.EQ.0)THEN JCFA=100 IF(ELAS.EQ.'YES')JCFA=10 ENDIF IF(RAD.EQ.'NO')JCFA=-IABS(JCFA) IF(RUN.EQ.'REDA'.OR.RUN.EQ.'DI')IMODE=-9 ENDIF IF(RUN.EQ.'DR'.AND.RAD.EQ.'NO')JCFR=201 IF(RUN.EQ.'DR'.AND.NTAR2.LT.IABS(NTAR1))NTAR2=IABS(NTAR1) IF(RUN.EQ.'DRAY')IMODE=-1 IF(RUN.EQ.'CASC')IMODE=-2 IF(RUN.EQ.'JET')IMODE=-8 IF(IMODE.EQ.-13)RUN='FEAR' IF(IMODE.EQ.-5.AND.RUN.EQ.'FEAR')IMODE=-13 IF(IMODE.EQ.-8.OR.IMODE.EQ.-15)THEN WRITE(6,*)'PROCESSING FOR ADF09' X ,' NO LONGER SUPPORTED: USE PROGRAM ADASDR INSTEAD' STOP 'PROCESSING FOR ADF09 NO LONGER SUPPORTED HERE' ENDIF C IF(COREX.NE.' '.AND.ITRG.LT.0)ITRG=1 IF(NTAR1.LT.0)THEN NTAR1=-NTAR1 IF(ITRG.LT.0)ITRG=1 ENDIF NBINI=NTAR1+1 NBINR=NTAR2+1 BPLOT=NPLOT.GT.0 C IF(JCFJ.LE.0)JCFJ=999 IF(JCFY.LE.0)JCFY=999 IF(JCFE.LE.0)JCFE=999 IF(IMODE.GE.0)IMODE=-19 IF(IMODE.EQ.-9.AND.IABS(JCFA).LT.10)THEN IF(JCFA.GE.0)JCFA=50 IF(JCFA.LT.0)JCFA=-50 ENDIF JCFX=0 NAME='JCF*' IF(JCFA.NE.0)THEN JCFX=JCFA NAME='JCFA' ENDIF IF(JCFR.NE.0)THEN JCFX=JCFR NAME='JCFR' ENDIF IF(JCFJ.NE.999)THEN JCFX=JCFJ NAME='JCFJ' ENDIF C WRITE(6,11) NTAR1,NX,NTAR2,UNITS,NCUT,LCUT,NC,NAME,JCFX,IMODE 11 FORMAT(/1X,'NTAR1=',I3,3X,'NX=',I3,3X,'NTAR2=',I3,3X, X'ENERGY UNITS=',F15.5,3X,'NCUT=',I4,3X,'LCUT=',I3,3X,'NC=',I3 X,3X,A4,'=',I4,3X,'IMODE=',I4) IF(LSPI.GT.0)WRITE(6,12)LSPI 12 FORMAT(' LSPI=',I6) IF(J2PI.GE.0)WRITE(6,6)J2PI 6 FORMAT(' J2PI=',I6) IF(MAX2J.LT.100)WRITE(6,'(1X,A6,I3)')'MAX2J=',MAX2J IF(ITHETA.GE.0.OR.ISP.GT.0)WRITE(6,10)ITHETA,ISP 10 FORMAT(' ITHETA=',I4,3X,'ISP=',I3) IF(NBINI.GT.NBINR)NBINI=NBINR NBINM=NBINI-1 IT=1 IF(RUN.EQ.'FEAR')IT=2 IF(IT*NBINM.GT.NDIM2)THEN WRITE(6,847)NBINM*IT 847 FORMAT(/' INCREASE NDIM2 TO AT LEAST',I3) STOP '*** INCREASE NDIM2' ENDIF IF(NBINR.GT.NDIM5)THEN WRITE(6,848)NBINR 848 FORMAT(/' INCREASE NDIM5 TO AT LEAST',I3) STOP '*** INCREASE NDIM5' ENDIF IF(NBINM.LT.1) THEN WRITE(6,849)NBINM 849 FORMAT(/' NTAR1 MUST BE .GT. 0, BUT INPUT NTAR1=',I3) STOP '*** NTAR1 MUST BE .GT. 0' ENDIF NBINRM=NBINR-1 C IF(NMAX.GT.0)NCUT=NMAX IF(LMAX.GT.-1)LCUT=LMAX IF(NCUT.LT.1)NCUT=100000 IF(LCUT.LT.0)LCUT=100000 C C*************************NAMELIST-TWO********************************** C C GRAPH1--PLOT OF RESONANCE CROSS SECTION VS. ENERGY C GRAPH2--PLOT OF CONVOLUTED CROSS SECTION VS. ENERGY C C NBIN--NUMBER OF ENERGY BINS, IF .LT. 0 NO RESONANCES C NBIN1--NUMBER OF CROSS SECTION BINS C C EMIN--MINIMUM ENERGY IN UNITS FOR GRAPHS C N.B. ANY CROSS SECTIONS LESS THAN EMIN ARE IGNORED BY CONVOLUTION C EMAX--MAX ENERGY IN UNITS FOR GRAPHS, RELATIVE TO INITIAL STATE C ERES=BIN WIDTH << EWIDTH C C EWIDTH--IF.EQ. 0 THEN ORNL/AARHUS VELOCITY CONVOLUTION C IF.GT.0 GAUSSIAN CONVOLUTION ENERGY IN UNITS, UNLESS C EWIDTH .LT. 1.1E-3 THEN USES LORENTZIAN. C IF.LT.0 AND .GT. -1 MAXWELLIAN DISTRIBUTION, KT=EMIN TO EMAX C IF NEGATIVE INTEGER, COMPTON PROFILE FOR RESONANT TRANSFER, C -1 H2 MOL, -2 HE, -3 LI, -4 BE, -6 C, -10 NE ATOMS. C GRAPH ENERGY=PROJECTILE ENERGY * RATIO OF ELECTRON TO ION MASS C RATIO=1/1822.89 * ATOMIC MASS NUMBER. C C INAG.GT. 0 USE NAG ROUTINES FOR CONVOLUTIONS C .EQ. 0 NON-NAG TRAPEZOIDAL, PLUS GAUSS-LAGUERRE FOR MAXWELL C .LT. 0 NON-NAG TRAPEZOIDAL, PLUS MIDPOINT RULE FOR MAXWELL C DEFAULT: NAG FOR NON-MAXWELL, MIDPOINT FOR MAXWELL. C C KTPAR, KTPER = CHARACTERISTIC TEMPS OF MERGED-BEAM EXP. IN UNITS. C DEFAULTS (IF ZERO) TO VALUES SET IN FUNCTION DITTNER C C PRINTS EVERY NP CROSS SECTIONS / RATES, DEFAULT=25 C NOTE: FOR EMIN=0.0633 RYD AND EMAX=633.0 RYD THIS PRINTS OUT RATES C LOG T(K) = 4.0, 4.1, 4.2, ....... 7.9, 8.0 IF NBIN=501. C C RCOR .GT. 0.0 CORRECTION FACTOR FOR CORE RADIATIVE RATE C ACOR .GT. 0.0 CORRECTION FACTOR FOR ALL AUGER RATES C RCOR, ACOR .LE. 0.0 DEFAULT, RESET TO 1.0 C NLCOR .NE.0 CORRECTION FACTORS ACORL(LV+1) FOR LV=0,1,...|NLCOR|-1 C .GT.0 APPLIED TO EACH AUGER RATE WITH RYDBERG A.M. LV C .LT.0 APPLIED TO DR CROSS SECTION WITH RYDBERG A.M. LV. C NNCOR .GT. 0 CORRECTION FACTORS; N, ACORN(N) FOR I=1,NNCOR C APPLIED TO ENERGY-AVERAGED CROSS SECTIONS FOR N=NV. C E.G. N-DEPENDENT FIELD-ENHANCEMENT FACTORS FOR DR. C NACOR .GT. 0 AUGER YIELDS FOR REDA; ICOR(I),ACORA(I), I=1,NACOR; C FOR THE ICOR(I)'TH AUTOIONIZING TERM/LEVEL. C C JYLD: REDA OPTION FOR WHEN RADIATION NEGLECTED. C .EQ. 1 SETS ALL AUGER YIELDS .EQ. 1.0 (DEFAULT). C .EQ. 0 AS ABOVE, EXCEPT SETS YIELD=0.0 IF AUGER FORBIDDEN. C C TOLR CONTROLS RADIATIVE STABILIZATION. TOLR=0 MEANS ALL RADIATIVE C TRANSITIONS TO AUTOIONIZING LEVELS ARE ASSUMED NOT TO CONTRIBUTE TO C DR. ALSO, TOLR.GT.1.0E3 (RY) MEANS ALL RADIATIVE TRANSITIONS ARE C ASSUMED TO BE STABILIZING. IN BETWEEN, ATTEMPTS TO EVALUATE TWO-STEP C RADIATIVE CASCADE FOR ALL AUTOIONIZING LEVELS WITHIN TOLR (RY) OF C GROUND CONTINUUM USING RATES IN STANDARD O1, O1U ETC FILES. C SEE ALSO, IMODE=-2 FOR ALTERNATE TREATMENT OF CASCADE. C TAKE CARE WITH TOLR .LT. 0.0 FOR HIGH-N (NO DETAILS!) - DISABLED. C CURRENTLY, TOLR .LT. 0 IS RESET POSITIVE AND LEVELS WITHIN C TOLR OF GROUND CONTINUUM TAKEN TO BE BOUND - NO YIELDS EVALUATED. C C NR1.LE.NR2 N-BOUNDS ON RADIATIVE STABILIZATION OF VALENCE ELECTRON C GENERATED BY POST-PROCESSOR (H-LIKE), OTHERWISE NONE. C NOTE: IF NR2 IS NOT SEPCIFIED THEN IT IS DETERMINED INTERNALLY, SO C SET NR1.LT.0 TO SWITCH-OFF. C C IF IUP.GE.0 H-LIKE RATES ARE ONLY PP'D FOR LV.GT.0. FOR LV=0 TO IUP C THE AS RAD RATES TO NR1-1 ARE N^3-SCALED UP TO NR2. NR2 MUST BE SET C (>0) AND OBVIOUSLY NR1 SHOULD BE ONE MORE THAN THE HIGHEST AS N. C C NECOR .NE. 0 : READ CALCULATED THEN OBSERVED TARGET/CORE ENERGIES C E1C(J) ARE CALCULATED CORE ENERGIES, J=1,IABS(NECOR), C E1X(J) ARE OBSERVED CORE ENERGIES, J=1,IABS(NECOR). C ECORT .GT. 0 SHIFT ALL RESONANCE POSITIONS DOWN ECORT(UNITS). C C NQDT .GT. 0 READ QUANTUM DEFECTS FOR L=0...NQDT-1, TO BE USED IN C DETERMINING PARENTS FOR APPLICATION OF NECOR ENERGY CORRECTIONS. C C ITYPE SPECIFIES TREATMENT OF NON-RESONANT BACKGROUND (IF PRESENT). C ITYPE=1,2 LEAST SQUARES FIT. C ITYPE=3,4 SPLINE (=4, CONVOLG,X ONLY). C ITYPE=1,4 ASSUMES BACKGROUND INDEPENDENT OF CONVOLUTION ENERGY. C ITYPE=2,3 EXPLICITLY INTEGRATES BACKGROUND CONVOLUTION. C C NENG CAN BE SET TO USE LESS THAN THE NUMBER OF BACKBGROUND C ENERGIES READ-IN IN BRR. C C NLOTZ .GT. 0 ADDS-IN SCALED LOTZ RESULT FOR DIRECT IONIZATION. C TLOTZ(I,N) (UNSCALED) IS JUST THE OCCUPATION NUMBER. C ELOTZ(I,N) IS THE AVERAGE IONIZATION ENERGY (IN UNITS) OF THE C ORBITALS ACCOUNTED FOR BY TLOTZ. C I=1,5 INITIAL METASTABLE STATES; C N=1,NLOTZ PARAMETERS - SET TLOTZ .LE. 0.0 IF NONE. C C NGAUSS,IGAUSS (IMODE.EQ.-5): EVALUATE LORENTZIAN AT NGAUSS POINTS C AND CONVOLUTE AT EVERY IGAUSS'TH POINT C N.B. DOES NOT APPLY TO RUN='FEAR' WHICH USES NBIN TO CONTROL MESH. C C EBDMIN, EBDMAX : ONLY EVALUATE PHOTORECOMBINATION FOR FINAL ATOM C (BINDING) ENERGIES (RELATIVE TO LOWEST CONTINUUM) LYING IN THE C GIVEN RANGE. C EPHMIN, EPHMAX : ONLY EVALUATE PHOTORECOMBINATION FOR PHOTON C ENERGIES LYING IN THE GIVEN RANGE. C (DOES NOT APPLY TO RR YET-TEST COMMENTED OUT). C C *******ABOVE SELECTIONS DO NOT APPLY TO RADIATION ADDED IN PP, C I.E. TYPE-II OUTER. ******************** C C TCOOL= TIME OF FLIGHT THROUGH MERGING SECTION OF COOLER (IF KNOWN) C TFLITE= TIME OF FLIGHT FROM COOLER TO ANALYZER MAGNET, IN SECS. C NFLITE= MAX N TO SURVIVE ANALYZER (HERE, NCUT IS USED TO TEST C SENSITIVITY TO MAX N TO CONSIDERED IN LIFETIME CALC.) C IMPORTANT: EACH N UP TO NFLITE+1 SHOULD BE CALCULATED C ELSE INTERPOLATION CAN GIVE RISE TO ERRORS. C TFLITE, NFLITE ARE NEEDED, TCOOL IS OPTIONAL. C .OR. C NFNLMX.GT.0 MAXIMUM RYDBERG N FOR WHICH DETECTION PROBABILITES C ARE PRESENT IN THE FILE 'FNL' FROM SCHIPPERS MODEL. C C TOLB=2.0E-5 (DEFAULT) C SET TOLB COARSER TO HANDLE USER SUPPLIED IMBALANCED CONTINUUM C EXPANSIONS, I.E. IF NOT ALL PARTIAL WAVES HAVE SAME TARGET CI. C C***************************END-TWO************************************* C TOLR=0.0 TOLB=-1.0 ECORT=0.0 RCOR=1.0 ACOR=1.0 TPAR=0.0 TPER=0.0 NBIN=501 EMIN=0.0 EMAX=20.0*UNITS EWIDTH=0.5*UNITS NP=25 NR1=-1 NR2=-1 NECOR=0 NLCOR=0 NNCOR=0 NACOR=0 JYLD=1 ITYPE=-1 DO N=1,5 DO I=1,5 TLOTZ(I,N)=-100.0 ELOTZ(I,N)=9999.0*UNITS ENDDO ENDDO IGAUSS=-1 NGAUSS=-1 EBDMIN=-1.0E30 EBDMAX=1.0E30 EPHMIN=-1.0 EPHMAX=1.0E30 IOLD=0 NFLITE=-1 TFLITE=-1.0 TCOOL=0.0 IUP=-9 ESWTCHX=999999. NENG=-1 INAG=999 NQDT=-1 NFNLMX=0 NCUTRR=0 C READ(5,TWO) C IF(NFNLMX.GT.0)THEN ! nl-specific detection probailities IFNLMX=NFNLMX*(NFNLMX-1)/2 IF(IFNLMX.GT.NDIM24)THEN WRITE(6,*)'*** INCREASE NDIM24 TO AT LEAST:', IFNLMX STOP '*** INCREASE NDIM24' ENDIF DO I=1,3 READ(80,*) ENDDO DO IFNL=1,IFNLMX READ(80,*,END=802)NFNL,LFNL,FNL(IFNL) C WRITE(*,*) NFNL,LFNL,FNL(IFNL) ENDDO GO TO 803 802 WRITE(6,*)'END OF *.FNL FILE REACHED TOO SOON' STOP 'END OF *.FNL FILE REACHED TOO SOON' 803 CONTINUE ENDIF C ESWTCHX=ESWTCHX/UNITS IF(NFLITE.LT.0.OR.TFLITE.LT.0.0)THEN NFLITE=NR2 TFLITE=-1.0 ENDIF IF(TFLITE.GE.0.0)THEN WRITE(6,*) WRITE(6,*)'TCOOL=',TCOOL,'TFLITE=',TFLITE,' NFLITE=',NFLITE NR2=-1 !MUST DETERMINE INTERNALLY THEN ENDIF C IF(EBDMIN.GE.0.0)WRITE(6,173)EBDMIN,EBDMAX 173 FORMAT(/' ****RECOMBINATION RESTRICTED TO THOSE ATOMS WITH' X,' BINDING ENERGY IN THE RANGE',F10.6,'TO',F10.6,' UNITS'/) EBDMIN=EBDMIN/UNITS EBDMAX=EBDMAX/UNITS IF(EPHMIN.GE.0.0)WRITE(6,174)EPHMIN,EPHMAX 174 FORMAT(/' ****RECOMBINATION RESTRICTED TO THOSE ATOMS WITH' X,' PHOTON ENERGY IN THE RANGE',F10.6,'TO',F10.6,' UNITS'/) EPHMIN=EPHMIN/UNITS EPHMAX=EPHMAX/UNITS C IF(IMODE.EQ.-5)THEN IF(NGAUSS.GT.NDIM3)THEN WRITE(6,*)' INCREASE NDIM3 TO GET REQUESTED RESOLUTION',NGAUSS NGAUSS=NDIM3 ENDIF WRITE(6,178)IGAUSS,NGAUSS 178 FORMAT(/' IGAUSS=',I3,3X,'NGAUSS=',I7/) ENDIF C DO I=1,5 DO N=1,NLOTZ IF(TLOTZ(I,N).GT.0.0)WRITE(6,171)I,TLOTZ(I,N),ELOTZ(I,N) 171 FORMAT(' I=',I2,3X,'TLOTZ(I)=',F6.3,3X,'ELOTZ(I)=',F8.4) ELOTZ(I,N)=ELOTZ(I,N)/UNITS TLOTZ(I,N)=240.0*TLOTZ(I,N)/ELOTZ(I,N) ENDDO ENDDO C IF(EMIN.LT.0.0)STOP '***ERROR: MUST SET POSTIVE EMIN' C NBIN0=NBIN IF(NBIN0.LT.0.OR.NC.GT.0)BFEAR=.FALSE. NBIN=IABS(NBIN0) C IF(NBINR.LE.NECOR)NECOR=NBINR-1 C WRITE(6,13)NBIN0,EMIN,EMAX,EWIDTH,TOLB 13 FORMAT(/1X,'NBIN=',I5,3X,'EMIN=',F10.3,3X, X'EMAX=',F10.3,3X,'EWIDTH=',F10.3 X,3X,'TOLB=',F10.6) IF(NBIN.GT.NDIM1) STOP 'INCREASE NDIM1 TO NBIN' C TOLB=TOLB/UNITS ECORT=ECORT/UNITS C IF(RCOR.LE.0.0)RCOR=1.0 IF(ACOR.LE.0.0)ACOR=1.0 IF(RCOR*ACOR.NE.1.0)WRITE(6,308)ACOR,RCOR 308 FORMAT(/1X,'ACOR=',F8.4,3X,'RCOR=',F8.4) C IF(TPAR+TPER.GT.0.0)WRITE(6,307)TPAR,TPER 307 FORMAT(/1X,'TPAR=',F8.6,3X,'TPER=',F8.6) A00=0.0 B00=0.0 IF(TPAR.GT.0.0)THEN A00=SQRT(TPAR/UNITS) A00=1.0/A00 ENDIF IF(TPER.GT.0.0)THEN B00=SQRT(TPER/UNITS) B00=1.0/B00 ENDIF C IF(NP.LE.0)NP=25 IZ=0 IF(EWIDTH.LT.-0.9999)IZ=-EWIDTH+1.0E-4 IF(IZ.GT.0)EWIDTH=-EWIDTH NBIN1=NBIN-1 C IF(INAG.EQ.999)THEN C INAG=1 !NAG, INC G-L FOR MAXWELL INAG=0 !USES TRAP OR NON-NAG G-L (MAXWELL) IF(EWIDTH.LT.0.0)INAG=-1 !MIDPOINT MAXWELL, ELSE TRAP ENDIF IF(INAG.GT.0)THEN WRITE(6,*)'NAG ROUTINES COMMENTED-OUT: SET INAG<=0, OR NOT AT ALL' STOP 'NAG ROUTINES COMMENTED-OUT: SET INAG<=0, OR NOT AT ALL' ENDIF C IF(NQDT.GT.0)THEN READ(5,*)(QDTS(N),N=0,NQDT-1) WRITE(6,172)(QDTS(N),N=0,NQDT-1) 172 FORMAT(/' QUAUNTUM DEFECTS FOR L=0,1,2...:',10F8.3) ENDIF C IF(NASTD.GT.0)READ(5,*)(NLEV(I),I=1,NASTD) C IF(ITRG.GT.0)THEN !ADASDR STYLE INPUT READ(5,309)ITEST 309 FORMAT(6X,I2) BACKSPACE(5) BLS=ITEST.EQ.0 BIC=ITEST.NE.0 NBINP=MAX(NBINM,NBINRM,IABS(NECOR)) C IF(BLS)THEN WRITE(6,816) 816 FORMAT(/1X,'(2S+1) L P') DO I=1,NBINP READ(5,992)IWS(I),IWL(I),IPAR,ICFX,NI,E1C(I),MERGE E1C(I)=E1C(I)*UNITS !SINCE RYD HERE IF(IWS(I).EQ.0)THEN WRITE(6,*)'*** PREMATURE END OF STAT. WEIGHT INPUT:' WRITE(6,*)'*** REQUESTED=',NBINP,' BUT FOUND=',I-1 STOP '*** PREMATURE END OF STAT. WEIGHT INPUT' ENDIF 992 FORMAT(3I2,I5,I5,F18.6,3X,A4) WRITE(6,817)IWS(I),IWL(I),IPAR 817 FORMAT(I6,2I3) ENDDO DO I=1,999 !SKIP ANY EXTRA TARGET INFO READ(5,992)ITEST,IDUM,IDUM,IDUM,IDUM,DUM IF(ITEST.EQ.0)GO TO 994 !TERMINATOR ENDDO ENDIF IF(BIC)THEN WRITE(6,818) 818 FORMAT(/1X,'2J P',3X,'(2S+1) L') DO I=1,NBINP READ(5,993)IWT(I),IPAR,IWS(I),IWL(I),ICFX,NI,E1C(I),MERGE E1C(I)=E1C(I)*UNITS !SINCE RYD HERE IF(IWS(I).EQ.0)THEN WRITE(6,*)'*** PREMATURE END OF STAT. WEIGHT INPUT:' WRITE(6,*)'*** REQUESTED=',NBINRM,' BUT FOUND=',I-1 STOP '*** PREMATURE END OF STAT. WEIGHT INPUT' ENDIF 993 FORMAT(2I2,2X,2I2,2I5,3X,F15.8,3X,A4) ENDDO DO I=1,NBINP IPAR=0 IF(IWS(I).LT.0)IPAR=1 IWS(I)=IABS(IWS(I)) IF(I.LE.NBINRM)WRITE(6,819)IWT(I),IPAR,IWS(I),IWL(I) 819 FORMAT(I3,I2,3X,I5,I3) IWL(I)=IWT(I)+1 IWS(I)=0 ENDDO DO I=1,999 !SKIP ANY EXTRA TARGET INFO READ(5,993)IDUM,IDUM,ITEST,IDUM,IDUM,IDUM,DUM IF(ITEST.EQ.0)GO TO 994 !TERMINATOR ENDDO ENDIF ENDIF C IF(IMODE.EQ.-8.OR.IMODE.EQ.-88.OR.ITRG.LT.0)THEN IRD=NBINM IF(IMODE.EQ.-8.OR.RUN.EQ.'FEAR')IRD=NBINRM EI(1)=0.0 READ(5,*)(IWS(I),IWL(I),I=1,IRD) WRITE(6,815)(IWS(I),IWL(I),I=1,IRD) 815 FORMAT(/1X,'(2S+1) L/2J+1'//15(I5,I2)) ELSE READ(5,*)(EI(I),IWS(I),IWL(I),I=1,NBINM),EI(NBINI) WRITE(6,80) 80 FORMAT(/1X,'TARGET BINS + W(I)'/) IF(EI(1).LT.0.0)THEN BACKSPACE(5) READ(5,*)(EI(I),IWS(I),IWL(I),I=1,NBINRM),EI(NBINR) WRITE(6,9)(EI(I),IWS(I),IWL(I),I=1,NBINRM),EI(NBINR) 9 FORMAT(8(F11.3,I3,I2)) ELSE WRITE(6,9)(EI(I),IWS(I),IWL(I),I=1,NBINM),EI(NBINI) IF(TOLB.LT.0.0.AND.IMODE.NE.-9)TOLB=2.0E-5 ENDIF ENDIF C C SET TOLB COARSER TO HANDLE USER SUPPLIED IMBALANCED CONTINUUM C EXPANSIONS, I.E. IF NOT ALL PARTIAL WAVES HAVE SAME TARGET CI. C 994 IF(TOLB.LT.0.0)TOLB=5.0E-6 C C RR CUT-OFF. NORMALLY DETERMINE INTERNALLY FROM TARGET ENERGIES. C IF(NCUTRR.GT.0)THEN READ(5,*)(NCUTR(I),I=1,NCUTRR) WRITE(6,88)(NCUTR(I),I=1,NCUTRR) 88 FORMAT(/'*** RR N CUT-OFF:',16I5) DO I=NCUTRR+1,NBINM NCUTR(I)=0 ENDDO ELSE DO I=1,NBINM NCUTR(I)=999999 ENDDO ENDIF C IF(NACOR.GT.0)THEN IF(NACOR.GT.NDIM26)THEN WRITE(6,*)'NACOR REQUIRES NDIM26 AT LEAST',NACOR STOP '*** INCREASE NDIM26' ENDIF DO I=1,NACOR READ(5,*)ICOR(I),ACORA(I) ENDDO ENDIF C IF(NLCOR.NE.0)THEN NLCOR0=NLCOR NLCOR=IABS(NLCOR) IF(NLCOR.GT.NDIM25)THEN WRITE(6,*)'NLCOR REQUIRES NDIM25 AT LEAST',NLCOR STOP '*** INCREASE NDIM25' ENDIF READ(5,*)(ACORL(I),I=1,NLCOR) WRITE(6,177)(ACORL(I),I=1,NLCOR) 177 FORMAT(/' ACORL',10F10.6) DO I=NLCOR,NDIM25 ACORL(I)=ACORL(NLCOR) ENDDO NLCOR=NLCOR0 ELSE DO I=1,NDIM25 ACORL(I)=1.0 ENDDO ENDIF C IF(NNCOR.GT.0)THEN IF(NNCOR.GT.NDIM1)THEN WRITE(6,*)'NNCOR REQUIRES NDIM1 AT LEAST',NNCOR STOP '*** INCREASE NDIM1' ENDIF DO I=1,NDIM1 ACORN(I)=1.0 ENDDO N0=999999 READ(11,*)NNCOR DO I=1,NNCOR READ(11,*)N,ACORN(N) WRITE(6,181)N,ACORN(N) 181 FORMAT(I5,F10.3) IF(N.GT.N0+1)THEN T=N-N0 TT=(ACORN(N)-ACORN(N0))/T DO J=N0+1,N-1 T=J-N0 ACORN(J)=ACORN(N0)+T*TT ENDDO ENDIF N0=N ENDDO IF(N.LT.NDIM1)THEN DO I=N+1,NDIM1 ACORN(I)=ACORN(N) ENDDO ENDIF ENDIF C TOLR=TOLR/UNITS IF(RUN.EQ.'DR2')TOLR=5.0E2 BLOR=(EWIDTH.GT.0.0.AND.EWIDTH.LT.1.1E-7).OR.IMODE.EQ.-5 EWIDTH=EWIDTH/UNITS C IF(IMODE.EQ.-6)THEN WRITE(6,*)' *** IMODE=-6 NO LONGER SUPPORTED: SET ECORLS/IC < 0' STOP ' *** IMODE=-6 NO LONGER SUPPORTED' ENDIF C C + & - OPTIONS GOT INTERCHANGED, DO NOT ALLOW OLD +NECOR C OPTION UNLESS IOLD=1 THEN C NECOR .GT. 0 ECORI(I), I=1,NECOR CORRECTION ENERGIES ARE APPLIED C TO CONTINUUM ATTACHED TO TARGET BIN I (NOT RECOMMENDED). C JMAX=IABS(NECOR) IF(IOLD.NE.1)NECOR=-JMAX IF(JMAX.GT.NDIM8)THEN WRITE(6,888)JMAX 888 FORMAT(/' INCREASE NDIM8 TO AT LEAST',I5) STOP '*** INCREASE NDIM8' ENDIF TOLE=0.0 IF(NECOR)81,83,82 C 81 IF(ITRG.LE.0)READ(5,*)(E1C(J),J=1,JMAX) READ(5,*)(E1X(J),J=1,JMAX) WRITE(6,377)(E1C(J),J=1,JMAX) WRITE(6,378)(E1X(J),J=1,JMAX) WRITE(6,*)' ' 377 FORMAT(' E1 THY=',10F9.3) 378 FORMAT(' E1 EXP=',10F9.3) C DO J=1,JMAX E1C(J)=E1C(J)/UNITS E1X(J)=E1X(J)/UNITS ENDDO TC1=E1C(1) E1C(1)=0.0 TX1=E1X(1) E1X(1)=0.0 DO I=1,JMAX DO J=I,JMAX TC=E1C(J)-E1C(I) TX=E1X(J)-E1X(I) ECORI(I,J)=TC-TX ENDDO ENDDO DO J=2,JMAX TOLE=MAX(TOLE,ABS(ECORI(1,J))) ENDDO TOLE=1.1D0*TOLE E1C(1)=TC1 E1X(1)=TX1 !NOT USED GO TO 83 C 82 READ(5,*)(ECORI(I,1),I=1,JMAX) C WRITE(6,374)NECOR,(ECORI(I,1),I=1,NECOR) 374 FORMAT(/' NECOR=',I5,5X,'ECORI=',8F10.3) DO I=1,NECOR ECORI(I,1)=ECORI(I,1)/UNITS ENDDO 83 DO I=1,NBINR EI(I)=EI(I)/UNITS IF(IWS(I).EQ.0)THEN IWT(I)=IWL(I) ELSE IWT(I)=IABS(IWS(I))*(2*IWL(I)+1) IF(IMODE.EQ.-8)IWS(I)=IABS(IWS(I)) ENDIF ENDDO C C***********************NAMELIST-THREE********************************** C C *** MAINLY GRAPHING CONTROLS, NO LONGER USED.*** C C SMAX1 .GT.0 MAX CROSS SECTION IN MB FOR GRAPH 1 C SMIN1 .GT.0 MIN CROSS SECTION IN MB FOR GRAPH 1 C C SMAX2 .GT.0 MAX CROSS SECTION IN MB (DR) OR KB (RTEX) FOR GRAPH 2 C MAX RATE IN 1.0E-11 CM3/SEC FOR GRAPH2 C SMIN2 .GT.0 MIN CROSS SECTION IN MB (DR) OR KB (RTEX) FOR GRAPH 2 C MIN RATE IN 1.0E-11 CM3/SEC FOR GRAPH2 C C IF(SMAX1*SMAX2.EQ.0.0) THEN AUTOSCALE. C C IBARN: POWER OF TEN BY WHICH Y-AXIS IS RESCALED. C THE SMIN/MAX ETC SHOULD BE IN THESE NEW UNITS. C C C EMESH, SMESH1,2 : OPTIONAL SPACING FOR X&Y-AXIS, UNITS AS E, SMAX. C C CONVRT, XSTEP, ECOR, XCOR CAN BE USED TO MANIPULATE INPUT C EXPERIMENTAL DATA. DEPENDS ON DATA SOURCE (SEE OPERATION BELOW). C C YMULT: ATTEMPT TO ELIMINATE UNRESOLVED RESONANCES (R-MATRIX OR C IRIPDW LORENTIZIAN). RESET PEAK IF FACTOR YMULT LARGER C THAN POINTS ON EITHER SIDE. DEFAULT 1.0E24, NO RESET. C A GOOD VALUE TO CHOOSE IS 5. C C ISYM: NCAR-GRAPHICS SYMBOL FOR EXPERIMENTAL DATA PLOT. C C ECORB IN SR.BEXA: REDUCE ENERGY OF DIRECT+E-A BACKGROUND, INPUT C FROM ALTERNATE SOURCE. C C XSIZE, YSIZE: OBSELETE, WERE USED BY DISSPLA GRAPHICS. C C*****************************END-THREE********************************* C CIRN=0.0 !NOT USED CIRD=0.0 !NOT USED SMIN1=0.0 SMIN2=0.0 EMESH=0.0 SMESH1=0.0 SMAX1=0.0 SMESH2=0.0 SMAX2=0.0 SORIG1=0.0 SORIG2=0.0 CONVRT=0.0 XSTEP=0.0 ECOR=0.0 XCOR=0.0 EBCOR=0.0 XSIZE=6.0 YSIZE=6.0 YMULT=1.0E24 ISYM=0 IBARN=0 C READ(5,THREE,END=157,ERR=157) C COLD IF(ISYM.EQ.0)ISYM=-4 IF(ISYM.EQ.0)ISYM=1 ! NCAR V3.2 C IF(YMULT.LT.101.0)WRITE(94,102)YMULT 102 FORMAT(' YMULT=',F6.2// X,' IE',4X,' EMESH(IE) ',5X,' OMEGA(IE-1) ',5X,' OMEGA(IE) ' X,5X,' OMEGA(IE+1)') C EBCOR=EBCOR/UNITS CIRN=CIRN/UNITS BSCALE=SMAX1*SMAX2.EQ.0.0 C UNCOMMENT TO SCALE Y-MIN C IF(BSCALE)THEN C SMIN1=1.0E20 C SMIN2=1.0E20 C ENDIF C IF(EWIDTH.GT.0.0)WRITE(6,15) SMESH1,SMAX1,SMESH2,SMAX2 15 FORMAT(/5X,'SMESH1=',F10.5,' MB',5X,'SMAX1=',F10.5,' MB',5X, 1 'SMESH2=',F10.5,' MB',5X,'SMAX2=',F10.5,' MB') IF(EWIDTH.LE.0.0)WRITE(6,810)SMESH1,SMAX1,SMESH2,SMAX2 810 FORMAT(/5X,'SMESH1=',F10.5,' MB',5X,'SMAX1=',F10.5,' MB',5X, X'SMESH2=',F10.5,' 10-11 CM3/S',5X,'SMAX2=',F10.5,' 10-11 CM3/S') C IF(EMESH.EQ.0.0)EMESH=(EMAX-EMIN)/5.0 EORIG=EMIN ESTEP=(EMAX-EMIN)/6.0 IF(SMESH1.EQ.0.0)SMESH1=(SMAX1-SMIN1)/5.0 IF(SMESH2.EQ.0.0)SMESH2=(SMAX2-SMIN2)/5.0 IF(ILOG.LE.0.AND.SORIG1.LE.0.0)THEN SORIG1=0.001*SMAX1 IF(SORIG1.LE.0.0)SORIG1=1.E-4 ENDIF IF(ILOG.LE.0.AND.SORIG2.LE.0.0)THEN SORIG2=0.001*SMAX2 IF(SORIG2.LE.0.0)SORIG2=1.E-4 ENDIF SCYCLE=YSIZE/3.0 ! OBSOLETE (DISSPLA ONLY) TCYCLE=XSIZE/3.0 ! OBSOLETE (DISSPLA ONLY) C 157 TORIG=0.001*EMAX IF(EMIN.GT.1.0E-6*EMAX)TORIG=EMIN IF((ILOG.LT.0.OR.EWIDTH.GT.0.0).AND.EMIN.EQ.0.0)EMIN=TORIG*0.1 IF(TORIG.LT.EMIN)TORIG=EMIN C C********************************************************* C EX--EXPERIMENTAL ENERGIES IN UNITX C SX--EXPERIMENTAL CROSS SECTIONS IN MB OR kB C EXPERIMENTAL RATES IN 1.0E-11 CM3/SEC C ERSX--EXPERIMENTAL ERROR BARS C WEX--FRACTION OF BEAM IN TARGET BIN C********************************************************* C LMAX=0 NX0=NX NX=IABS(NX0) NXX=NX IF(NX.GT.0) THEN L=0 158 L=L+1 IF(L.GT.1)GO TO 156 C C UNIT=5 READ(5,*)(WEX(L,I),I=1,NBINM) IF(WEX(L,1).EQ.0.0)GO TO 156 C UNIT=3 READ(3,*)NXX,UNITX C T=UNITS/UNITX IF(IMODE.EQ.-7)THEN IF(NXX.GT.NDIM23) THEN WRITE(6,850)NXX 850 FORMAT(/' TOO MANY EXPERIMENTAL POINTS, NEED INCREASE' X ,' NDIM23 TO AT LEAST',I5) STOP '*** INCREASE NDIM23' ENDIF READ(3,*) (EXX(L,I),I=1,NXX) READ(3,*) (SXX(L,I),I=1,NXX) READ(3,*)(ERSXX(L,I),I=1,NXX) C ELSE C READ(3,*)(SXX(L,I),I=1,NXX) ELSE IF(NXX.GT.50)ISYM=2 E1=EMIN/T E2=EMAX/T J=0 DO I=1,NXX READ(3,*)T1,T2,T3 IF(T1.GT.E1.AND.T1.LT.E2)THEN J=J+1 IF(J.LE.NDIM23)THEN EXX(L,J)=T1 SXX(L,J)=T2 ERSXX(L,J)=T3 ENDIF ENDIF ENDDO IF(J.GT.NDIM23)THEN WRITE(6,850)J NXX=NDIM23 ELSE NXX=J ENDIF ENDIF C DO I=1,NXX IF(XSTEP.NE.0.0)EXX(L,I)=(I-1)*XSTEP IF(CONVRT.NE.0.0)SXX(L,I)=SXX(L,I)/ABS(CONVRT) EXX(L,I)=EXX(L,I)/UNITX C CONVERT TO V*SIGMA IF SIGMA READ-IN, CASE CONVRT.LT.0 EWIDTH.EQ.0 C SET CONVRT.EQ.-1 IF SIGMA UNITS 1.E-18 IF(EWIDTH.EQ.0.0.AND.CONVRT.LT.0.0) C SXX(L,I)=21.877*SQRT(ABS(EXX(L,I)))*SXX(L,I) C C CONVERT TO SIGMA IF V*SIGMA READ-IN, CASE CONVRT.LT.0 EWIDTH.GT.0 C SET CONVRT.EQ.-1 IF V*SIGMA UNITS 1.E-11 IF(EWIDTH.GT.0.0.AND.CONVRT.LT.0.0) C SXX(L,I)=SXX(L,I)/(21.877*SQRT(ABS(EXX(L,I)))) C EXX(L,I)=EXX(L,I)*UNITS SXX(L,I)=SXX(L,I)-XCOR EXX(L,I)=EXX(L,I)-ECOR ENDDO C GO TO 158 156 IF(NX0.LT.0)LMAX=L-1 END IF NX=NXX C C ENERGY BINS C EBIN(1)=EMIN C EBIN(NBIN)=EMAX C DBIN=NBIN1 IF(ILOG.LT.0)THEN EMAX=LOG10(EMAX) EMIN=LOG10(EMIN) END IF IF(NPUB.EQ.-2)GO TO 75 IF(IMODE.EQ.-2)LMAX=4 NT=2*NBIN1+1 IF(NT.LT.201.AND.NPUB.NE.-1)NT=201 C C RESOLVE LORENTZIAN ON FINE MESH BUT CONVOLUTE ON COARSE C IF(IMODE.EQ.-5)THEN IF(NGAUSS.LE.0)NGAUSS=NDIM3 IF(IGAUSS.LE.0)IGAUSS=NGAUSS/(NT-1) IF(IGAUSS.LT.1)IGAUSS=1 NT=(NGAUSS-IGAUSS+1)/IGAUSS NT=NT*IGAUSS NP=NP*IGAUSS ELSE IGAUSS=1 ENDIF C T=NT-1 EH=(EMAX-EMIN)/T DO I=1,NT T=I-1 E0=EMIN+T*EH IF(ILOG.LT.0)E0=10.0**E0 ET(I)=E0/UNITS ENDDO IF(NC.GT.0.AND..NOT.BLOR.AND.NBIN0.GT.0)GO TO 76 ERES=(EMAX-EMIN)/DBIN DO I=1,NBIN T=I-1 T=EMIN+T*ERES IF(ILOG.LT.0)T=10.0**T EBIN(I)=T/UNITS ENDDO IF(ILOG.LT.0)WRITE(6,18)NR1,NR2 18 FORMAT(/1X,'LOGARITHMIC ENERGY BIN, ', X10X,'NR1=',I3,5X,'NR2=',I3//) IF(ILOG.GE.0)WRITE(6,21)ERES,NR1,NR2 21 FORMAT(/5X,'ERES=',1PE12.4,10X,'NR1=',I3,5X,'NR2=',I3//) 76 CONTINUE IF(ILOG.LT.0)THEN EMIN=10.0**EMIN EMAX=10.0**EMAX ENDIF C C GENERATE NON-RESONANT BACKGROUND C C EX, OR RR FROM R-MATRIX IF(IMODE.NE.-9)CALL BEX(NBINR,NBINM,LMAX,JCFA) C E-A IF(IMODE.EQ.-9)CALL BEXA(NBINR,NBINM,JCFA,LMAX) C RR FROM AUTOSTRUCTURE IF(JCFA.EQ.0.AND..NOT.BBACK)CALL BRR(NBINM,LMAX,NCUT,LCUT,IWT,EI X,NCUTR,NCUTRR,NECOR,IPRINT,IMODE,NMIN,LMIN) C C READ-IN R-MATRIX DATA FOR COMPARISON WITH IP-IR-DW C CALL RMATRX(LMAX,BRMDAT,YMULT,UNITS,JCFA,IMODE) C IF(NBIN0.LT.0)GO TO 75 DO I=1,NBIN1 DO L=1,LMAX SBIN(L,I)=0.0 ENDDO ENDDO IF(NC.GT.0)GO TO 77 C C SUM OVER CROSS SECTIONS C IF(IMODE.EQ.-8.OR.IMODE.EQ.-15)THEN C WRITE(6,*)'JET OPTION NO LONGER SUPPORTED: USE ADASDR INSTEAD' C ELSE C CALL CROSSX(ITHETA,ISP,IMODE,NBIN1,NBINM,NR1,NR2,NCUT,LCUT,NECOR X ,NRSLMX,ECORI,EI,IWT,NBINR,ILOG,UNITS,IPRINT,TOLR,ACOR,RCOR,EBIN X ,SBIN,EWIDTH,IZ,LMAX,IWS,IWL,ERSOL,NMIN,LMIN,IUP,IPARNT,TOLE) C ENDIF C IF(IMODE.EQ.-1)GO TO 997 IF(IMODE.EQ.-2)GO TO 75 C C WRITE-OUT BINNED CROSS SECTIONS C WRITE(7,16)NBIN 16 FORMAT(I5) WRITE(7,78)(EBIN(I),I=1,NBIN) DO L=1,LMAX WRITE(7,78)(SBIN(L,I),I=1,NBIN1) 78 FORMAT(6(1PE12.6)) ENDDO C IF(NPUB.LT.-2)GO TO 997 GO TO 75 C C READ-IN BINNED CROSS SECTIONS, OR RESONANCE DATA. C 77 IF(BLOR)THEN DO I=1,NDIM11 READ(8,*,END=24)EREZ(I),GSIG(I),GAM(I),ITRAN(I),L1,L2 ENDDO WRITE(6,1009) 1009 FORMAT(/' ***** WARNING, UNABLE TO READ-IN ALL THE LORENTZIANS,' X ,' INCREASE NDIM11'/) I=NDIM11+1 24 JYMAX=I-1 ELSE DO N=1,NC READ(7,16)NBIN NBIN1=NBIN-1 READ(7,152)(EBIN(I),I=1,NBIN) DO L=1,LMAX READ(7,152)(TBIN(I),I=1,NBIN1) 152 FORMAT(6E12.6) DO I=1,NBIN1 SBIN(L,I)=SBIN(L,I)+TBIN(I) ENDDO ENDDO ENDDO IF(NBIN0.LT.0)NBIN=-NBIN NBIN0=NBIN NBIN=IABS(NBIN) ENDIF C 75 IF(NPUB.EQ.-1)GO TO 31 IF(NPUB.LT.-2)GO TO 997 C C INITIALISE GRAFX C CNCAR CALL NCAR1(NPUB,ILOG) C 31 LBMAX=LMAX IF(NX0.GT.0.AND..NOT.BRMDAT)LBMAX=1 IFIRST=0 C C *** START BIG LOOP OVER ALL TRANSITIONS (OUTPUT) C DO 2000 L=1,LBMAX IF(BPLOT.AND.L.NE.NPLOT)GO TO 2000 IF(BSCALE)THEN SMAX1=0.0 SMAX2=0.0 ENDIF IF(UNITS-150000.0.GT.0.0)THEN ISW=1 ELSE IF(UNITS-109000.0.GT.0.0)THEN ISW=2 ELSE IF(UNITS-13.0.GT.0.0)THEN ISW=3 ELSE IF(UNITS-0.9.GT.0.0)THEN ISW=4 ELSE IF(UNITS-0.4.GT.0.0)THEN ISW=5 ELSE ISW=6 END IF IF(NX.GT.0)THEN DO I=1,NX EX(I)=EXX(L,I) SX(I)=SXX(L,I) ERSX(I)=ERSXX(L,I) IF(BSCALE.AND.SX(I).GT.SMAX2)SMAX2=SX(I) IF(BSCALE.AND.SX(I).LT.SMIN2)SMIN2=SX(I) ENDDO ENDIF IF(NPUB.EQ.-2)GO TO 244 IF(IMODE.EQ.-2)THEN C C FIT SPLINE TO CASCADE COEFFICIENT FOR GRAPHICS C DO I=1,NBIN TBIN(I)=SBIN(L,I) ENDDO CALL SPLYN(NBIN,EBIN,TBIN,3,T,3,T,SP1,SP2,SP3,SP4,SP5) J1=0 IF(EWIDTH)93,93,95 93 T=1.0D11 GO TO 96 94 T=1.0D18 GO TO 96 95 IF(IZ.EQ.0)GO TO 94 T=1.0D21 96 IF(WEX(L,1).GT.0.0)T=T*WEX(L,1) DO I=1,NT,IGAUSS E0=ET(I) IF(ILOG.LT.0)E0=LOG10(E0) STC(I)=SPVAL(NBIN,EBIN,TBIN,SP1,SP2,SP3,SP4,E0,J1) IF(ILOG.LT.0)STC(I)=10.0**STC(I) STC(I)=STC(I)*T ENDDO GO TO 234 ELSE C LOAD SPLINE IF(BBACK.AND.ITYPE.GE.3.AND.LMAX.GT.1)CALL LOADSP(L) ENDIF C C OPTIONALLY ADD GROUND PLUS METASTABLE FRACTIONS C IF(IMODE.NE.-5)THEN DO J=1,NBIN1 IF(NX.EQ.0.OR.BRMDAT)GO TO 198 SBIN(L,J)=WEX(L,1)*SBIN(L,J) IF(NBINM.EQ.1)GO TO 198 DO M=2,NBINM SBIN(1,J)=SBIN(1,J)+WEX(1,M)*SBIN(M,J) ENDDO 198 TBIN(J)=SBIN(L,J) ENDDO ENDIF C IF(BRMDAT.AND.NX.NE.0)THEN IF(NX0.LT.0)STOP 'COINCIDENT EMISSION WITH R-MATRIX NOT CODED' DO I=1,NT STC(I)=0.0 STR(I)=0.0 ENDDO ENDIF C C CONVOLUTE CROSS SECTIONS C JSP=0 J0=1 DO 211 I=1,NT C E0=ET(I) IF(IMODE.EQ.-5)GO TO 201 C DO J=J0,NBIN1 IF(E0.GE.EBIN(J).AND.E0.LT.EBIN(J+1)) GO TO 230 ENDDO IF(E0.LT.EBIN(J0))THEN !ROUND-OFF ERROR J=J0 ELSE J=NBIN1 ENDIF C 230 J0=J ST(I)=TBIN(J0) C C DETERMINE TYPE OF CONVOLUTION C IF(EWIDTH)203,202,204 C C COMPTON C 204 IF(IZ.EQ.0.OR.BLOR)GO TO 201 SCC=CONVOLC(E0,IZ,EBIN,TBIN,NBIN0,L) IF(BRMDAT)SRR=RCONVOLC(E0,IZ,L) GO TO 200 C C LORENTZIAN C 201 IF(BLOR)THEN IF(BFEAR)THEN SCC=SBIN(NBINM+L,J0) IF(ITYPE.GE.3)THEN IF(NBINM.EQ.1)THEN IF(BBACK)SCC=SCC X +SPVAL(NENG,ENERG,PCS,SP1,SP2,SP3,SP4,EBIN(J0+1),JSP) X /EBIN(J0+1) ELSE STOP 'RELOAD SPLINE FOR MORE THAN ONE TARGET STATE' ENDIF ELSE IF(BBACK)THEN U=EBIN(J0+1)/SIGMA(L,7) IF(U.LE.0.0)U=1.0-U IF(U.GE.1.0)THEN TT=SIGMA(L,1)+SIGMA(L,2)/U+SIGMA(L,3)/(U*U) X +SIGMA(L,4)*LOG(U)+SIGMA(L,5)*LOG(U)/U ENDIF TT=TT/(EBIN(J0+1)-SIGMA(L,6)) SCC=SCC+TT ENDIF ENDIF ELSE IF(BRMDAT)SRR=RCONVOLL(E0,L) SCC=CONVOLL(E0,L) ENDIF ELSE C C GAUSSIAN C IF(E0.EQ.0.0)E0=ET(1) SCC=CONVOLG(E0,EWIDTH,EBIN,TBIN,NBIN0,L) IF(BRMDAT)SRR=RCONVOLG(E0,EWIDTH,L) ENDIF GO TO 200 C C COOLER C !SWITCH AT HIGH-E 202 IF(E0*B00**4.LT.100.*(A00**2-B00**2).AND.E0.LT.ESWTCHX)THEN SCC=CONVOLX(E0,EBIN,TBIN,NBIN0,L) IF(BRMDAT)SRR=RCONVOLX(E0,L) ELSE IF(IFIRST.EQ.0)THEN IFIRST=1 WRITE(6,1037)E0*UNITS 1037 FORMAT(//'***NOTE: COOLER DISTRIBUTION SWITCHES TO SCALED' X, ' GAUSSIAN AT E(UNITS)=',F7.3) ENDIF SCC=21.877*SQRT(E0)*CONVOLG(E0,E9999,EBIN,TBIN,NBIN0,L) IF(BRMDAT)SRR=21.877*SQRT(E0)*RCONVOLG(E0,E9999,L) ENDIF GO TO 200 C C MAXWELLIAN C 203 IF(E0.EQ.0.0)E0=1.E-10 SCC=CONVOLM(E0,EBIN,TBIN,NBIN,L) IF(BRMDAT)SRR=RCONVOLM(E0,L) C 200 IF(NX.NE.0.AND.BRMDAT)THEN STC(I)=STC(I)+SCC*WEX(1,L) STR(I)=STR(I)+SRR*WEX(1,L) ELSE STC(I)=SCC STR(I)=SRR ENDIF C 211 CONTINUE C C CONVOLUTE LORENTZIAN WITH GAUSSIAN OR COOLER DISTRIBUTION C IF(IMODE.EQ.-5)THEN IF(IZ.NE.0)STOP 1134 DO I=1,NT ST(I)=STC(I) ENDDO C C TRY & ELIMINATE UNRESOLVED RESONANCES DO I=3,NT QMN=MIN(ST(I-2),ST(I)) QMX=MAX(ST(I-2),ST(I)) IF(ST(I-1).GT.QMX*YMULT)THEN WRITE(94,*)I-1,UNITS*ET(I-1),ST(I-2),ST(I-1),ST(I) ST(I-1)=QMN*1.01 ENDIF ENDDO DO I=1,NT,IGAUSS E0=ET(I) STC(I)=CONVOL(E0,EWIDTH,ET,ST,NT,L) ENDDO BLOR=.FALSE. ENDIF C C SET BOUNDS FOR PLOTS C 234 DO I=1,NT ET(I)=ET(I)*UNITS IF(BSCALE)THEN IF(ST(I).GT.SMAX1)SMAX1=ST(I) IF(ST(I).LT.SMIN1)SMIN1=ST(I) ENDIF IF(ILOG.LE.0)THEN IF(ST(I).LT.SORIG1) ST(I)=SORIG1 ENDIF ENDDO C DO I=1,NT,IGAUSS STC(I)=STC(I)*10.**IBARN IF(BRMDAT)STR(I)=STR(I)*10.**IBARN IF(BSCALE)THEN IF(STC(I).GT.SMAX2)SMAX2=STC(I) IF(STC(I).LT.SMIN2)SMIN2=STC(I) IF(BRMDAT)THEN IF(STR(I).GT.SMAX2)SMAX2=STR(I) IF(STR(I).LT.SMIN2)SMIN2=STR(I) ENDIF ENDIF IF(ILOG.LE.0)THEN IF(STC(I).LT.SORIG2) STC(I)=SORIG2 IF(BRMDAT)THEN IF(STR(I).LT.SORIG2) STR(I)=SORIG2 ENDIF ELSE IF(STC(I).LT.1.D-99)STC(I)=0.0D0 IF(BRMDAT)THEN IF(STR(I).LT.1.D-99)STR(I)=0.0D0 ENDIF ENDIF ENDDO IF(NPUB.EQ.-1)GO TO 32 C C PLOT ENERGY-AVERAGED AND CONVOLUTED CROSS SECTIONS C 244 SUNIT=UNITS SWIDTH=EWIDTH C CNCAR CALL NCAR2( L,IMODE,NPUB,BLOR,NC,BSCALE,XSIZE,YSIZE,JCFA,ILOG,EMIN CNCAR X,EMESH,EMAX,SMIN1,SMESH1,SMAX1,EORIG,ESTEP,SORIG1,SCYCLE,TORIG, CNCAR XTCYCLE,ET,ST,NT,SWIDTH,IZ,ITHETA,TPAR,TPER,SUNIT,ISW,SMIN2,SMESH2, CNCAR XSMAX2,SORIG2,STC,EX,SX,ERSX,NX,LBMAX,STR,BRMDAT,ISYM,IGAUSS,IBARN) C C PRINTED OUTPUT C 32 IF(NX.GT.0) THEN WRITE(6,300) 300 FORMAT(//1X,'EXPERIMENTAL DATA') WRITE(6,310) 310 FORMAT(/1X,'ENERGIES') WRITE(6,320) (EX(I),I=1,NX) 320 FORMAT(1X,10F10.4) IF(EWIDTH.GT.0.0.AND.IZ.EQ.0) WRITE(6,330) 330 FORMAT(/1X,'CROSS SECTION (10-18 CM**2)') IF(IZ.GT.0)WRITE(6,331) 331 FORMAT(/1X,'CROSS SECTION (10-21 CM**2)') IF(EWIDTH.EQ.0.0) WRITE(6,335) 335 FORMAT(/1X,'V*SIGMA (10-11 CM**3/S)') IF(EWIDTH.LT.0.0)WRITE(6,333) 333 FORMAT(/1X,'RATE COEFFICIENT (10-11 CM**3/S)') WRITE(6,340) (SX(I),I=1,NX) 340 FORMAT(1X,10F10.5) END IF C IF(NPUB.NE.-2)THEN IF(EWIDTH.GT.0.0) WRITE(6,350) 350 FORMAT(//1X,'THEORETICAL CROSS SECTION') IF(EWIDTH.EQ.0.0) WRITE (6,355) 355 FORMAT(//1X,'THEORETICAL VALUES OF V*SIGMA') IF(EWIDTH.LT.0.0)WRITE(6,360) 360 FORMAT(//1X,'THEORETICAL RATE COEFFICIENT') WRITE(6,310) WRITE(6,320) (ET(I),I=1,NT,NP) IF(EWIDTH.GT.0.0.AND.IZ.EQ.0) WRITE(6,330) IF(IZ.GT.0)WRITE(6,331) IF(EWIDTH.EQ.0.0) WRITE(6,335) IF(EWIDTH.LT.0.0)WRITE(6,333) WRITE(6,340) (STC(I),I=1,NT,NP) C WRITE(13,*)'#' IF(BRMDAT)WRITE(16,*)'#' DO I=1,NT,IGAUSS IF(ILOG.GE.-1)THEN WRITE(13,366)ET(I),STC(I) IF(BRMDAT)WRITE(16,366)ET(I),STR(I) ELSE WRITE(13,366)LOG10(ET(I)),LOG10(STC(I)) IF(BRMDAT)WRITE(16,366)LOG10(ET(I)),LOG10(STR(I)) ENDIF ENDDO C 365 FORMAT(F12.5,1PE14.4) 366 FORMAT(1PE16.8,E14.4) C DO I=1,NT ET(I)=ET(I)/UNITS ENDDO ENDIF C 2000 CONTINUE C C *** END BIG LOOOP OVER ALL TRANSITIONS C IF(NPUB.EQ.-1)GO TO 997 C C CLOSE GRAFX CNCAR CALL NCAR3 C 997 RETURN C END C*********************************************************************** REAL*8 FUNCTION QDT(QD,NZ0,NE,N,L) IMPLICIT REAL*8 (A-H,O-Z) C EVALUATES ONE-ELECTRON ENERGY WITH NON-ZERO QUANTUM DEFECT C C : QD0, UNIVERSAL QUANTUM DEFECT GIVEN BY C QD0*(NE**1.67-1)/(Z0**.67*Z**.33*(1+L**3)) C CURRENT VALUE IN FUNCTION QDT IS QD0=0.182 C PARAMETER (QD0=0.182) COMMON /QDTS/QDTS(0:30),NQDT C IF(N.LE.0)THEN QD=0.0 QDT=0.0 RETURN ENDIF TZ0=NZ0 TZ=NZ0-NE+1 IF(L.LT.0.OR.NE.LE.1)THEN QD=0.0 ELSE IF(NQDT.GT.L)THEN QD=QDTS(L) ELSE TL=L**3+1 TE=NE QD=QD0*(TE**1.667-1.0)/(TZ0**0.667*TZ**0.333*TL) ENDIF ENDIF TN=N TN=TN-QD QDT=-(TZ/TN)**2 RETURN END C*********************************************************************** REAL*8 FUNCTION RCONVOLC(E,IZ,L) IMPLICIT REAL*8 (A-H,O-Z) C C CONVOLUTE R-MATRIX CROSS SECTION WITH COMPTON PROFILE. C C******SHOULD ONLY BE USED WHERE RESONANCES DOMINATE SINCE IT ASSUMES C THAT THE CROSS SECTION IS ZERO OUTSIDE OF THE TABULATION.******* C PARAMETER(NDIM2=36,NDIM43=300001,NDIM45=5,NDIM46=NDIM43) PARAMETER(NTMR=100,NDIM5=150) COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /RMXQ/EMSHRX(NDIM43),OMEGA(NDIM46),RMXN(NDIM45,NDIM43) X ,EVECR(NDIM46),ENAT(NTMR),MXE DIMENSION ET(10) DATA (ET(I),I=1,10)/1.14,1.81,0.40,0.69,0.0,0.83,0.0,0.0,0.0,1.59/ C ANS=0.0 TE=SQRT(E) IF(TE.LT.1.D-40)GO TO 3 TE=0.5/TE DO 1 I=1,MXE EVECR(I)=EMSHRX(I)-ENAT(IREV(L,1)) Q=(EVECR(I)+ET(IZ)-E)*TE TT=RMXN(L,I) OMEGA(I)=TT*COMPTON(IZ,Q) 1 CONTINUE C IF(MXE.GT.5)GO TO 2 RCONVOLC=0.0 RETURN C 2 IF(MXE.GT.NDIM46)THEN WRITE(6,101)MXE 101 FORMAT(' SR.RCONVOLC: INCREASE NDIM46 TO: ',I6) STOP ' SR.RCONVOLC: INCREASE NDIM46' ENDIF C IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVECR,OMEGA,MXE,ANS,ER,IFAIL) CDP CALL D01GAF(EVECR,OMEGA,MXE,ANS,ER,IFAIL) C C IF(ANS.GT.1.0E-1.AND.ABS(ER).GT.1.0E-3*ANS)THEN C WRITE(6,*)E,ANS,ER C IF(ABS(ER).GT.1.0E-2*ANS)STOP 16 C ENDIF IF(IFAIL.NE.0)THEN WRITE(6,100)IFAIL 100 FORMAT(' SR.RCONVOLC: IFAIL=',I3) STOP 17 ENDIF C ELSE ANS=TRAP(EVECR,OMEGA,MXE) ENDIF C 3 RCONVOLC=ANS*TE RETURN END C*********************************************************************** REAL*8 FUNCTION RCONVOLG(E0,EWIDTH,L) IMPLICIT REAL*8 (A-H,O-Z) C C CONVOLUTE R-MATRIX CROSS SECTION WITH GAUSSIAN C PARAMETER(NDIM2=36,NDIM43=300001,NDIM45=5,NDIM46=NDIM43) PARAMETER(NTMR=100,NDIM5=150) COMMON /DITT/A00,B00 COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /RMXQ/EMSHRX(NDIM43),OMEGA(NDIM46),RMXN(NDIM45,NDIM43) X ,EVECR(NDIM46),ENAT(NTMR),MXE COMMON /LOTZ/TLOTZ(5,5),ELOTZ(5,5),NLOTZ C E=E0+ENAT(IREV(L,1)) C TL=0.0 DO 33 N=1,NLOTZ IF(TLOTZ(L,N).GT.0.0)THEN IF(E.GT.ELOTZ(L,N))TL=TL+TLOTZ(L,N)*LOG(E/ELOTZ(L,N))/E ENDIF 33 CONTINUE C IF(E.LT.EMSHRX(1))THEN RCONVOLG=TL RETURN ENDIF IF(E.GT.EMSHRX(MXE))THEN RCONVOLG=RMXN(L,MXE)+TL RETURN ENDIF C IF(EWIDTH.LT.200.0)THEN A=1.6651092/EWIDTH ELSE C HEIDELBERG SCALING (A0=A=1.0/SQRT(kTpar(Ryd)) NEGLECT B (kTperp) OF C OF DOUBLE MAXWELLIAN). A0=58.3 IF(A00.GT.0.0)A0=A00 A=0.5*A0/SQRT(E0) ENDIF C PIE=ACOS(-1.0) EMIN=E-PIE/A IF(EMIN.LT.EMSHRX(1))EMIN=EMSHRX(1) IF(EMIN.LE.0.0)EMIN=1.0E-20 EMAX=E+PIE/A IF(EMAX.GT.EMSHRX(MXE))EMAX=EMSHRX(MXE) C II=0 DO 1 I=1,MXE IF(EMSHRX(I).LT.EMIN)GO TO 1 IF(EMSHRX(I).GT.EMAX)GO TO 3 II=II+1 EVECR(II)=EMSHRX(I)-ENAT(IREV(L,1)) T=(EMSHRX(I)-E)*A T=T*T TT=RMXN(L,I) DO 34 N=1,NLOTZ IF(EVECR(II).GT.ELOTZ(L,N))THEN TL=TLOTZ(L,N)*LOG(EVECR(II)/ELOTZ(L,N))/EVECR(II) TT=TT+TL ENDIF 34 CONTINUE OMEGA(II)=TT*EXP(-T) 1 CONTINUE C 3 IF(II.GT.5)GO TO 2 RCONVOLG=0.0 RETURN C 2 IF(II.GT.NDIM46)THEN WRITE(6,101)II 101 FORMAT(' SR.RCONVOLG: INCREASE NDIM46 TO: ',I6) STOP ' SR.RCONVOLG: INCREASE NDIM46' ENDIF C IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVECR,OMEGA,II,ANS,ER,IFAIL) CDP CALL D01GAF(EVECR,OMEGA,II,ANS,ER,IFAIL) C C IF(ANS.GT.1.0E-1.AND.ABS(ER).GT.1.0E-3*ANS)THEN C WRITE(6,*)E,ANS,ER C IF(ABS(ER).GT.1.0E-2*ANS)STOP 16 C ENDIF IF(IFAIL.NE.0)THEN WRITE(6,100)IFAIL 100 FORMAT(' SR.RCONVOLG: IFAIL=',I3) STOP 17 ENDIF C ELSE ANS=TRAP(EVECR,OMEGA,II) ENDIF C RCONVOLG=ANS*A*0.5641895 RETURN END C*********************************************************************** REAL*8 FUNCTION RCONVOLL(E0,L) IMPLICIT REAL*8 (A-H,O-Z) C C INTERPOLATE R-MATRIX CROSS SECTION FOR E C PARAMETER(NDIM2=36,NDIM43=300001,NDIM45=5,NDIM46=NDIM43) PARAMETER(NTMR=100,NDIM5=150) COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /RMXQ/EMSHRX(NDIM43),OMEGA(NDIM46),RMXN(NDIM45,NDIM43) X ,EVECR(NDIM46),ENAT(NTMR),MXE C E=E0+ENAT(IREV(L,1)) C IF(E.LT.EMSHRX(1))THEN RCONVOLL=0.0 RETURN ENDIF IF(E.GE.EMSHRX(MXE))THEN RCONVOLL=RMXN(L,MXE) RETURN ENDIF C DO 1 I=2,MXE IF(E.LT.EMSHRX(I))GO TO 2 1 CONTINUE 2 T1=(EMSHRX(I)-E)/(EMSHRX(I)-EMSHRX(I-1)) T2=(E-EMSHRX(I-1))/(EMSHRX(I)-EMSHRX(I-1)) RCONVOLL=T1*RMXN(L,I-1)+T2*RMXN(L,I) RETURN END C*********************************************************************** REAL*8 FUNCTION RCONVOLM(E,L) IMPLICIT REAL*8 (A-H,O-Z) C C CONVOLUTE R-MATRIX CROSS SECTION WITH MAXWELLIAN ENERGY DISTRIBUTION. C C******SHOULD ONLY BE USED FOR RECOMBINATION SINCE IT ASSUMES THAT C THE CROSS SECTION IS ZERO OUTSIDE OF THE TABULATION.******* C PARAMETER(NDIM2=36,NDIM43=300001,NDIM45=5,NDIM46=NDIM43) PARAMETER(NTMR=100,NDIM5=150) COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /RMXQ/EMSHRX(NDIM43),OMEGA(NDIM46),RMXN(NDIM45,NDIM43) X ,EVECR(NDIM46),ENAT(NTMR),MXE C DO 1 I=1,MXE EVECR(I)=EMSHRX(I)-ENAT(IREV(L,1)) T=EVECR(I)/E TT=RMXN(L,I)*EVECR(I) OMEGA(I)=TT*EXP(-T) 1 CONTINUE T=SQRT(E) C IF(MXE.GT.5)GO TO 2 RCONVOLM=0.0 RETURN C 2 IF(MXE.GT.NDIM46)THEN WRITE(6,101)MXE 101 FORMAT(' SR.RCONVOLM: INCREASE NDIM46 TO: ',I6) STOP ' SR.RCONVOLM: INCREASE NDIM46' ENDIF C IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVECR,OMEGA,MXE,ANS,ER,IFAIL) CDP CALL D01GAF(EVECR,OMEGA,MXE,ANS,ER,IFAIL) C C IF(ANS.GT.1.0E-1.AND.ABS(ER).GT.1.0E-3*ANS)THEN C WRITE(6,*)E,ANS,ER C IF(ABS(ER).GT.1.0E-2*ANS)STOP 16 C ENDIF IF(IFAIL.NE.0)THEN WRITE(6,100)IFAIL 100 FORMAT(' SR.RCONVOLM: IFAIL=',I3) STOP 17 ENDIF C ELSE ANS=TRAP(EVECR,OMEGA,MXE) ENDIF C RCONVOLM=ANS*24.6854/(T*E) RETURN END C*********************************************************************** REAL*8 FUNCTION RCONVOLX(E,L) IMPLICIT REAL*8 (A-H,O-Z) C C CONVOLUTE R-MATRIX CROSS SECTION WITH COOLER DISTRIBUTION C PARAMETER(NDIM2=36,NDIM43=300001,NDIM45=5,NDIM46=NDIM43) PARAMETER(NTMR=100,NDIM5=150) COMMON /DITT/A00,B00 COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /RMXQ/EMSHRX(NDIM43),OMEGA(NDIM46),RMXN(NDIM45,NDIM43) X ,EVECR(NDIM46),ENAT(NTMR),MXE COMMON /LOTZ/TLOTZ(5,5),ELOTZ(5,5),NLOTZ DATA DUM/-999./,EZERO/0.01/ C TL=0.0 DO 33 N=1,NLOTZ IF(TLOTZ(L,N).GT.0.0)THEN IF(E.GT.ELOTZ(L,N))TL=TL+TLOTZ(L,N)*LOG(E/ELOTZ(L,N))/E ENDIF 33 CONTINUE C IF(E.LT.2.*EMSHRX(1)-ENAT(IREV(L,1))-EMSHRX(2))THEN RCONVOLX=(TL+TL)*10.938*SQRT(E) RETURN ENDIF C IF(E.GT.EMSHRX(MXE)-ENAT(IREV(L,1)))THEN TL=TL+RMXN(L,MXE) RCONVOLX=(TL+TL)*10.938*SQRT(E) RETURN ENDIF C C ESTIMATE WIDTH OF COOLER DISTRIBUTION....... C A0=100.0 IF(A00.GT.0.0)A0=A00 B0=10.0 IF(B00.GT.0.0)B0=B00 T=10.0/B0**2 A=1.0E6 IF(E.GT.1.0E-10)A=0.5*A0/SQRT(E) PIE=ACOS(-1.0) EMIN=MIN(E-PIE/A,E-T) IF(EMIN.LT.EMSHRX(1)-ENAT(IREV(L,1))) XEMIN=EMSHRX(1)-ENAT(IREV(L,1)) IF(EMIN.LE.0.0)EMIN=1.0D-70 EMAX=MAX(E+PIE/A,E+T) IF(EMAX.GT.EMSHRX(MXE)-ENAT(IREV(L,1))) XEMAX=EMSHRX(MXE)-ENAT(IREV(L,1)) C IF(E.LT.EZERO)THEN C C USE CONSTANT STEP IN SQRT(ENERGY) NEAR ZERO; INTERPOLATE OMEGA C EMESH=EMSHRX(2)-EMSHRX(1) NPTS=(EMAX-EMIN)/EMESH +1 IF(NPTS.LT.6)NPTS=6 EMESH=NPTS-1 C C TRANSFORM INTEGRAL TO AVOID SINGULARITY AT E=0 USING U=SQRT(E) C EMAX=SQRT(EMAX) EMIN=SQRT(EMIN) EMESH=(EMAX-EMIN)/EMESH C I0=2 DO 5 J=1,NPTS T=J-1 EVECR(J)=EMIN+T*EMESH EU=EVECR(J)*EVECR(J) DO 1 I=I0,MXE IF(EU.GE.EMSHRX(I-1)-ENAT(IREV(L,1)).AND. XEU.LT.EMSHRX(I)-ENAT(IREV(L,1)))GO TO 6 1 CONTINUE I=0 IF(J.EQ.1)I=2 IF(J.EQ.NPTS)I=MXE IF(I.EQ.0)STOP 'RCONVOLX: MESH SCREW-UP??' 6 I0=I E1=EMSHRX(I-1)-ENAT(IREV(L,1)) IF(E1.EQ.0.0)E1=1.0D-70 E2=EMSHRX(I)-ENAT(IREV(L,1)) T1=E1*(E2-EU)/(E2-E1) T2=E2*(E1-EU)/(E1-E2) TT=T1*RMXN(L,I-1)+T2*RMXN(L,I) TT=TT/EU DO 34 N=1,NLOTZ IF(EU.GT.ELOTZ(L,N))THEN TL=TLOTZ(L,N)*LOG(EU/ELOTZ(L,N))/EU TT=TT+TL ENDIF 34 CONTINUE OMEGA(J)=TT*DITTNER(DUM,EU,E)/EVECR(J) 5 CONTINUE C ELSE C C USE CONSTANT STEP IN ENERGY; NO INTERPOLATION. C II=0 DO 4 I=1,MXE IF(EMSHRX(I)-ENAT(IREV(L,1)).LT.EMIN)GO TO 4 IF(EMSHRX(I)-ENAT(IREV(L,1)).GT.EMAX)GO TO 3 II=II+1 EVECR(II)=SQRT(EMSHRX(I)-ENAT(IREV(L,1))) TT=RMXN(L,I) DO 35 N=1,NLOTZ IF(EMSHRX(I)-ENAT(IREV(L,1)).GT.ELOTZ(L,N))THEN T=TLOTZ(L,N)*LOG(EMSHRX(I)-ENAT(IREV(L,1))/ELOTZ(L,N))/(EMSHRX(I) X-ENAT(IREV(L,1))) TT=TT+T ENDIF 35 CONTINUE OMEGA(II)=TT*DITTNER(DUM,EMSHRX(I)-ENAT(IREV(L,1)),E)/EVECR(II) 4 CONTINUE 3 NPTS=II C ENDIF C IF(NPTS.GT.5)GO TO 2 TL=TL+RCONVOLL(E,L) RCONVOLX=(TL+TL)*10.938*SQRT(E) WRITE(6,*)' ***WARNING, SR.RCONVOLX: INSUFFICIENT POINTS' X,' TO CONVOLUTE AT E=',E RETURN C 2 IF(NPTS.GT.NDIM46)THEN WRITE(6,101)II 101 FORMAT(' SR.RCONVOLX: INCREASE NDIM46 TO: ',I6) STOP 18 ENDIF C IF(INAG.GT.0)THEN IFAIL=0 C NAG D01GAE,F CSP CALL D01GAE(EVECR,OMEGA,NPTS,TL,ER,IFAIL) CDP CALL D01GAF(EVECR,OMEGA,NPTS,TL,ER,IFAIL) C C IF(TL.GT.1.0E-1.AND.ABS(ER).GT.1.0E-3*TL)THEN C WRITE(6,*)E,TL,ER C IF(ABS(ER).GT.1.0E-2*TL)STOP 16 C ENDIF C IF(IFAIL.NE.0)THEN WRITE(6,100)IFAIL 100 FORMAT(' SR.RCONVOLX: IFAIL=',I3) STOP 17 ENDIF C ELSE TL=TRAP(EVECR,OMEGA,NPTS) ENDIF C TL=TL+TL C RCONVOLX=(TL+TL)*10.938 C RETURN END C C**************************************************************** C SUBROUTINE RMATRX(LMAX,BRMDAT,YMULT,UNITS,JCFA,IMODE) IMPLICIT REAL*8 (A-H,O-Z) C C READ-IN N-STATE R-MATRIX OMEGA FILE TO BE COMPARED WITH IP-IR-DW C PARAMETER(NDIM43=300001,NTMR=100,NDIM2=36,NDIM5=150,NDIM45=5 X,NDIM46=NDIM43) LOGICAL BRMDAT,BLASR DIMENSION AYLD(NTMR),LSPJ(NTMR),EII(NTMR) COMMON /LABEL/IMX(NDIM5,NDIM5),IREV(NDIM2,2),INAG COMMON /RMXQ/EMSHRX(NDIM43),OMEGA(NDIM46),RMXN(NDIM45,NDIM43) X ,EVECR(NDIM46),ENAT(NTMR),MXE DIMENSION CON(NDIM5),ISAT(NTMR),LAT(NTMR) X,IMX0(NDIM5,NTMR) C BRMDAT=.FALSE. READ(12,*,END=75)IDUM REWIND(12) C IF(IMODE.EQ.-9)THEN NYLD=0 EAUTO=0.0 REWIND(15) READ(15,*,END=5)NYLD,EAUTO IF(NYLD.GT.NTMR)THEN WRITE(6,*) ' SR.RMATRX: INCREASE NTMR FROM ',NTMR,' TO ',NYLD X,' TO OBTAIN NON-UNITY AUGER YIELDS FOR REMAINING STATES' NYLD=NTMR ENDIF DO 4 I=1,NYLD READ(15,*)II,LSPJ(II),EII(II),AYLD(II) 4 CONTINUE ENDIF C 5 BLASR=.FALSE. C DEFAULT, NO ELASTIC OMEGAS FROM R-MATRIX FOR IONS. C READ(12,*)NZED,NELC C BRMDAT=.TRUE. IF(NZED.EQ.NELC)THEN BLASR=.TRUE. TAZ=1.0 ELSE IF(JCFA.EQ.0)BLASR=.TRUE. TAZ=NZED-NELC TAZ=TAZ*TAZ ENDIF C READ(12,*)NAST,MXE,NOMWRT C IF(NAST.GT.NTMR)THEN WRITE(6,100)NAST 100 FORMAT(//' SR.RMATRX, INCREASE NTMR TO AT LEAST ',I3) STOP 38 ENDIF C READ(12,*)(ISAT(I),LAT(I),I=1,NAST) READ(12,*)(ENAT(I),I=1,NAST) C 710 FORMAT(5E16.6) C IF(IMODE.EQ.-9)THEN WRITE(6,106) 106 FORMAT(//' MATCHING OF STATES FOR EXCITATION-AUTOIONIZATION'/ X,' II',6X,'LSPJ',7X,'EII',5X,'N',5X,'LTEST',6X,'ENAT') EAUTO=EAUTO/TAZ NYLD0=0 DO 6 N=1,NAST IF(ENAT(N).LE.EAUTO)THEN NYLD0=N ELSE II=N-NYLD0 IF(II.GT.NYLD)GO TO 2 IF(ISAT(N).NE.0)THEN LTEST=100*LAT(N)+10000*IABS(ISAT(N)) IF(ISAT(N).LT.0)LTEST=-LTEST IF(LTEST.NE.LSPJ(II))THEN WRITE(6,*)' SR.RMATRX: MIS-MATCH OF STATES FOR E-A, ' X,II,LSPJ(II),N,LTEST STOP ENDIF ELSE LTEST=ABS(LAT(N))-1 IF(LAT(N).LT.0)LTEST=-LTEST L1=IABS(LSPJ(II)) L2=L1/10000 L2=L1-L2*10000 L3=L2/100 L3=L2-L3*100 IF(LSPJ(II).LT.0)L3=-L3 IF(LTEST.NE.L3)THEN WRITE(6,*)' SR.RMATRX: MIS-MATCH OF STATES FOR E-A, ' X,II,LSPJ(II),N,LTEST STOP ENDIF ENDIF WRITE(6,105)II,LSPJ(II),EII(II),N,LTEST,ENAT(N)*TAZ 105 FORMAT(I3,I10,F12.5,3X,I3,I10,F12.5) ENDIF 6 CONTINUE ENDIF C 2 IF(NOMWRT.EQ.(NAST*(NAST+1))/2)BLASR=.TRUE. IF(.NOT.BLASR)NOMT=(NAST*(NAST-1))/2 IF(BLASR)NOMT=(NAST*(NAST+1))/2 IF(NOMWRT.GT.0)NOMT=NOMWRT IF(NOMT.GT.NDIM46)THEN WRITE(6,103)NOMT 103 FORMAT(//' SR.RMATRX, INCREASE NDIM46 TO AT LEAST ',I3) BRMDAT=.FALSE. RETURN ENDIF IF(LMAX.GT.NDIM45)THEN WRITE(6,101)LMAX 101 FORMAT(//' SR.RMATRX, INCREASE NDIM45 TO AT LEAST ',I3) BRMDAT=.FALSE. RETURN ENDIF C N=0 DO 7 I=1,NAST ENAT(I)=ENAT(I)*TAZ IF(I.GT.NDIM5)GO TO 7 IF(ISAT(I).NE.0)THEN W=ABS(ISAT(I))*(2*LAT(I)+1) ELSE W=ABS(LAT(I)) ! B.P. LAT=2*J+1 ENDIF CON(I)=87.9735/W IMX0(I,I)=0 IP=I+1 IF(BLASR)IP=I IF(IP.GT.NAST)GO TO 7 DO 8 J=IP,NAST N=N+1 IMX0(I,J)=N 8 CONTINUE 7 CONTINUE C IF(MXE.GT.NDIM43)THEN WRITE(6,*)' SR.RMATRX: MXE REDUCED TO ',NDIM43,' INCREASE NDIM43' X,' TO ',MXE,' TO RETAIN ALL INPUT ENERGIES' MXE=NDIM43 ENDIF DO 1 IE=1,MXE C READ(12,*)EMSHRX(IE),(OMEGA(N),N=1,NOMT) C 700 FORMAT(E11.5,6(E11.3)/(11X,6(E11.3))) C EMSHRX(IE)=EMSHRX(IE)*TAZ C DO 9 L=1,LMAX RMXN(L,IE)=0.0 J=IREV(L,2) IF(J.GT.0)THEN IF((EMSHRX(IE)-ENAT(J)).LT.0.0)GO TO 9 IF(J.GT.NAST)GO TO 9 I=IREV(L,1) N=IMX0(I,J) IF(N.GT.0)RMXN(L,IE)=OMEGA(N) ELSE I=L IF(JCFA.NE.0)THEN K0=NYLD0+1 DO 10 K=K0,NAST T=0.0 N=IMX0(I,K) IF(N.GT.0)T=OMEGA(N) IF(K-NYLD0.LE.NYLD)T=T*AYLD(K-NYLD0) RMXN(L,IE)=RMXN(L,IE)+T 10 CONTINUE ELSE RMXN(L,IE)=OMEGA(I) ENDIF ENDIF T=(EMSHRX(IE)-ENAT(I)) IF(T.EQ.0.0)T=1.D-70 RMXN(L,IE)=RMXN(L,IE)*CON(I)/T IF(RMXN(L,IE).LT.0.0)RMXN(L,IE)=0.0 C IF(N.GT.0)THEN C C TRY AND ELIMINATE UNRESOLVED RESONANCES CC IF(IE.GT.3)THEN CC QMN=MIN(RMXN(L,IE-3),RMXN(L,IE)) CC QMX=MAX(RMXN(L,IE-3),RMXN(L,IE)) CC IF(RMXN(L,IE-2).GT.QMX*YMULT.AND.RMXN(L,IE-1).GT.QMX*YMULT)THEN CC WRITE(94,*)IE-1,UNITS*EMSHRX(IE-1),RMXN(L,IE-3),RMXN(L,IE-2) CC X,RMXN(L,IE-1),RMXN(L,IE) CC ENDIF CC ENDIF C IF(IE.GT.2)THEN QMN=MIN(RMXN(L,IE-2),RMXN(L,IE)) QMX=MAX(RMXN(L,IE-2),RMXN(L,IE)) IF(RMXN(L,IE-1).GT.QMX*YMULT)THEN WRITE(94,*)IE-1,UNITS*EMSHRX(IE-1),RMXN(L,IE-2),RMXN(L,IE-1) X,RMXN(L,IE) RMXN(L,IE-1)=QMN*1.01 ENDIF ENDIF C C ENDIF 9 CONTINUE 1 CONTINUE 75 RETURN END C*********************************************************************** SUBROUTINE RMODX(AR,NUMR,JCR,LMX,QLB,QN,N,L,NZ,NE) IMPLICIT REAL*8 (A-H,O-Z) C EVAULATE AR FOR 2-STATE MQDT DR PARAMETER (HBAR=4.837769E-17,NDIM14=200) INTEGER QN,QLB DIMENSION AR(*),JCR(*),LMX(*),QN(*),QLB(NDIM14,10) IF(N*NUMR.EQ.0)RETURN TPI=2.0*ACOS(-1.0) EN=N DE=QDT(QD0,NZ,NE,N,L) DE=-2.0*DE/(EN-QD0) T=DE/(HBAR*TPI) DO 1 I=1,NUMR K=JCR(I) J=LMX(K) M=QLB(K,J) IF(QN(M).NE.N)GO TO 1 TA=ABS(AR(I)/T) IF(TA.GT.1.0E-4)THEN TA=T*(EXP(TA)-1.0) AR(I)=SIGN(TA,AR(I)) ENDIF 1 CONTINUE RETURN END C**************************************************************** SUBROUTINE RYIELD(RYLD,IRRV,ECORE,EMIN,NUMA,NUMR,NV,LV,NR0,NZ0,NE X,IPRINT) IMPLICIT REAL*8 (A-H,O-Z) INTEGER SS LOGICAL BRAD C C EVALUATE SECOND STEP FLUORESCENCE YIELD C PARAMETER (NDIM0=108) PARAMETER (NDIM1=10001) PARAMETER (NDIM2=36) PARAMETER (NDIM3=100001) PARAMETER (NDIM4=9999) PARAMETER (NDIM5=150) PARAMETER (NDIM7=20000000) PARAMETER (NDIM8=100) PARAMETER (NDIM9=12) PARAMETER (NDIM10=5) PARAMETER (NDIM11=99999) PARAMETER (NDIM12=9000000) PARAMETER (NDIM13=95000) PARAMETER (NDIM14=200) PARAMETER (NDIM15=501) PARAMETER (NDIM16=50) PARAMETER (NDIM17=800) PARAMETER (NDIM25=15) PARAMETER (NDIM26=75) PARAMETER (NDIM27=150) PARAMETER (NDIM66=99) PARAMETER (JTEMP=10) C DIMENSION RYLD(*),IRRV(*) C COMMON/XX/ICA(NDIM12),JCA(NDIM12),ITA(NDIM12),AA(NDIM12) X, EION(NDIM12),JTA(NDIM12),IWA(NDIM12),EC(NDIM12) X, JTR(NDIM7),ICR(NDIM7),JCR(NDIM7),JWR(NDIM7) X, IWR(NDIM7),DEL(NDIM7),ITR(NDIM7),AR(NDIM7),EATOM(NDIM7) X, IK(NDIM13),IT(NDIM13),SS(NDIM13),LL(NDIM13),JJ(NDIM13) X, JK(NDIM13),LCF(NDIM13) X, ENERG(NDIM13),SUMAN(NDIM5),NG(NDIM14) COMMON /YLD/SUMAD(NDIM4),SUMRD(NDIM4),EFN,EFMIN X,IYLD(NDIM13),LSPJ(NDIM4),NYLD COMMON /DIP/ RSUMC(NDIM15),CP(NDIM15),CM(NDIM15),JDUM(NDIM15) C IF(NYLD*NUMA*NUMR.EQ.0)RETURN ZERO=0.0 RSUMD=ZERO BRAD=.FALSE. C IF(NV.EQ.999)GO TO 160 IF(LV.LT.0.OR.LV.EQ.999)GO TO 160 NR1=NR0+1 NR2=NDIM66 NMIN=MAX0(NR1,LV) NMAX=MIN0(NR2,NV-1) IF(NMIN.GT.NMAX)GO TO 160 DO 7 I=NMIN,NMAX RSUMC(I)=ZERO 7 CONTINUE BRAD=.TRUE. LV0=MAX(LV,1) DZ=NZ0-NE+1 DZ=DZ*DZ DEN=QDT(QD0,NZ0,NE,NV,LV) TV=NV*NV LP=LV+1 TL=LV TLP=LP DO 161 N=NMIN,NMAX T=N*N DE=DZ*(TV-T)/(TV*T) CALL DIPOL(-1,N,NV,ZERO,LP,CP,CM,JDUM) T1=TLP*CM(LP)*1.0E10**JDUM(LP) T2=ZERO IF(LV.GT.0)T2=TL*CP(LV)*1.0E10**JDUM(LV) T=(T1+T2)/(TL+TLP) T0=DE**3*2.6775E9/DZ T=T*T0 RSUMD=RSUMD+T IF(N.LE.NDIM15)RSUMC(N)=T 161 CONTINUE C 160 DO 1 I=1,NYLD RYLD(I)=ZERO SUMAD(I)=ZERO SUMRD(I)=RSUMD IRRV(I)=0 1 CONTINUE C DO 2 I=1,NUMR M=IYLD(ITR(I)) IF(M.GT.0)THEN IRRV(M)=ITR(I) T=ABS(AR(I)) IF(EATOM(I).LT.EMIN)RYLD(M)=RYLD(M)+T SUMRD(M)=SUMRD(M)+T ENDIF 2 CONTINUE C DO 3 I=1,NUMA M=IYLD(ITA(I)) IF(M.GT.0)THEN IRRV(M)=ITA(I) SUMAD(M)=SUMAD(M)+ABS(AA(I)) ENDIF 3 CONTINUE C DO 4 I=1,NYLD C IF(BRAD)THEN J=IRRV(I) IF(J.GT.0)THEN K=JK(J) TJ=ENERG(K)+ECORE-DEN DO 5 K=NMIN,NMAX T=QDT(QD0,NZ0,NE,K,LV0) !lv->lv0 c.f.adasdr IF((TJ+T).GT.EMIN)GO TO 6 RYLD(I)=RYLD(I)+RSUMC(K) 5 CONTINUE ENDIF ENDIF C 6 TT=ZERO T=SUMAD(I)+SUMRD(I) IF(T.GT.ZERO)TT=RYLD(I)/T IF(IPRINT.GT.0)THEN WRITE(6,100)I,IRRV(I),SUMAD(I),RYLD(I),SUMRD(I),TT 100 FORMAT(40X,2I5,3(1PE15.4),5X,0PF10.5) ENDIF RYLD(I)=TT 4 CONTINUE C RETURN END C************************************************************************ SUBROUTINE SPLYN(N,X,Y,I1,E1,I2,E2,A,B,C,D,S) IMPLICIT REAL*8 (A-H,O-Z) C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE. C CUBIC SPLINE FITTING TO THE DATA POINTS (X(J),Y(J)),J=1,2...N C WITH KNOTS AT X(J),J=2,3...(N-1), C IN THE FORM Y(X)=A(J)+Z*(B(J)+Z*(C(J)+Z*D(J))), C FOR X IN THE RANGE (X(J),X(J+1)), C WHERE Z=X-(X(J)+X(J+1))/2. C ONE OF THE FOLLOWING END CONDITIONS MUST BE CHOSEN FOR EACH END: C (1)SPECIFIED END FIRST DERIVATIVES; SET I1=1, E1=(DY/DX)(X=X(1)) C I2=1, E2=(DY/DX)(X=X(N)) C (2)SPECIFIED END 2ND DERIVATIVES; SET I1=2, E1=((D/DX)**2)Y (X=X(1)) C I2=2, E2=((D/DX)**2)Y (X=X(N)) C (3)END 2ND DERIVATIVE =NEXT-TO-END 2ND DERIVATIVE; SET I1=3, I2=3 C (NO NEED TO SET E1,E2) C (4)3RD DERIVATIVE CONTINUOUS AT FIRST AND LAST KNOTS; SET I1=4, I2=4 C (NO NEED TO SET E1,E2). C N.B. THE CHOSEN CONDITIONS NEED NOT BE THE SAME FOR THE TWO ENDS. C INPUT: N,X(J),Y(J) (J=1,2...N),I1,E1,I2,E2. C OUTPUT: A(J),B(J),C(J),D(J) (J=1,2...(N-1)) C S(J) (J=1,2...N), THE SECOND DERIVATIVE OF Y. DIMENSION A(N),B(N),C(N),D(N),X(N),Y(N),S(N) H1=X(2)-X(1) T1=(Y(2)-Y(1))/H1 GO TO (1,2,3,4),I1 1 B(1)=H1+H1 C(1)=H1 D(1)=6.0 *(T1-E1) GO TO 5 2 B(1)=1.0 C(1)=0.0 D(1)=E1 GO TO 5 3 B(1)=1.0 C(1)=-1.0 D(1)=0.0 GO TO 5 4 B(1)=1.0 C(1)=0.0 D(1)=0.0 5 GO TO (6,7,8,9),I2 6 H2=X(N)-X(N-1) A(N)=H2 B(N)=H2+H2 D(N)=6.0 *(E2-(Y(N)-Y(N-1))/H2) GO TO 10 7 A(N)=0.0 B(N)=1.0 D(N)=E2 GO TO 10 8 A(N)=-1.0 B(N)=1.0 D(N)=0.0 GO TO 10 9 A(N)=0.0 B(N)=1.0 D(N)=0.0 10 N1=N-1 DO 11 J=2,N1 H2=X(J+1)-X(J) T2=(Y(J+1)-Y(J))/H2 A(J)=H1 B(J)=2.0 *(H1+H2) C(J)=H2 D(J)=6.0 *(T2-T1) H1=H2 T1=T2 11 CONTINUE IF(I1-4)13,12,13 12 A(2)=0.0 H1=X(2)-X(1) H2=X(3)-X(2) B(2)=B(2)+H1+H1*H1/H2 C(2)=C(2)-H1*H1/H2 13 IF(I2-4)15,14,15 14 C(N-1)=0.0 T1=X(N-1)-X(N-2) T2=X(N)-X(N-1) A(N-1)=A(N-1)-T2*T2/T1 B(N-1)=B(N-1)+T2+T2*T2/T1 15 CALL TRIMAT(N,A,B,C,D,S) IF(I1-4)17,16,17 16 S(1)=((H1+H2)*S(2)-H1*S(3))/H2 17 IF(I2-4)19,18,19 18 S(N)=((T1+T2)*S(N-1)-T2*S(N-2))/T1 19 DO 20 J=1,N1 H1=X(J+1)-X(J) T1=0.25 *H1*H1 D(J)=(S(J+1)-S(J))/(6.0 *H1) C(J)=0.25 *(S(J+1)+S(J)) B(J)=(Y(J+1)-Y(J))/H1-T1*D(J) A(J)=0.5 *(Y(J+1)+Y(J))-T1*C(J) 20 CONTINUE RETURN END C************************************************************************ REAL*8 FUNCTION SPVAL(N,X,Y,A,B,C,D,X1,J1) IMPLICIT REAL*8 (A-H,O-Z) C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE. C EVALUATES CUBIC SPLINE FIT TO Y(X) AT X=X1, WHERE X1 LIES IN THE C INTERVAL (X(J1),X(J1+1)), GIVEN THE SPLINE COEFFICIENTS C A(J),B(J),C(J),D(J) PRODUCED BY SUBROUTINE SPLYN. C J1 NEED NOT BE SET AS INPUT, BUT EXECUTION MAY BE QUICKER IF IT IS. C INPUT: X(J), Y(J), J=1,2...N : NOTE, Y(J) NOT NEEDED. (NRB) C A(J),B(J),C(J),D(J), J=1,2...N-1 C X1 C J1 (OPTIONAL). C OUTPUT: SPVAL=Y(X1). DIMENSION X(N),Y(N),A(N),B(N),C(N),D(N) I1=1 I2=N I=1 IF (X(1).LT.X(N)) GO TO 1 I1=N I2=1 I=-1 1 IF((J1-I1)*(J1-I2+I).GT.0) J1=I1 2 IF(X1-X(J1))3,9,6 3 IF (J1.EQ.I1) GO TO 9 J1=J1-I GO TO 2 6 IF (X1.LE.X(J1+I)) GO TO 9 IF (J1.EQ.(I2-I)) GO TO 9 J1=J1+I GO TO 6 9 J2=J1+I Z=X1-0.5 *(X(J2)+X(J1)) IF (J2.GT.J1) J2=J1 SPVAL=A(J2)+Z*(B(J2)+Z*(C(J2)+Z*D(J2))) RETURN END C*********************************************************************** SUBROUTINE SUME(KMAX,IL,QF,IA,AA,EC,AR,ITR,IPRINT,NBIN1,EBIN,SBIN X,COEF) C MULTI-ELECTRON CONTINUA, SINGLE PHOTON CONTINUUM IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(NDIM1=10001,NDIM2=36) DIMENSION IL(*),QF(*),IA(*),AA(*),EBIN(*),SBIN(NDIM2,NDIM1) C FIND CROSS SECTION BIN DO 21 J=1,NBIN1 IF(EC.GE.EBIN(J).AND.EC.LT.EBIN(J+1))THEN J0=J GO TO 22 ENDIF 21 CONTINUE RETURN C 22 PSI=0.0 QSUM=0.0 SUMA=0.0 DO 1 K=1,KMAX I=IA(K) T=ABS(AA(I)) SUMA=SUMA+T L=IL(K) IF(L.GT.0)THEN QSUM=QSUM+1.0E0/QF(L) PSI=PSI+1.0E0/(T*QF(L)**2) ENDIF 1 CONTINUE PSIP=1.0E0+PSI*AR DEL=AR/(SUMA*PSIP) T=1.0E0-QSUM*QSUM ETA=1.0E0+DEL*T DEL=-DEL-DEL SUM=T+2.0E0*DEL*QSUM T=DEL**2-ETA**2+1.0E0 T=T*SUMA*PSI SUM=SUM+T SUM=SUM*AR/(ETA*PSIP**2) CROSS=COEF*SUM/((EBIN(2)-EBIN(1))*EBIN(J0+1)) C C STORE BINNED CROSS SECTION C SBIN(1,J0)=SBIN(1,J0)+CROSS C PRINT IF(QSUM.NE.0.0)QSUM=1.0/QSUM**2 IF(IPRINT.GE.-1)WRITE(6,201)ITR,EC,CROSS,QSUM 201 FORMAT(I5,2X,'SUM',3(1PE15.4)/) C RETURN END C*********************************************************************** SUBROUTINE SUMG(LMAX,IQ,QF,AR,AA,EC,EIONMN,IPRINT,ITR,JTR,DEL0 X,EATOM,NBIN1,EBIN,SBIN,COEF) C MULTI-PHOTON CONTINUA, SINGLE ELECTRON CONTINUUM IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BLOR,BFEAR,BBACK PARAMETER(NDIM1=10001,NDIM2=36,NDIM3=100001) COMMON /BACK/EVEC(NDIM3),VEC(NDIM3),SIGMA(NDIM2,7),BBACK,ITYPE,ISM X,IXTRP(NDIM2) DIMENSION JTR(*),IQ(*),QF(*),AR(*),DEL0(*),EBIN(*),SBIN(NDIM2 X,NDIM1),EATOM(*) COMMON /JCF/JCFA,JCFR,JCFJ,JCFY,JCFE,JPAR,LSPI,J2PI,BLOR,BFEAR X,MAX2J COMMON /PHOTON/EBDMIN,EBDMAX,EPHMIN,EPHMAX C PIE=ACOS(-1.0) C FIND CROSS SECTION BIN DO 21 J=1,NBIN1 IF(EC.GE.EBIN(J).AND.EC.LT.EBIN(J+1))THEN J0=J GO TO 22 ENDIF 21 CONTINUE RETURN C 22 T1=0.0 T2=0.0 T3=0.0 DO 1 L=1,LMAX J=IQ(L) T=ABS(AR(J)) T1=T1+T T=T/QF(L) T2=T2+T T=T/QF(L) T3=T3+T 1 CONTINUE PSI=1.0E0+T3/AA DEL=T2/(AA*PSI) DEL=-DEL-DEL ETA=1.0E0+PSI*T1/AA-(T2/AA)**2 ETA=ETA/PSI TL=COEF/PSI**2 TE=TL/((EBIN(2)-EBIN(1))*EBIN(J0+1)*ETA) CROSS=0.0 C C EVALUATE ENERGY-AVERAGED C-S C DO 2 L=1,LMAX J=IQ(L) IF(EIONMN-EATOM(J).LT.EBDMIN.OR.EIONMN-EATOM(J).GT.EBDMAX)GO TO 2 IF(DEL0(J).LT.EPHMIN.OR.DEL0(J).GT.EPHMAX)GO TO 2 T=DEL/QF(L) TT=T1/QF(L)-T2 TT=(TT/AA)**2 T=(1.0E0+T)**2-(ETA/QF(L))**2+TT SUM=TE*ABS(AR(J))*T Q2=QF(L)**2 IF(IPRINT.GE.0)WRITE(6,200)ITR,JTR(J),DEL0(J),SUM,Q2 200 FORMAT(2I5,3(1PE15.4)) CROSS=CROSS+SUM C C EVALUATED (MODIFIED) LORENTZIAN C IF(BLOR)THEN T0=4.13413E16/AA DO 3 I=1,NBIN1 XI=T0*(EBIN(I+1)-EC) T=TT+(1.0E0+XI/QF(L))**2 T=T/((XI-DEL)**2+ETA**2) C SUBTRACT-OFF RR BACKGROUND TO AVOID DOUBLE COUNTING IF(BBACK)T=T-QF(L)**(-2) T=T0*T*ABS(AR(J))*TL/(PIE*EBIN(I+1)) SBIN(2,I)=SBIN(2,I)+T 3 CONTINUE ENDIF 2 CONTINUE C C STORE BINNED CROSS SECTION C SBIN(1,J0)=SBIN(1,J0)+CROSS C PRINT IF(IPRINT.GE.-1)WRITE(6,201)ITR,EC,CROSS 201 FORMAT(I5,2X,'SUM',2(1PE15.4)/) C RETURN END C*********************************************************************** REAL*8 FUNCTION THETA(ITHE,L) IMPLICIT REAL*8 (A-H,O-Z) C EVALUATES SQUARE OF SPHERICAL HARMONIC A.M.=L, M=0. PL=1.0 TL=L+L+1 IF(ITHE.EQ.0)GO TO 1 T0=ITHE T0=T0*0.0174532 X=COS(T0) LS=L+1 IF(LS.GT.6)LS=6 GO TO (1,2,3,4,5,6),LS 2 PL=X GO TO 1 3 PL=1.5*X*X-0.5 GO TO 1 4 PL=X*(2.5*X*X-1.5) GO TO 1 5 PL=(X*X*(35.0*X*X-30.0)+3.0)*0.125 GO TO 1 6 P0=1.0 P1=X DO 7 I=2,L TL=I TL1=I+1 TL2=I+I+1 P2=TL2*X*P1-TL*P0 P2=P2/TL1 PL=P2 P0=P1 P1=P2 7 CONTINUE 1 THETA=PL*PL*TL*0.0795774 RETURN END C*********************************************************************** REAL*8 FUNCTION THETR(ITHE,MSP,MSS,L,LP,JA,JAP,BOLD) IMPLICIT REAL*8 (A-H,O-Z) C EVALUATES ASYMMETRY PARAMETER C.F. PERCIVAL AND SEATON C TARGET ION AN S-STATE ONLY DIMENSION IBETA(8,15,15), BETA(8,15,15) LOGICAL BIC,BFM,BOLD COMMON /BETAX/BETA,IBETA IF(JA.GT.15)GO TO 11 IF(JAP.GT.15)GO TO 11 IF(BOLD)GO TO 19 BOLD=.TRUE. CALL GAMAF(100) DO 20 K=1,15 DO 21 J=1,15 DO 22 I=1,8 IBETA(I,J,K)=0 BETA(I,J,K)=0.0 22 CONTINUE 21 CONTINUE 20 CONTINUE 19 T0=ITHE T0=T0*0.0174532 X=COS(T0) P2=1.5*X*X-0.5 ZERO=0.0 ONE=1.0 TWO=2.0 BFM=.FALSE. TI=MSP-1 TI=TI*0.5 BIC=(JA+JAP-2).GT.0 IF(.NOT.BIC)GO TO 23 I=1 K=JA N=JAP IF(IBETA(I,K,N).NE.0)GO TO 10 IF(BFM)GO TO 14 J1=JA J2=JA J3=JAP J4=JAP M1=1 M2=1 MS=0 I=(-1)**(JA-1) IF(I.LT.0)MS=-1 GO TO 12 23 MS=MSS M1=MS I=M1 K=L+1 N=LP+1 IF(IBETA(I,K,N).NE.0)GO TO 10 EL=L ELP=LP ELP=LP EL2=L+L+1 MS=MS-1 S=MS S=0.5*S M2=M1+MS J1=IABS(L+L-MS)+1 J2=L+L+MS+1 C IF L=O BETA=0.0, TEST 12 B=0.0 DO 9 J=J1,J2,2 IF(.NOT.BIC)J3=IABS(J-3)+1 IF(.NOT.BIC)J4=J+2 TJ=J-1 TJ=0.5*TJ TA=0.0 DO 8 JP=J3,J4,2 TJP=JP-1 TJP=TJP*0.5 J5=1 J6=1 IF(MSP.EQ.0)GO TO 30 J5=IABS(J-MSP)+1 J6=J+MSP-1 TZ=0.0 30 DO 31 JF=J5,J6,2 J7=1 J8=1 IF(MSP.EQ.0)GO TO 32 F=JF-1 F=F*0.5 TY=0.0 J7=IABS(JF-3)+1 J8=JF+2 32 DO 33 JFP=J7,J8,2 M3=1 M4=1 IF(MSP.EQ.0)GO TO 34 FP=JFP-1 FP=FP*0.5 TX=0.0 M3=JF M4=JF+JF+1 MF=-JF-1 34 DO 35 M5=M3,M4 IF(MSP.EQ.0)GO TO 36 MF=MF+2 TF=MF TF=TF*0.5 TFM=-TF 36 TB=0.0 MM=-MS-2 DO 7 M=M1,M2 MM=MM+2 TP=MM TP=MM*0.5 TM=-TP T1=1.0 IF(.NOT.BIC)T1=WIG3J(S,EL,TJ,TP,ZERO,TM) IF(MSP.EQ.0)T2=WIG3J(TJP,ONE,TJ,TP,ZERO,TM) TII=MF-MM TII=TII*0.5 IF(MSP.GT.0)T2=WIG3J(TJ,TI,F,TP,TII,TFM) T3=T1*T2 TB=TB+T3*T3 7 CONTINUE IF(MSP.EQ.0)GO TO 35 T3=WIG3J(FP,ONE,F,TF,ZERO,TFM) TX=TX+T3*T3*TB 35 CONTINUE IF(MSP.EQ.0)GO TO 33 T3=WIG6J(TJ,F,TI,FP,TJP,ONE) T1=JFP TY=TY+T1*T3*T3*TX 33 CONTINUE IF(MSP.EQ.0)GO TO 31 T1=JF TZ=TZ+T1*T1*TY 31 CONTINUE IF(MSP.GT.0)TB=TZ T3=1.0 T1=1.0 IF(.NOT.BIC)T3=WIG6J(EL,TJ,S,TJP,ELP,ONE) IF(.NOT.BIC)T1=JP TA=TA+TB*T1*T3*T3 8 CONTINUE T1=J IF(.NOT.BIC)T1=T1*T1 B=B+T1*TA 9 CONTINUE IF(BIC)GO TO 13 MS=MS+1 T=MS B=B*EL2/T 13 T1=MSP IF(MSP.GT.0)B=B/T1 BETA(I,K,N)=0.5-1.5*B IBETA(I,K,N)=1 10 THETR=1.0+BETA(I,K,N)*P2 RETURN 14 H=0.0 IF(JA.EQ.1)GO TO 25 T1=JA-1 T1=T1*0.5 T2=JAP-1 T2=T2*0.5 T3=WIG6J(T1,T1,TWO,ONE,ONE,T2) T4=WIG6J(T1,T1,TWO,ONE,ONE,T1) IF(T3*T4.EQ.0.0)GO TO 25 J=JA-JAP J=J/2 I=(-1)**J H=I H=H*T3/T4 I=(-1)**(JA-1) C J INTEGER M=0 ONLY A0=-1 C J INTEGER M=0 EQUAL M=+-1 C A0=2.0/(T1*(T1+1.0)) -1.0 C J HALF INTEGER M=1/2 ONLY IF(I.LT.0)A0=0.75/(T1*(T1+1.0)) -1.0 H=H*A0 25 BETA(1,K,N)=-0.5*H IBETA(1,K,N)=1 I=1 GO TO 10 11 WRITE(6,102) JA,JAP 102 FORMAT(2I5,'STORAGE EXCEEDED IN THETR') THETR=0.0 RETURN END C************************************************************************ REAL*8 FUNCTION TRAP(EVEC,OMEGA,MXE) IMPLICIT REAL*8 (A-H,O-Z) C C SIMPLE TRAPEZOIDAL RULE FOR R-MATRIX CONVOLUTION INTEGRAL C WHEN NAG NOT PRESENT. CURRENTLY ASSUMES FINE ENERGY MESH. C DOES **NOT** NEED CONSTANT SPACING IN ENERGY. C TBD, INTERPOLATE COARSE ENERGY MESH. C DIMENSION EVEC(MXE),OMEGA(MXE) C T=0.0 DO I=2,MXE T=T+(EVEC(I)-EVEC(I-1))*(OMEGA(I)+OMEGA(I-1)) ENDDO TRAP=T*0.5 RETURN END C************************************************************************ SUBROUTINE TRIMAT(N,A,B,C,D,Y) IMPLICIT REAL*8 (A-H,O-Z) C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE. C SOLUTION OF TRI-DIAGONAL MATRIX EQUATION BY FORWARD AND BACKWARD PASS C (SEE 'MODERN COMPUTING METHODS', PAGES 97,98). C INPUT: N, (THE MATRIX IS N BY N) C A(J), J=2,3...N (SUB-DIAGONAL ELEMENTS) C B(J), J=1,2...N (DIAGONAL ELEMENTS) C C(J), J=1,2...N-1 (SUPER-DIAGONAL ELEMENTS) C D(J), J=1,2...N (RIGHT-HAND SIDE). C OUTPUT: N,A,B AND C ARE PRESERVED, D IS OVERWRITTEN C Y(J), J=1,2...N CONTAINS THE SOLUTION VECTOR. DIMENSION A(N),B(N),C(N),D(N),Y(N) Y(1)=B(1) DO 1 J=2,N T=A(J)/Y(J-1) Y(J)=B(J)-T*C(J-1) D(J)=D(J)-T*D(J-1) 1 CONTINUE Y(N)=D(N)/Y(N) DO 2 I=2,N J=N-I+1 Y(J)=(D(J)-C(J)*Y(J+1))/Y(J) 2 CONTINUE RETURN END C*********************************************************************** REAL*8 FUNCTION WIG3J(A1,A2,A3,B1,B2,B3) C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE. C CALCULATES WIGNER 3-J SYMBOL ( A1 A2 A3 ) C ( B1 B2 B3 ) IN DOUBLE PRECISION. C N.B. A CALL GAMAF(J) STATEMENT MUST HAVE BEEN EXECUTED PREVIOUSLY, C WITH J NOT LESS THAN A1+A2+A3+1. C FOR SINGLE PRECISION VERSION, CHANGES ARE REQUIRED AT C LINES 1,13,14,18,20,25,27,29,30,69,121, AND IT MAY BE NECESSARY C TO RETAIN LINES 14 AND 20 AS REAL*8(D) AND 1.0D0,1.0D3,1.0D-3/ C OR REAL*16(D) AND 1.0Q0,1.0Q3,1.0Q-3/ C IF VERY LARGE INPUT VALUES ARE USED. C LAST CHANGED ON 22 JAN 80. IMPLICIT REAL*8 (A-C,E-H,O-Z), 1 REAL*8 (D) DIMENSION GAM(500),JGAM(500),K(3),L(2) COMMON /AB10/GAM,JGAM DATA ZERO, EPS1, EPS2, HALF, ONE, SC,I/ 1 0.0E0,1.0E-20,1.0E-3,0.501E0,1.0E0,1.0E3,1/ DATA DONE, DSC, DSC1/ 1 1.0E0,1.0E3,1.0E-3/ CALL DELTA2(A1,A2,A3,T,J) IF(T-EPS1)1,1,2 1 WIG3J=ZERO RETURN 2 AB1=ABS(B1) IF(A1-AB1+EPS2)1,3,3 3 AB2=ABS(B2) IF(A2-AB2+EPS2)1,4,4 4 IF(A3-ABS(B3)+EPS2)1,5,5 5 N=ABS(B1+B2+B3)+ONE-EPS2 IF(N)1,6,1 6 N1=A1+B1+EPS2 N11=A1+B1+HALF N3=A2+B2+EPS2 N31=A2+B2+HALF N5=A3+B3+EPS2 N51=A3+B3+HALF NG2=N1+N3+N5 IF(NG2-N11-N31-N51)1,7,1 7 IF(AB1+AB2)31,31,30 30 N2=A1-B1+EPS2 N4=A2-B2+EPS2 N6=A3-B3+EPS2 K(1)=N2 K(2)=N3 K(3)=N1+N3-N6 C1=A3-A2+B1 IF(C1)8,9,9 8 L(1)=C1-EPS2 GO TO 10 9 L(1)=C1+EPS2 10 C1=A3-A1-B2 IF(C1)11,12,12 11 L(2)=C1-EPS2 GO TO 13 12 L(2)=C1+EPS2 13 NMIN=0 DO 16 N=1,2 IF(L(N))14,16,16 14 IF(L(N)+NMIN)15,16,16 15 NMIN=-L(N) 16 CONTINUE NMAX=K(1) DO 18 N=2,3 IF(K(N)-NMAX)17,18,18 17 NMAX=K(N) 18 CONTINUE T=T*GAM(N1+I)*GAM(N2+I)*GAM(N3+I)*GAM(N4+I)*GAM(N5+I)*GAM(N6+I) T=SQRT(T) N=N1-N4+NMIN IF(2*(N/2)-N)19,20,19 19 T=-T 20 J=J+JGAM(N1+I)+JGAM(N2+I)+JGAM(N3+I)+JGAM(N4+I)+JGAM(N5+I) 1 +JGAM(N6+I) N1=K(1)-NMIN N2=L(1)+NMIN N3=K(2)-NMIN N4=L(2)+NMIN N5=K(3)-NMIN T=T/(GAM(NMIN+I)*GAM(N1+I)*GAM(N2+I)*GAM(N3+I)*GAM(N4+I) 1 *GAM(N5+I)) M1=JGAM(NMIN+I)+JGAM(N1+I)+JGAM(N2+I)+JGAM(N3+I)+JGAM(N4+I) 1 +JGAM(N5+I) IF(NMAX-NMIN)21,21,22 21 WIG3J=T*SC**(J-M1-M1) RETURN 22 D1=N1+I D2=N2 D3=N3+I D4=N4 D5=N5+I D6=NMIN DT=DONE DSUM=DONE NMAX1=NMAX-NMIN DSC2=DSC*DSC DO 23 N=1,NMAX1 D1=D1-DONE D2=D2+DONE D3=D3-DONE D4=D4+DONE D5=D5-DONE D6=D6+DONE DT=-DT*D1*D3*D5/(D2*D4*D6) DSUM=DSUM+DT 24 IF(DSUM*DSUM-DSC2)23,23,25 25 DSUM=DSUM*DSC1 DT=DT*DSC1 J=J+1 GO TO 24 23 CONTINUE SUM=DSUM T=T*SUM GO TO 21 31 NG=NG2/2 NG1=(NG2+1)/2 IF(NG-NG1)1,32,32 32 N2=NG-N1 N4=NG-N3 N6=NG-N5 T=SQRT(T)*GAM(NG+I)/(GAM(N2+I)*GAM(N4+I)*GAM(N6+I)) M1=JGAM(N2+I)+JGAM(N4+I)+JGAM(N6+I)-JGAM(NG+I) IF(2*(NG/2)-NG)33,21,33 33 T=-T GO TO 21 END C*********************************************************************** REAL*8 FUNCTION WIG6J(A1,A2,A3,B1,B2,B3) C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE. C CALCULATES WIGNER 6-J SYMBOL ( A1 A2 A3 ) C ( B1 B2 B3 ) IN DOUBLE PRECISION. C N.B. A CALL GAMAF(J) STATEMENT MUST HAVE BEEN EXECUTED PREVIOUSLY, C WITH J NOT LESS THAN JMAX+2, WHERE JMAX IS THE LARGEST PERIMETER C OF ANY TRIANGLE IN THE TETRAHEDRON REPRESENTING THE SYMBOL. C FOR SINGLE PRECISION VERSION, CHANGES ARE REQUIRED AT C LINES 1,14,15,19,21,31, AND IT MAY BE NECESSARY TO RETAIN C LINES 15 AND 21 AS REAL*8(D) AND 1.0D0,1.0D3,1.0D-3/ C OR REAL*16(D) AND 1.0Q0,1.0Q3,1.0Q-3/ C IF VERY LARGE INPUT VALUES ARE USED. C LAST CHANGED ON 22 JAN 80. IMPLICIT REAL*8 (A-C,E-H,O-Z), 1 REAL*8 (D) DIMENSION GAM(500),JGAM(500),K(4),L(3) COMMON /AB10/GAM,JGAM DATA ZERO, EPS1, EPS2, SC,I/ 1 0.0E0,1.0E-20,1.0E-3,1.0E3,1/ DATA DONE, DSC, DSC1/ 1 1.0E0,1.0E3,1.0E-3/ CALL DELTA2(A1,A2,A3,T1,J1) CALL DELTA2(A1,B2,B3,T2,J2) CALL DELTA2(A2,B1,B3,T3,J3) CALL DELTA2(A3,B1,B2,T4,J4) T=T1*T2*T3*T4 IF(T-EPS1)1,1,2 1 WIG6J=ZERO RETURN 2 J=J1+J2+J3+J4 T=SQRT(T) K(1)=A1+A2+A3+EPS2 K(2)=A1+B2+B3+EPS2 K(3)=A2+B1+B3+EPS2 K(4)=A3+B1+B2+EPS2 L(1)=A1+B1+A2+B2+EPS2 L(2)=A2+B2+A3+B3+EPS2 L(3)=A1+B1+A3+B3+EPS2 NMIN=K(1) DO 4 N=2,4 IF(K(N)-NMIN)4,4,3 3 NMIN=K(N) 4 CONTINUE NMAX=L(1) DO 6 N=2,3 IF(L(N)-NMAX)5,6,6 5 NMAX=L(N) 6 CONTINUE IF(2*(NMIN/2)-NMIN)7,8,7 7 T=-T 8 N1=NMIN-K(1) N2=NMIN-K(2) N3=NMIN-K(3) N4=NMIN-K(4) N5=L(1)-NMIN N6=L(2)-NMIN N7=L(3)-NMIN T=T*GAM(NMIN+2)/(GAM(N1+I)*GAM(N2+I)*GAM(N3+I)*GAM(N4+I) 1 *GAM(N5+I)*GAM(N6+I)*GAM(N7+I)) M1=JGAM(NMIN+2)-JGAM(N1+I)-JGAM(N2+I)-JGAM(N3+I)-JGAM(N4+I) 1 -JGAM(N5+I)-JGAM(N6+I)-JGAM(N7+I) IF(NMAX-NMIN)9,9,10 9 WIG6J=T*SC**(J+M1+M1) RETURN 10 DSUM=DONE DT=DONE DP1=N1 DP2=N2 DP3=N3 DP4=N4 DP5=N5+I DP6=N6+I DP7=N7+I DP8=NMIN+I DSC2=DSC*DSC NMAX1=NMAX-NMIN DO 11 N=1,NMAX1 DP1=DP1+DONE DP2=DP2+DONE DP3=DP3+DONE DP4=DP4+DONE DP5=DP5-DONE DP6=DP6-DONE DP7=DP7-DONE DP8=DP8+DONE DT=-DT*DP5*DP6*DP7*DP8/(DP1*DP2*DP3*DP4) DSUM=DSUM+DT 12 IF(DSUM*DSUM-DSC2)11,11,13 13 DSUM=DSUM*DSC1 DT=DT*DSC1 J=J+1 GO TO 12 11 CONTINUE SUM=DSUM T=T*SUM GO TO 9 END C*********************************************************************** REAL*8 FUNCTION XTRP(E,OMEG,X,IXTRP) IMPLICIT REAL*8 (A-H,O-Z) C C EXTRAPOLATE OMEGA USING KNOWN FUNCTIONAL FORMS C CALLED WHEN OMEGA REQUIRED BEYOND END OF SPLINE FIT. C IXTRP=1, OMEGA~CONST*LOG(E) : ELECTRIC DIPOLE C IXTRP=2, OMEGA~CONST : NON-ELECTRIC DIPOLE, NON-EXCHANGE C IXTRP=3, OMEGA~CONST/E**2 : EXCHANGE C IXTRP=4, OMEGA~CONST/E : RADIATIVE RECOMBINATION C GO TO (1,2,3,4),IXTRP 1 XTRP=OMEG*LOG(X)/LOG(E) RETURN 2 XTRP=OMEG RETURN 3 XTRP=OMEG*E*E/(X*X) RETURN 4 XTRP=OMEG*E/X RETURN END