C N. R. BADNELL PROGRAM ADASPE UoS v2.12 17/10/23 C C*********************************************************************** C C POST-PROCESSOR FOR ** AUTOSTRUCTURE ** (ADAS ONLY) C *************************************************** C C CALCULATES LS/IC PHOTOEXCITATION DATA IN ADF38 FORMAT. C C*********************************************************************** C PROGRAM MAIN C SUN TIME REAL*4 TARRY(2),TIME C C OPEN(5,FILE='adasin') !STDIN OPEN(6,FILE='adasout') !STDOUT C OPEN(7,FILE='ocsp') !BINNED CROSS SECTIONS PARTIALS C OPEN(8,FILE='ocst') !BINNED CROSS SECTIONS TOTAL C OPEN(10,FILE='adf38l') !ADAS LEVEL OUTPUT C OPEN(11,FILE='adf38r') !ADAS RATE OUTPUT C OPEN(13,FILE='XDRSTOT') !CONVOLUTED DRS TOTAL C OPEN(13,FILE='XPEPAR') !CONVOLUTED PE PARTIALS C OPEN(14,FILE='XPETOT') !CONVOLUTED PE TOTAL C OPEN(20,FILE='adf38lu',FORM='UNFORMATTED') C OPEN(21,FILE='adf38ru',FORM='UNFORMATTED') C OPEN(70,FILE='on') !AUTOS DATA FILE (FORMATTED) C OR C OPEN(70,FILE='onu',FORM='UNFORMATTED') !AUTOS DATA FILE (UNFORM) C CALL POSTP 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 WRITE(6,*) 'PROGRAM ADASPE: NORMAL END' C CLOSE(6) CLOSE(10) CLOSE(11) C CLOSE(70) C END C C*********************************************************************** C SUBROUTINE POSTP C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (NDIM1=10001) !BIN ENERGIES PARAMETER (NDIM5=600) !ELECTRON TARGETS PARAMETER (NDIM2=NDIM5+1) PARAMETER (NDIM3=30) !BINNED E-TARGETS PARAMETER (NDIM4=16) !BINNED P-TARGETS PARAMETER (NDIM13=2500000) !PHOTON TARGETS PARAMETER (NDIM17=2500000) PARAMETER (NDIM25=99) !NO L-DEP CORRECTIONS PARAMETER (NDIM28=NDIM4) !TEMPERATURES C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) C PARAMETER (DTWO=2.0D0) C PARAMETER (TOLC=1.1D-7) C CHARACTER*4 NAME,RADBF,COD(20),RESOLV,RAD4 CHARACTER MATCH*3,RAD*6,PABS*3,PRINT*6 CHARACTER*12 F18 C LOGICAL BCA,BLS,BIC,BRSLVF,BFORM,BPRINT,BMATCH,BLOR,boop,boldf C X,EX C DIMENSION IWT(NDIM5),IWS(NDIM5),IWL(NDIM5),IWJ(NDIM5) X ,EI(NDIM2),E1C(NDIM5) C DIMENSION EBIN(NDIM1),SBIN(NDIM1,NDIM3,NDIM4),TBIN(NDIM1,NDIM4) X ,EPT(NDIM4),EET(NDIM3),TEMP(NDIM28) C COMMON /CORR/ACORN(NDIM1),ACORL(NDIM25),RMIN,NNCOR,NLCOR COMMON /JCF/JCFA,JCFR,JCFJ,LSPI,J2PI,JCF(20),RADBF,RAD,PABS C NAMELIST/ONE/NTAR,IPRINT,NCUT,LCUT,JCFR,JCFJ,NRSLMX,IRSLMX,JRSLMX X ,RADBF,LSPI,J2PI,NMIN,LMIN,NMAX,LMAX,JCF,RESOLV,MATCH X ,NTARP,NTART,UNITS,RAD,PABS,nc,JCFA,boop,boldf,PRINT X ,NTAR0,NTAR1,NTAR2 !COMPATIBILITY ADASPI/DR C NAMELIST/TWO/EMIN,EMAX,NR1,NNCOR,NLCOR,ACOR,RCOR,TOLR,TOLB X ,RMIN,NR2,DELTAF,TEAPOT,TOLN,JTEMP,IRDT,JTHETA X ,NBIN,EWIDTH,NGAUSS,ERES,EMINC,EMAXC X ,EBDMIN,EBDMAX,DELTAE,PFACT,NLAG !COMPATIBILITY ADASPI C F18='(6(1PE12.6))' C C SET-UP DEFAULTS IF NO UNIT5 FILE READ C MATCH='NO' NTAR0=0 !INPUT UNUSED NTAR1=0 NTAR2=0 NTARP=-1 NTART=NDIM5 C IRD=0 BCA=.FALSE. BLS=.FALSE. BIC=.FALSE. DO I=1,20 COD(I)=' ' JCF(I)=0 ENDDO C C READ HEADER TO DETERMINE IF LS OR IC RUN (/LS/ OR /IC/), C THE REST OF THE LINE IS FOR COMMENT, IT IS ADDED TO THE END OF ADF38. C C INQUIRE (FILE='adasin',EXIST=EX) C IF(.NOT.EX)GO TO 1003 C OPEN(5,FILE='adasin') !STDIN C READ(5,1000)COD 1000 FORMAT(20A4) WRITE(6,1001)COD 1001 FORMAT(1X,50('-'),'ADASPE',50('-')//1X,20A4//1X,50('-'),'(V2.12)' X,50('-')//) C IRD=1 BCA=COD(1).EQ.'/CA/' BLS=COD(1).EQ.'/LS/' BIC=COD(1).EQ.'/IC/' IF(.NOT.BCA.AND..NOT.BLS.AND..NOT.BIC.AND.COD(1).NE.'/ /')THEN WRITE(6,1002)COD(1) 1002 FORMAT(' ***INPUT CODE ERROR: ONLY / /, /CA/, /LS/ OR /IC/ ARE' X ,' ALLOWED, WHILE YOUR INPUT IS "',A4,'"') STOP 'INPUT ERROR ON UNIT5' ENDIF C 1003 CONTINUE C NTAR=IRD-1 C C C**********************NAMELIST-ONE************************************* C C ***NOTHING IS COMPULSORY, BUT...NTAR HIGHLY RECOMMENDED C----------------------------------------------------------------------- C C ***OPTIONAL INPUT DESCRIBING ELECTRON TARGET: C C NTAR .NE. 0 |NTAR| ELECTRON CONTINUUM TARGETS LABELLED & WRITTEN C .EQ. 0 IS ALLOWED, NO CONTINUUM INFO WRITTEN THEN (DEFAULT). C .LT. 0 ALL ELECTRON TARGETS FOUND ARE WRITTEN, NO STAT. C WEIGHTS ABOVE -NTAR, OF COURSE. C C MATCH = 'YES' ALLOWS FOR A COLLISION RUN RESTRICTED C BY SYMMETRY (E.G. NAST/J) SO THAT NOT ALL TARGETS C CAN FORM THESE CHANNELS. UNIT5 TARGETS ARE SKIPPED C UNTIL A MATCH IS FOUND. C = 'NO' JUST FLAGS ANY MIS-MATCHES AND STOPS IF NOT C ALL REQUESTED TARGETS HAVE BEEN FOUND. DEFAULT. C C NTARP = NO. OF ELECTRON TARGETS FOR WHICH PARTIALS ARE WRITTEN. C DEFAULT, NTAR. C C NTART= NO. OF ELECTRON TARGETS FOR WHICH PARTIALS ARE SUMMED-OVER C TO FORM TOTALS. DEFAULT, ALL POSSIBLE. C C CURRENTLY, NTAR, NTARP, NTART ARE INDEPENDENT OF EACH OTHER. SO IF C NTARP .GT. NTAR THEN THERE IS NO LABELLING OF THOSE .GT. NTAR C AND IF NTART .NE. NTARP THEN THE SUM OF THE PARTIALS FILE C WILL NOT GIVE THE TOTALS FILE (CAN HAVE NTART.GT.NTARP). C FURTHERMORE, THEY "ASSUME" THE SAME ELECTRON TARGETS IN EACH C DATABLOCK. SO, BEST NOT TO RESOLVE ELECTRON TARGETS BEYOND C THE COMMON SET. THIS COULD BE HANDLED/CODED ALONG THE SAME C LINES AS IN ADASPI, SHOULD THE NEED ARISE. C C IF HEADER /CA/, /LS/ OR /IC/ THEN, *AFTER* NAMELIST-TWO, READ C NTAR CFG/TERM/LEVEL INFO AS OUTPUT BY AS CAVES/TERMS/LEVELS C FILES. VIZ. C *** IW IPAR CA C OR C *** IWS IWL IPAR LS C OR C *** IWJ IPAR IWS IWL IC (HERE IWJ=2J). C THIS INFO IS WRITTEN TO THE ADF38L FILE. C C IF HEADER / / THEN NO TARGET INFO READ/WRITTEN, C DEFAULT IF NO UNIT5 C C IRSLMX(JRSLMX) -- ARE THE MAX LOWER(UPPER) INDEX OF RESOLVED DATA. C THIS IS ON A PER-FILE BASIS (SINCE THE MASTER LEVEL LIST C IS ONLY COMPILED AFTER ALL DATA HAS BEEN READ-IN AND C PROCESSED). SO, IF THE FIRST IRSLMX LEVELS ARE NOT THE C SAME IN ALL FILES THEN THERE WILL BE SOME ADDITIONAL C MASTER LEVELS PRESENT (OR MISSING, DEPENDING ON WHICH C FILE YOU BASED YOUR CHOICE). C AGAIN, ONLY RESOLVED DATA EXISTS FOR PE. C C RESOLV .EQ. 'YES' UPPER STATES ARE RESOLVED IN ADF38R. THIS CAN C LEAD TO A LONG LISTING IN ADF38L. C .EQ. 'NO' ONLY LOWER STATES ARE RESOLVED IN ADF38R AND C LISTED IN ADF38L C DEFAULT .EQ. 'NO' UNLESS JRSLMX SET, THEN .EQ. 'YES'. C C NRSLMX -- IS THE MAX N OF LOWER LEVEL RESOLVED DATA, DEFAULT=6. C N.B. THERE IS NO BUNDLED-N DATA FOR HIGHER-N, UNLIKE DR. C C RADBF .EQ. 'B-F' INCLUDE ONLY RADIATIVE TRANSITIONS BETWEEN AUTO- C IONIZING STATES AND TRUE BOUND STATES. DEFAULT C .EQ. 'B-B' B-F PLUS TRANSITIONS BETWEEN TRUE BOUND STATES. C .EQ. 'F-F' B-F PLUS TRANSITIONS BETWEEN AUTOIONIZING STATES C .EQ. 'ALL' ALL POSSIBLE TRANSITIONS. C N.B.MORE SELECTIVE CONTROL IS AVAILABLE VIA TOLR AND TOLN C (SEE BELOW NAMELIST TWO) WHICH OVERRIDES THE RADBF SETTING. C C RAD & PABS: C CONTROL TREATMENT OF RADIATION DAMPING, I.E. WHAT RADIATION C IS INCLUDED IN THE TOTAL WIDTH, AND HOW PHOTOABSORPTION CAN BE C DESCRIBED. IT IS MUCH MORE POWERFUL THAN THE JCFR.GT.100,200 C OPTION AVAILABLE IN THE RECOMBINATION POST-PROCESSORS - IT C NEEDS TO BE SO AS TO BE ABLE TO MIRROR THE (RESTRICTED) C R-MATRIX REPRESENTATION. C UNLESS STATED, THE RAD OPERATION ACTS ON BOTH PARTIAL (XPEPAR) C AND TOTAL (XPETOT) CROSS SECTIONS. PABS ACTS ON XPETOT ONLY. C C SIMPLE OPERATION: C RAD: C .EQ. 'NO' OMITS RADIATION DAMPING. C .EQ. 'YES' INCLUDES RADIATION DAMPING. *DEFAULT* (='AUTO') C THIS DOES *NOT* NECESSESRILY MIRROR R-MATRIX C .EQ. 'RM' ATTEMPTS TO MIRROR DAMPED R-MATRIX (='BOUND') C .EQ. 'OP' SETS SWITCHES TO MATCH 2004 UPDATED OP OPERATION C .EQ. 'DR' OR 'PR' ATTEMPS TO MIMIC ADASDR RECOMBINATION TO C TRUE BOUND ONLY (='AUTO0') C .EQ. 'DRS' INCLUDES RADIATION/SATELLITES TO AUTOIONIZING C STATES, SO SUM OF SATELLITES .GE. ADASDR TOTAL. C THESE TWO DR OPTIONS REQUIRE THE USER TO SET TEMP/S C TO GET AN XDRSTOT FILE, ELSE JUST XPEPAR/TOT AGAIN. C PABS: C .EQ. 'YES' PHOTOABSORPTION IN XPETOT C .EQ. 'NO' PHOTOIONIZATION ONLY IN XPETOT (DEFAULT) C (IF RAD.EQ.'NO' THEN PHOTOIONIZATION=PHOTOABSORPTION.) C C----------------------------------------------------------------------- C C ***VARIABLES HERE-ON ARE NORMALLY FOR TESTING ETC. ONLY*** C C RAD: C ADVANCED OPERATION: C C .EQ. 'BOUND' INCLUDES ONLY RADIATION TO TRUE BOUND STATES. C THIS MIRRORS THE STANDARD STGB/R-MATRIX APPROACH. C IT INCLUDES SUCH RADIATION IN THE WIDTH. C .EQ. 'BOUND0' THEN C XPEPAR MIRRORS (DAMPED) R-MATRIX XPIPAR C XPETOT MIRRORS (DAMPED) R-MATRIX XPITOT C (THERE IS NO 'BOUND1' AS BOUND STATES CANNOT AUTOIONIZE.) C .EQ. 'BOUND2' INCLUDES RADIATION IN (PHOTOABSORPTION) CROSS C SECTION, XPETOT ONLY. THIS THEN MIRRORS NON-NTYP2I C DAMPED R-MATRIX XPATOT. IF RADIATION IS NTYP2I (ONLY) C THEN R-MATRIX XPATOT IS UNCHANGED FROM ITS UNDAMPED. C THUS, XPETOT MORE ACCURATELY DESCRIBES THE BROADENING C OF THE PHOTOABSORPTION BECAUSE IT INCLUDES NTYP2I. C SO C 'BOUND'='BOUND0' IF PABS.EQ.'NO' C 'BOUND'='BOUND2' IF PABS.EQ.'YES' C C .EQ. 'AUTO' INCLUDES RADIATION TO AUTOIONIZING STATES AS WELL. C THIS IS *NOT* THE STANDARD STGB/R-MATRIX APPROACH. C IT INCLUDES SUCH RADIATION IN THE WIDTH. C .EQ. 'AUTO0' ASSUMES THESE AUTOIONIZING STATES SUBSEQUENTLY C RADIATE AGAIN AND SO DO NOT CONTRIBUTE TO PHOTOIONIZATION C GENERALLY, THIS IS NOT A GOOD APPROXIMATION, AS DR C STUDIES SHOW AUTOIONIZATION IS MUCH MORE LIKELY. C BUT, IT IS ALL THAT CAN BE DONE FOR XPEPAR DESCRIBED BY C A TWO-STEP PROCESS. HOWEVER, FOR XPETOT: C .EQ. 'AUTO1' ASSUMES THESE AUTOIONIZING STATES SUBSEQUENTLY C AUTOIONIZE. THIS CAN BE REPRESENTED IN XPETOT SINCE IT C DOES NOT (NEED TO) RESOLVE WHERE TO. C .EQ. 'AUTO2', AS 'AUTO1' PLUS 'BOUND2' THUS XPETOT CORRESPONDS C TO PHOTOABSORPTION AGAIN, BUT WITH THE FULL BROADENING C DUE TO RADIATION TO AUTOIONIZING STATES AS WELL AS BOUND. C THIS XPETOT IS THE MOST ACCURATE DESCRIPTION OF TOTAL C PHOTOIONIZATION & PHOTOABSORPTION. C BUT, XPEPAR IS UNCERTAIN (NO MORE THAN R-MATRIX XPIPAR) C AS WE DON'T KNOW HOW MUCH RE-AUTOIONIZES TO THESE STATES. C IT IS CORRECTLY BROADENED (UNLIKE R-MATRIX XPIPAR). C SO C 'AUTO'='AUTO1' IF PABS.EQ.'NO' C 'AUTO'='AUTO2' IF PABS.EQ.'YES' C C C JRSLMX IS FOR TESTING ONLY AND ONLY MAKES SENSE IF RESOLV='YES' C (SEE ABOVE) AND SO RESOLV IS SET SO IN THIS CASE UNLESS C USER EXPLICITLY SETS RESOLV='NO'. SEE ALSO RADBF. C USE OF NCUT/LCUT (SEE BELOW) IS THE PREFERRED WAY TO RESTRICT C SUM OVER UPPER STATES, BUT RATHER A COARSE ONE. C C NCUT(OR MAX) .GT. 0 IGNORES CONTRIBUTIONS FROM N .GT. NCUT(OR MAX) C LCUT(OR MAX) .GE. 0 " " L .GT. LCUT(OR MAX) C NMIN .GT. 0, IGNORES CONTRIBUTIONS FROM N .LT. NMIN C LMIN .GE. 0, " " L .LT. LMIN C DEFAULT: INCLUDE ALL. C C JCFJ .GT. 0 NEGLECTS CAPTURE INTO CONFIGS .GT. JCFJ. C .LT. 0 NEGLECTS CAPTURE INTO CONFIGS .LE. -JCFJ. C DEFAULT: INCLUDE ALL. C JCF(J) AS JCFJ BUT FOR UNIT J SO DIFFERENT VALUES CAN BE USED. 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,200 - SUPERCEDED BY THE RAD OPTION. C .EQ. 0 DEFAULT, DOES NOTHING. C C JCFA .GT. 0 OMIT CONTINUUM CONFIGURATIONS .GT. JCFA. C THIS CAN BE USED TO OMIT AUTOIONIZATION INTO EXCITED C STATES FOR EXAMPLE, PROVIDED CONFIGS SUITABLY ORDERED. C *** THIS IS A DIFFERENT OPERATION FROM MDRCS13. *** C .LT. 0 OMIT CONTINUUM CONFIGURATIONS THAT RESULT FROM C CORE RE-ARRANGEMENT, I.E NL+E-. C C LSPI .GT. 0 INCLUDE PARTIAL WAVE LSPI=10000*(2S+1)+100*L+PI ONLY C J2PI .GE. 0 INCLUDE PARTIAL WAVE J2PI=100*(2*J)+PI ONLY C DEFAULT: INCLUDE ALL. C C IPRINT= PRINT LEVEL C .EQ. 0, DETAILED PRINTOUT OF EACH NTARP PARTIAL CROSS SECT. C .EQ.-1,+1, NL CROSS SECTIONS, FOR NTARP TARGETS C .GE. 0 WRITES PHOTON TARGETS TO ADF38L EVEN IF NO PE DATA. C . C PRINT='FORM' FORMATTED adf38l,r files (DEFAULT) C ='UNFORM' UNFORMATTED adf38lu,ru files. C C UNITS ENERGY UNITS USED FOR EWIDTH AND CONVOLUTED ENERGIES *ONLY*: C 13.606 FOR EV,1.0 FOR RYDBERGS (DEFAULT). C C NC .GT. 0 READ OLD ocsp/t FILES. C C NOTE: TESTS INVOLVING LSPI, J2PI AND JCFR MAY HAVE BEEN C COMMENTED-OUT BY 'CT' FOR SPEED AS THEY ARE RARELY USED. C C C****************************END-ONE************************************ C C PRINT='FORM' IPRINT=-1 NCUT=-66 LCUT=-77 JCFA=0 JCFR=0 JCFJ=0 NRSLMX=6 IRSLMX=-1 JRSLMX=-1 RESOLV=' ' RADBF=' ' LSPI=0 J2PI=-1 NMIN=-10 LMIN=-10 NMAX=-10 LMAX=-10 UNITS=DONE RAD=' ' PABS=' ' nc=0 boldf=.false. boop=.true. !read radiative rates in batches in CROSSJ C C----------------------------------------------------------------------- C IF(IRD.NE.0)READ(5,ONE) C C----------------------------------------------------------------------- C IF(RAD.EQ.' ')RAD='YES' IF(RAD.EQ.'YES'.OR.RAD.EQ.'AUTO')THEN IF(PABS.EQ.'YES')THEN RAD='AUTO2' ELSE RAD='AUTO1' ENDIF ELSEIF(RAD.EQ.'RM'.OR.RAD.EQ.'BOUND')THEN IF(PABS.EQ.'YES')THEN RAD='BOUND2' ELSE RAD='BOUND0' ENDIF ELSEIF(RAD.EQ.'DRS')THEN IF(RADBF.EQ.' ')RADBF='F-F' RAD='AUTO0' ELSEIF(RAD.EQ.'DR'.OR.RAD.EQ.'PR')THEN RAD='AUTO0' ENDIF C RAD4=RAD IF(RAD.NE.'NO'.AND.RAD.NE.'OP'.AND. X RAD4.NE.'BOUN'.AND.RAD4.NE.'AUTO')THEN WRITE(6,*)'*** UNRECOGNIZED RAD OPTION: ',RAD STOP '*** UNRECOGNIZED RAD OPTION ***' ENDIF C IF(PABS.EQ.'YES')THEN IF(RAD4.EQ.'BOUN')THEN IF(RAD.NE.'BOUND2')THEN WRITE(6,*)'*** CONFLICT BETWEEN RAD AND PABS OPTIONS: ' X ,RAD,PABS STOP '*** CONFLICT BETWEEN RAD AND PABS OPTIONS ***' ENDIF ENDIF IF(RAD4.EQ.'AUTO')THEN IF(RAD.NE.'AUTO2')THEN WRITE(6,*)'*** CONFLICT BETWEEN RAD AND PABS OPTIONS: ' X ,RAD,PABS STOP '*** CONFLICT BETWEEN RAD AND PABS OPTIONS ***' ENDIF ENDIF ELSEIF(PABS.EQ.'NO')THEN IF(RAD4.EQ.'BOUN')THEN IF(RAD.EQ.'BOUND2')THEN WRITE(6,*)'*** CONFLICT BETWEEN RAD AND PABS OPTIONS: ' X ,RAD,PABS STOP '*** CONFLICT BETWEEN RAD AND PABS OPTIONS ***' ENDIF ENDIF IF(RAD4.EQ.'AUTO')THEN IF(RAD.EQ.'AUTO2')THEN WRITE(6,*)'*** CONFLICT BETWEEN RAD AND PABS OPTIONS: ' X ,RAD,PABS STOP '*** CONFLICT BETWEEN RAD AND PABS OPTIONS ***' ENDIF ENDIF ELSEIF(PABS.NE.' ')THEN WRITE(6,*)'*** UNRECOGNIZED PABS OPTION (YES/NO ONLY): ',PABS STOP '*** UNRECOGNIZED PABS OPTION ***' ENDIF C IF(UNITS.EQ.DZERO)STOP 'ERROR: UNITS MUST BE NON-ZERO!' UNITS=ABS(UNITS) !NEGATIVE FLAG NOT USED C IF(IRSLMX.LT.0)IRSLMX=NDIM17+1 C IF(JRSLMX.GT.0)THEN IF(RESOLV.NE.'NO')THEN RESOLV='YES' ELSE WRITE(0,*)' *** WARNING: YOU ARE RESTRICTING UPPER STATES BUT' X ,' ARE GIVING NO DETAILED INFO IN ADF38L/R.' WRITE(6,*)' *** WARNING: YOU HAVE SET JRSLMX=',JRSLMX,' BUT' X ,' ARE GIVING NO DETAILED INFO IN ADF38L/R AS RESOLV="NO".' ENDIF ELSE IF(RESOLV.NE.'YES')RESOLV='NO' IF(JRSLMX.LT.0)JRSLMX=NDIM17+1 ENDIF BRSLVF=RESOLV.EQ.'YES' C IF(RADBF.EQ.' ')RADBF='B-F' IF(RADBF.EQ.'B-F')THEN !BOUND-FREE ONLY TOLN=0 TOLR=0 ELSEIF(RADBF.EQ.'B-B')THEN !B-F PLUS BOUND-BOUND TOLN=99999 TOLR=0 ELSEIF(RADBF.EQ.'F-F')THEN !B-F PLUS FREE-FREE TOLN=0 TOLR=99999 ELSEIF(RADBF.EQ.'ALL')THEN TOLN=99999 TOLR=99999 ELSE WRITE(0,*)'***ERROR: UNRECOGNIZED RADBF OPTION:',RADBF STOP'***ERROR: UNRECOGNIZED RADBF OPTION!' ENDIF C IF(NTAR.GE.0)NTAR=MAX(NTAR,NTAR1,NTAR2) !COMPATIBILITY MODE IF(NTAR0.NE.0)WRITE(0,*)'***N.B.: NTAR0 INPUT IGNORED (INTERNAL)' IF(NTART.LT.0)NTART=0 C BMATCH=MATCH.EQ.'YES' C IF(NMAX.GT.0)NCUT=NMAX IF(RAD.EQ.'OP'.AND.NCUT.LE.0)NCUT=NRSLMX !UPPER *AND* LOWER IF(LMAX.GT.-1)LCUT=LMAX C IF(JCFR.GT.100)THEN WRITE(0,*)'*** JCFR.GT.100,200 SUPERCEDED BY RAD OPTION' WRITE(6,*)'*** JCFR.GT.100,200 SUPERCEDED BY RAD OPTION' IF(JCFR.GT.200)THEN RAD='NO' JCFR=0 ELSE STOP '*** JCFR.GT.100 NOT SUPPORTED BY ADASPE' ENDIF ENDIF IF(JCFA.EQ.0)JCFA=9999 IF(JCFJ.EQ.0)JCFJ=9999 JCFX=0 NAME='JCF*' IF(JCFR.NE.0)THEN JCFX=JCFR NAME='JCFR' ENDIF IF(JCFJ.NE.9999)THEN JCFX=JCFJ NAME='JCFJ' ENDIF IF(IABS(JCFA).NE.9999)THEN JCFX=JCFA NAME='JCFA' ENDIF C WRITE(6,11) NTAR,NMIN,LMIN,NCUT,LCUT,NAME,JCFX 11 FORMAT(/' NTAR=',I3,3X,'NMIN=',I4,3X,'LMIN=',I3 X,3X,'NMAX=',I4,3X,'LMAX=',I3,3X,A4,'=',I5) C IF(BLS.AND.LSPI.GT.0)WRITE(6,12)LSPI 12 FORMAT(' LSPI=',I6) IF(BIC.AND.J2PI.GE.0)WRITE(6,6)J2PI 6 FORMAT(' J2PI=',I6) C IF(NCUT.LT.1)NCUT=100000 IF(LCUT.LT.0)LCUT=100000 LCUT=MIN(LCUT,NCUT-1) C C C*************************NAMELIST-TWO********************************** C C ***NOTHING IS COMPULSORY C----------------------------------------------------------------------- C C NECOR .EQ. 0: THEORETICAL POSITIONS ARE USED - FIXED IN ADASPE. C C NR1 NR1 .EQ. 0 NO OUTER ELECTRON RADIATION. C IF NR1 .GT.0 THEN RADIATIVE STABILIZATION C OF THE VALENCE ELECTRONS IS GENERATED INTERNALLY. C NR1 IS THE LOWER BOUND. IN THIS CASE SET IT C EQUAL TO THE LARGEST CORE PRINCIPAL QUANTUM C NUMBER (N) +1. C IF .EQ. 999 ATTEMPTS TO DETERMINE NR1 INTERNALLY, C THIS IS THE DEFAULT. C (OUTER ELECTRON RADIATION FROM AUTOSTRUCTURE IS C ALWAYS INCLUDED OF COURSE.) C C TEAPOT : IF GROUND STATE OF ION MISSING, SET TEAPOT TO ITS RYD C TOTAL ENERGY, I.E..LT. ZERO SO CODE CAN DIFFERENTIATE C BETWEEN TRUE BOUND AND AUTOIONIZING STATES. C C----------------------------------------------------------------------- C C NBIN .EQ. 0 DEFAULT, DOES NOTHING. C .NE. 0 THEN GENERATE CROSS SECTIONS, WITH |NBIN| *PHOTON* C ENERGIES (LINEARLY) BETWEEN EMIN, EMAX (BELOW). C .GT. 0 NO FINAL-STATE RESOLVED DATA, NO ADF38 WRITTEN. C C |EWIDTH| .GT. TOLC (1.1D-7 RYD, CURRENTLY) THEN CONVOLUTE CROSS C SECTIONS WITH GAUSSIAN DISTRIBUTION OF EWIDTH UNITS. C PARTIALS AND TOTALS OUTPUT TO XPEPAR AND XPETOT. C .LE. TOLC THEN NO CONVOLUTION. C .GE. 0 GENERATE BINNED CROSS SECTIONS. C ONLY REQUIRES A COARSE ENERGY MESH. C EWIDTH .LT. 0 USE LORENTZ PROFILE. NEEDS A FINE ENERGY MESH C C.F. R-MATRIX. C .EQ.0 DEFAULT, I.E. UNCONVOLUTED BINNED CROSS SECTIONS C IN ocsp,t AND NO OUTPUT IN XPEPAR, XPETOT. C C EMIN -- MINIMUM PHOTON ENERGY IN UNITS (DEFAULT ZERO) C N.B. ANY CROSS SECTIONS LESS THAN EMIN ARE OMITTED C FROM ocsp/t, XPEPAR, XPETOT. C C EMAX -- MAXIMUM PHOTON ENERGY IN UNITS (DEFAULT HUGE - NOT GOOD) C N.B. ANY CROSS SECTIONS GREATER THAN EMAX ARE OMITTED C FROM ocsp/t, XPEPAR, XPETOT. C C EMIN, EMAX ARE THE SAME FOR *ALL* PHOTON TARGETS, SINCE THE C RELEVANT QUANTITY IS THE PHOTON ENERGY RELATIVE TO THE INITIAL C STATE, *NOT* RELATIVE TO THE GROUND STATE. SO, ENSURE EMIN IS C SMALL ENOUGH TO INCLUDE ANY/ALL LOW-LYING RESONANCES ACCESSED FROM C EXCITED PHOTON TARGETS. I.E. EMIN=ZERO IS THE SAFE CHOICE. C C ALTERNATIVELY (IF MXE.GT.0) THEN USE STGF "MESH" MXE,E0,EINCR. C CAN ONLY BE RYDBERG UNITS (AS STGF) AND IN ADDITION MUST SET C UNITS=Z**2 IF E0,EINC ARE INPUT Z-SCALED. *ONLY* E0,EINCR CAN C Z-SCALED. ALL OTHER INPUT ENERGIES *MUST* BE UNSCALED RYDBERGS. C FURTHERMORE, IF E0 IS THE STARTING VALUE OF THE ELECTRON ENERGY C (AS STGF) THEN SET TEAPOT.GT.0 TO THE *UNSCALED* IONIZATION C ENERGY (RYD) TO CONVERT TO THE PHOTON MESH. THIS OVERRIDES THE C NORMAL FUNCTION OF TEAPOT, SO THE GROUND STATE OF THE ION MUST C BE PRESENT IN THE RATES FILE. C C----------------------------------------------------------------------- C C ***VARIABLES HERE-ON ARE NORMALLY FOR TESTING ETC. ONLY*** C C NGAUSS .GT. 0 CONVOLUTION POINTS BETWEEN EMIN AND EMAX. C .LT. 0 -NGAUSS CONVOLUTION POINTS PER EWIDTH. C .EQ. 0 2*nbin+1 CONVOLUTION POINTS BETWEEN EMIN AND EMAX. C C EMINC--MINIMUM E-ENERGY IN UNITS FOR PROCESSING (DEFAULT ZERO) C N.B. ANY CROSS SECTIONS LESS THAN EMINC ARE OMITTED FROM ADF38. C EMAXC--MAXIMUM E-ENERGY IN UNITS FOR PROCESSING (DEFAULT HUGE) C N.B. ANY CROSS SECTIONS GREATER THAN EMAXC ARE OMITTED FROM ADF38. C NOTE: TESTS INVOLVING EMINC AND EMAXC MAY HAVE BEEN C COMMENTED-OUT BY 'CT' FOR SPEED AS THEY ARE RARELY USED. C C RCOR .GT. 0.0 CORRECTION FACTOR FOR CORE RADIATIVE RATE C ACOR .GT. 0.0 CORRECTION FACTOR FOR ALL AUGER RATES C NLCOR .GT.0 CORRECTION FACTORS ACORL(LV+1) FOR LV=0,1,...NLCOR-1 C APPLIED TO EACH AUGER RATE 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 RCOR, ACOR, NLCOR, NNCOR .LE. 0.0 **DEFAULT**, RESET TO 1.0 C C RMIN IS THE SMALLEST RADIATIVE RATE RETAINED (DEFAULT -1, ALL) C C TOLR CONTROLS INITIAL STATES TO PHOTOEXCITE FROM: C INITIAL STATES UP TO TOLR RYD ABOVE THE IONIZATION LIMIT. C DEFAULT = 0.0 SO ONLY TRUE BOUND INITIAL STATES CONSIDERED. C MODIFIED BY RAD. C C TOLN CONTROLS FINAL STATES TO PHOTOEXCITE TO: C FINAL STATES UP TO TOLN RYD BELOW THE IONIZATION LIMIT. C DEFAULT = 0.0 SO ONLY AUTOIONIZING FINAL STATES CONSIDERED. C MODIFIED BY RAD. C C NR2 IS THE HIGHEST N FOLLOWING OUTER ELECTRON RADIATION. C FIXED INTERNALLY: ALL POSSIBLE TRANSITIONS. C C TOLB=MAX(1.5D-7,5.0D-9*DZ*NZ) RYD, 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 DELTAF IS THE MINIMUM VALUE OF THE OSCILLATOR STRENGTH RETAINED C FOR OUTPUT TO ADF38R. DEFAULT 1.D-5. C C DEFAULT OPERATION IS PHOTOEXCITATION. ADF38L, ADF38R ALWAYS WRITTEN. C C IF BINNED CROSS SECTIONS ARE REQUESTED (NBIN.NE.0) THEN THEY C ARE PHOTOEXCITATION ONES, ANALAGOUS TO DR. C C *** HOWEVER, IF TEMPERATURES ARE SET THEN PARTIAL DR RATE COEFFICIENTS C ARE BINNED (BY PHOTON ENERGY) INSTEAD, E.G. FOR DR SATELLITES, AS C THEY ARE JUST THE (DR) PHOTON EMISSIVITY COEFFICIENTS (PECS). *** C C JTEMP.EQ.0 USE ADAS DEFAULT TEMPERATURES, IF REQUIRED. C .GT.0 READ-IN JTEMP TEMPERATURES IN KELVIN. C .LT.0 READ-IN -JTEMP TEMPERATURES IN LOG(K). C C IRDT.EQ.0 HISTORIC TEMP(J=1,JTEMP) READ AFTER ALL TARGET INFO ETC. C .NE.0 STRAIGHT AFTER NAMELIST, FOR EASE OF USE WITH SCRIPT. C C JTHETA.GE.0 RESTRICT NUMBER OF ADAS DEFAULT TEMPERATURES TO JTHETA C DEFAULT=0 - NO DR. C C HINTS: THEN DO SET C C NRSLMX.EQ.999 SAY TO ENSURE ANY/ALL SATELLITES ARE INCLUDED, C UNLESS YOU REALLY DO WANT TO RESTRICT THEM (IT ACTS C LIKE THE DR NCUT.) C C EMAX TO THE LARGEST *PHOTON* ENERGY REQUIRED TO BE BINNED, THIS IS C LIKLELY LARGER THAN THE LARGEST *ELECTRON* ENERGY, WHICH CAN C BE RESTRICTED WITH EMINC,EMAXC. C C DO *NOT* SET RADBF='ALL' OR 'F-F' UNLESS YOU REALLY WANT TO COUNT C RADIATION TO AUTOIONIZING STATES AS CONTRIBUTING TO RECOMBINATION C (I.E. INCLUDE THESE RATES IN THE NUMERATOR.) C THE DEFAULT RADBF IS 'B-F' (SAFE FOR DR) BUT... C C***************************END-TWO************************************* C C TOLB=-DONE RCOR=-DONE ACOR=-DONE RMIN=-DONE EMIN=DZERO EMAX=99999.0D0 EMINC=DZERO EMAXC=99999.0D0 ERES=-DONE NLCOR=0 NNCOR=0 NR2=-1 NR1=999 !NEW DEFAULT JTHETA=0 JTEMP=0 IRDT=0 DELTAF=1.D-5 TEAPOT=DZERO NBIN=0 EWIDTH=DZERO NGAUSS=0 MXE=0 EINCR=DZERO E0=DZERO C C----------------------------------------------------------------------- C IF(IRD.NE.0)READ(5,TWO) C C----------------------------------------------------------------------- C IF(IRDT*JTEMP.NE.0)THEN !ALTERNATE TEMP READ FOR SCRIPT JJTEMP=ABS(JTEMP) IF(JJTEMP.GT.NDIM28)THEN WRITE(6,*)'TOO MANY TEMPS; INCREASE NDIM28 TO:',JJTEMP STOP 'ERROR: TOO MANY TEMPS; INCREASE NDIM28 TO JTEMP' ENDIF READ(5,*)(TEMP(K),K=1,JJTEMP) ENDIF C TOLB0=TOLB IF(TOLR.LT.DZERO)TOLR=DZERO IF(TOLN.LT.DZERO)TOLN=DZERO C IF(MXE.NE.0)THEN !ASSUME STGF MESH IF(EINCR.EQ.DZERO)STOP 'ERROR: EINCR=0 WHEN MXE IN USE' NBIN=MXE EMIN=E0 EMAX=E0+(IABS(MXE)-1)*EINCR IF(UNITS.NE.DONE)THEN !TRY AND FIGURE OUT ANY Z-SCALING Z=SQRT(UNITS) IF(Z.LT.DONE)Z=DONE/Z NZ=NINT(Z) IF(ABS(Z-NZ).GT.1.D-5)THEN !USER ONLY INPUT Z UNITS=UNITS*UNITS ELSE !CAN ONLY ASSUME Z**2 WRITE(0,*)'*** ASSUMING Z-SCALED CHARGE = ',NZ WRITE(0,*)'*** IF INCORRECT, RESET UNITS= Z**2' WRITE(6,*)'*** ASSUMING Z-SCALED CHARGE = ',NZ WRITE(6,*)'*** IF INCORRECT, RESET UNITS= Z**2' ENDIF IF(UNITS.GT.DONE)UNITS=DONE/UNITS EMIN=EMIN/UNITS !NOW UNSCALED RYD EMAX=EMAX/UNITS !NOW UNSCALED RYD UNITS=DONE ENDIF IF(TEAPOT.GT.DZERO)THEN !CONVERT FROM E TO P MESH EMIN=EMIN+TEAPOT EMAX=EMAX+TEAPOT TEAPOT=DZERO ENDIF ENDIF C WRITE(6,13)EMIN,EMAX,NR1,TOLB,TOLR,TOLN,DELTAF,TEAPOT 13 FORMAT(/1X,'EMIN=',F10.3,3X,'EMAX=',F10.3,3X,'NR1=',I3 X,3X,'TOLB=',F12.8,3X,'TOLR=',F10.4,3X,'TOLN=',F10.4,3X X,'DELTAF=',F10.7,3X,'TEAPOT=',F10.1) C EMINC=EMINC/UNITS !ELECTRON ENERGY RANGE EMAXC=EMAXC/UNITS !RESTRICTS *ALL* OUTPUT C C SET-UP BINS: PHOTON ENERGY RANGE DEFINED BY EMIN, EMAX C (CURRENTLY, RESTRICTS BINNED CROSS SECTIONS ONLY) C NBIN0=NBIN IF(NBIN.NE.0)THEN NBIN=ABS(NBIN) IF(NBIN.GT.NDIM1)THEN WRITE(6,*)' ***DIMENSION EXCEEDED, INCREASE NDIM1 TO: ',NBIN STOP ' ***DIMENSION EXCEEDED, INCREASE NDIM1' ENDIF NBIN1=NBIN-1 IF(ERES.LE.DZERO)THEN ERES=(EMAX-EMIN)/NBIN1 ELSE EMAX=EMIN+NBIN1*ERES ENDIF DO N=1,NBIN T=N-1 T=EMIN+T*ERES EBIN(N)=T/UNITS ENDDO BLOR=EWIDTH.LT.DZERO IF(.NOT.BLOR)THEN WRITE(6,14)NBIN0,ERES 14 FORMAT(/' BINNED CROSS SECTIONS WRITTEN: NBIN=',I6, X ' WITH BIN WIDTH=',1PE12.4) OPEN(7,FILE='ocsp') !OPEN PARTIAL FILE OPEN(8,FILE='ocst') !OPEN TOTAL FILE ELSE WRITE(6,8)NBIN0,ERES 8 FORMAT(/' LORENTZIAN PROFILES MAPPED-OUT: MXE=',I7, X ' AND EINCR=',1PE12.4) ENDIF IF(EWIDTH.NE.DZERO)THEN IF(ABS(EWIDTH)/UNITS.GT.TOLC)THEN WRITE(6,10)EWIDTH 10 FORMAT(/' AND CONVOLUTED WITH EWIDTH=',F8.4, X ' FWHM GAUSSIAN DISTRIBUTION') ENDIF EWIDTH=EWIDTH/UNITS IF(NBIN.NE.0.AND.(EWIDTH.LT.DZERO.OR.EWIDTH.GT.TOLC))THEN IF(JTEMP.GT.0.OR.JTHETA.GT.0)THEN OPEN(13,FILE='XDRSTOT') ELSE OPEN(13,FILE='XPEPAR') OPEN(14,FILE='XPETOT') ENDIF ENDIF ENDIF C C INITIALZE BIN TARGETS C IF(NTARP.LE.0)THEN LMAX=IABS(NTAR) !NOTE CHANGE OF MEANING FOR LMAX ELSE LMAX=NTARP !PARTIAL ELECTRON TARGETS RESOLVED ENDIF IF(LMAX.GT.NDIM3)THEN WRITE(6,15)NDIM3,LMAX 15 FORMAT(/'***PARTIAL BINNED CROSS SECTION FILE RESTRICTED TO', X 'LOWEST ',I4,' ELECTRON TARGETS.'/ X '***INCREASE NDIM3 TO:',I5,' TO OBTAIN ALL REQUESTED.'/ X ' (DO YOU REALLY WANT/NEED THEM ALL...?)') LMAX=NDIM3 ENDIF C IF(JTEMP.EQ.0.AND.JTHETA.LE.0)THEN LBIN=1 !PHOTON TARGETS IF(IRSLMX.LE.NDIM17)LBIN=MIN(IRSLMX,NDIM13) IF(LBIN.GT.NDIM4)THEN WRITE(6,16)NDIM4,LBIN 16 FORMAT(/'***BINNED CROSS SECTION FILES RESTRICTED TO', X 'LOWEST ',I5,' PHOTON TARGETS.'/ X '***INCREASE NDIM4 TO:',I6,' TO OBTAIN ALL REQUESTED.'/ X ' (DO YOU REALLY WANT/NEED THEM ALL...?)') LBIN=NDIM4 ENDIF C IF(EWIDTH.LT.DZERO.OR.EWIDTH.GT.TOLC)THEN WRITE(13,32)LBIN,LMAX 32 FORMAT('# PARTIAL PHOTOIONIZATION CROSS SECTIONS FROM',I5, X ' PHOTON TARGETS TO',I5,' ELECTRON TARGETS') IF(PABS.EQ.'YES')THEN WRITE(14,33)LBIN 33 FORMAT('# TOTAL PHOTOABSORPTION CROSS SECTIONS FROM ',I5, X ' PHOTON TARGETS ') ELSE WRITE(14,34)LBIN 34 FORMAT('# TOTAL PHOTOIONIZATION CROSS SECTIONS FROM ',I5, X ' PHOTON TARGETS ') ENDIF ENDIF ELSE LBIN=IABS(JTEMP) IF(LBIN.EQ.0)LBIN=MIN(JTHETA,NDIM4) ENDIF c if(nc.gt.0)then !read existing ocsp/t if(ngauss.eq.0)ngauss=2*nbin+1 go to 77 endif C DO L0=1,LBIN !IRSLMX DO L=1,LMAX !PARTIAL NTAR/P DO N=1,NBIN1 SBIN(N,L,L0)=DZERO ENDDO ENDDO ENDDO DO L0=1,LBIN !IRSLMX PHOTON TARGETS DO N=1,NBIN1 !TOTAL NTART TBIN(N,L0)=DZERO ENDDO ENDDO ELSE !ONLY ADF38L,R OUTPUT LMAX=0 LBIN=0 EWIDTH=DZERO EBIN(2)=DONE EBIN(1)=DZERO ERES=EBIN(2)-EBIN(1) ENDIF C IF(RCOR.LE.DZERO)RCOR=-DONE IF(ACOR.LE.DZERO)ACOR=-DONE IF(ABS(RCOR*ACOR).NE.1.0D0)WRITE(6,308)ACOR,RCOR 308 FORMAT(/1X,'ACOR=',F8.4,3X,'RCOR=',F8.4) C EI(1)=DZERO !FLAG AUTOMATIC SEARCH FOR TARGET ENERGIES C ISIGN=1 IF(NTAR.LT.0)ISIGN=-1 IMAX=MIN(ISIGN*NTAR,NDIM5) C DO I=1,NDIM5 E1C(I)=DZERO ENDDO C C READ ELECTRON TARGET INFO C EDUM=DZERO C IF(BLS)THEN READ(5,825,END=850)NAME 825 FORMAT(28X,A4) BFORM=NAME.NE.' ' !OLD- OR NEW-STYLE IF(.NOT.BFORM)WRITE(6,816) 816 FORMAT(/1X,'(2S+1) L P') IF(BFORM)WRITE(6,814) 814 FORMAT(/1X,'(2S+1) L P E1C(RYD)') BACKSPACE(5) DO I=1,IMAX IF(.NOT.BFORM)READ(5,*,END=821)IWS(I),IWL(I),IPAR IF(BFORM)READ(5,827,END=821)IWS(I),IWL(I),IPAR,IDM,IDM,E1C(I) 827 FORMAT(3I2,I5,I5,F18.6) IF(IWS(I).EQ.0)GO TO 821 !TERMINATOR IWS(I)=IABS(IWS(I)) IWT(I)=IWS(I)*(2*IWL(I)+1) IF(.NOT.BFORM)WRITE(6,817)IWS(I),IWL(I),IPAR IF(BFORM)WRITE(6,817)IWS(I),IWL(I),IPAR,E1C(I) 817 FORMAT(I6,2I3,3X,F13.6) ENDDO IF(IMAX.EQ.NDIM5)THEN WRITE(6,847) STOP 'INCREASE NDIM5' ENDIF IF(BFORM)THEN DO I=1,9999 !SKIP ANY EXTRA TARGET INFO READ(5,827,END=820)ITEST,IDUM,IDUM,IDUM,IDUM,EDUM IF(ITEST.EQ.0)GO TO 820 !TERMINATOR ENDDO ENDIF GO TO 820 !ALL ASKED-FOR FOUND 821 NTAR=ISIGN*(I-1) WRITE(6,822)NTAR 822 FORMAT(/,'*** ATTENTION: NTAR REDUCED TO',I4, X ' NON-DEGENERATE TERMS') ENDIF 847 FORMAT(/' *** TOO MANY TARGETS TO BE READ, INCREASE NDIM5') C IF(BCA)THEN BFORM=.TRUE. !AS NO OLD-STYLE WRITE(6,811) 811 FORMAT(/1X,' W P E1C(RYD)') DO I=1,IMAX READ(5,*,END=831)IWS(I),IPAR,IDM,E1C(I) IF(IWS(I).EQ.0)GO TO 831 !TERMINATOR IWT(I)=IWS(I) WRITE(6,837)IWS(I),IPAR,E1C(I) 837 FORMAT(I6,I3,3X,F13.6) IWL(I)=0 !TO USE BLS ENDDO IF(IMAX.EQ.NDIM5)THEN WRITE(6,847) STOP 'INCREASE NDIM5' ENDIF IF(BFORM)THEN DO I=1,9999 !SKIP ANY EXTRA TARGET INFO READ(5,*,END=820)ITEST,IDUM,IDUM,EDUM IF(ITEST.EQ.0)GO TO 820 !TERMINATOR ENDDO ENDIF GO TO 820 !ALL ASKED-FOR FOUND 831 NTAR=ISIGN*(I-1) WRITE(6,832)NTAR 832 FORMAT(/,'*** ATTENTION: NTAR REDUCED TO',I4, X ' NON-DEGENERATE CFGS') ENDIF C IF(BIC)THEN READ(5,826,END=850)NAME 826 FORMAT(30X,A4) BFORM=NAME.NE.' ' !OLD- OR NEW-STYLE IF(.NOT.BFORM)WRITE(6,818) 818 FORMAT(/1X,'2J P',3X,'(2S+1) L') IF(BFORM)WRITE(6,813) 813 FORMAT(/1X,'2J P',3X,'(2S+1) L E1C(RYD)') BACKSPACE(5) DO I=1,IMAX IF(.NOT.BFORM)READ(5,*,END=823)IWJ(I),IPAR,IWS(I),IWL(I) IF(BFORM)READ(5,828,END=823)IWJ(I),IPAR,IWS(I),IWL(I) X ,IDUM,IDUM,E1C(I) 828 FORMAT(2I2,2X,2I2,2I5,3X,F15.8) IF(IWS(I).EQ.0)GO TO 823 !TERMINATOR IWS(I)=IABS(IWS(I)) IWT(I)=IWJ(I)+1 IF(.NOT.BFORM)WRITE(6,819)IWJ(I),IPAR,IWS(I),IWL(I) IF(BFORM)WRITE(6,819)IWJ(I),IPAR,IWS(I),IWL(I),E1C(I) 819 FORMAT(I3,I2,3X,I5,I3,3X,F15.8) ENDDO IF(IMAX.EQ.NDIM5)THEN WRITE(6,847) STOP 'INCREASE NDIM5' ENDIF IF(BFORM)THEN DO I=1,9999 !SKIP ANY EXTRA TARGET INFO READ(5,828,END=820)IDUM,IDUM,ITEST,IDUM,IDUM,IDUM,EDUM IF(ITEST.EQ.0)GO TO 820 !TERMINATOR ENDDO ENDIF GO TO 820 !ALL ASKED-FOR FOUND 823 NTAR=ISIGN*(I-1) WRITE(6,824)NTAR 824 FORMAT(/,'*** ATTENTION: NTAR REDUCED TO',I4, X ' NON-DEGENERATE LEVELS') ENDIF C C CHECK/SET TOLB C 820 IF(E1C(1).NE.DZERO.OR.E1C(2).GT.DZERO)THEN IF(E1C(1).EQ.DZERO)E1C(1)=1.D-70 TOLB=1.D10 DO I=2,IABS(NTAR) T=E1C(I)-E1C(I-1) IF(T.GT.DZERO.AND.T.LT.TOLB)TOLB=T ENDDO IF(TOLB.LT.TOLB0)THEN !WRITE WARNING, BUT ALLOW USER SET VALUE WRITE(6,829)TOLB0,TOLB 829 FORMAT(/' *** WARNING: YOUR INPUT TOLB IS LARGER THAN THE', X ' MINIMUM TARGET SPLITTING:',1P2E10.3/' *** RECOMMEND', X ' UNSETTING TOLB AND LET CODE DETERMINE IT!'/) TOLB=TOLB0 !RE-INSTATE USER VALUE ELSE IF(TOLB0.LE.DZERO.AND.TOLB.GT.DZERO)THEN TOLB=TOLB/2 ELSE !ORIGINAL INPUT (MAYBE UNSET) TOLB=TOLB0 ENDIF ENDIF ENDIF C C ALT. SET OF GROUND-STATE ENERGY C IF(NTAR.EQ.0.AND.TEAPOT.EQ.DZERO)TEAPOT=EDUM C C RE-SET NTAR C 850 NTARX=MAX(NTARP,NTART) IF(NTARX.LT.0)NTARX=0 NTAR=MIN(ISIGN*NTAR,NTARX) !.GE.0 NTAR0=ISIGN*NTAR !"ORIGINAL" C C NOT NECESSARY TO RESTRICT LMAX BASED ON TARGET INFO READ C LMAX=MIN(LMAX,NTAR) C LMAX=MAX(LMAX,NTARP) C IF(NTARP.LT.0)THEN IF(NTAR0.GE.0)THEN NTARP=NTAR ELSE NTARP=NDIM5 ENDIF ENDIF C IF(.NOT.BCA.AND..NOT.BLS.AND..NOT.BIC.OR.NTAR0.LT.NTARP)THEN DO I=NTAR+IRD,NDIM5 IWS(I)=0 IWL(I)=0 IWJ(I)=0 IWT(I)=0 ! 1 IF DR ENDDO ENDIF C C CORRECTION FACTORS - SEE NAMELIST WRITEUP C IF(NLCOR.GT.0)THEN IF(NLCOR.GT.NDIM25)THEN WRITE(6,*)'NLCOR REQUIRES NDIM25 AT LEAST',NLCOR STOP 'INCREASE NDIM25 TO NLCOR' ENDIF C READ(5,*)(ACORL(I),I=1,NLCOR) WRITE(6,177)(ACORL(I),I=1,NLCOR) 177 FORMAT(/' ACORL',10F10.6) C DO I=NLCOR,NDIM25 ACORL(I)=ACORL(NLCOR) ENDDO ELSE DO I=1,NDIM25 ACORL(I)=DONE ENDDO ENDIF C IF(NNCOR.GT.0)THEN IF(NNCOR.GT.NDIM1)THEN WRITE(6,*)'NNCOR REQUIRES NDIM1 AT LEAST',NNCOR STOP 'INCREASE NDIM1 TO NNCOR' ENDIF DO I=1,NDIM1 ACORN(I)=DONE ENDDO N0=999999 C READ(5,*)NNCOR C DO I=1,NNCOR C READ(5,*)N,ACORN(N) WRITE(6,181)N,ACORN(N) 181 FORMAT(I5,F10.3) C 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 C SET TEMPERATURES (USER INPUT ALWAYS IN KELVIN SINCE ADAS USES KELVIN) C IF(JTEMP.NE.0)THEN JJTEMP=ABS(JTEMP) IF(JJTEMP.GT.NDIM28)THEN WRITE(6,*)'TOO MANY TEMPS; INCREASE NDIM28 TO:',JJTEMP STOP 'ERROR: TOO MANY TEMPS; INCREASE NDIM28 TO JTEMP' ENDIF IF(IRDT.EQ.0)READ(5,*)(TEMP(K),K=1,JJTEMP) !IF NOT ALREADY READ IF(JTEMP.LT.0)THEN DO K=1,JJTEMP TEMP(K)=10**TEMP(K) ENDDO JTEMP=-JTEMP ENDIF ELSE TEMP(1)=-DONE JTEMP=JTHETA !MAY RESTRICT ADAS TEMPS ENDIF C IF(NBIN0.EQ.0.AND.(JTEMP.NE.0.OR.JTHETA.NE.0))THEN IF(PRINT.EQ.'UNFORM')THEN !ONLY FOTMATTED ADF38R HAS DRS/PEC WRITE(6,*)'*** IGNORING TEMPERATURES SINCE NO BINNING SET-UP' WRITE(0,*)'*** IGNORING TEMPERATURES SINCE NO BINNING SET-UP' JTEMP=0 JTHETA=0 ENDIF ENDIF C IF(JTEMP.GT.0)THEN C C REMIND USER ABOUT DIFFERENCE WITH ADASDR FOR DR SATELLITES C IF(RADBF.EQ.'F-F'.OR.RADBF.EQ.'ALL')THEN WRITE(6,*) X'*** DR SATELLITES INCLUDE RADIATION TO AUTOIONIZING STATES' WRITE(6,*) X'*** THIS DOES NOT MIRROR ADASDR OPERATION' WRITE(6,*) X'*** SET RAD="DR" TO RECOVER ADASDR TOTALS' WRITE(0,*) X'*** DR SATELLITES INCLUDE RADIATION TO AUTOIONIZING STATES' WRITE(0,*) X'*** THIS DOES NOT MIRROR ADASDR OPERATION' WRITE(0,*) X'*** SET RAD="DR" TO RECOVER ADASDR TOTALS' ENDIF IF(RAD4.EQ.'AUTO')RAD='AUTO0' !SILENT AS MINOR IF(RAD.NE.'AUTO0'.AND.RAD.NE.'OP')THEN !ONLY IN adasout NOW WRITE(6,*) X'*** NOTE: RADIATION TO AUTOIONIZING STATES OMITTED FROM WIDTH' WRITE(6,*)'*** SET RAD="DR" TO INCLUDE IT TO MIRROR ADASDR' WRITE(0,*) X'*** NOTE: RADIATION TO AUTOIONIZING STATES OMITTED FROM WIDTH' WRITE(0,*)'*** SET RAD="DR" TO INCLUDE IT TO MIRROR ADASDR' ENDIF IF(NRSLMX.EQ.6)THEN WRITE(6,*)'*** COMMENT: YOU MAY WANT TO INCREASE NRSLMX' WRITE(0,*)'*** COMMENT: YOU MAY WANT TO INCREASE NRSLMX' ENDIF C C NBIN0=ABS(NBIN0) !NO ADF38 FILES C ELSE C ENDIF C IF(NBIN0.LE.0)THEN C C STANDARD PE FILES C BPRINT=PRINT.NE.'UNFORM' IF(BPRINT)THEN OPEN(10,FILE='adf38l') !ADAS LEVEL OUTPUT OPEN(11,FILE='adf38r') !ADAS RATE OUTPUT ELSE OPEN(20,FILE='adf38lu',FORM='UNFORMATTED') OPEN(21,FILE='adf38ru',FORM='UNFORMATTED') ENDIF C ENDIF C C C SUM OVER CROSS SECTIONS C CALL CROSSJ(NTAR,NTAR0,NMIN,LMIN,NCUT,LCUT,NRSLMX,IRSLMX,JRSLMX X ,DELTAF,TEAPOT,EI,IWT,NR1,NR2,IPRINT,BPRINT,TOLR,ACOR,RCOR X ,EMINC,EMAXC,E1C,TOLN,TOLB0,TOLB,IWS,IWL,IWJ,BCA,BLS,BIC X ,BRSLVF,BMATCH,NTARP,NTART,LMAX,LBIN,JTEMP,TEMP,NBIN0,EBIN X ,SBIN,TBIN,EPT,EET,BLOR,boop,boldf) C C C WRITE-OUT CROSS SECTIONS C IF(NBIN0.NE.0)THEN IF(EWIDTH.GE.DZERO)THEN !BINNED WRITE(7,17)NBIN 17 FORMAT(I5) WRITE(7,F18)(EBIN(N),N=1,NBIN) DO L0=1,LBIN DO L=1,LMAX WRITE(7,F18)(SBIN(N,L,L0),N=1,NBIN1) C 18 FORMAT(6(1PE12.6)) ENDDO ENDDO CLOSE(7) IF(JTEMP.EQ.0)THEN WRITE(8,17)NBIN WRITE(8,F18)(EBIN(N),N=1,NBIN) DO L0=1,LBIN WRITE(8,F18)(TBIN(N,L0),N=1,NBIN1) ENDDO ELSE DO L0=1,LBIN !JTEMP NOW DO L=1,LMAX T=DZERO DO N=1,NBIN1 T=T+SBIN(N,L,L0) ENDDO TBIN(L,L0)=T*ERES ENDDO ENDDO WRITE(6,731) DO L0=1,LBIN WRITE(6,732)TEMP(L0)*1.5789D5,(TBIN(L,L0),L=1,LMAX) ENDDO ENDIF CLOSE(8) ELSEIF(EWIDTH.GE.-TOLC)THEN !RAW LORENTZIAN WRITE(13,205)NBIN1 WRITE(14,205)NBIN1 DO L0=1,LBIN DO L=1,LMAX WRITE(13,20)EPT(L0)*UNITS,EET(L)*UNITS,l0,l WRITE(13,19)(EBIN(N),SBIN(N,L,L0),N=1,NBIN1) ENDDO ENDDO CLOSE(13) DO L0=1,LBIN WRITE(14,20)EPT(L0)*UNITS,EET(1)*UNITS,l0 WRITE(14,19)(EBIN(N),TBIN(N,L0),N=1,NBIN1) ENDDO CLOSE(14) GO TO 900 ENDIF ENDIF c c read previous ocsp/t files, and convolute. c 77 if(nc.gt.0.and.ewidth.gt.tolc)then read(7,17,end=78)nbin nbin1=nbin-1 read(7,f18)(ebin(n),n=1,nbin) do l0=1,lbin do l=1,lmax read(7,f18)(sbin(n,l,l0),n=1,nbin1) enddo enddo 78 close(7) read(8,17,end=79)nbin nbin1=nbin-1 read(8,f18,end=79)(ebin(n),n=1,nbin) do l0=1,lbin read(8,f18,end=79)(tbin(n,l0),n=1,nbin1) enddo 79 close(8) endif C C CONVOLUTE WITH GAUSSIAN C IF(ABS(EWIDTH).GT.TOLC)THEN IF(NGAUSS.LT.0)THEN NGAUSS=-NGAUSS-1 IF(NGAUSS.LT.5)NGAUSS=20 DEG=ABS(EWIDTH)/NGAUSS T=(EBIN(NBIN)-EBIN(1))/DEG NT=NINT(T) ELSEIF(NGAUSS.LT.50)THEN IF(EWIDTH.GT.DZERO)THEN NT=2*NBIN1 ELSE T=(EBIN(NBIN)-EBIN(1))/EWIDTH NT=NINT(-T) NT=MAX(200,5*NT) ENDIF ELSE NT=NGAUSS-1 ENDIF C WRITE(13,205)NT+1 205 FORMAT('#',40X,'AT',I7,' ENERGIES') C T=NT DEG=(EBIN(NBIN)-EBIN(1))/T NT=NT+1 DE=(EBIN(2)-EBIN(1)) T=2*ABS(EWIDTH)/DE !GO 2 SIGMA EITHER SIDE N0=NINT(T) W=DEG/DE E0=EBIN(1) DO L0=1,LBIN DO L=1,LMAX WRITE(13,20)EPT(L0)*UNITS,EET(L)*UNITS,l0,l 20 FORMAT('#',1P,2E18.8,2i5) DO N=1,NT E=E0+(N-1)*DEG NN=NINT(N*W) N1=MAX(1,NN-N0) N2=MIN(NBIN1,NN+N0) SCC=CONVOLG(E,EWIDTH,EBIN,SBIN(1,L,L0),N1,N2) WRITE(13,19)E*UNITS,SCC 19 FORMAT(1PE16.8,E14.4) ENDDO ENDDO ENDDO CLOSE(13) IF(JTEMP.EQ.0)THEN WRITE(14,205)NT+1 DO L0=1,LBIN WRITE(14,20)EPT(L0)*UNITS,EET(1)*UNITS,l0 DO N=1,NT E=E0+(N-1)*DEG NN=NINT(N*W) N1=MAX(1,NN-N0) N2=MIN(NBIN1,NN+N0) TCC=CONVOLG(E,EWIDTH,EBIN,TBIN(1,L0),N1,N2) WRITE(14,19)E*UNITS,TCC ENDDO ENDDO CLOSE(14) ENDIF ENDIF C 900 CONTINUE C C COMMENTS C IF(NBIN0.LE.0)THEN C C USE EITHER IF(BPRINT)THEN WRITE(10,*)' ' !TERMINATOR C OR c WRITE(10,1005)(COD(I),I=2,20) !COMMENT-OUT IF CATTING LATER C TO END LEVEL LIST (adf38l) C IF(NBIN0.LE.0)WRITE(11,1005)(COD(I),I=2,20) CLOSE(10) CLOSE(11) ELSE WRITE(20)' ' !TERMINATOR IF(NBIN0.LE.0)WRITE(21)(COD(I),I=2,20) CLOSE(20) CLOSE(21) ENDIF C ENDIF C RETURN C 731 FORMAT(//' T(K) ',4X,'ALFT( 1)',2X,'ALFT( 2)',2X,'ALFT( 3)' X,2X,'ALFT( 4)',2X,'ALFT( 5)',2X,'ALFT( 6)' X,2X,'ALFT( 7)',2X,'ALFT( 8)',2X,'ALFT( 9)',2X,'ALFT(10)' X/4X,'----',3X,10(2X,'--------')) 732 FORMAT(1PE10.2,1X,(10E10.2)) 1005 FORMAT(/'C',110('-')/'C'/'C',19A4/'C'/'C',110('-')) C END C C*********************************************************************** C REAL*8 FUNCTION CONVOLG(E,EWIDTH,EBIN,SBIN,N1,N2) IMPLICIT REAL*8 (A-H,O-Z) C C CONVOLUTE CROSS SECTIONS WITH GAUSSIAN DISTRIBUTION C PARAMETER (DZERO=0.0D0) PARAMETER (DTWO=2.0D0) C DIMENSION EBIN(*),SBIN(*) C A=1.6651092D0/EWIDTH !2*sqrt(ln(2)) SUM=DZERO C IF(EWIDTH.GT.DZERO)THEN !BINNED DO I=N1,N2 IF(SBIN(I).GT.DZERO)THEN XI=EBIN(I) XI1=EBIN(I+1) SUM=SUM+SBIN(I)*(ERF(A*(E-XI))-ERF(A*(E-XI1)))/DTWO ENDIF ENDDO ELSE !LORENTZIANS A=-A DO I=N1,N2 !ASSUME LINEAR IF(SBIN(I).GT.DZERO)THEN T=A*(EBIN(I)-E) T=T*T SUM=SUM+SBIN(I)*EXP(-T) ENDIF ENDDO SUM=SUM*(EBIN(2)-EBIN(1))*A*0.5641895D0 !1/sqrt(pi) ENDIF C CONVOLG=SUM RETURN END C C*********************************************************************** C SUBROUTINE CROSSJ(NTAR,NTAR0,NMN,LMN,NCUT,LCUT,NRSLMX,IRSLM0 X ,JRSLM0,DELTAF,TEAPOT,EI,IWT,NR1,NR2,IPRINT,BPRINT,TOLR,ACOR X ,RCOR,EMINC,EMAXC,E1C,TOLN,TOLB0,TOLB,IWS,IWL,IWJ,BCA,BLS,BIC X ,BRSLVF,BMATCH,NTARP,NTART,LMAX,LBIN,JTEMP,TEMP,NBIN0,EBIN X ,SBIN,TBIN,EPT,EET,BLOR,boop,boldf) C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER(NDIM1=10001 !BIN ENERGIES X ,NDIM5=600 !ELECTRON TARGETS X ,NDIM2=NDIM5+1 X ,NDIM3=30 !BINNED E-TARGETS X ,NDIM4=16 !BINNED P-TARGETS X ,NDIM6=050 !GROUPS IN A CONFIG *** X ,NDIM7=1000000 !***REDUCE THIS IF POSS. BIG MEMORY c X ,NDIM7=500 000 000 !***SET BOOP=.TRUE. INSTEAD X ,NDIM10=3000000 !TERMS/LEVELS - REVERSE c X ,NDIM12=02 000 000 !***REDUCE THIS IF POSS. BIG MEMORY X ,NDIM12=105 000 000 !***SET NMETAR/J & NMETAP/J IN AS RUN X ,NDIM13=2500000 !PHOTON TARGETS X ,NDIM14=2000 !CONFIGS X ,NDIM15=101 !MAX L+1 FOR DIPOLES X ,NDIM17=2500000 !RESOLVED RADIATIVE X ,NDIM19=5000 !TERMS IN A GROUP *** X ,NDIM24=103 !NUCLEAR CHARGE (LABEL) X ,NDIM25=99 !NO L-DEP CORRECTIONS X ,NDIM26=60 !MAX NO. OF AS ORBITALS X ,NDIM28=NDIM4 !TEMPERATURES X ,NDIM29=10 !ADF38 STANDARD TEMPS X ,NDIM30=1500 !MASTER CONFIGS *** X ,NDIM32=10000) !TERMS IN A CONFIG *** C DO NOT INFLATE "***" C N.B. NDIM30,NDIM32 ARRAYS ARE NOW ALLOCATABLE, BUT THE INITIAL ALLOC C IS NOT EXACT AND SO USER MAY NEED TO SET LARGE ENOUGH EXPLICITLY C USING ABOVE. BUT WE DO NOT INFLATE INITIALLY. THE INITIAL ALLOC C MAY BE TWEAKED/IMPROVED WITH EXPERIENCE. C PARAMETER (DZERO=0.0D0) PARAMETER (NLIT=60) PARAMETER (MXORB0=60) !NO. NL READ FROM AS, .LE. NDIM26 PARAMETER (ALF3=8.0325D9) !alpha^3/2*tau_0 PARAMETER (PI=3.14159265359D0) PARAMETER (HHBAR=2.41888D-17) !hbar/2 PARAMETER (CON1=1.33704D-14) !2*tau_0*(pi*a_0)**2 PARAMETER (CON2=1.00432D-9) !(2/alpha)**2*2*tau_0*(pi*a_0)**2 PARAMETER (DKCM=109737.4D0) C INTEGER*4 MTEST4,MBLNK4 !keep I*4 for backward compat INTEGER*4 QS0,QL0,QND,QLD !KEEP AS I*4 FOR READING UNFORM C INTEGER SS,SSR,QSB,QLB,QL,QN,QSP,QLP,QSR,QLR,QNV,QLV X,QTT,QTTE,QTE,QTI,QST,QLT,QNB,QNT,QMB,QMT,QS00,QL00,QSR0 C INTEGER*2 QTTG C CHARACTER LAB4*4,LAB2*2,LSQ*2,FILNAM*4,MPP*1 X,RADBF*4,RAD*6,RAD4*4,PABS*3 X,CMBLNK*4,CMSTAR*4 CHARACTER*1 CLABL(20),CLIT(0:NLIT) CHARACTER F29*59,F290*45 C LOGICAL BPRINT,BPRNT0,BPRNT1,BPRNTP,BCFA,BCFM,BCFP,BRAD,BINT,BFAST X,BLOR,BBIN,BPASS1,BFORM,BCA,BLS,BIC,BRADBF,BRSLVF,BMATCH,BPABS X,BPION,BTEST,BOLDFL,BOLDFR,EX,BWARN,boop,boldf C REAL*4 AA,EC REAL*4 AR,EATOM,DEL C ALLOCATABLE :: ICA(:),ITA(:),AA(:),JTA(:),EC(:) C DIMENSION EBIN(NDIM1),SBIN(NDIM1,NDIM3,NDIM4),TBIN(NDIM1,NDIM4) X ,EPT(NDIM4),EET(NDIM3),EII(NDIM2),EI(NDIM2),TC(NDIM2) C DIMENSION WNP(NDIM5),LMP(NDIM5),QSP(NDIM5,10),QLP(NDIM5,10) X ,IWT(NDIM5),IWS(NDIM5),IWL(NDIM5),IWJ(NDIM5) X ,E1C(NDIM5),ECA(NDIM5),SUMAN(NDIM5) C DIMENSION JTR(NDIM7),JCR(NDIM7),ITR(NDIM7) X ,AR(NDIM7),EATOM(NDIM7),DEL(NDIM7) C DIMENSION IK(NDIM13),SS(NDIM13),LL(NDIM13),JJ(NDIM13) !,IT(NDIM13) X ,LCF(NDIM13) DIMENSION ENERG(NDIM13) C DIMENSION IAUTO(NDIM13),ILSJ(NDIM13),IRSOL(NDIM13) C DIMENSION JK(NDIM10),ITAR(NDIM10),jauto(ndim10) X ,JFIRST(NDIM10),JLAST(NDIM10),KFIRST(NDIM10),KLAST(NDIM10) C DIMENSION NG(NDIM14),ICF(NDIM14),QNB(NDIM14,10),QMB(NDIM14,10) X ,QSB(NDIM14,10),QLB(NDIM14,10),LMX(NDIM14) X ,NOCC(10),QS0(10),QL0(10),QS00(10),QL00(10),QSR0(10) X ,QN(NDIM26),QL(NDIM26),QND(NDIM26),QLD(NDIM26) C DIMENSION WNR(NDIM17),LMR(NDIM17),QSR(NDIM17,10),QLR(NDIM17,10) X ,SSR(NDIM17),LLR(NDIM17),JJR(NDIM17),QNV(NDIM17),QLV(NDIM17) X ,IRSOL0(NDIM17),JV0(NDIM17),JTR0(NDIM17),AR0(NDIM17) C ALLOCATABLE X QNT(:,:),QMT(:,:),QST(:,:),QTI(:) X,QLT(:,:),LMT(:),NGG(:),QTE(:,:) C C DIMENSION QNT(NDIM30,10),QMT(NDIM30,10),QST(NDIM30,10),QTI(NDIM30) C X,QLT(NDIM30,10),LMT(NDIM30),NGG(NDIM30),QTE(NDIM30,0:NDIM6) C ALLOCATABLE X QTTG(:,:),ICQTG(:,:,:) ccf x,ICQT(:,:) C X,QTTG(NDIM30,NDIM32),ICQTG(NDIM30,NDIM6,NDIM19) !ICQTG BIG MEMORY ccf x,ICQT(NDIM30,NDIM32) C DIMENSION QTT(NDIM13),QTTE(NDIM13) C DIMENSION CP(NDIM15),CM(NDIM15),JDUM(NDIM15),RSUML(NDIM15) C DIMENSION LIT(0:NLIT),LABL(20),LSQ(NDIM24) C DIMENSION COEF(NDIM28),COFT(NDIM3,NDIM28),FREL(NDIM28) X ,TEMP(NDIM28),THT(NDIM29) C COMMON /CORR/ACORN(NDIM1),ACORL(NDIM25),RMIN,NNCOR,NLCOR COMMON /JCF/JCFA,JCFR,JCFJ,LSPI,J2PI,JCF(20),RADBF,RAD,PABS C DATA CLABL /'S','P','D','F','G','H','I','J','K','L','M','N','O' X,'P','Q','R','S','T','U','*'/, CMBLNK/' '/, CMSTAR/'****'/ DATA CLIT/'0','1','2','3','4','5','6','7','8','9','A','B','C','D', X 'E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T', X 'U','V','W','X','Y','Z','a','b','c','d','e','f','g','h','i','j', X 'k','l','m','n','o','p','q','r','s','t','u','v','w','x','y'/ DATA LSQ /'H','HE','LI','BE','B','C','N','O','F','NE','NA','MG' X,'AL','SI','P','S','CL','AR','K','CA','SC','TI','V','CR','MN' X,'FE','CO','NI','CU','ZN','GA','GE','AS','SE','BR','KR','RB','SR' X,'Y','ZR','NB','MO','TC','RU','RH','PD','AG','CD','IN','SN','SB' X,'TE','I','XE','CS','BA' X,'LA','CE','PR','ND','PM','SM','EU','GD','TB','DY','HO','ER','TM' X,'YB','LU' X,'HF','TA','W','RE','OS','IR','PT','AU','HG','TL','PB','BI','PO' X,'AT','RN','FR','RA' X,'AC','TH','PA','U','NP','PU','AM','CM','BK','CF','ES','FM','MD' X,'NO','LR'/ DATA XTHT/1.0D3,2.0D3,5.0D3,1.0D4,2.0D4,5.0D4,1.0D5,2.0D5,5.0D5,1.0D6/ DATA JTHT/10/ cC C FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS C TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY C OPEN(90,STATUS='SCRATCH',FORM='FORMATTED') WRITE(90,1111)CMSTAR,(CLIT(I),I=0,NLIT) 1111 FORMAT(A4,80A1) BACKSPACE(90) READ(90,1111)MSTAR,(LIT(I),I=0,NLIT) WRITE(90,1111)CMBLNK,(CLABL(I),I=1,20) BACKSPACE(90) READ(90,1111)MBLNK,(LABL(I),I=1,20) BACKSPACE(90) READ(90,1111)MBLNK4 CLOSE(90) C MXDIM6=0 MXDIM7=0 MXDIM10=0 MXDIM12=0 MXDIM13=0 MXDIM14=0 MXDIM17=0 MXDIM19=0 MXDIM30=0 MXDIM32=0 C C********* C PREAMBLE C********* C BOLDFL=boldf !F USE I6, T USE I4, FOR NPRNT INDEX IN ADF38L BOLDFR=boldf !F USE I6, T USE I5, FOR LEVEL INDEX IN ADF38R C IF(MXORB0.GT.NLIT)WRITE(6,*)'***WARNING: MIGHT NOT BE ABLE ' X ,' TO DECODE ORBITAL, INCREASE LIT SPEC.' C IF(NRSLMX.LT.2)NRSLMX=6 C IF(.NOT.BLS)BLS=BCA c c boop=ntar.eq.0 !for large radiative cases C NTARX=NTAR IF(NTARP.NE.NDIM5.OR.NTAR0.LT.0)NTARX=MAX(NTARX,NTARP) IF(NTART.NE.NDIM5)NTARX=MAX(NTARX,NTART) IF(NTARX.GT.NDIM5)THEN WRITE(6,847)NTARX 847 FORMAT(/' INCREASE NDIM5 TO AT LEAST',I5) STOP 'INCREASE NDIM5' ENDIF IF(NTARX.LE.0)NTARX=-1 NTARX0=NTARX NTARP0=NTARP NTART0=NTART C C*********** C INITIALIZE C*********** C NR10=NR1 NR20=NR2 INR1=IABS(NR1) BRAD=NR1.GT.0 RAD4=RAD BRADBF=RADBF.EQ.'B-F'.AND.RAD4.NE.'AUTO'.AND.RAD.NE.'OP' BPION=RAD.EQ.'AUTO1'.OR.RAD.EQ.'AUTO2' !CONTRIBUTES TO IONIZATION BPABS=RAD.EQ.'BOUND2'.OR.RAD.EQ.'AUTO2'!CONTRIBUTES TO ABSORPTION X .OR.PABS.EQ.'YES' MV=0 NCMX=0 NVMAX=0 LVMAX=-1 C NBIN=ABS(NBIN0) NBIN1=NBIN-1 BBIN=EI(1).GE.DZERO ERES=EBIN(2)-EBIN(1) !ASSUME LINEAR IFLAGE=0 NRSOL=0 NRSOL1=0 E00=1.D15 JE00=0 EX=.TRUE. BPASS1=.TRUE. IF(IPRINT.GT.1)IPRINT=0 IF(IPRINT.LT.-1)IPRINT=-1 BPRNTP=IPRINT.GE.0 BPRNT0=IPRINT.EQ.0 BPRNT1=IPRINT.GE.-1 IF(JCF(1).NE.0)JCFJ=JCF(1) JCFP=9999 JCFM=-999 IF(JCFJ.GT.0)JCFP=JCFJ IF(JCFJ.LT.0)JCFM=-JCFJ NCFT=0 NENG=0 JCFRB=IABS(JCFR) NZOLD=0 NEOLD=0 BWARN=JTEMP.GT.0 DRSUM=0 !CHECKSUM C IF(TEMP(1).GT.DZERO)THEN DO J=1,JTEMP TJ=SQRT(TEMP(J)) COEF(J)=2.0707D-16/(TJ*TEMP(J)) TEMP(J)=TEMP(J)/1.5789D5 ENDDO ITST=JTEMP/2+1 ELSE ITST=5 IF(JTEMP.LE.0)THEN CPE JTEMP=JTHT !USER MUST SET JTEMP OR JTHETA ELSE JTEMP=MIN(JTEMP,JTHT) ENDIF c if(ncmn.eq.1)itst=(3*itst)/2 ENDIF C C****************************************************** C POSSIBLE UNIT NOS TO BE CHECKED FOR DATA: READ NV, LV C****************************************************** C MR=70 MRU=MR IFILE=1 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,*)'NO RATE INPUT DATA ON FILE o1 OR o1u!!!' STOP 'NO RATE INPUT DATA ON FILE o1 OR o1u!!!' ENDIF ENDIF C C RE-ENRTY POINT FOR NEW FILE C WNP(1)=DZERO EIONMN=DZERO LV00=-1 331 NV0=100000 LV0=-99 if(bform)then MXORB=min(40,MXORB0) !g77 could not read too far off end else mxorb=mxorb0 endif IRSLMX=IRSLM0 JRSLMX=JRSLM0 C 31 NV=0 IEND=1 IF(BFORM)READ(MR,38,END=1000)NV,LV IF(.NOT.BFORM)READ(MRU,END=1000)NV,LV 38 FORMAT(5X,I5,5X,I5) C IF(NV.EQ.0.AND.NV0.EQ.100000)THEN NV=INR1 LV=-1 ENDIF IF(NV.EQ.0)GO TO 1000 C IF(INR1.NE.999.AND.LV.GE.0)THEN IF(NV.LT.INR1)THEN WRITE(6,39)NV,NR1 39 FORMAT(' ERROR IN CROSSJ: NV MUST BE .GE. ABS(NR1):',2I6) STOP ' ERROR IN CROSSJ: NV MUST BE .GE. ABS(NR1):' ENDIF ENDIF IF(LV.LT.0.AND.LV00.GE.0)THEN WRITE(6,*)'***ERROR: RE-ORDER INPUT FILES on(u) ETC SO THAT' X ,' EQUIVALENT ELECTRON FILES COME FIRST***' STOP '***ERROR: RE-ORDER INPUT FILES on(u)' ENDIF C BCFA=IABS(JCFA).NE.9999 !.AND.LV.GE.0 BCFM=JCFR.LT.0.AND.LV.GE.0 BCFP=JCFR.GT.0.AND.LV.GE.0 IF(LV0.LT.0.OR.LV.LT.0)THEN MV0=MV NCMX0=NCMX MV=0 NCMX=-1 WNP0=-1.0D0 KFPM=0 IF(BBIN)EI(1)=1.0D0 NTARX=NTARX0 NTARP=NTARP0 NTART=NTART0 DO L=1,NDIM15 RSUML(L)=DZERO ENDDO ENDIF C IF(LV.EQ.LV0)GO TO 37 C 91 IF(LV.GT.LCUT.AND.LV.NE.999)GO TO 1000 C C************** C START A NEW L C************** C LVMAX=MAX(LVMAX,LV) LV0=LV NV0=NV-1 LV00=LV0-1 C C************** C START A NEW N C************** C 37 DO L=1,NTAR TC(L)=DZERO ENDDO BINT=.FALSE. IF(NV.LE.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(BWARN.AND.NV.GT.NV0+1)THEN WRITE(6,*) & ' *** XDRSTOT INCOMPLETE, NO INTERPOLATION FOR MISSING N' WRITE(0,*) & ' *** XDRSTOT INCOMPLETE, NO INTERPOLATION FOR MISSING N' BWARN=.FALSE. ENDIF 75 NV0=NV NVMAX=MAX(NV,NVMAX) NVMAX=MIN(NCUT,NVMAX) C C************************************ C READ HEADER, AND MAYBE ORBITAL CODE C************************************ C NCFD=0 NZ0D=0 NED=0 DO I=1,MXORB QND(I)=0 ENDDO IEND=2 IF(BFORM)THEN 299 READ(MR,101,END=1002) NCFD,NZ0D,NED,(QND(I),QLD(I),I=1,MXORB) if(kfpm.eq.0.and.qnd(mxorb).ne.0.and.mxorb.lt.mxorb0)then mxorb=mxorb+20 mxorb=min(mxorb,mxorb0) backspace(mr) go to 299 endif ELSE READ(MRU,END=1002,ERR=303)NCFD,NZ0D,NED,(QND(I),QLD(I),I=1,MXORB) GO TO 302 303 IF(EX)THEN !START OF A FILE REWIND(MRU) !SO REWIND READ(MRU) READ(MRU) ELSE STOP 'UNABLE TO READ ORBITAL HEADER...' !SHOULD NOT GET HERE ENDIF ENDIF 101 FORMAT(I3,12X,I2,6X,I2,4X,60(I3,I2)) C 302 NCF=NCFD !NOT EOF SO SAFE TO RELABEL IF(NCF.EQ.0)GO TO 999 !RETURN NZ0=NZ0D NE=NED DO I=1,MXORB QN(I)=QND(I) QL(I)=QLD(I) ENDDO C IF(NZOLD.NE.0.AND.NZ0.NE.NZOLD)THEN WRITE(6,*)'*** ERROR: DIFFERENT ELEMENTS ON TWO FILES, NZ=' X ,NZOLD,NZ0 STOP '*** ERROR: DIFFERENT ELEMENTS ON TWO FILES' ENDIF NZOLD=NZ0 C IF(NEOLD.NE.0.AND.NE.NE.NEOLD)THEN WRITE(6,*)'*** ERROR: DIFFERENT IONS ON TWO FILES, NE=' X ,NEOLD,NE STOP '*** ERROR: DIFFERENT IONS ON TWO FILES' ENDIF NEOLD=NE C DO I=1,MXORB !SHORT ORBITAL LIST IF(QN(I).LE.0)GO TO 301 ENDDO I=MXORB+1 301 MXORB=I-1 C IF(NCF.GT.NDIM14)THEN WRITE(6,136)NCF 136 FORMAT(' DIMENSION EXCEEDED IN SR.CROSSJ, INCREASE NDIM14 TO',I5) STOP ' DIMENSION EXCEEDED IN SR.CROSSJ, INCREASE NDIM14' ENDIF MXDIM14=MAX(NCF,MXDIM14) C IF(.NOT.ALLOCATED(QNT))THEN IDIM30=MAX(NDIM30,NCF) c ALLOCATE X(QNT(IDIM30,10),QMT(IDIM30,10),QST(IDIM30,10),QTI(IDIM30) X,QLT(IDIM30,10),LMT(IDIM30),NGG(IDIM30),QTE(IDIM30,0:NDIM6) X ,STAT=IERR) c IF(IERR.NE.0)THEN WRITE(6,*)'*** ALLOCATION FAILS FOR QNT ETC.' STOP '*** ALLOCATION FAILS FOR QNT ETC.' ENDIF ENDIF C NZ=NZ0-NE+1 DZ=NZ*NZ TV=NV TV=TV*TV DEN=QDT(QD0,NZ0,NE,NV,LV,0) IF(BPASS1)THEN C TOLB0=TOLB IF(TOLB0.LE.DZERO)TOLB=MAX(1.5D-7,1.0D-9*DZ*NZ) TOLBE=TOLB IF(BFORM)TOLBE=MAX(TOLBE,2.D-6) ENDIF C IF(TEMP(1).LE.DZERO)THEN DO J=1,JTEMP TEMP(J)=DZ*THT(J) TJ=SQRT(TEMP(J)) COEF(J)=2.0707D-16/(TJ*TEMP(J)) TEMP(J)=TEMP(J)/1.5789D5 ENDDO ENDIF C C************************ C READ CONFIGURATION DATA C************************ C IEND=3 DO N=1,10 NOCC(N)=0 ENDDO MAXG=0 NCFT0=NCFT DO 102 I=1,NCF C IF(BFORM)READ(MR,179,END=1002)II,NGR,MA0,MB0,(QS0(J),QL0(J),J=1,10 X) IF(.NOT.BFORM)READ(MRU,END=1002)II,NGR,MA0,MB0,(QS0(J),QL0(J),J=1, X10) 179 FORMAT(2I5,2X,I3,I2,1X,10(I2,A1)) C IN=IABS(II) NG(IN)=NGR MAXG=MAX(MAXG,NGR) C C DECODE CONFIGURATIONS: C LMX(I) IS THE NO OF DISTINCT OPEN-SHELL ORBITALS IN CONFIG I. C QSB(I,J) IS THE OCCUPATION NO OF ORBITAL J IN CONFIG I. C QLB(I,J) IS THE ORBITAL NO OF ORBITAL J IN CONFIG I, J=1,LMX(I). C QS0,QL0 CONTAIN EISSNER SPECIFICATION OF CONFIG TO BE DECODED. C ICF(I) IS THE CONFIG NO OF CONFIG I IN THE MASTER LIST. C IF(LV00.NE.LV0.OR.BRSLVF)ICF(I)=0 C 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,NLIT IF(QL0(J).EQ.LIT(K))GO TO 17 ENDDO QLB(I,J)=0 GO TO 16 17 QLB(I,J)=K QNB(I,J)=QN(K) QMB(I,J)=QL(K) IF(QN(K).LE.10)NOCC(QN(K))=1 16 CONTINUE J=LMX(I) IF(II.LT.0)THEN LMX(I)=J-1 QSB(I,J)=MBLNK ELSEIF(LV00.NE.LV0.OR.BRSLVF)THEN M=QLB(I,J) IF(M.GT.MXORB.OR.M.EQ.0)THEN WRITE(6,*)'***ERROR, CF=',II,' USES ORBITAL NO=',M X ,' WHICH IS NOT DEFINED IN ORBITAL HEADER!!' STOP'***ERROR, NEED ORBITAL NOT DEFINED IN HEADER!!' ENDIF C C************************** C SET-UP/EXTEND MASTER LIST C************************** C DO 151 N=1,NCFT IF(LMX(I).NE.LMT(N))GO TO 151 DO J=1,LMX(I) IF(QSB(I,J).NE.QST(N,J))GO TO 151 COLD IF(QLB(I,J).NE.QLT(N,J))GO TO 151 IF(QNB(I,J).NE.QNT(N,J))GO TO 151 IF(QMB(I,J).NE.QMT(N,J))GO TO 151 ENDDO ICF(I)=N !OLD MASTER c write(6,776)i,n c 776 format(i10,i5) MV=MAX(MV,MV0) NCMX=MAX(NCMX,NCMX0) GO TO 102 151 CONTINUE C NO MATCH, ADD TO MASTER LIST, IF SUITABLE IF(QN(M).NE.NV.OR.LV.LT.0.OR.BRSLVF)THEN NCFT=NCFT+1 IF(NCFT.GT.IDIM30)THEN WRITE(6,*)'INCREASE DIMENSION OF NDIM30' STOP 'INCREASE DIMENSION OF NDIM30' ENDIF ICF(I)=-NCFT !NEW LMT(NCFT)=LMX(I) DO J=1,LMX(I) QST(NCFT,J)=QSB(I,J) QLT(NCFT,J)=QLB(I,J) QNT(NCFT,J)=QNB(I,J) QMT(NCFT,J)=QMB(I,J) ENDDO c write(6,777)ncft,(qnb(i,j),qmb(i,j),qsb(i,j),j=1,lmx(i)) c 777 format(i5,10(2x,i2,i2,a1)) ENDIF C C******************************** C ATTEMPT TO DETERMINE MAX CORE N C******************************** C IF(LV.LT.0)THEN MV=NV JM=LMX(I)-1 IF(JM.EQ.0)THEN IF(NCMX.LE.0)NCMX=NV GO TO 102 ENDIF 77 M=QLB(I,JM) IF(QN(M).LT.NV)THEN NCMX=MAX(NCMX,QN(M)) ELSE JM=JM-1 IF(JM.GT.0)GO TO 77 IF(NCMX.LE.0)NCMX=NV GO TO 102 ENDIF ELSEIF(QN(M).NE.NV)THEN J=LMX(I) C M=QLB(I,J) MV=QN(M) JM=J-1 IF(JM.EQ.0)GO TO 102 M=QLB(I,JM) IF(MV.EQ.QN(M).OR.QSB(I,J).NE.LIT(1))THEN NCMX=MAX(NCMX,MV) ELSE NCMX=MAX(NCMX,QN(M)) ENDIF ELSE JM=LMX(I)-1 IF(JM.EQ.0)GO TO 102 M=QLB(I,JM) IF(NCMX.GT.0)THEN NCMX=MIN(NCMX,QN(M)) ELSE NCMX=QN(M) ENDIF ENDIF ENDIF C 102 CONTINUE C MXDIM30=MAX(NCFT,MXDIM30) C IF(MB0.GT.0)THEN DO M=MA0,MB0 N=QN(M) NOCC(N)=1 ENDDO ENDIF C C********************************************* C DETERMINE INNER EXCITED-STATE HYDROGENIC RAD C********************************************* C IF(INR1.EQ.999)THEN !.AND.LV.GE.0 C INR1=NR1 IF(LV.LT.0)THEN !CATCH ALL-N SINCE LV.GE.0 REMOVED DO N=1,10 IF(NOCC(N).EQ.0)THEN NCMX=MAX(NCMX,N-2) GO TO 100 ENDIF ENDDO ENDIF 100 IF(NR1.NE.NCMX+1)THEN NR1=NCMX+1 WRITE(6,*)' ' WRITE(6,*)'*** NR1 RESET TO:',NR1 ENDIF BRAD=.TRUE. ENDIF IF(INR1.LE.0)THEN !.OR.LV.LT.0 MV=0 NR1=0 BRAD=.FALSE. ENDIF C c original OP - wrong, only ON for first nl because of kfpm test c (for dn>1, none here for dn=1) c c if(rad.eq.'OP')then c do l=1,mv c rsuml(l)=dzero c enddo c endif c IF(.NOT.BRAD.OR.KFPM.GT.0)GO TO 161 !KFPM=0 FIRST BLOCK IF(NR20.LT.0)NR2=NV NMIN=NR1 NMAX=MIN(NR2,MV-1) IF(NMIN.GT.NMAX)THEN MV=0 GO TO 161 ENDIF IF(MV.NE.MV0)WRITE(6,*)'*** MV RESET TO:',MV TMV=MV*MV DZP=(NZ+1)*(NZ+1) C IF(MV.EQ.NV)DZP=(NZ+0.5D0)*(NZ+0.5D0) DO N=NMIN,NMAX T=N*N DE=DZP*(TMV-T)/(TMV*T) CALL DIPOL(-1,N,MV,DZERO,MV,CP,CM,JDUM) DO L=0,MV-1 TL=L LP=L+1 TLP=LP T1=TLP*CM(LP)*1.0D10**JDUM(LP) T2=DZERO IF(L.GT.0)T2=TL*CP(L)*1.0D10**JDUM(L) T=(T1+T2)/(TL+TLP) T0=DE**3*2.6775D9/DZP T=T*T0 RSUML(LP)=RSUML(LP)+T ENDDO ENDDO C C************************** C READ AUTOIONIZATION RATES C************************** C 161 BFAST=.NOT.BFORM.AND.NLCOR.EQ.0.AND..NOT.BCFM.AND.ACOR.LT.0.0D0 X .AND.JCFJ.EQ.9999.AND..NOT.BCFA C IEND=4 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 I=0 IF(.NOT.ALLOCATED(EC))THEN C IF(BFORM)READ(MR,112,END=1002)I1,I2 IF(.NOT.BFORM)READ(MRU,END=1002)I1,I2 C IF(I2.EQ.0)GO TO 113 IF(BFORM)BACKSPACE(MR) IF(.NOT.BFORM)BACKSPACE(MRU) C ALLOCATE (ICA(NDIM12),ITA(NDIM12),JTA(NDIM12),AA(NDIM12) X ,EC(NDIM12),STAT=IERR) IF(IERR.NE.0)THEN WRITE(6,*)'*** FAILURE TO ALLOCATE AUTOIONIZATION MEMORY' STOP '*** FAILURE TO ALLOCATE AUTOIONIZATION MEMORY' ENDIF C ENDIF IEND=5 C 111 I=I+1 C IF(BFORM)READ(MR,112,END=1002)I1,I2,IWA,JCA,I3,T1,T2,EION IF(.NOT.BFORM)READ(MRU,END=1002)I1,I2,IWA,JCA,I3,T1,T2,EION 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 JTA(I)=I3 AA(I)=T1 EC(I)=T2 C AA(I)=ABS(AA(I)) IF(BFAST)GO TO 111 C C APPLY CORRECTIONS I=I-1 C**** IF(ICA(I+1).GT.JCFP.OR.ICA(I+1).LE.JCFM)GO TO 111 IF(JCFA.GT.0)THEN IF(-JCA.GT.JCFA)GO TO 111 !JCA(I+1) ELSEIF(JCFA.LT.0.and.lv.ge.0)THEN mn=qlb(-jca,lmx(-jca)) if(qn(mn).eq.nv)go to 111 ENDIF C**** IF(BCFM.AND.JCFRB.NE.ICA(I+1))GO TO 111 I=I+1 IF(NLCOR.LE.0)THEN AA(I)=AA(I)*ABS(ACOR) ELSE IF(LV+1.GT.0.AND.LV.LT.NDIM25)AA(I)=AA(I)*ACORL(LV+1) ENDIF ENDIF C GO TO 111 C 113 NUMA=I-1 C IF(NUMA.GE.NDIM12) THEN WRITE(6,73)NUMA 73 FORMAT(' SR.CROSSJ: NUMBER OF AUTOIONIZATION RATES EXCEEDS STORAGE X, INCREASE NDIM12 TO',I10) STOP ' SR.CROSSJ: NUMBER OF AUTOIONIZATION RATES EXCEEDS STORAGE X, INCREASE NDIM12' ENDIF MXDIM12=MAX(NUMA,MXDIM12) C EIONMN=MIN(EIONMN,EION,TEAPOT) C C************** C READ ENERGIES C************** C IEND=6 IF(NENG.GT.0)NENG0=NENG 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.EQ.0)THEN DO I=1,NDIM10 JFIRST(I)=0 JLAST(I)=-1 ENDDO GO TO 124 ENDIF ECORE0=ECORE !UNUSED DEN0=DEN !UNUSED C IEND=7 IF(BFORM)READ(MR,105,END=1002)MTEST4 IF(.NOT.BFORM)READ(MRU,END=1002)MTEST4 105 FORMAT(26X,A4) C BTEST=MTEST4.NE.MBLNK4 !IC=TRUE IF(BLS.AND.BTEST)THEN IF(BCA)THEN WRITE(6,371) 371 FORMAT(' RUN INITIALIZED FOR CA BUT LS/IC DATA FOUND') STOP 'ERROR: RUN INITIALIZED FOR CA BUT LS/IC DATA FOUND' ELSE WRITE(6,370) 370 FORMAT(' RUN INITIALIZED FOR LS BUT IC DATA FOUND') STOP 'ERROR: RUN INITIALIZED FOR LS BUT IC DATA FOUND' ENDIF ENDIF IF(BIC.AND..NOT.BTEST)THEN WRITE(6,374) 374 FORMAT(' RUN INITIALIZED FOR IC BUT LS DATA FOUND') STOP 'ERROR: RUN INITIALIZED FOR IC BUT LS DATA FOUND' ENDIF if(bls.neqv..not.btest)stop 'coupling confusion' if(bic.neqv.btest)stop 'coupling confusion' C IF(NENG.GT.NDIM13)THEN WRITE(6,369)NENG 369 FORMAT('NUMBER OF LEVELS EXCEEDS STORAGE,INCREASE NDIM13 TO',I7) STOP ' NUMBER OF LEVELS EXCEEDS STORAGE,INCREASE NDIM13' ENDIF MXDIM13=MAX(NENG,MXDIM13) C IF(.NOT.ALLOCATED(QTTG))THEN IDIM32=MAXG/8 IF(BLS)IDIM32=IDIM32/3 IDIM32=MAX(NDIM32,IDIM32) c ALLOCATE X (QTTG(IDIM30,IDIM32),ICQTG(IDIM30,NDIM6,NDIM19),STAT=IERR) IF(IERR.NE.0)THEN WRITE(6,*)'*** ALLOCATION FAILS FOR QTTG,ICQTG' STOP '*** ALLOCATION FAILS FOR QTTG,ICQTG' ENDIF ccf ccf ALLOCATE (ICQT(IDIM30,IDIM32),STAT=IERR) ccf IF(IERR.NE.0)THEN ccf WRITE(6,*)'*** ALLOCATION FAILS FOR ICQT' ccf STOP '*** ALLOCATION FAILS FOR ICQT' ccf ENDIF ENDIF C C IRSLMX=MIN(IRSLMX,NENG) !NOT IF NOT COMMON!!! C NRR=NV NAUTO=0 IRAD=NENG+1 MFLAG=0 IEND=8 C DO 122 I=1,NENG C IF(BFORM)READ(MR,123,END=1002)I1,IT,I2,I3,I4,I5,EE IF(.NOT.BFORM)READ(MRU,END=1002)I1,IT,I2,I3,I4,I5,EE 123 FORMAT(5X,6I5,F15.6) C IK(I)=I1 SS(I)=I2 LL(I)=I3 JJ(I)=I4 LCF(I)=I5 ENERG(I)=EE C M=IK(I) M=IABS(M) IF(M.LE.NDIM10)THEN JK(M)=I JFIRST(M)=0 JLAST(M)=-1 KFIRST(M)=0 KLAST(M)=-1 jauto(m)=0 ENDIF MFLAG=MAX(MFLAG,M) K=IABS(LCF(I)) IF(IRAD.GT.NENG.AND.LCF(I).LT.0)IRAD=I C IF(BLS)THEN IF(BCA)THEN ILSJ(I)=0 IF(BFORM)THEN SS(I)=100000*IT+SS(I) !as write i10 read as 2i5 ENDIF ELSE ILSJ(I)=10000*IABS(SS(I))+100*LL(I) IF(SS(I).LT.0)ILSJ(I)=ILSJ(I)+1 ENDIF ENDIF IF(BIC)THEN ILSJ(I)=100*IABS(JJ(I)) IF(SS(I).LT.0)ILSJ(I)=ILSJ(I)+1 ENDIF C C******************************** C INDEX UPPER/AUTOIONIZING STATES (AND AVOID DOUBLE COUNTING) C******************************** C TE=ENERG(I)+ECORE IF(LCF(I).GT.0.AND.LCF(I).LE.JCFP.AND.LCF(I).GT.JCFM X .AND.TE.GE.EIONMN-TOLN)THEN IF(TE.LT.EIONMN)IRAD=MAX(I,IRAD) IF(QN(QLB(K,LMX(K))).NE.NV.and.lv.ge.0)GO TO 122 NAUTO=NAUTO+1 IAUTO(NAUTO)=IK(I) IF(M.LE.NDIM13)jauto(m)=nauto GO TO 122 ENDIF C C******************************** C SET-UP TARGET BINS AND INDEXING (ONLY DONE FOR A NEW UNIT). C******************************** C IF(BINT)GO TO 122 IF(KFPM.GT.NTARX)GO TO 122 IF(LCF(I).GT.0)GO TO 122 EIONMN=MIN(EIONMN,TE) C IF(ENERG(I).GT.(WNP0+TOLB))THEN C KFPM=KFPM+1 IF(BBIN)EII(KFPM)=TE C IF(KFPM.EQ.2)TOLN=MAX(TOLN,4.D-4*DZ-(EII(2)-EII(1))) C IF(KFPM.LE.NTARX)THEN WNP(KFPM)=-TE DO J=1,10 QSP(KFPM,J)=QSB(K,J) QLP(KFPM,J)=QLB(K,J) ENDDO LMP(KFPM)=LMX(K) C IF(E1C(KFPM).NE.DZERO)THEN !CHECK TARGET ENERGIES T=TE+WNP(1) T0=E1C(KFPM) IF(KFPM.EQ.1)THEN IF(BPRNT0)WRITE(6,372)TOLBE 372 FORMAT(3X,'IE',10X,'E(N)',14X,'E(N+1)',2X,'TOLB=' X ,1PE10.3) T0=T0-E1C(1) ENDIF MMM=MBLNK T1=ABS(T-T0) IF(T1.GT.TOLBE)THEN IF(BMATCH)THEN !LOOK FOR A MATCH NT=NTAR DO N=KFPM+1,NT T0=E1C(N) T2=ABS(T-T0) IF(T2.GT.T1)THEN !NOT FOUND WRITE(6,375)KFPM,T 375 FORMAT(/'*** UNABLE TO MATCH TARGET:',I5,F18.8,' IN' X ,' RATE FILE WITH THAT IN USER SUPPLIED adasin') STOP '*** UNABLE TO MATCH TARGETS' ELSE IF(T2.LT.TOLBE)THEN !FOUND IN=N-KFPM DO J=N,NT !RE-ALIGN JN=J-IN E1C(JN)=E1C(J) IWJ(JN)=IWJ(J) IWS(JN)=IWS(J) IWL(JN)=IWL(J) ENDDO NTAR=NTAR-IN GO TO 135 !MOVE ON ENDIF ENDIF T1=T2 ENDDO ELSE !JUST FLAG A MIS-MATCH MMM=MSTAR IFLAGE=IFLAGE+1 ENDIF ENDIF 135 IF(BPRNT0.OR.BMATCH.OR.MMM.NE.MBLNK) X WRITE(6,373)KFPM+IABS(NTAR0)-NTAR,T0,KFPM,T,MMM 373 FORMAT(2(I5,F18.8,5X),A4) ENDIF ENDIF C ENDIF C C ALLOW FOR ANY DRIFT OF CONTINUUM ENERGIES WNP0=ENERG(I) C 122 CONTINUE C IF(MFLAG.GT.NDIM10)THEN WRITE(6,368)MFLAG 368 FORMAT(' NUMBER OF LEVELS EXCEEDS STORAGE,INCREASE NDIM10 TO',I6) STOP 'ERROR: NUMBER OF LEVELS EXCEEDS STORAGE,INCREASE NDIM10' ELSE MENG=MFLAG !FOR CORRELATION LABELS ENDIF MXDIM10=MAX(MENG,MXDIM10) c ia1=1 ia2=nauto C C***************************************** C END ENERGY READ AND INDEXING BY SYMMETRY C***************************************** C NTEST=IABS(NTAR) IF(NTARX.LT.NDIM5)NTEST=MAX(NTARX,NTEST) C IF(KFPM.LT.NTEST)THEN WRITE(6,378)NTEST,KFPM 378 FORMAT(' ERROR: YOU HAVE FLAGGED NTAR*=',I5,' E-TARGETS BUT' X ,' ONLY ',I5,' CAN BE DETERMINED FROM YOUR AUTOSTRUCTURE DATA.'/ X /' POSSIBLE CAUSES:'/ X '1. THERE ARE NOT NTAR* E-TARGET CONTINUA - DID YOU RESTRICT' X ,' N+1 SYMMETRIES? IF NO MIS-MATCH FLAGGED, SET MATCH="YES" .'/ X ,'2. LEVEL SPLITTING IS .LT. 1.D-6 BUT O1 IS BEING USED - ' X ,'SWITCHED TO UNFORMATTED DATA ON O1U.' / X ,'3. TOLB IS TOO LARGE - TRY SETTING IT TO LESS THAN HALF OF ' X ,'THE GLOBAL SMALLEST LEVEL SPLITTING, NOT JUST THE FIRST NTAR.' X ) ISIGN=1 IF(NTAR0.LT.0)ISIGN=-1 IF(KFPM.LT.NTAR)WRITE(6,*)' REDUCE NTAR TO: ',ISIGN*KFPM,' ?' WRITE(6,*) X ' ERROR: NUMBER OF E-TARGETS REQUESTED EXCEEDS THOSE FOUND' STOP '*** NUMBER OF E-TARGETS REQUESTED EXCEEDS THOSE FOUND' C NTARX=KFPM ELSE IF(NTAR0.LT.0)WRITE(6,377)KFPM 377 FORMAT(/' NOTE: NO. OF ELECTRON TARGETS FOUND',I5) IF(KFPM.LT.NTARX)NTARX=KFPM NTARP=MIN(NTARP,NTARX) ENDIF C IF(BBIN.AND.EI(1).GE.DZERO)THEN IF(KFPM.EQ.NTARX)EII(KFPM+1)=0.8D0*EII(NTARX) EI(1)=1.2D0*EII(1) DO M=1,NTARX EI(M+1)=EII(M+1)-0.5D0*(EII(M+1)-EII(M)) ENDDO ENDIF KFPM=NDIM2 !NENG C IF(BPASS1.AND.NBIN0.LE.0)THEN C IF(BLS)LAB4='/LS/' IF(BCA)LAB4='/CA/' IF(BIC)LAB4='/IC/' IF(NZ0.LE.NDIM24)THEN LAB2=LSQ(NZ0) ELSE LAB2='**' ENDIF C IF(BPRINT)WRITE(11,88)LAB2,NZ,LAB4 IF(.NOT.BPRINT)WRITE(21)LAB2,NZ,LAB4 C IF(BRSLVF)THEN LAB4='JRSL' IF(BPRINT)WRITE(11,89)LAB4,(I,I=1,NTARP) IF(.NOT.BPRINT)WRITE(21)LAB4,(I,I=1,NTARP) ELSE LAB4=' G' IF(BPRINT)THEN IF(BOLDFR)THEN WRITE(11,87)LAB4,(I,I=1,NTARP) ELSE WRITE(11,89)LAB4,(I,I=1,NTARP) ENDIF ELSE WRITE(21)LAB4,(I,I=1,NTARP) ENDIF ENDIF C ENDIF C IF(BPASS1)THEN IF(BPRNT1)WRITE(6,90) IF(BPRNT0)WRITE(6,33) ENDIF C IF(BPRNT0.AND.NV.GE.0)WRITE(6,34)NV,LV C IF(BINT)GO TO 705 C C************************************************ C SET-UP INDEXING FOR TERMS WITHIN MASTER CONFIGS C************************************************ C IF(LV00.NE.LV0.OR.BRSLVF)THEN C C QTI(L) IS THE NO OF TERMS IN MASTER CONFIG L. C QTT(M) IS THE POSITION OF CURRENT TERM M WITHIN ITS MASTER CONFIG. C THE POSITION OF A TERM WITHIN A CONFIG IN THE MASTERLIST NEVER CHANGES C DO L=1,NCFT QTI(L)=0 ENDDO C DO M=1,MENG !REVERSE INDEX LOOP QTT(M)=0 I=JK(M) IF(I.GT.0)THEN K=IABS(LCF(I)) IF(ICF(K).NE.0)THEN L=IABS(ICF(K)) QTI(L)=QTI(L)+1 QTT(M)=QTI(L) ENDIF ENDIF ENDDO C DIM TEST IFLAGT=0 DO L=NCFT0+1,NCFT IFLAGT=MAX(QTI(L),IFLAGT) ENDDO IF(IFLAGT.GT.IDIM32)THEN WRITE(6,*)'DIMENSION EXCEEDED IN CROSSJ: INCREASE NDIM32 TO' X ,IFLAGT STOP 'DIMENSION EXCEEDED IN CROSSJ: INCREASE NDIM32' ENDIF MXDIM32=MAX(IFLAGT,MXDIM32) C C DETERMINE SYMMETRY GROUPS WITHIN A MASTER CONFIG L C NGG(L) IS NO OF GROUPS FOR CONFIG L C QTE(L,N) IS A TEMP HOLD OF THE SYMMETRY OF GROUP N C QTTG(L,QTT) IS THE GROUP NO OF A TERM WITHIN THE CONFIG C DO L=NCFT0+1,NCFT NGG(L)=0 QTE(L,0)=-1 ENDDO C DO M=1,MENG !REVERSE INDEX LOOP I=JK(M) IF(I.GT.0)THEN K=IABS(LCF(I)) IF(ICF(K).LT.0)THEN !SET UP GROUPS FOR NEW CONFIGS L=-ICF(K) N=NGG(L) IF(QTE(L,N).NE.ILSJ(I))THEN !NEW GROUP N=N+1 NGG(L)=N IF(N.LE.NDIM6)QTE(L,N)=ILSJ(I) ENDIF QTTG(L,QTT(M))=NGG(L) ENDIF ENDIF ENDDO C DIM TEST IFLAGT=0 DO L=NCFT0+1,NCFT IFLAGT=MAX(NGG(L),IFLAGT) ENDDO IF(IFLAGT.GT.NDIM6)THEN WRITE(6,*)'DIMENSION EXCEEDED IN CROSSJ: INCREASE NDIM6 TO' X ,IFLAGT STOP 'DIMENSION EXCEEDED IN CROSSJ: INCREASE NDIM6' ENDIF MXDIM6=MAX(IFLAGT,MXDIM6) C C DETERMINE ENERGY ORDER POSITION OF TERM M WITHIN ITS SYMMETRY GROUP: C QTTE(M) C DO L=1,NCFT DO N=1,NGG(L) QTE(L,N)=0 ENDDO ENDDO C DO I=1,NENG !EFFECTIVE REVERSE INDEX LOOP K=IABS(LCF(I)) IF(ICF(K).NE.0)THEN L=IABS(ICF(K)) M=IABS(IK(I)) IF(M.GT.0)THEN J=QTT(M) IF(J.GT.0)THEN N=QTTG(L,J) QTE(L,N)=QTE(L,N)+1 QTTE(M)=QTE(L,N) ENDIF ENDIF ENDIF ENDDO C DIM TEST IFLAGT=0 DO L=NCFT0+1,NCFT DO N=1,NGG(L) IFLAGT=MAX(QTE(L,N),IFLAGT) ENDDO ENDDO IF(IFLAGT.GT.NDIM19)THEN WRITE(6,*)'DIMENSION EXCEEDED IN CROSSJ: INCREASE NDIM19 TO' X ,IFLAGT STOP 'DIMENSION EXCEEDED IN CROSSJ: INCREASE NDIM19' ENDIF MXDIM19=MAX(IFLAGT,MXDIM19) !GLOBAL C LV00=LV0 ENDIF C C********************************************************* C DETERMINE CONTINUUM PARENTS AND EXISTING RESOLVED STATES C********************************************************* C c write(77,*)nv,lv,e00,wnr(1) IFIRST=1 DO 36 I=1,NENG C IRSOL(I)=0 KK=IABS(IK(I)) ITAR(KK)=-1 C IF(LCF(I).LT.0)THEN !CONTINUUM TE=ENERG(I)+ECORE DO M=IFIRST,NTARX IF(TE.GE.EI(M).AND.TE.LT.EI(M+1))THEN ITAR(KK)=M IF(M.GT.IFIRST)IFIRST=M GO TO 36 ENDIF ENDDO ELSE !DISCRETE K=LCF(I) L=ICF(K) IF(L.GT.0)THEN !MASTER (NOT FIRST TIME) ccf N=ICQT(L,QTT(KK)) !MATCH BY POSITION IN CONFIG N=ICQTG(L,QTTG(L,QTT(KK)),QTTE(KK))!BY ENERGY ORDER IN GROUP IF(N.GT.0)THEN IRSOL(I)=N C TEST ENERGY MATCH c TE=ABS(WNR(N)-WNR(1)-ENERG(I)-ECORE+WNR(1)) c IF(TE.GT.0.1*ABS(WNR(N)-WNR(1)))THEN c WRITE(77,*)I,LCF(I),KK,N,ENERG(I)+ECORE-WNR(1) c X ,WNR(N)-WNR(1),TE c ENDIF ELSE IRSOL(I)=-1 !NOT WANTED ENDIF ENDIF ENDIF C 36 CONTINUE C DO I=1,NCF ICF(I)=IABS(ICF(I)) ENDDO C C**************************************** C SET-UP INDEXING FOR NEW RESOLVED STATES C**************************************** C DO 127 I=1,NENG C IF(LCF(I).LT.0)GO TO 127 IF(IRSOL(I).NE.0)GO TO 127 !MASTER, BUT NOT FIRST TIME IF(IK(I).LE.0)GO TO 127 TE=ENERG(I)+ECORE IF(TE.GE.EIONMN+TOLR.AND..NOT.BRSLVF)GO TO 705 !NON-META AUTOION C IF(NRSOL.GE.JRSLMX)GO TO 705 !DONE C K=LCF(I) J1=LMX(K) M=QLB(K,J1) C IF(.NOT.BRSLVF)THEN IF(NRSOL.GE.IRSLMX)GO TO 705 !DONE IF(QN(M).GT.NRSLMX)GO TO 127 !CASE LOWER-N HIGHER-UP,UNLIKELY ENDIF C NRSOL=NRSOL+1 IF(NRSOL.GT.NDIM17)THEN WRITE(6,379) 379 FORMAT(' SR.CROSSJ: INCREASE NDIM17') STOP' SR.CROSSJ TOO MANY RESOLVED RESONANCES, INCREASE NDIM17' ENDIF IF(QN(M).EQ.NV.AND.LV.GE.0)THEN QNV(NRSOL)=NV QLV(NRSOL)=QL(M) GO TO 130 ENDIF C IF(.NOT.BPASS1)THEN !FIRST BLOCK, SO CANNOT EXIST C C TEST IF(ICF(K).EQ.0)THEN WRITE(6,*)'MASTER LIST PROBLEM FOR CF=',K STOP 'MASTER LIST PROBLEM?' ENDIF C C MAY NOT BE IN FIRST BLOCK, NO REASON TO STOP C STOP 'UNABLE TO FIND PRE-EXISTING RESOLVED CORE STATE' C ENDIF C C DOES NOT EXIST SO EXTEND LIST C QNV(NRSOL)=-QN(M) QLV(NRSOL)=QL(M) C 130 L=ICF(K) KK=IABS(IK(I)) ccf IF(L.GT.0)ICQT(L,QTT(KK))=NRSOL !MASTER IF(L.GT.0)THEN N=QTTE(KK) IF(N.GT.0)THEN ICQTG(L,QTTG(L,QTT(KK)),N)=NRSOL !MASTER ENDIF ENDIF C c write(6,*)i,nrsol,qnv(nrsol),qlv(nrsol),energ(i)*107737. c IRSOL(I)=NRSOL SSR(NRSOL)=-IABS(SS(I)) LLR(NRSOL)=-LL(I)-1 !SO CAN TAG =/- JJR(NRSOL)=IABS(JJ(I)) LMR(NRSOL)=LMX(K) WNR(NRSOL)=ENERG(I)+ECORE IF(WNR(NRSOL).LT.E00)THEN E00=WNR(NRSOL) JE00=NRSOL ENDIF DO J=1,10 QSR(NRSOL,J)=QSB(K,J) QLR(NRSOL,J)=QLB(K,J) ENDDO C 127 CONTINUE C C********************* C READ RADIATIVE RATES C********************* C 705 BFAST=.NOT.BFORM.AND.RMIN.LT.0.0D0.AND.RCOR.LT.0.0D0.AND..NOT. XBRADBF C IEND=9 IF(BFORM)READ(MR,104,END=1002)NZTEST IF(.NOT.BFORM)READ(MRU,END=1002)NZTEST,NDUME 104 FORMAT(66X,I2) C IF(.NOT.BRADBF)IRAD=NENG IF(NZTEST.LT.1)THEN NUMR=1 ITR(1)=0 GO TO 133 ENDIF C IEND=10 IF(BFORM)READ(MR,103,END=1002) IEND=11 C if(boop)then rsumd1=dzero if(bform)then read(mr,132)icr,i10 backspace(mr) else read(mru)icr,i10 backspace(mru) endif endif C I=0 131 I=I+1 IF(BFORM)READ(MR,132,END=1002)ICR,I1,IWR,I2,I3,JWR,T1,T2,T3 IF(.NOT.BFORM)READ(MRU,END=1002)ICR,I1,IWR,I2,I3,JWR,T1,T2,T3 132 FORMAT(6I5,1PE15.5,2(0PF15.6)) c if(boop)then if(i1.ne.i10)then if(i1.ne.0)then if(bform)backspace(mr) if(.not.bform)backspace(mru) c else !debug breakpoint c write(0,*)'end of radiative reads' endif ia=jauto(i10) i10=i1 if(ia.eq.0)then if(i1.eq.0)go to 1411 !we are done i=0 go to 131 else ia1=ia ia2=ia numr=i-1 if(numr.gt.ndim7) then write(6,74)numr stop 'crossj: number of radiative rates exceeds ndim7' endif mxdim7=max(numr,mxdim7) if(bint)go to 1411 if(rsumd1.eq.dzero)go to 124 go to 160 endif endif endif C IF(I1.EQ.0)THEN NUMR=I-1 GO TO 133 ENDIF C IF(I.LE.NDIM7)THEN ITR(I)=I1 JCR(I)=I2 JTR(I)=I3 AR(I)=T1 DEL(I)=T2 EATOM(I)=T3 C AR(I)=ABS(AR(I)) IF(BFAST)GO TO 131 C AR(I)=AR(I)*ABS(RCOR) IF(AR(I).LT.RMIN.OR.JK(JTR(I)).GT.IRAD)I=I-1 ENDIF GO TO 131 C 133 IEND=12 IF(NUMR.GT.NDIM7) THEN WRITE(6,74)NUMR 74 FORMAT(' SR.CROSSJ: NUMBER OF RADIATIVE RATES EXCEEDS STORAGE, INC XREASE NDIM7 TO',I10) STOP ' SR.CROSSJ: NUMBER OF RADIATIVE RATES EXCEEDS STORAGE, INC XREASE NDIM7' ENDIF MXDIM7=MAX(NUMR,MXDIM7) C C**************************************************************** C EXIT POINT IF THIS NV,LV IS NOT REQUIRED, GO AND READ NEW NV,LV C**************************************************************** 124 IF(BINT)GO TO 31 C C C********************************************************* C EVALUATE HYDROGENIC RADIATIVE RATES FOR VALENCE ELECTRON C (CONTRIBUTES TO TOTAL WIDTH, I.E. DENOMINATOR, ONLY.) C********************************************************* C (CAN'T USE WITH LV=999 AS ONLY STORE SINGLE UPPER LV) C IF(NR20.LT.0)NR2=9999 C RSUMD1=DZERO IF(.NOT.BRAD)GO TO 160 IF(LV.LT.0.OR.LV.EQ.999)GO TO 160 NMIN=MAX(NR1,LV) NMAX=MIN(NR2,NV-1) IF(NMIN.GT.NMAX)GO TO 160 LP=LV+1 TL=LV TLP=LP DO N=NMIN,NMAX T=N*N DE=DZ*(TV-T)/(TV*T) CALL DIPOL(-1,N,NV,DZERO,LP,CP,CM,JDUM) T1=TLP*CM(LP)*1.0D10**JDUM(LP) T2=DZERO IF(LV.GT.0)T2=TL*CP(LV)*1.0D10**JDUM(LV) T=(T1+T2)/(TL+TLP) T0=DE**3*2.6775D9/DZ T=T*T0 RSUMD1=RSUMD1+T ENDDO C 160 IF(NUMR.EQ.0.AND..NOT.BRAD)GO TO 31 C C C******************************************** C PROCESS UNSORTED RATES: BEGIN BIG LOOP 1410 C******************************************** C C FIRST RESCALE N FOR CASE NENG=0 C TRR=1.0D0 TER=0.0D0 IF(NV.GT.NRR)THEN T1=NRR T2=NV TRR=(T1/T2)**3 TER=DZ/(NRR*NRR)-DZ/(NV*NV) ENDIF C C INDEX RANGE OF STATES 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 C LOOP THRU UPPER/AUTOIONIZING STATES C DO 1410 IA=ia1,ia2 !1,NAUTO C ITAI=IAUTO(IA) ITT=JK(ITAI) C IF(BRSLVF.AND.IRSOL(ITT).EQ.0)GO TO 1410 C IF(BLS)THEN IWAJ=IABS(SS(ITT))*(2*LL(ITT)+1) CT IF(LSPI.GT.0.AND.ILSJ(ITT).NE.LSPI)GO TO 1410 ENDIF IF(BIC)THEN IWAJ=IABS(JJ(ITT))+1 CT IF(J2PI.GT.0.AND.ILSJ(ITT).NE.J2PI)GO TO 1410 ENDIF C I=LCF(ITT) J=LMX(I) N=QLB(I,J) NVV=QN(N) LVV=QL(N) C RSUMD2=DZERO IF(MV.GT.0)THEN !SO LV.GE.0 IF(LV.LT.0)THEN N=QLB(I,J) L=QL(N)+1 RSUMD2=RSUML(L) IF(QSB(I,J).EQ.LIT(2))THEN RSUMD2=RSUMD2+RSUML(L) ELSE N=QLB(I,J-1) L=QL(N)+1 RSUMD2=RSUMD2+RSUML(L) ENDIF ELSE N=QLB(I,J-1) L=QL(N)+1 RSUMD2=RSUML(L) ENDIF ENDIF C RSUMD=RSUMD1+RSUMD2 C DO M=1,NTARX SUMAN(M)=DZERO ENDDO SUMAD=DZERO C C PERFORM RELEVANT SUMS OF AUGER RATES C c etest=503.5 DO 141 J=JFIRST(ITAI),JLAST(ITAI) C IF(ITAI.NE.ITA(J))GO TO 141 C SUMAD=SUMAD+AA(J) C M=JTA(J) IF(M.LE.0)GO TO 141 !CONT STATE NOT RESOLVED LS=ITAR(M) IF(LS.LE.0.OR.LS.GT.NTARX)GO TO 141 !CONT STATE NOT RESOLVED IF(EC(J).LT.EMINC.OR.EC(J).GT.EMAXC)GO TO 141 C SUMAN(LS)=SUMAN(LS)+AA(J) ECA(LS)=EC(J) !-etest C 141 CONTINUE C IF(NBIN0.EQ.0)SUMAD38=SUMAD !HOLD FOR ADF38R C C INITIALIZE FOR SUM OVER RADIATIVE RATES C SUMBN=DZERO SUMRN=DZERO C IF(NR2.LT.NV)SUMRN=RSUMD !TEST SUMRD=RSUMD IF(NBIN0.EQ.0)SUMRD38=SUMRD !HOLD FOR ADF38R NRSOL0=0 C C PERFORM RELEVANT SUMS OF RADIATIVE RATES (LOOP OVER LOWER STATES) C DO 243 K=KFIRST(ITAI),KLAST(ITAI) C IF(ITR(K).NE.ITAI)GO TO 243 !CASE >1 MULTIPOLE MN=QLB(JCR(K),LMX(JCR(K))) TARK=AR(K) !DOWNWARD TE=DZERO IF(QN(MN).NE.NV)THEN TARK=AR(K)*TRR TE=TER ENDIF IF(NBIN0.EQ.0)SUMRD38=SUMRD38+TARK C CT IF(BCFP.AND.JCFR.EQ.JCR(K))TE=-1.D10 IF(EATOM(K)+TE.GE.EIONMN+TOLR) THEN !FINAL (LOWER) STATE AUTO IF(BPION)THEN !PHOTOIONIZATION SUMAD=SUMAD+TARK ELSEIF(RAD.EQ.'AUTO0'.OR.RAD.EQ.'OP')THEN !PHOTORECOMBINATION/OP SUMRD=SUMRD+TARK ENDIF GO TO 243 ELSE !FINAL (LOWER) STATE TRUE BOUND IF(BPABS)THEN !PHOTOABSORPTION SUMAD=SUMAD+TARK ELSE !PHOTOIONIZATION SUMRD=SUMRD+TARK ENDIF ENDIF C SUMRN=SUMRN+TARK IF(RAD.EQ.'OP')DTEST=TARK !UPDATED OP TESTED DOWN C M=JK(JTR(K)) IF(BLS)JWR0=(2*LL(M)+1)*IABS(SS(M)) IF(BIC)JWR0=IABS(JJ(M))+1 TARK=(TARK*IWAJ)/JWR0 !DOWN->UP C SUMBN=SUMBN+TARK IF(RAD.NE.'OP')DTEST=TARK C C STORE RESOLVED RADIATION C N=IRSOL(M) IF(N.GT.0.AND.DTEST.GT.ALF3*DEL(K)*DEL(K)*DELTAF)THEN IF(BRSLVF.AND.(N.GT.IRSLMX.OR.QN(MN).GT.NRSLMX))GO TO 243 NRSOL0=NRSOL0+1 JTR0(NRSOL0)=K AR0(NRSOL0)=TARK !UPWARD IRSOL0(NRSOL0)=N SSR(N)=IABS(SSR(N)) !TAG RAD FROM LOWER EXISTS ENDIF C 243 CONTINUE C C IN THE CASE OF PHOTOIONIZATION, SUMAD38 BELOW INCLUDES RADIATIVE WIDTH C TO AUTOIONIZING STATES (THE TOTAL WIDTH SUMAD+SUMRD IS UNCHANGED.) IF(NBIN0.LT.0)THEN !ADF38R REFLECTS XPEPAR/TOT SUMAD38=SUMAD SUMRD38=SUMRD C ELSE !ADF38R USES UNMODIFIED SUMAD ENDIF C IF(BRSLVF.AND.NRSOL0.GT.0)THEN M=IRSOL(ITT) LLR(M)=IABS(LLR(M)) !TAG RAD TO UPPER EXISTS ENDIF C IF(SUMBN.EQ.DZERO.OR.NRSOL0.EQ.0)GO TO 1410 !SWIFT EXIT C C EVALUATE CROSS SECTIONS C CROSSD=MAX(SUMAD,HHBAR) IF(RAD.NE.'NO')CROSSD=CROSSD+SUMRD !ADD-IN RADIATION DAMPING C DO 435 L=1,NTARP C IF(NNCOR*NV.GT.0)SUMAN(L)=SUMAN(L)*ACORN(NV) C IF(JTEMP.GT.0)THEN !DOWNWARD CROSSN=SUMAN(L) TI=IWT(L) CROSS=CROSSN/(CROSSD*TI) DO M=1,JTEMP T=-ECA(L)/TEMP(M) IF(T.GT.-75.0D0)THEN COFT(L,M)=CROSS*EXP(T)*COEF(M) ELSE COFT(L,M)=DZERO ENDIF ENDDO CROSS=CROSS*SUMRN*IWAJ ELSE !UPWARD CROSSN=SUMAN(L)*SUMBN CROSS=CROSSN/CROSSD ENDIF IF(CROSS.LE.DZERO)GO TO 435 CROSS=CON1*CROSS/ECA(L) TC(L)=TC(L)+CROSS/ERES C IF(BPRNT0)WRITE(6,32)LCF(ITT),ITAI,IWT(L),IWAJ,ECA(L),SUMAN(L) X ,SUMAD,SUMRN,SUMRD,SUMBN,CROSS/ERES 32 FORMAT(4I5,7(1PE15.4)) C 435 CONTINUE C C BIN ENERGY-AVERAGED OR LORENTZIAN BY *PHOTON* ENERGY C IF(NBIN0.NE.0)THEN C IF(JTEMP.GT.0)THEN !MAXWELLIAN DR C DO N0=1,NRSOL0 K=JTR0(N0) IF(DEL(K).GE.EBIN(1).AND.DEL(K).LT.EBIN(NBIN))THEN T=(DEL(K)-EBIN(1))/ERES !ASSUME LINEAR N=T N=N+1 c write(*,*)n,ebin(n),del(k),ebin(n+1) M=JK(JTR(K)) IF(BLS)JWR0=(2*LL(M)+1)*IABS(SS(M)) IF(BIC)JWR0=IABS(JJ(M))+1 TT=JWR0*AR0(N0)/ERES DO M=1,JTEMP DO L=1,LMAX SBIN(N,L,M)=SBIN(N,L,M)+COFT(L,M)*TT ENDDO ENDDO ENDIF ENDDO C ELSE !PE C CROSS=CON2/CROSSD IF(BLOR)THEN W=CROSSD*HHBAR !HALF-WIDTH CROSS=CROSS*W/PI W2=W*W ENDIF C DO N0=1,NRSOL0 L0=IRSOL0(N0) IF(L0.LE.LBIN)THEN K=JTR0(N0) IF(DEL(K).GE.EBIN(1).AND.DEL(K).LT.EBIN(NBIN))THEN TT=CROSS*AR0(N0) T=(DEL(K)-EBIN(1))/ERES !ASSUME LINEAR N=T N=N+1 c write(*,*)n,ebin(n),del(k),ebin(n+1) IF(BLOR)THEN !LORENTZIAN T=63.6D0*W/ERES !99% OF AREA NN=NINT(T) if(nn.lt.5)write(63,*)nn,n,ebin(n),w,tt*sumad*pi/w N1=MAX(1,N-NN) N2=MIN(N+NN,NBIN1) T=TT/(DEL(K)*DEL(K)) ELSE !BINNED N1=N N2=N1 TT=TT/(ERES*EBIN(N1+1)*EBIN(N1+1)) ENDIF C IF(BPABS)THEN !PHOTOABSORPTION DO N=N1,N2 IF(BLOR)TT=T/((EBIN(N)-DEL(K))**2+W2) TBIN(N,L0)=TBIN(N,L0)+TT*CROSSD ENDDO ELSE !PE+AUTOIONIZATION DO N=N1,N2 IF(BLOR)TT=T/((EBIN(N)-DEL(K))**2+W2) DO L=1,LMAX SBIN(N,L,L0)=SBIN(N,L,L0)+TT*SUMAN(L) ENDDO IF(NTART.LT.NDIM5)THEN DO L=1,NTART TBIN(N,L0)=TBIN(N,L0)+TT*SUMAN(L) ENDDO ELSE !ALL, INDEPENDENT OF NTARP TBIN(N,L0)=TBIN(N,L0)+TT*SUMAD ENDIF ENDDO ENDIF ENDIF ENDIF ENDDO C ENDIF IF(NBIN0.GT.0)GO TO 1410 ENDIF C C************************************************** C WRITE PHOTOEXCITATION XSCNS TO ADAS FORMAT ADF38R C ***** **** ****** C************************************************** C c if(nbin0.eq.0)go to 1410 !test skip writes c N=1 K=JTR0(N) M=IRSOL0(N) IF(QNV(M).EQ.NV)MP=LABL(20) IF(QNV(M).NE.NV)MP=MBLNK C IF(.NOT.BRSLVF)THEN C NRSOL1=MAX(M,NRSOL1) IF(BLS)JJJ=SSR(M)*(2*IABS(LLR(M))-1) IF(BIC)JJJ=JJR(M)+1 C IF(BPRINT)THEN IF(BOLDFR)THEN WRITE(11,26)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) X ,SUMRD38,SUMAD38,(SUMAN(L),L=1,NTARP) ELSE WRITE(11,20)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) X ,SUMRD38,SUMAD38,(SUMAN(L),L=1,NTARP) ENDIF ELSE WRITE(21)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) X ,SUMRD38,SUMAD38,(SUMAN(L),L=1,NTARP) ENDIF C DO N=2,NRSOL0 M=IRSOL0(N) NRSOL1=MAX(M,NRSOL1) IF(QNV(M).EQ.NV)MP=LABL(20) IF(QNV(M).NE.NV)MP=MBLNK K=JTR0(N) IF(BLS)JJJ=SSR(M)*(2*IABS(LLR(M))-1) IF(BIC)JJJ=JJR(M)+1 IF(BPRINT)THEN IF(BOLDFR)THEN WRITE(11,26)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) ELSE WRITE(11,20)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) ENDIF ELSE WRITE(21)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) ENDIF ENDDO C ENDIF C IF(BRSLVF)THEN C IF(JTEMP.GT.0)THEN !MAXWELLIAN DR M=JK(JTR(K)) IF(BLS)JWR0=(2*LL(M)+1)*IABS(SS(M)) IF(BIC)JWR0=IABS(JJ(M))+1 TT=JWR0*AR0(N) DRSUM=DRSUM+COFT(1,1)*TT !CHECKSUM ENDIF C JJJ=IRSOL(JK(ITR(K))) IF(BPRINT)THEN WRITE(11,20)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) X ,SUMRD38,SUMAD38,(SUMAN(L),L=1,NTARP) IF(JTEMP.GT.0)WRITE(11,19)((COFT(L,M)*TT,M=1,JTEMP),L=1,NTARP) ENDIF IF(.NOT.BPRINT)WRITE(21)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) X ,SUMRD38,SUMAD38,(SUMAN(L),L=1,NTARP) C DO N=2,NRSOL0 M=IRSOL0(N) IF(QNV(M).EQ.NV)MP=LABL(20) IF(QNV(M).NE.NV)MP=MBLNK K=JTR0(N) C IF(JTEMP.GT.0)THEN !MAXWELLIAN DR M=JK(JTR(K)) IF(BLS)JWR0=(2*LL(M)+1)*IABS(SS(M)) IF(BIC)JWR0=IABS(JJ(M))+1 TT=JWR0*AR0(N) DRSUM=DRSUM+COFT(1,1)*TT !CHECKSUM ENDIF C JJJ=IRSOL(JK(ITR(K))) IF(BPRINT)THEN WRITE(11,205)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) X ,((COFT(L,M)*TT,M=1,JTEMP),L=1,NTARP) ENDIF IF(.NOT.BPRINT)WRITE(21)IRSOL0(N),JJJ,NVV,LVV,MP,DEL(K),AR0(N) ENDDO C ENDIF C 1410 CONTINUE c 1411 if(boop)then nrsol0=0 if(i10.ne.0)then i=0 numa=-iabs(numa) !don't re-index augers - slow! go to 131 endif numa=-numa !for safety (currently not re-used) if(bint)go to 31 endif C C************************************************ C END PROCESSING OF UNSORTED RATES: BIG LOOP 1410 C************************************************ C IF(BPRNT1.AND.NV.GE.0)WRITE(6,35)NV,LV,(TC(L),L=1,NTARP) 35 FORMAT(I5,I3,2X,9(1PE13.4)) C C GO AND READ NEW NL BLOCK C MXDIM17=MAX(NRSOL,MXDIM17) IF(.NOT.BRSLVF.AND..NOT.BPRNTP)NRSOL=NRSOL1!START AT THE LAST USED EX=.FALSE. BPASS1=.FALSE. GO TO 31 C C ABORT 1002 NV=0 WRITE(6,1107)IEND,FILNAM 1107 FORMAT(/' ******WARNING, IEND= ',I2,' UNEXPECTED END OF DATA ON ' X,'FILE ',A3,'/u !!!!',/' ******ADF38 FILES MAY BE INCOMPLETE!'/) WRITE(0,*)'WARNING, UNEXPECTED EOF ON ',FILNAM C GO TO 1001 C C********************** C GO AND READ NEW FILE C********************** C 1000 CLOSE(MR) !MRU=MR IFILE=IFILE+1 IF(JCF(IFILE).NE.0)THEN JCFJ=JCF(IFILE) IF(JCFJ.GT.0)JCFP=JCFJ IF(JCFJ.LT.0)JCFM=-JCFJ ENDIF 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 IF(EX)GO TO 331 C C 1001 CONTINUE C IF(JTEMP.GT.0)WRITE(6,139)TEMP(1)*1.5789D5,DRSUM 139 FORMAT(/' DRS CHECKSUM:'/' T(K) ALFT( 1)'/ X,' ---- --------'/1PE10.2,1X,1E10.2/) C IF(TOLB.GT.TOLB0)WRITE(6,137)TOLB 137 FORMAT(/' *** NOTE: TOLB HAS BEEN RESET TO =',1PE10.2,' RYD'/) C IF(NBIN0.LE.0)THEN IF(BPRINT)WRITE(11,138)NRSLMX,NVMAX,LVMAX !,IRSLMX IF(.NOT.BPRINT)WRITE(21)NRSLMX,NVMAX,LVMAX !,IRSLMX 138 FORMAT(/' NRSLMX=',I4,' NVMAX=',I4 !,' IRSLMX=',I7 X ,' LVMAX=',I4) ENDIF C IF(IFLAGE.NE.0)WRITE(6,142)IFLAGE 142 FORMAT(//'NOTE: ',I4,' UNIT5 TARGET ENERGIES DID NOT MATCH WITH' X,' THOSE PRESENT IN THE RATE FILE, SEE ABOVE "***" !'/11X X,' TARGET LEVEL LABELLING MAYBE INCORRECT...') C IF(NBIN0.NE.0)THEN IF(WNP(1).GT.DZERO)THEN EET(1)=-WNP(1) !.LT.0 ELSE EET(1)=EIONMN ENDIF DO M=2,LMAX EET(M)=-EET(1)-WNP(M) !.GT.0 ENDDO IF(JTEMP.EQ.0)THEN EPT(1)=WNR(1) !.LT.0 DO M=2,LBIN EPT(M)=-EPT(1)+WNR(M) !.GT.0 ENDDO ELSE DO J=1,JTEMP EPT(J)=TEMP(J)*1.5789D5 ENDDO ENDIF IF(NBIN0.GT.0)GO TO 999 !RETURN ENDIF C C*********************************************** C WRITE PE TERM/LEVEL DATA TO ADAS FORMAT ADF38L C ***** ***** ****** C*********************************************** C c if(nbin0.eq.0)go to 999 !test skip writes c IF(NTAR0.LT.0)NTAR=NTARX C IF(BLS)LAB4='/LS/' IF(BIC)LAB4='/IC/' IF(BCA)LAB4='/CA/' C IF(NE.LE.NDIM24)THEN LAB2=LSQ(NE) ELSE LAB2='**' ENDIF C IF(WNP(1).LE.DZERO)WNP(1)=-EIONMN WNP0=WNP(1)*DKCM C IF(BPRINT)THEN WRITE(10,21)LAB2,NZ0,LAB4 IF(BOLDFL)THEN IF(BCA)THEN WRITE(10,220)WNP0,NTAR ELSE IF(BLS)WRITE(10,22)WNP0,NTAR IF(BIC)WRITE(10,23)WNP0,NTAR ENDIF ELSE IF(BCA)THEN WRITE(10,720)WNP0,NTAR ELSE IF(BLS)WRITE(10,722)WNP0,NTAR IF(BIC)WRITE(10,723)WNP0,NTAR ENDIF ENDIF ELSE WRITE(20)LAB2,NZ0,LAB4 WRITE(20)WNP0,NTAR ENDIF C C PARENT INDEXING C DO M=1,NTAR C WNP(M)=-WNP(M)*DKCM+WNP0 IF(BLS)THEN TW=IWS(M)*(2*IWL(M)+1) TW=0.5D0*(TW-1.0D0) ENDIF IF(BIC)THEN TW=IWJ(M) TW=0.5D0*TW ENDIF C DO J=1,10 QS0(J)=MBLNK QL0(J)=MBLNK IF(J.LE.LMP(M))THEN K=QLP(M,J) QS0(J)=LIT(QN(K)) L=MIN((QL(K)+1),20) QL0(J)=LABL(L) ENDIF ENDDO C J1=MAX(5,LMP(M)) J0=J1-4 C IF(M.GT.NTAR)THEN C MP=LABL(20) C ELSE C MP=MBLNK C ENDIF C IF(BPRINT)THEN IF(BCA)THEN WRITE(10,280)M,(QS0(J),QL0(J),QSP(M,J),J=J0,J1),TW,WNP(M) X ,MBLNK !MP ELSE WRITE(10,28)M,(QS0(J),QL0(J),QSP(M,J),J=J0,J1),IWS(M) X ,LIT(IWL(M)),TW,WNP(M),MBLNK !MP ENDIF ELSE IF(BCA)THEN WRITE(20)M,(QS0(J),QL0(J),QSP(M,J),J=J0,J1),TW,WNP(M) X ,MBLNK !MP ELSE WRITE(20)M,(QS0(J),QL0(J),QSP(M,J),J=J0,J1),IWS(M) X ,LIT(IWL(M)),TW,WNP(M),MBLNK !MP ENDIF ENDIF C ENDDO C C RESOLVED INDEXING C IF(NRSOL.EQ.0)GO TO 999 !RETURN C IRSOL0(1)=1 !TRY AND CATCH GROUND-STATE DO M=2,NRSOL IRSOL0(M)=0 IF(BRSLVF)THEN IF(SSR(M).GT.0.OR.LLR(M).GT.0)THEN IRSOL0(M)=M !DATA EXISTS ELSE IF(BPRNTP)IRSOL0(M)=-M !LIST, BUT FLAG ENDIF ELSE IF(SSR(M).GT.0)THEN IRSOL0(M)=M !DATA EXISTS ELSE IF(BPRNTP)IRSOL0(M)=-M !LIST, BUT FLAG ENDIF ENDIF ENDDO C NRSOL0=NRSOL IF(.NOT.BPRNTP)THEN !DO NOT PRINT UNUSED LOWER LEVELS NRSOL0=0 DO J=1,NRSOL IF(IRSOL0(J).EQ.0)THEN !UNUSED, MOVE OUT OF SORT WNR(J)=DZERO ELSE NRSOL0=NRSOL0+1 ENDIF ENDDO ENDIF C CALL HPSRTI(NRSOL,WNR,JV0) C IF(BPRNTP)THEN !PRINT UNUSED LOWER LEVELS DO J=1,NRSOL IF(IRSOL0(J).LT.0)JV0(J)=-JV0(J) !BUT FLAG ENDDO ENDIF C IF(NRSOL.NE.NRSOL0)THEN WRITE(6,140)NRSOL,NRSOL0 140 FORMAT(/' *** ATTENTION: NO. OF INITIAL STATES REDUCED FROM', X I8,' TO',I8/4X,' BECAUSE NO RADIATIVE DATA ON FILE FOR' X ,' THESE STATES') NRSOL=NRSOL0 ENDIF C IF(NRSOL.EQ.0)THEN !WRITE LOWEST STATE ANYWAY JV0(1)=JE00 NRSOL=1 M=IABS(JV0(1)) ELSE M=IABS(JV0(1)) IF(M.NE.JE00)THEN WRITE(6,*)'MIS-MATCH ON GROUND STATE:',M,JE00 WRITE(6,*)'CHECK GROUND STATE EXISTS IN FIRST RATE FILE' STOP 'MIS-MATCH ON GROUND STATE: SEE ADASOUT' ENDIF ENDIF C E00=WNR(M) !RENORMALIZE G.S. ENERGY WNR0=E00 WNR0=-WNR0*DKCM C IF(BLS)LAB2='LS' IF(BCA)LAB2='CA' IF(BIC)LAB2='IC' C IF(BPRINT)THEN IF(BCA)THEN WRITE(10,250)LAB2,WNR0,NRSOL F290="(2I6,4X,5(A1,A1,A1,1X),'(',F8.1,')',F11.1,A1)" IF(NRSOL.GT.99999.AND.BPRNTP.OR.NRSOL.GT.999999)F290(4:6)="7,2" ELSE IF(BLS)WRITE(10,25)LAB2,WNR0,NRSOL IF(BIC)WRITE(10,24)LAB2,WNR0,NRSOL F29= X "(2I6,4X,5(A1,A1,A1,1X),'(',A1,')',A1,'(',F4.1,')',F11.1,A1)" IF(NRSOL.GT.99999.AND.BPRNTP.OR.NRSOL.GT.999999)F29(4:6)="7,2" ENDIF ELSE WRITE(20)LAB2,WNR0,NRSOL ENDIF C DO M0=1,NRSOL C M=IABS(JV0(M0)) IF(WNR(M).GE.EIONMN)THEN MP=LABL(20) ELSE MP=MBLNK ENDIF WNR(M)=(WNR(M)-E00)*DKCM C ISSR=IABS(SSR(M)) ILLR=IABS(LLR(M))-1 IF(BLS)THEN TW=ISSR*(2*ILLR+1) TW=0.5D0*(TW-1.0D0) ENDIF IF(BIC)THEN TW=IABS(JJR(M)) TW=0.5D0*TW ENDIF C DO J=1,10 QS0(J)=MBLNK QL0(J)=MBLNK C IF(J-LMR(M))46,47,27 IF(J.LE.LMR(M))THEN C 47 CONTINUE C IF(QNV(M).EQ.0)GO TO 46 IF(J.EQ.LMR(M).AND.QNV(M).NE.0)THEN K=IABS(QNV(M)) QS0(J)=LIT(K) L=MIN((QLV(M)+1),20) QL0(J)=LABL(L) ELSE C 46 CONTINUE K=QLR(M,J) IF(QN(K).GT.NRSLMX)THEN WRITE(6,*) X '***ERROR: ORBITAL CONFUSION BETWEEN onu FILES: M0,M,N,L=' WRITE(6,*)M0,M,QN(K),QL(K) STOP'***ERROR: ORBITAL CONFUSION BETWEEN onu FILES' ENDIF QS0(J)=LIT(QN(K)) L=MIN((QL(K)+1),20) QL0(J)=LABL(L) ENDIF ENDIF C 27 CONTINUE ENDDO C IF(LMR(M).LE.5)THEN C J0=1 J1=5 IF(BPRINT)THEN IF(BCA)THEN WRITE(10,F290)M0,JV0(M0),(QS0(J),QL0(J),QSR(M,J),J=J0,J1) X ,TW,WNR(M),MP ELSE WRITE(10,F29)M0,JV0(M0),(QS0(J),QL0(J),QSR(M,J),J=J0,J1) X ,LIT(ISSR),LIT(ILLR),TW,WNR(M),MP ENDIF ELSE IF(BCA)THEN WRITE(20)M0,JV0(M0),(QS0(J),QL0(J),QSR(M,J),J=J0,J1) X ,TW,WNR(M),MP ELSE WRITE(20)M0,JV0(M0),(QS0(J),QL0(J),QSR(M,J),J=J0,J1) X ,LIT(ISSR),LIT(ILLR),TW,WNR(M),MP ENDIF ENDIF C ELSE C DO J=1,10 QS00(J)=MBLNK QL00(J)=MBLNK QSR0(J)=MBLNK ENDDO C MPP='+' J1=0 DO J=1,LMR(M) IF(QL0(J).EQ.LABL(1).AND.QSR(M,J).EQ.LIT(2))GO TO 99 !FULL S IF(QL0(J).EQ.LABL(2).AND.QSR(M,J).EQ.LIT(6))GO TO 99 !FULL P IF(QL0(J).EQ.LABL(3).AND.QSR(M,J).EQ.LIT(10))GO TO 99!FULL D IF(QL0(J).EQ.LABL(4).AND.QSR(M,J).EQ.LIT(14))GO TO 99!FULL F J1=J1+1 QL00(J1)=QL0(J) QS00(J1)=QS0(J) QSR0(J1)=QSR(M,J) 99 ENDDO C IF(J1.EQ.0)THEN QS00(1)=QS0(LMR(M)) QL00(1)=QL0(LMR(M)) QSR0(1)=QSR(M,LMR(M)) ENDIF C IF(J1.GT.5)MPP='!' J1=MAX(5,J1) J0=J1-4 IF(BPRINT)THEN IF(BCA)THEN WRITE(10,300)M0,JV0(M0),MPP,(QS00(J),QL00(J),QSR0(J) X ,J=J0,J1),TW,WNR(M),MP ELSE WRITE(10,30)M0,JV0(M0),MPP,(QS00(J),QL00(J),QSR0(J) X ,J=J0,J1),LIT(ISSR),LIT(ILLR),TW,WNR(M),MP ENDIF ELSE IF(BCA)THEN WRITE(20)M0,JV0(M0),MPP,(QS00(J),QL00(J),QSR0(J) X ,J=J0,J1),TW,WNR(M),MP ELSE WRITE(20)M0,JV0(M0),MPP,(QS00(J),QL00(J),QSR0(J) X ,J=J0,J1),LIT(ISSR),LIT(ILLR),TW,WNR(M),MP ENDIF ENDIF C ENDIF C ENDDO c if(bprint)call flush(10) C C----------------------------------------------------------------------- C 999 IF(ALLOCATED(EC))DEALLOCATE (ICA,ITA,JTA,AA,EC,STAT=IERR) IF(IERR.NE.0)THEN WRITE(6,*)'*** FAILURE TO DEALLOCATE AUTOIONIZATION MEMORY' STOP '*** FAILURE TO DEALLOCATE AUTOIONIZATION MEMORY' ENDIF C IF(ALLOCATED(QNT))DEALLOCATE (QNT,QMT,QST,QTI,QLT,LMT,NGG,QTE X ,STAT=IERR) IF(IERR.NE.0)THEN WRITE(6,*)'*** FAILURE TO DEALLOCATE QNT ETC.' STOP '*** FAILURE TO DEALLOCATE QNT ETC.' ENDIF C IF(.NOT.ALLOCATED(QTTG))DEALLOCATE (QTTG,ICQTG,STAT=IERR) IF(IERR.NE.0)THEN WRITE(6,*)'*** FAILURE TO DEALLOCATE QTTG,ICQTG' STOP '*** FAILURE TO DEALLOCATE QTTG,ICQTG' ENDIF C ccf IF(.NOT.ALLOCATED(ICQT))DEALLOCATE (ICQT,STAT=IERR) ccf IF(IERR.NE.0)THEN ccf WRITE(6,*)'*** FAILURE TO DEALLOCATE ICQT' ccf STOP '*** FAILURE TO DEALLOCATE ICQT' ccf ENDIF C C WRITE SOME INFO ON ACTUAL DIMENSION USAGE C WRITE(6,"(///' DIMENSION',9X,'SET',6X,'USED'/)") WRITE(6,"(' NDIM6 ',5X,2I10)")NDIM6,MXDIM6 WRITE(6,"(' NDIM7 ',5X,2I10)")NDIM7,MXDIM7 WRITE(6,"(' NDIM10',5X,2I10)")NDIM10,MXDIM10 WRITE(6,"(' NDIM12',5X,2I10)")NDIM12,MXDIM12 WRITE(6,"(' NDIM13',5X,2I10)")NDIM13,MXDIM13 WRITE(6,"(' NDIM14',5X,2I10)")NDIM14,MXDIM14 WRITE(6,"(' NDIM17',5X,2I10)")NDIM17,MXDIM17 WRITE(6,"(' NDIM19',5X,2I10)")NDIM19,MXDIM19 WRITE(6,"(' NDIM30',5X,2I10)")IDIM30,MXDIM30 WRITE(6,"(' NDIM32',5X,2I10)")IDIM32,MXDIM32 C C----------------------------------------------------------------------- C RETURN C C----------------------------------------------------------------------- C 19 FORMAT(71X,1P,6E12.3) 20 FORMAT(2I6,I3,I4,A1,1PE15.6,9E12.3/(71X,6E12.3)) 205 FORMAT(2I6,I3,I4,A1,1PE15.6,E12.3,24X,6E12.3/(71X,6E12.3)) 21 FORMAT("SEQ='",A2,"'",5X,"NUCCHG=",I3,49X,A4/) 22 FORMAT(3X,'PARENT TERM INDEXING',17X,'BWNP=',F12.1,2X,'NPRNT=',I4/ X3X,'--------------------'/3X,'INDP',9X,'CODE',17X,'S L WI',8X X,'WNP'/3X,'----',9X,'----',17X,'- - --',2X,'----------') 220 FORMAT(/3X,'PARENT CONFG INDEXING',16X,'BWNP=',F12.1,2X,'NPRNT=', XI4/3X,'---------------------'/3X,'INDP',9X,'CODE',17X,' WI', X8X,'WNP'/3X,'----',9X,'----',17X,'--------',2X,'----------') 23 FORMAT(3X,'PARENT LEVEL INDEXING',16X,'BWNP=',F12.1,2X,'NPRNT=',I4 X/3X,'---------------------'/3X,'INDP',9X,'CODE',17X,'S L WI',8X, X'WNP'/3X,'----',9X,'----',17X,'- - --',2X,'----------') 722 FORMAT(3X,'PARENT TERM INDEXING',17X,'BWNP=',F12.1,2X,'NPRNT=',I6/ X3X,'--------------------'/3X,'INDP',9X,'CODE',17X,'S L WI',8X X,'WNP'/3X,'----',9X,'----',17X,'- - --',2X,'----------') 720 FORMAT(/3X,'PARENT CONFG INDEXING',16X,'BWNP=',F12.1,2X,'NPRNT=', XI6/3X,'---------------------'/3X,'INDP',9X,'CODE',17X,' WI', X8X,'WNP'/3X,'----',9X,'----',17X,'--------',2X,'----------') 723 FORMAT(3X,'PARENT LEVEL INDEXING',16X,'BWNP=',F12.1,2X,'NPRNT=',I6 X/3X,'---------------------'/3X,'INDP',9X,'CODE',17X,'S L WI',8X, X'WNP'/3X,'----',9X,'----',17X,'- - --',2X,'----------') 24 FORMAT(/3X,A2,' RESOLVED LEVEL INDEXING',11X,'BWNR=',F12.1,1X X,'NLVL=',I6/3X,'--------------------------'/3X,'INDX',2X,'IRSL',3X X,'CODE',17X,'S L WJ',8X,'WNR'/3X,'----',2X,'----',3X,'----',17X, X'- - --',2X,'----------') 25 FORMAT(/3X,A2,' RESOLVED TERM INDEXING',12X,'BWNR=',F12.1,1X X,'NTRM=',I6/3X,'-------------------------'/3X,'INDX',2X,'IRSL',3X X,'CODE',17X,'S L WJ',8X,'WNR'/3X,'----',2X,'----',3X,'----',17X, X'- - --',2X,'----------') 250 FORMAT(/3X,A2,' RESOLVED CONFG INDEXING',11X,'BWNR=',F12.1,3X X,'NCFG=',I4/3X,'--------------------------'/3X,'INDX',2X,'INDP',3X X,'CODE',17X,' WJ',8X,'WNR'/3X,'----',2X,'----',3X,'----',17X X,'--------',2X,'----------') 26 FORMAT(3I5,I4,A1,1PE15.6,9E12.3/(71X,6E12.3)) 28 FORMAT(I6,10X,5(A1,A1,A1,1X),'(',I1,')',A1,'(',F4.1,')',F11.1,A1) 280 FORMAT(I6,10X,5(A1,A1,A1,1X),'(',F8.1,')',F11.1,A1) C 29 FORMAT(2I6,4X,5(A1,A1,A1,1X),'(',I1,')',A1,'(',F4.1,')',F11.1,A1) C 290 FORMAT(2I6,4X,5(A1,A1,A1,1X),'(',F8.1,')',F11.1,A1) 30 FORMAT(2I6,3X,A1,5(A1,A1,A1,1X),'(',A1,')',A1,'(',F4.1,')',F11.1 X,A1) 300 FORMAT(2I6,3X,A1,5(A1,A1,A1,1X),'(',F8.1,')',F11.1,A1) 33 FORMAT(3X,'CF',4X,'J',3X,'WI',3X,'WJ',8X,'EC(J)',10X,'SUMAN' X,9X,'SUMAD',10X,'SUMRN',10X,'SUMRD',10X,'SUMBN',8X,'CROSS(MB)') 34 FORMAT(I5,I3) 87 FORMAT(1X,'IRSL',1X,A4,4X,'N',3X,'L',6X,'DEL(RYD)',7X,'B(SEC)' X,6X,'R(SEC)',6X,'A(SEC):',6(5X,I3,4X)/(71X,6(5X,I3,4X))) 88 FORMAT(A2,I2,5X,A4/) 89 FORMAT(2X,'IRSL',2X,A4,2X,'N',3X,'L',6X,'DEL(RYD)',7X,'B(SEC)' X,6X,'R(SEC)',6X,'A(SEC):',6(5X,I3,4X)/(71X,6(5X,I3,4X))) 90 FORMAT(//4X,'N L',6X,'CROSS(MB)',4X,'CROSS(MB)',4X,'CROSS(MB)', X4X,'CROSS(MB)',4X,'CROSS(MB)',4X,'CROSS(MB)',4X,'CROSS(MB)',4X X,'CROSS(MB)',4X,'CROSS(MB)') C END C C*********************************************************************** C SUBROUTINE DIPOL(JSW,N1,N2,E2,LMAX,CP,CM,JC) C C----------------------------------------------------------------------- C C ALAN BURGESS DAMTP CAMBRIDGE, MODS BY NRB. C C SR.DIPOL CALCULATES SQUARES OF HYDROGENIC DIPOLE LENGTH RADIAL MATRIX C ELEMENTS 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 C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) C PARAMETER (PI=3.14159265359D0) PARAMETER (S1=1.0D10) PARAMETER (S2=1.0D-10) PARAMETER (TEST1=1.0D-20) PARAMETER (TEST2=1.0D20) PARAMETER (TEST3=0.044D0) PARAMETER (TEST4=0.1D0) PARAMETER (TEST5=300.0D0) PARAMETER (TEST6=1.0D-30) PARAMETER (TEST7=1.0D30) C DIMENSION CP(LMAX),CM(LMAX),JC(LMAX) C PI=ACOS(-DONE) C N=N1 E=E2 IF(JSW.LE.0)THEN EN2=N2 N3=N2 IF(N1.EQ.N2)GO TO 59 IF(N2.LT.N1)THEN N=N2 EN2=N1 N3=N1 ENDIF E=-DONE/(EN2*EN2) ENDIF C EN=N ENN=EN*EN E1=-DONE/ENN JMAX=LMAX C1=DONE C2=DZERO JS=0 L=N+1 IF(N.LE.LMAX)THEN CP(N)=DONE CM(N)=DZERO JC(N)=0 JMAX=N-1 DO I=L,LMAX CP(I)=DZERO CM(I)=DZERO JC(I)=0 ENDDO ENDIF C 9 L=L-1 IF(L.GT.1)THEN EL=L ELL=EL*EL T1=DONE+ELL*E1 T2=DONE+ELL*E T3=L+L-1 T4=DONE/(T3+DONE) T5=(T3*T1*C2+T2*C1)*T4 C1=(T1*C2+T3*T2*C1)*T4 C2=T5 11 IF(C1*C1.GT.TEST2)THEN C1=S2*C1 C2=S2*C2 JS=JS+1 GO TO 11 ENDIF IF(L.LE.LMAX+1)THEN CP(L-1)=C1 CM(L-1)=C2 JC(L-1)=JS ENDIF GO TO 9 ENDIF C JS=0 T=4 T=DONE/(T*EN*ENN) IF(JSW.LE.0)THEN !JSW.LT.0 ENN2=EN2*EN2 T1=4 T1=T1*ENN*ENN2/(ENN2-ENN) T1=T1*T1 T=T*T1*T1/(EN2*ENN2) IF(N3.LE.30)THEN T=T*((EN2-EN)/(EN2+EN))**(N3+N3) GO TO 34 ENDIF E21=E/E1 IF(E21.LE.TEST4)THEN T2=DZERO DO J=1,11 T3=2*(11-J)+1 T2=DONE/T3+T2*E21 ENDDO T2=T2+T2 ELSE T3=EN/EN2 T2=LOG((DONE+T3)/(DONE-T3))/T3 ENDIF T2=T2+T2 T1=T1*EXP(-T2) C ELSE !JSW.GT.0 C T1=4 T1=T1*ENN/(DONE+ENN*E) T1=T1*T1 T=T*T1*T1 IF(E.LT.TEST3)THEN T3=2 T=T*(PI/T3) ELSE T4=SQRT(E) IF(T4.LE.TEST5)THEN T3=(PI+PI)/T4 T3=DONE-EXP(-T3) T3=DONE/T3 ELSE T4=PI/T4 T3=3 T3=(DONE+T4+T4*T4/T3)/(T4+T4) ENDIF T2=2 T=T*(PI*T3/T2) ENDIF C T4=ENN*E IF(T4.LE.TEST4)THEN T2=DZERO DO J=1,11 T3=2*(11-J)+1 T2=DONE/T3-T2*T4 ENDDO ELSE T3=SQRT(T4) T2=ATAN(T3)/T3 ENDIF T2=T2+T2 T2=T2+T2 T1=T1*EXP(-T2) ENDIF C !ALL JSW 34 DO J=1,N TJ=J+J T2=TJ*(TJ-DONE) T2=T2*T2 T=T*T1/T2 35 IF(T.LE.TEST1)THEN T=T*S1 JS=JS-1 GO TO 35 ENDIF 37 IF(T.GE.TEST2)THEN T=T*S2 JS=JS+1 GO TO 37 ENDIF ENDDO J=0 C 40 J=J+1 IF(J.LE.JMAX)THEN TJ=J TJ=TJ*TJ T1=DONE+TJ*E1 T2=DONE+TJ*E T3=CP(J) T3=T2*T*T3*T3 T4=CM(J) T4=T1*T*T4*T4 L1=JC(J)+JC(J)+JS C 42 IF(L1.LT.0)THEN IF(T4.GT.TEST6)THEN L1=L1+1 T3=T3*S2 T4=T4*S2 GO TO 42 ENDIF ELSEIF(L1.GT.0)THEN IF(T3.LT.TEST7)THEN L1=L1-1 T3=T3*S1 T4=T4*S1 GO TO 42 ENDIF ENDIF C CP(J)=T3 CM(J)=T4 JC(J)=L1 T=T*T1*T2 48 IF(T.GT.TEST2)THEN T=T*S2 JS=JS+1 GO TO 48 ENDIF GO TO 40 ENDIF C IF(N.LE.LMAX)THEN T2=DONE+ENN*E T3=CP(N) T3=T2*T*T3*T3 L1=JC(N)+JC(N)+JS C 52 IF(L1.LT.0)THEN IF(T3.GT.TEST6)THEN L1=L1+1 T3=T3*S2 GO TO 52 ENDIF ELSEIF(L1.GT.0)THEN IF(T3.LT.TEST7)THEN L1=L1-1 T3=T3*S1 GO TO 52 ENDIF ENDIF C CP(N)=T3 JC(N)=L1 ENDIF C RETURN C 59 JMAX=LMAX IF(N.LE.LMAX)THEN DO L=N,LMAX CP(L)=DZERO CM(L)=DZERO JC(L)=0 ENDDO JMAX=N-1 ENDIF T1=9 T2=4 T3=(T1/T2) T1=EN2*EN2 T2=T1*T3 DO J=1,JMAX TJ=J JC(J)=0 T=T2*(T1-TJ*TJ) CP(J)=T CM(J)=T ENDDO C RETURN END C C*********************************************************************** C SUBROUTINE HPSRTI(N,A,IP) C C----------------------------------------------------------------------- C C SR .HPSRTI CARRIES OUT AN IMPLICIT HEAPSORT BY *MAGNITUDE* C C INPUT: VECTOR A, LENGTH N. C OUTPUT: DOWN-ORDERED POINTER IN IP, A IS UNCHANGED. C (UP-ORDERED CAN BE OBTAINED BY CHANGING .LT. TO .GT. AS BELOW). C C IT IS CALLED BY: C C IT CALLS: C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C DIMENSION A(*),IP(*) C C----------------------------------------------------------------------- C DO I=1,N IP(I)=I ENDDO C IF(N.LT.2)GO TO 300 C L=N/2+1 IT=N C 100 IF(L.GT.1)THEN L=L-1 IPT=IP(L) ELSE IPT=IP(IT) IP(IT)=IP(1) IT=IT-1 IF(IT.EQ.1)THEN IP(1)=IPT GO TO 300 ENDIF ENDIF I=L J=L+L C 200 IF(J.LE.IT)THEN IF(J.LT.IT)THEN IF(abs(A(IP(J+1))).lt.abs(A(IP(J))))J=J+1 !.lt. down, .gt. up ENDIF IF(abs(A(IP(J))).lt.abs(A(IPT)))THEN !.lt. down, .gt. up IP(I)=IP(J) I=J J=J+J ELSE J=IT+1 ENDIF GO TO 200 ENDIF IP(I)=IPT GO TO 100 C C----------------------------------------------------------------------- C 300 RETURN C C----------------------------------------------------------------------- C END SUBROUTINE HPSRTI C C*********************************************************************** C REAL*8 FUNCTION QDT(QD,NZ0,NE,N,L,KAPPA) C C----------------------------------------------------------------------- C C NRB: 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 C KAPPA= 0 NON-RELATIVISTIC C =-1 KAPPA-AVERAGE RELATIVISTIC C = L RELATIVISTIC FOR J=L-0.5 C =-L-1 RELATIVISTIC FOR J=L+0.5 C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (ZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (QD0=0.182D0) PARAMETER (ALF2=5.325D-5) C COMMON /QDTS/QDTS(0:30),NQDT C IF(N.LE.0)THEN QD=ZERO QDT=ZERO RETURN ENDIF C TZ0=NZ0 NZ=NZ0-NE+1 TZ=NZ IF(L.LT.0.OR.NE.LE.1)THEN QD=ZERO ELSE IF(NQDT.GT.L)THEN QD=QDTS(L) ELSE TL=L**3+1 TE=NE QD=QD0*(TE**1.667D0-DONE)/(TZ0**0.667D0*TZ**0.333D0*TL) ENDIF ENDIF TN=N T3=TN*TN*TN TN=TN-QD C QDT=-(TZ/TN)**2 IF(KAPPA.EQ.0)RETURN C IF(KAPPA.EQ.-1)THEN ESO=ZERO ELSE IF(L.EQ.0)THEN WRITE(6,*)'*** FN.QDT ERROR: L=0 FOR KAPPA.NE.-1' ESO=ZERO ELSE ESO=ALF2*NZ**4*KAPPA/(T3*L*(L+1)*(2*L+1)) ENDIF ENDIF C IF(L.EQ.0)THEN ED=ALF2*NZ**4/T3 ELSE ED=ZERO ENDIF C EM=-ALF2*NZ**4*(4*N/(L+DONE/DTWO)-3)/(4*N*T3) C QDT=QDT+ESO+ED+EM C RETURN END