C N. R. BADNELL UoS v4.9 29/06/21 C C PROGRAM STGF C C CALCULATIONS FOR FREE ELECTRONS. C C RECENT MODIFICATIONS C NEW NAMELIST I/O C PERTURBING POTENTIALS REWORKED C QUADRUPOLE TOP-UP C DIPOLE TOP-UP CAN USE CBE C RADIATIVE DECAYS IN B.P. MODE C INFINITE ENERGY OMEGA'S (DIPOLE) C OCTUPOLE ETC. TOP-UP C OCTUPOLE ETC. PERTURBING POTENTIALS C DETAILED SQDT, WITH TYPE-I DAMPING, FOR DR/RE C DETAILED MQDT, WITH TYPE-I DAMPING, FOR DR/RE C NEUTRAL CASE ADDED C DARC DSTGH.DAT (AND H.DAT VIA DARC INTERFACE) C PARTITIONED H.DAT C C C PROGRAM MAIN C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MZKIL= 0) C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (MXOM=MZMEG*1000000+MZKIL*1000) PARAMETER (MXF=5) !(MZLMX+1)/2) C PARAMETER (ZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (THREE=3.0) PARAMETER (FOUR=4.0) PARAMETER (EINF=1.0D6) C LOGICAL QDT,WARN,WARNE,QJUMP,PQRD,BFORM C CHARACTER NAME*3,NUM(0:9)*1,PERT*3,ELAS*3,NAMKLS*7,PRINT*6 C SUN REAL*4 TARRY(2) C DIMENSION MSLP(MZSLP) C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1) COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X ,IPAR(MZTAR),NEWAR COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR) X ,IWD(MZTAR),IWT COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/CNTRLS/ISGPT,ITRMN,ITRMX COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2), X INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2), X MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF), X KTOPA(MXTST),KTOPB(MXTST),LRGLMN COMMON/CWARN/WARN COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) COMMON/MEMORY/OMEM(MXOM+1),MPOS(0:MZMSH),ITMAX,JTMAX COMMON/NRBCBE/RBE(MZCHF,MZCHF),LCBE COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET COMMON/NRBKUT/KUTPS,NCHOPT COMMON/NRBLMX/LMX COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF) COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBREC/LREC,IET(MZTAR) COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR) X ,OMST(MXTST),ITOP COMMON/NRBZED/TZED,LPRTSW COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT C NAMELIST/STGF/IPRINT,IRAD,IPERT,AC,RONE,IMESH,IOPT1,IRDEC,LRGLAM, 1 IPRKM,PERT,MINLT,MAXLT,ISKP0,LINC,NASTD,LCBE,ELAS,NOMWRT,IBETA, 2 IBIGE,LMX,KFLAG,IQDT,NDRMET,QETEST,NEWAR,IPRTSW,IOMSW,NCUTOFF,IEQ 3,IWARN,FNUMIN,ICCINT,INTPQ,ISGPT,ITRMN,ITRMX,FNUHYB,LPRTSW,ITOP 4,NTYP1,PRINT,IMODE,IDIP,IRD0,IJBIN,KUTPS C NAMELIST/MESH1/MXE,E0,EINCR,QNMAX,ABVTHR,BELTHR NAMELIST/MESH2/DQN,QNMAX,EMIN,EMAX,DEOPEN NAMELIST/MESH3/MXE,ABVTHR,BELTHR C DATA NUM /'0','1','2','3','4','5','6','7','8','9'/ C C WARN=.TRUE. WARNE=.TRUE. QJUMP=.FALSE. IWARN=999 C C CALL BLOCK DATA AS SUBROUTINE TO AVOID LINKAGE PROBLEMS C CALL BLOCK C C INITIALISE INDM C INDM=0 C C I/O UNITS C ********* C C 1 FOR OMEGA SCRATCH FILE (USED FOR IRAD.LT.2). C 2 RESERVED C 3 RESERVED C 4 RESERVED C 5 FOR PROGRAM CONTROL C 6 FOR PRINTED OUTPUT C 7 FOR VALUES OF OMEGA (USED FOR IRAD.LT.2). FILE OMEGA. C 8 FOR DIPOLE DATA INDEPENDENT OF SLPI. FILE F00. C 9 FOR DIPOLE DATA DEPENDENT ON SLPI. FILES F01 ETC. C 10 FOR INPUT R-MATRIX DATA. FILE H.DAT. C 11 RESERVED C 12 STGD DATA INDEPENDENT OF SLPI. FILE S00. C 13 STGD DATA DEPENDENT ONSLPI. FILES S01 ETC. C 14 FOR PARTIAL CROSS SECTIONS. FILE sigpw.dat C 17 FOR TERM INFORMATION FOR INPUT TO stgic. FILE term.dat. C 18 FOR VALUES OF DR OMEGA (USED FOR NDRMET.GT.0). FILE OMEGDR. C 19 FOR CHANNEL INFO FOR INPUT TO stgic. FILE jbinls. C 20 FOR REACTANCE MATRICES FOR DIFF XSCN. FILE KMAT.DAT. C 21 FOR KHI-MATRIX (=1-T) OUTPUT, MQDT OR JJOM FORMAT. FILE JBIN. C 22 FOR CASE DESCRIPTION AS REQUIRED BY JJOM. FILE JJDAT. C 23 RESERVED C 25 RESERVED C 27 RESERVED C 28 RESERVED C 29 RESERVED C 30 RESERVED C 31 FOR LINE STRENGTHS FOR INPUT TO stgicf. FILE strength.dat. C 32 FOR UNPHYSICAL K/S-MATRIX FOR stgicf. FILE k/smtls.001,002... C 33 RESERVED C 34 FOR EIGEN PHASE SUM. FILE ESUM. C 36 FOR UNPHYSICAL K-MATRIX. FILE kmatls. C 37 RESERVED C 38 RESERVED C C C OPEN(5,FILE='dstgf',STATUS='UNKNOWN') OPEN(6,FILE='routf',STATUS='UNKNOWN') C INQUIRE(FILE='H.DAT',EXIST=BFORM) IF(BFORM)THEN IWORD=1 OPEN(10,FILE='H.DAT',FORM='UNFORMATTED',STATUS='OLD') ELSE INQUIRE(FILE='DSTGH.DAT',EXIST=BFORM) IF(BFORM)THEN IWORD=2 OPEN(10,FILE='DSTGH.DAT',FORM='UNFORMATTED',STATUS='OLD') ELSE WRITE(6,*)'***ERROR: NO SUITABLE H.DAT FILE FOUND!' STOP '***ERROR: NO SUITABLE H.DAT FILE FOUND!' ENDIF ENDIF C C C WRITE NEWS C ********** C WRITE(6,6000) WRITE(6,6003) WRITE(6,6005) WRITE(6,6001) WRITE(6,6002)MZCHF,MZTAR,MZLMX,MZLP1,MZPTS,MZMSH,MZMNP, X MZSLP,MZTET,MZDEG,MZNRG,MZMET,MZREC,MZMEG C C C READ DATA FROM UNIT 5 C ********************* C C MQDT VARIABLES: C DEFAULTS: OFF - NON-MQDT OPERATION. C C IMODE -- CONTROLS READ/WRITE OF UNPHYSICAL MATRIX IN MQDT OPERATION. C = 0 WRITE THE UNPHYSICAL MATRIX TO FILE (JBIN) - DEFAULT. C THIS WOULD NORMALLY BE FOR A COARSE ENERGY MESH. C = 1 READ THE UNPHYSICAL MATRIX FROM FILE (JBIN). C SOLUTION ON A (NEWLY DEFINED) FINE ENERGY MESH OBTAINED SOLELY C BY INTERPOLATION OF THE PREVIOUS COARSE MESH DATA. C =-1 SINGLE PASS OPERATION. FULL SOLUTION ON A COARSE MESH. C INTERPOLATIVE SOLUTION ON A FINE MESH - SEE IEQ (NO JBIN). C IJBIN = 0 DEFAULT, DO NOT WRITE JBIN FOR IMODE=0. C IQDT = 0 NO MQDT EXCEPT GAILITIS VIA N.GT.QNMAX (I.E. QDT=.TRUE.) DEFAULT C IQDT =-1 PARALLEL QDT=.TRUE. OPERATION BUT **NOT** AVERAGED, SO DAMPING C STILL RESTRICTED TO RESONANCES CONVERGING TO LOWEST THRESHOLD. C IQDT = 1 FULL MQDT, ALL CHANNELS TREATED AS OPEN, USES UNPHYSICAL K/S-MX. C NOTE IQDT.GT.0 WILL INCLUDE DIPOLE PERTURBING POTENTIALS IF C I/PERT IS SET APPROPRIATELY. SEE ALSO IMODE. C = 2 WORK WITH UNPHYSICAL K-MX RATHER THAN S-MX. C IEQ -- CONTROLS HOW OFTEN THE UNPHYSICAL MATRIX IS UPDATED. C > 0 THEN UPDATED AT IEQ LINEARLY SPACED ENERGIES ACROSS THE TOTAL C ENERGY RANGE DEFINED BY THE INPUT ENERGY MESH. (IMODE=-1) C < 0 THEN UPDATED AT EVERY |IEQ|'TH POINT OF THE MESH, FINE FOR C CONSTANT STEP IN ENERGY, NOT SO GOOD (INEFFICIENT) FOR CONSTANT C STEP IN EFFECTIVE QUANTUM NUMBER. C DEFAULT = -1, THE K/S-MATRIX IS UPDATED AT EVERY ENERGY SO A C COARSE MESH SHOULD BE USED (IMODE=0). THEN RE-RUN WITH A FINE C ENERGY MESH (IMODE=1). C QETEST = 1.E-7 SCALED RYDBERGS (DEFAULT). THE K/S-MX IS ONLY RE-INTERPOLATED C WHEN ETOT HAS CHANGED BY MORE THAN QETEST SINCE THE LAST TIME. C GIVES A SMALL TIME SAVING WHEN USING A VERY FINE MESH E.G. 1.E-8. C SHOULD NOT NEED TO BE CHANGED. SHOULD BE SMALLER THAN COARSE STEP C FNUMIN= THE EFFECTIVE QUANTUM NUMBER BELOW WHICH THE CLOSED CHANNEL IS C OMITTED, USED BY IQDT=1,2 - DEFAULT=0. C FNUHYB= THE EFFECTIVE QUANTUM NUMBER BELOW WHICH THE CLOSED CHANNEL IS C THETA RATHER THAN S & C, USED BY IQDT=1,2 - DEFAULT=0. C C END MQDT SPECIFIC VARIABLES C C DAMPING VARIABLES: C DEFAULTS: EXCITATION DAMPING ON, DR/RR OFF. C C NTYP1 = 0 NO TYPE 1 (CORE) RADIATIVE DECAYS (DEFAULT). C > 0 INCLUDE TYPE 1 DECAY (AND SWITCHES ON IRDEC). C NDRMET= NUMBER OF INITIAL METASTABLE STATES FOR DR, DEFAULT=0. C NCUTOFF=MAX PRINCIPAL QUANTUM NUMBER FOR WHICH DR IS CALCULATED, C CASE OF IQDT.GT.0 ONLY. DEFAULT ALL (1000000). C C END DAMPING SPECIFIC VARIABLES C C C IPRINT = -2 FOR MINIMUM PRINT C = -1 OMEGAS PARTIAL IN BIG L AT EACH ENERGY C = 0 OMEGAS PARTIAL IN BIG L, AND TOTAL, AT EACH ENERGY C = 1 REACTANCE MX, OMEGAS PARTIAL IN SMALL AND BIG L..".. C = 2 DETAILS OF PERTURBING POTENTIALS. C = 3 FOR MAXIMUM PRINT (LARGE) C IRAD = 0 FOR NO RADIATIVE DATA ON UNIT 9 C = 1 FOR RADIATIVE DATA ON UNIT 9 C = 2 FOR RADIATIVE DATA ON UNIT 9 AND NO COLLISION STRENGTHS C IPERT = 0 FOR OMISSION OF LONG-RANGE MULTIPOLE POTENTIALS C = 1,2,3,4 FOR THEIR INCLUSION C 1 AND 2 OMIT LONG-RANGE POTENTIALS WHEN CLOSED- C CHANNEL RTWO EXCEEDS MESH. C 3 AND 4 DO NOT, THEY JUST NEGLECT CONTRIBUTION FROM C RTWO TO INFINITY INSTEAD. C 1 AND 3 PERTURB THE T-MATRIX, C 2 AND 4 PERTURB THE K-MATRIX (WHEN IPERT RESET C NEGATIVE INTERNALLY). C C AC = ACCURACY REQUIRED (1.E-5 DEFAULT) C RONE = DEBUG PARAMETER (NORMALLY TAKE RONE = 1.) C IMESH = 1 FOR FIXED INCREMENT IN ENERGIES C FOLLOWED BY C MXE, E0, EINCR FOR NUMBER OF ENERGIES, C FIRST ENERGY AND INCREMENT C OPTIONALLY SET QNMAX TO APPLY QDT (GAILITIS IN SQDT) C IMESH = 2 FOR FIXED INCREMENT IN EFFECTIVE QUANTUM C NUMBERS FOLLOWED BY C DQN, QNMAX, EMIN, EMAX, DEOPEN C DEFINED IN SUBROUTINE MESH C ********** SETS IPERT=0 FOR NU .GT. QNMAX (I.E. QDT USED) C C IMESH = 3 TO READ ENERGY MESH, FOLLOWED BY C MXE C (EMESH(M),M=1,MXE) C IMESH = -S TO CHOOSE MESH APROPRIATE FOR CASES WITH TOTAL C SPIN 2S+1 C FOLLOWED BY DATA AS FOR IMESH=2 C IOPT1 = 1 FOR ALL SLPI CASES C = 2 FOR SELECTED SLPI CASES FOLLOWED BY C IS, IL, IP FOR CASES SELECTED TERMINATING WITH C -1 -1 -1 C = -1 OR -2 AS ABOVE FOR + CASES BUT FIRST FOLLOWED BY C NASTD,(NLEV(N),N=1,NASTD) C = 10 FOR JAJOM, LS OMEGA WRITTEN C = 11 FOR JAJOM, NO OMEGA WRITTEN. C NASTD = NUMBER OF GROUPS (CAN BE READ DIRECTLY) C IWT DEFINES ENERGY WEIGHTING USED C = 0 MEAN C = 1 TERM (2S+1)*(2L+1) C =-1 LEVEL (2J+1) C IRDEC = 0 FOR NO RADIATIVE DECAYS (DEFAULT) C > 0 RADIATIVE DECAYS FOR EXCITATION (OPTIONAL) AND DR C (REQUIRED FOR NON-ZERO DR). C = 1 BELL AND SEATON C = 2 HICKMAN-ROBICHEAUX (MQDT ONLY, REVERTS TO =1 ELSE). C MINLT,MAXLT : IOPT1 IS SUBJECT TO SATSIFYING LRGL2.GE.MINLT AND C LRGL2.LE.MAXLT (LRGL2 = L OR 2*J). SEE ALSO LRGLAM. C LRGLAM= VALUE OF LRGL2 (TOTAL L, OR 2*J) TO APPLY TOP-UP AT. C SET .LT. 0 TO TURN-OFF TOP-UP (DEFAULT). C (SO TOP-UP IS NO LONGER CONTROLLED BY IPERT). C IN LS COUPLING, THIS IMPLIES MAXLT=LRGLAM SINCE WE HAVE C TOP-UP IN SMALL L AND LARGE L (MAXLT IS RESET IF NECESS). C IN B.P. MODE WE TOP-UP ONLY IN SMALL L SO HIGHER LRGL2'S C CAN BE PRESENT AND TOP-UP IN K/J IS TAKEN FROM THEM. C (IT IS NOT NECESS FOR MAXLT TO BE RESET THEN.) C OPTIMALLY, SET LRGLAM=2*MAX(J)-2. C IF IOPT1=2, JUST SET NON-NEGATIVE TO TURN ON TOP-UP C (PRECISE VALUE DETERMINED INTERNALLY FROM YOUR PARTIAL C WAVE LIST IS, IL, IP). THUS, NO J/K TOP-UP. C NOTE, IT IS NOW POSSIBLE TO TOP-UP WHILE NEGLECTING C THE LONG-RANGE MULTIPOLE POTENTIALS. C LCBE = VALUE OF LRGL2 FOR WHICH CBE OMEGA'S ARE CALCULATED, C DIPOLE TOP-UP IS THEN DONE WITH THE CBE OMEGA'S. C DEFAULT=999 IS RESET TO LRGLAM, SO SET NEGATIVE TO USE C CC OMEGAS IN DIPOLE TOP-UP (NOT RECOMMENDED). C ITOP = CONTROLS HOW NON-DIPOLE TOP-UP GOES OVER TO THE DEGENERATE C ENERGY CASE - SEE SR.TOP2 FOR DETAILS. C THE DEFAULT, =-1, SHOULD NOT NEED CHANGING. C ELAS ='NO' ELASTIC TRANSITIONS IN OMEGA FILE C ELAS ='YES' ELASTIC TRANSITIONS IN OMEGA FILE C IPRKM = 1 TO WRITE K-MATRIX ELEMENTS TO THE SEQUENTIAL FILE KMAT.DAT C FOR INPUT TO THE DIFFERENTIAL CROSS SECTION CODE C difls (LS) OR difjk (BP) C = 2 WRITE UNPHYSICAL K-MATRIX DATA TO kmatls. (TOM) C = 3 TO WRITE A SEQUENTIAL FILE pwflst, CONTAINING A LIST OF C PARTIAL WAVES AND ENERGIES AND A DIRECT ACCESS FILE rmabs, C CONTAINING THE K-MATRIX ELEMENTS. THESE FILES ARE USED FOR C INPUT TO THE PROGRAM pcrsx, WHICH GENERATES PARTIAL CROSS C SECTIONS OVER A RANGE OF ANGLES, AS WELL AS TOTAL CROSS C SECTIONS. ***NO LONGER OPERATIONAL - NRB*** C = 4 WRITE UNPHYSICAL K/S-MATRIX TO k/smtls.dat SO THAT IT CAN BE C READ BY stgicf/damp FOR THE CALCULATION OF INTERMEDIATE-COUPLING C COLLISION STRENGTHS. C = 5 ELASTIC PHYSICAL S-MATRIX FOR STGD DAMPING CONSTANT CODE. C = 0 NO WRITES (DEFAULT). C IRD0 >= 100, FOR IPRKM=4, WRITE LS K/S-MATRIX FILES BY SYMMETRY VIZ. C k/smtls.001, k/smtls.002 etc. C < 100, FOR IPRKM=4, WRITE A SINGLE LS K/S-MATRIX FILE k/smtls.dat. C DEFAULT: 105 C IDIP = 1 WRITE DIPOLE LINE STRENGTHS TO strength.dat. C = 0 NO WRITES. (DEFAULT: 0 IPRKM=0-3, 1 IPRKM=4,5) C ISKP0 = VALUE OF L/2J ABOVE WHICH OMEGA'S ARE FIRST TESTED TO SEE IF C HIGHER PARTIAL WAVES CAN BE NEGLECTED FOR A GIVEN ENERGY. C USEFUL FOR NX CODE FOR RANGING L=10-80 OVER E=~0 - 8 RY, C SAY, WHERE HIGH-L GIVES NEGLIGIBLE OMEGAS AT LOW-E, BUT C CAUSES NUMERICAL PROBLEMS NEVERTHELESS. C LINC = VALUE BY WHICH L/2J IS INCREMENTED; DEFAULT=1/2 AS CASE OF C AUTOMATIC GENERATION IN STG2 OR RECUP. USED WITH ISKP0. C NOMWRT= NUMBER OF ELEMENTS OF THE OMEGA ARRAY THAT ARE WRITTEN TO C AND READ FROM DIRECT ACCESS, AND THEN WRITTEN TO FILE OMEGA C IF .EQ. 0 NO OMEGAS ARE WRITTEN. C IF .NE. 0, THEN RESET FROM DEFAULT VALUE OF NAST*(NAST+/-1)/2 C .GT. 0, NOMWRT OMEGAS ARE WRITTEN ROW-WISE, INC ZEROES C -- EDIT OMEG TO DROP ZEROES (DEFAULT, ALL) C .LT. 0, -NOMWRT OMEGAS BETWEEN OPEN STATES ARE WRITTEN, C COLUMN-WISE. C IBETA > 0 THEN WRITE EXTRA STUFF TO STGBF FOR BETA PARAMETER. C IBIGE = 1 EVALUATE AN PRINT INFINITE ENERGY (ACTUALLY EINF*ZA**2 RY) C OMEGA. DIPOLE ONLY SO NO LONGER RECOMMENDED. C = 0 DO NOT (DEFAULT). C LMX = LARGEST PERTURBING MULTIPOLE INCLUDED WHEN IPERT=1/PERT=YES, C DEFAULT=2 I.E. DIPOLE AND QUADRUPOLE. NOTE, ONLY A SINGLE C MULTIPOLE POTENTIAL IS TREATED I.E. IF DIPOLE EXISTS THEN C THE OCTUPOLE IS NEGLECTED EVEN IF LMX=3. C ISGPT, ITRMN, ITRMX .NE. 0 THEN WRITE THE PARTIAL-WAVE CROSS SECTIONS C FROM TRANSITION ITRMN TO TRANSITION ITRMX AND ALSO THE SUM OF C THE THESE PARTIAL WAVE CROSS SECTIONS FOR EACH LSPI PARTIAL WAVE C TO THE FILE sigpw.dat C ABVTHR - DROP ENERGIES WITHIN ABVTHR (Z-SCALED RY) ABOVE A THRESHOLD C BELTHR - DROP ENERGIES WITHIN BELTHR (Z-SCALED RY) BELOW A THRESHOLD C APPLIES TO IMESH=1 ONLY. DEFAULT FOR IONS IS -1., -1. I.E. C NONE ARE DROPPED. DEFAULT FOR NEUTRALS IS 1.E-3, 1.E-3. C NOTE: BOTH MUST BE SET NON-NEGATIVE TO ACTIVATE EITHER ONE, C SO IF ONLY ONE IS TO BE RESTRICTIVE SET THE OTHER TO ZERO. C PRINT = 'FORM' THEN THE OMEGA FILE IS FORMATTED (DEFAULT). C 'UNFORM' THEN AN UNFORMATTED OMEGAU IS CREATED INSTEAD. C C C****OPTIONS BELOW ARE FOR EXPERIENCED USERS ONLY: C C NEWAR = 1 FORCES RECALCULATION OF ARDEC AT EVERY ENERGY KEEPING ONLY C FINAL STATES BELOW THE IONIZATION LIMIT (DEFAULT). C = 0 DOES NOT, AND SUMS OVER ALL ARAD - EXTREMELY DANGEROUS FOR DR C SINCE RADIATIVE TRANSITIONS TO AUTOIONIZING STATES ARE THEN C COUNTED AS RECOMBINED. THIS CAN LEAD TO A VERY LARGE OVER- C ESTIMATE OF THE DR CROSS SECTION. ***HOWEVER***, IF YOU ARE C INTERESTED IN (DAMPED) EXCITATION, THEN NEWAR=0 MIGHT BE C MORE APPROPRIATE. C IOMSW = 1 MQDT: OMIT CLOSED CHANNELS WITH N0 I.E. STGBF I/O) C = 0 ALLOW NEGATIVE IPERT, DEFAULT EXCEPT ABOVE CASE. C =-1 FORCE NEGATIVE IPERT. C LPRTSW= VALUE OF LRGL2 ABOVE WHICH NEGATIVE IPERT ALLOWED. C DEFAULT = -1 FOR IONS, I.E. ANY LRGL2 IN PRINCIPLE BUT THE C PRESENCE OF THE COULOMB POTENTIAL MEANS IN PRACTICE THAT C IPERT NEVER GOES NEGATIVE FOR THE LOWEST FEW L, EVEN WHEN E=0. C DEFAULT=5 FOR NEUTRALS, SINCE RINF SCALES AS 1/SQRT(E). C KFLAG = 0 REGENERATE K-QUANTUM NUMBER INTERNALLY, DO NOT ATTEMPT TO C READ IT FROM H.DAT (DEFAULT). C = 1 READ K-QUANTUM NUMBER FROM H.DAT, NOT WRITTEN BY STANDARD C INNER REGION CODES. SHOULD NOT BE NEEDED NOW. C ICCIN = 1 INCLUDE CLOSED-CLOSED PERTURBING INTEGRALS, MQDT & NON-MQDT C OPERATION - DEFAULT. C = 0 OMIT THEM. C INTPQ = 0 USE CORINT FOR CLOSED CHANNEL MQDT S,C INTEGRALS (DEFAULT). C = 1 USE THETA ETC TO GENERATE Q INTEGRALS. C C C INITIALIZE NAMELIST C C MQDT SPECIFIC VARIABLES (DEFAULTS: OFF) C IMODE=0 IQDT=0 IEQ=-1 !NEEDED FOR IMODE=-1 ONLY QETEST=1.E-7 !SHOULDN'T NEED CHANGING FNUMIN=2.5 !NOT REQUIRED FOR PRODUCTION WORK FNUHYB=-1.0 !NOT REQUIRED FOR PRODUCTION WORK C END C C DAMPING SPECIFIC VARIABLES (DEFAULTS: OFF) C NTYP1=0 NDRMET=0 NCUTOFF=1000000 !SHOULDN'T NEED CHANGING C END IPRINT=-2 IPRKM=0 IRAD=0 IPERT=0 PERT='NO' AC=1.0E-5 RONE=ONE IMESH=2 IOPT1=1 IRDEC=0 LRGLAM=-1 MINLT=-1 MAXLT=1000 ISKP0=-1 LINC=1 NASTD=0 IWT=-1 LCBE=999 ELAS=' ' NOMWRT=999999 IBETA=0 IBIGE=0 IDIP=-1 LMX=-1 ISGPT=0 ITRMN=0 ITRMX=0 ABVTHR=-1. BELTHR=-1. ITOP=-1 PRINT='FORM' IRD0=105 IJBIN=0 KUTPS=99999 C C DO NOT CHANGE NEXT 7 VARIABLES UNLESS YOU REALLY KNOW WHAT YOU ARE DOING. NEWAR=1 IOMSW=11 IPRTSW=0 LPRTSW=-1 KFLAG=0 ICCINT=1 INTPQ=0 C READ(5,STGF) C BFORM=PRINT.EQ.'FORM'.OR.PRINT.EQ.'form' IF(NTYP1.LT.0)NTYP1=0 IF(KFLAG.NE.0)KFLAG=1 C IF(IQDT.LE.0)THEN IOMSW=10 IMODE=0 ELSE IF(FNUHYB.GT.0)IOMSW=-IABS(IOMSW) !SO USE 10 RATHER THAN 0 ENDIF IF(IQDT.EQ.0)INTPQ=0 IF(IRAD.GT.0.OR.IOMSW.LT.0)INTPQ=0 !FOR NOW IF(IWARN.EQ.999)THEN IF(IQDT.LE.0)IWARN=0 IF(IQDT.GT.0)IWARN=1 ENDIF IF(IMODE.GE.0.OR.IQDT.LE.0)IEQ=-1 IF(IEQ.EQ.0)IEQ=-1 IF(IEQ.EQ.1)IEQ=2 IF(IMODE.LT.0.AND.IEQ.EQ.-1)IMODE=0 !SINCE NO INTERP IQDT0=IQDT IQDT=IQDT/100 IF(IQDT.EQ.0)IQDT=IQDT0 IF(IMODE.EQ.0)IQDT0=100*IQDT !WRITE JBIN IF(IMODE.NE.0)IQDT0=IQDT !MAY READ JBIN IF(NTYP1.GT.0.AND.IRDEC.EQ.0)THEN IF(IQDT.LE.0)THEN IRDEC=1 ELSE IRDEC=2 ENDIF ENDIF IF(IRDEC.GT.0.AND.IQDT.EQ.2)THEN !STGF ONLY WRITE(6,*)' ***ERROR: NO RADIATION DAMPING WITH UNPHYSICAL K-MX' X, '. USE IQDT=1 OR RUN STGFDAMP INSTEAD' STOP 'RESET IQDT=1 FOR IRDEC .GT. 0' ENDIF C IF(IPRKM.NE.0.AND.IMODE.LT.0)THEN WRITE(6,*)' *** ERROR: SET IPRKM=0 FOR INTERPOLATION, IMODE=-1' STOP ' *** ERROR: SET IPRKM=0 FOR INTERPOLATION, IMODE=-1' ENDIF IF(IPRKM.EQ.2.AND.IQDT.NE.2)IPRKM=0 IF(IPRKM.EQ.5.AND.IQDT.NE.0)THEN WRITE(6,*)' *** ERROR: SET IQDT=0 FOR OUTPUT OF S-MX FOR STGD' STOP ' *** ERROR: SET IQDT=0 FOR OUTPUT OF S-MX FOR STGD' ENDIF IF(ISKP0.LE.0)THEN IF(IPRKM.EQ.0.AND.IQDT.LE.0)THEN ISKP0=10 ELSE ISKP0=15 ENDIF ENDIF C PQRD=IQDT0.GT.0.AND.IQDT0.LT.100.OR.ABS(IEQ).NE.1 IF(QETEST.LE.ZERO)QETEST=1.E-10 IF(IPRTSW.EQ.0.AND.IRAD.GT.0)IPRTSW=1 IF(NDRMET.GT.0.AND.ELAS.NE.'YES')THEN WRITE(6,609) ELAS='YES' !ENSURE ELASTIC PRESENT FOR DR ENDIF IONE=1 IF(ELAS.EQ.'YES')IONE=0 IF(LMX.LT.0)LMX=2 IF(IBIGE.NE.0)IBIGE=1 IF(MAXLT.LT.0)MAXLT=1000 INSKP=1000 IF(MINLT.GT.ISKP0)INSKP=MINLT+1 COLD IF(LRGLAM.GE.0.AND.MAXLT.NE.1000)LRGLAM=MAXLT ! ALLOW BP J/K TOP LCBE=MIN(LCBE,LRGLAM-1) IF(LRGLAM.GE.0.AND.LCBE.LT.0)WRITE(6,698) IF(ITOP.NE.-2)ITOP=-1 C IF(NDRMET.GT.MZMET)THEN WRITE(6,*)' ***DIMENSION ERROR, NDRMET=',NDRMET,' >MZMET',MZMET STOP ENDIF C C ADJUST IPERT, NPERT=1 DO NOT SWITCH-OFF PERTURBATION. C IF(PERT.EQ.'YES')THEN IF(NDRMET.LE.0)IPERT=4 !ALWAYS USE K-MX PERT IF(NDRMET.GT.0)IPERT=4 ENDIF IF(IQDT.LT.0)IPERT=0 !NO PERT HERE COLD IF(IRAD.GT.0.AND.IPERT.GT.2)IPERT=IPERT-2 COLD IF(IQDT*IRDEC*IRAD.NE.0)IPERT=0 !NOT IN STGBF YET CNEW: DO NOT SWITCH-OFF AS STGBF JUST DROPS THE RTWO TO INFINITY INTEGRAL, CNEW FOR NOW, BUT WILL AT SOME POINT DO THE LONG-RANGE INTEGRALS AS IN ALPHAQ. C NPERT=0 IF(IABS(IPERT).GT.2)THEN NPERT=1 I2=ISIGN(2,IPERT) IPERT=IPERT-I2 ENDIF IPERTR=IPERT C IF(ISGPT.NE.0)OPEN(14,FILE='sigpw.dat',STATUS='UNKNOWN') IF(IPRKM.EQ.1)OPEN(20,FILE='KMAT.DAT',STATUS='UNKNOWN') IF(IPRKM.EQ.5)THEN IDIP=1 IF(NOMWRT.EQ.0)NOMWRT=-1 IF(NOMWRT.GT.0)THEN WRITE(6,*)'*** WARNING: RE-SETTING NOMWRT.LT.0 FOR IPRKM=5' NOMWRT=-99999 ENDIF ENDIF IF(IPRKM.EQ.4)THEN IF(IDIP.LT.0)IDIP=1 OPEN(19,FILE='jbinls',FORM='UNFORMATTED',STATUS='UNKNOWN') IF(IRD0.LT.100)THEN IF(IQDT.EQ.1)THEN OPEN(32,FILE='smtls.dat',FORM='UNFORMATTED' X ,STATUS='UNKNOWN') ELSE OPEN(32,FILE='kmtls.dat',FORM='UNFORMATTED' x ,STATUS='UNKNOWN') ENDIF ENDIF ENDIF C C SELECT TYPE OF ENERGY MESH C QNMAX=-ONE C IF(IMESH.EQ.1)THEN C C CASE OF IMESH = 1 C MXE=1 E0=ONE EINCR=ZERO C READ(5,MESH1) C IF(MXE.GT.MZMSH)THEN WRITE(6,699)MXE STOP ENDIF C IF(IMODE.LE.0)QETEST=MIN(QETEST,ABS(IEQ)*EINCR/2) C E=E0-EINCR DO I=1,MXE E=E+EINCR EMESH(I)=E ENDDO C ELSE IF (IMESH.EQ.2.OR.IMESH.LT.0) THEN C C CASE OF IMESH = 2 OR = -S C DEOPEN=AC C READ(5,MESH2) C ELSE IF(IMESH.EQ.3) THEN C C CASE OF IMESH = 3 C READ(5,MESH3) C EINCR=ONE READ(5,*)EMESH(1) DO M=2,MXE READ(5,*)EMESH(M) EINCR=MIN(EINCR,EMESH(M)-EMESH(M-1)) ENDDO C IMESH=1 IF(IMODE.LE.0)QETEST=MIN(QETEST,ABS(IEQ)*EINCR/2) C ENDIF C C ISP=0 IF (IMESH.LT.0) ISP=ABS(IMESH) C C SELECT IOPT1 C IF(NASTD.GT.0)IOPT1=-ABS(IOPT1) C C CASE OF IOPT1 NEGATIVE C IF (IOPT1.LT.0) THEN IOPT1=-IOPT1 IF(NASTD.EQ.0)READ(5,*)NASTD IF(NASTD.GT.MZTAR)THEN WRITE(6,697)NASTD STOP END IF READ(5,*)(NLEV(N),N=1,NASTD) WRITE(6,6021)NASTD,(NLEV(N),N=1,NASTD) END IF C C CASE OF IOPT1 FOR JAJOM C IF (IOPT1.GE.10.OR.IQDT.GT.0) THEN C OPEN K-/S-MATRIX OUTPUT FILE FOR MQDT. IF(IMODE.EQ.0.AND.IJBIN.NE.0) X OPEN(21,FILE='JBIN',STATUS='UNKNOWN',FORM='UNFORMATTED') C OPEN K-/S-MATRIX INPUT FILE FOR MQDT. IF(IMODE.GT.0) X OPEN(21,FILE='JBIN',STATUS='OLD',FORM='UNFORMATTED') C IF(IOPT1.GE.10.AND.IRAD.NE.0) THEN WRITE(6,*)' IRAD SET ZERO BECAUSE IOPT1.GE.10' IRAD=0 ENDIF ENDIF C C CASE OF IOPT1 = 2 C IF(IOPT1.EQ.2) THEN WRITE(6,602) KSLP=0 IF(LRGLAM.GE.0)LRGLAM=0 C 10 READ(5,*,END=3999)IS,IL,IP C IF(LRGLAM.GE.0)LRGLAM=MAX(IL,LRGLAM) IF(IS.NE.999.AND.IL.NE.-1)THEN KSLP=KSLP+1 ISLP=10000*IABS(IS)+100*IL+IP IF(IS.LT.0)ISLP=-ISLP MSLP(KSLP)=ISLP WRITE(6,603)ISLP IF (ISP .GT. 0) THEN IF (ISP .NE. IABS(IS)) THEN WRITE(6,'('' SPIN FOR THIS CASE .NE. IMESH'')') STOP END IF END IF GOTO 10 ENDIF C IF(KSLP.EQ.0)THEN WRITE(6,600) STOP ENDIF C IF(KSLP.GT.MZSLP)THEN WRITE(6,605)KSLP STOP ENDIF C ENDIF C C 3999 WRITE(6,601)IPRINT,IRAD,IPERT,LMX,AC,IMESH,IOPT1,IRDEC,IMODE,IQDT X ,IEQ,IOMSW,NCUTOFF,FNUMIN,FNUHYB,NDRMET,NTYP1 C C C RADIATIVE TRANSITION PROBABILITIES C ********************************** C IF(IRDEC.GT.0.OR.IBIGE.EQ.1.OR.IRAD.GT.0.OR.IDIP.GT.0)THEN C CALL READ1 C IF(ELAS.EQ.' ')THEN IF(NZED.EQ.NELC)ELAS='YES' IF(NZED.NE.NELC)ELAS='NO' ENDIF IONE=1 IF(ELAS.EQ.'YES')IONE=0 C DO I=1,NAST IPAR(I)=-1 ENDDO KMAX=(NAST*(NAST-2*IONE+1))/2 DO K=1,KMAX ARAD(K)=-ONE ENDDO C C TWIDDLE: NRB NASTR=NAST NASTDO=NASTD NASTD=0 C 6 CALL READ2(IOPT1) C CALL RAD C IF(IEND.EQ.0)THEN IF(MORE2.GT.0)THEN GOTO 6 ELSE WRITE(6,606) K=0 DO I=1+IONE,NAST DO J=1,I-IONE K=K+1 IF(ARAD(K).LT.ZERO)THEN WRITE(6,*)J,I,ARAD(K) ARAD(K)=ZERO ENDIF ENDDO ENDDO ENDIF ENDIF C C RESTORE: NRB NASTD=NASTDO C REWIND 10 C ENDIF C C START MAIN CALCULATIONS C *********************** C WRITE(6,604) C CALL ACSUB C C READ R-MATRIX DATA FOR TARGET C CALL READ1 C IF(ELAS.EQ.' ')THEN IF(NZED.EQ.NELC)ELAS='YES' IF(NZED.NE.NELC)ELAS='NO' ENDIF IONE=1 IF(ELAS.EQ.'YES')IONE=0 C IF(LPRTSW.LT.0.AND.(NZED.EQ.NELC.OR.IQDT.GT.0))THEN LPRTSW=5 IF(NSPN2.EQ.0)LPRTSW=2*LPRTSW+1 ENDIF C CALL SCALE1(IOPT1) C IF(NZED.EQ.NELC)THEN TZED=ZERO IF(ABVTHR.LT.0.)ABVTHR=1.E-3 IF(BELTHR.LT.0.)BELTHR=1.E-3 ELSE TZED=ONE ENDIF C C SET-UP ENERGY MESH C IF(IMESH.EQ.1) CALL PRUNE(ABVTHR,BELTHR) IF(IMESH.EQ.2 .OR. IMESH.LT.0) CALL MESH C C WRITE PRELIMINARY INFORMATION TO INPUT FILE FOR STGICF C IF(IPRKM.EQ.4)THEN WRITE(19) MXE,NZED,NELC WRITE(19) (EMESH(IE),IE=1,MXE) ENDIF C C DECIDE WHEN TO UPDATE UNPHYSICAL K/S-MATRIX C IF(IQDT.GT.0)THEN IF(IMESH.EQ.1.OR.IEQ.LT.0)THEN IF(IEQ.LT.0)THEN IEQ=-IEQ IEQ0=IEQ ELSE IEQ0=MXE/(IEQ-1) IF(IEQ0.EQ.0)IEQ0=1 ENDIF DO IE=1,MXE IEE(IE)=0 IF(MOD(IE-1,IEQ0).EQ.0)IEE(IE)=IE ENDDO IEE(MXE)=MXE ELSE DEQ=(EMAX-EMIN)/(IEQ-1) EQ=EMIN DO IE=1,MXE IF(EMESH(IE).GE.EQ)THEN IEE(IE)=IE EQ=EQ+DEQ ELSE IEE(IE)=0 ENDIF ENDDO ENDIF ENDIF C C INITIAL WRITES TO UNIT 8 (FOR STGBF, STGFF) C IF(IRAD.GT.0)THEN H=ACNUM KP2=4*((MZPTS-1)/4)+1 RTWO=(KP2-1)*H+RZERO RTWOC=RTWO KP2C=KP2 IPERTW=IPERT IF(IPERT.GT.0)IPERTW=1 C CALL BODE(H,KP2,IPERT,RZERO) C OPEN(8,FILE='F00',STATUS='UNKNOWN',FORM='UNFORMATTED') C REWIND(8) WRITE(8)NZED,NELC WRITE(8)NAST,(ENAT(I),I=1,NAST),(ISAT(I),LAT(I),I=1,NAST) X ,(ARDEC(I),I=1,NAST) WRITE(8)KP2 WRITE(8)RZERO,H WRITE(8)(WBODE(I),I=1,KP2) WRITE(8)IPERTW,IQDT IF(IQDT.GT.0)THEN MXE0=0 DO IE=1,MXE IF(IEE(IE).NE.0)THEN MXE0=MXE0+1 OMEGDR(1,MXE0)=EMESH(IE) ENDIF ENDDO WRITE(8)MXE0 WRITE(8)(OMEGDR(1,I),I=1,MXE0) ELSE WRITE(8)MXE WRITE(8)(EMESH(I),I=1,MXE) ENDIF WRITE(8)BSTO ENDIF C C INITIAL WRITES TO UNIT 12 (FOR STGD) C IF(IPRKM.EQ.5)THEN OPEN(12,FILE='S00',STATUS='UNKNOWN',FORM='UNFORMATTED') REWIND(12) WRITE(12)NZED,NELC,NAST,IONE AZ=MAX(NZED-NELC,1) CONS=THREE/(LOG(EINF*AZ**2)*FOUR) WRITE(12)(ENAT(I),I=1,NAST),(ISAT(I),LAT(I),I=1,NAST) X ,(CONS*ABS(SLIN(I)),I=1,((NAST-IONE)*(NAST+1+IONE))/2) WRITE(12)MXE WRITE(12)(EMESH(I),I=1,MXE) C SET-UP CONTROL FOR DIRECT ACCESS UNIT 13 FILES, ONE PER SLP LREC=0 DO I=1,NAST LREC=MAX(LREC,IABS(LAT(I))) ENDDO LREC=MZREC*(LREC+1)*(LREC+2) DO IT=1,NAST DO IE=1,MXE IF(EMESH(IE).GE.ENAT(IT))THEN IET(IT)=IE !FIRST OPEN CHANNEL E FOR TARGET GO TO 913 ENDIF ENDDO GO TO 915 913 ENDDO 915 CONTINUE ENDIF C C START CALCULATION OF OMEGAS C C INITIALISE OMEGAS TO ZERO C IF(IRAD.LT.2)THEN C IF(NOMWRT.EQ.0)THEN WRITE(6,*) WRITE(6,*)' *** OMEGA FILE IS NOT WRITTEN IN THIS CASE ***' NOMT=0 ELSE NOMT0=(NAST*(NAST+1-2*IONE))/2 NOMT=MIN(NOMT0,ABS(NOMWRT)) IF(NOMWRT.LT.0)NOMT=-NOMT NOMWRT=NOMT C CALL OMEG(0,EMESH,MXE,ENAT,NAST,OMEGA,NOMWRT,IONE) C IF(NDRMET.GT.0)THEN DO I=1,MXE DO J=1,NDRMET OMEGDR(J,I)=ZERO ENDDO ENDDO ENDIF ENDIF C DO IE=1,MXE ISKP(IE)=INSKP ENDDO INSKP=-INSKP C ENDIF C C START LOOP ON SLPI CASES C ************************ C KASE=1 DO I=1,NAST IPAR(I)=-1 ENDDO C C READ R-MATRIX DATA FOR NEXT SLPI CASE C ************************************* C 1000 CALL READ2(IOPT1) C C TERMINATE IF EOF ON H.DAT C IF(MORE2.EQ.-777)GO TO 3000 C IF(INSKP.LT.0.AND.NSPN2.EQ.0)THEN IF(ISKP0.EQ.15.OR.ISKP0.EQ.10)ISKP0=2*ISKP0+MOD(LRGL2,2) IF(MINLT.GT.ISKP0)THEN INSKP=MINLT+2 ELSE INSKP=1000 ENDIF DO IE=1,MXE ISKP(IE)=INSKP ENDDO ELSE INSKP=IABS(INSKP) ENDIF C ISLP=10000*IABS(NSPN2)+100*LRGL2+NPTY2 IF(NSPN2.LT.0)ISLP=-ISLP IF(LRGLAM.GE.0)THEN IF(NSPN2.NE.0)MAXLT=MIN(LRGLAM,MAXLT) !FOR FTOP IF(NSPN2.EQ.0)MAXLT=MIN(LRGLAM+2,MAXLT) ENDIF IF(LRGL2.LT.MINLT.OR.LRGL2.GT.MAXLT)THEN IF(MORE2.NE.0)GO TO 1000 GO TO 3000 ENDIF C C FOR IOPT1=2, CHECK WHETHER REQUIRED VALUE OF SLPI HAS BEEN FOUND C IF(IOPT1.EQ.2)THEN DO 30 K=KASE,KSLP IF(ISLP.NE.MSLP(K))GOTO 30 KK=K GOTO 40 30 CONTINUE C C CASE NOT FOUND C GOTO 2000 C C CASE FOUND C RE-ORDER STORED UNIT 5 DATA C 40 IF(KK.NE.KASE)MSLP(KK)=MSLP(KASE) C ENDIF C C C SCALE R-MATRIX DATA FOR SLPI CASE C ********************************* C IPERT=IPERTR C CALL SCALE2 C IF(LRGLAM.GE.0)CALL TOP1(LRGLAM) C IFLAG=IWARN !LIMIT WARNING MESSAGES IFLEG=IWARN !LIMIT WARNING MESSAGES C IF(IPERT.EQ.0)WRITE(6,641) IF(IPRINT.GT.0.AND.IRAD.NE.2) WRITE(6,640) C IF(IRAD.NE.0.AND.IOPT1.LE.9) THEN WRITE(8)NSPN2,LRGL2,NPTY2 NAME='F'//NUM(KASE/10)//NUM(KASE-10*(KASE/10)) OPEN(9,FILE=NAME,STATUS='UNKNOWN',FORM='UNFORMATTED') REWIND(9) WRITE(9)NSPN2,LRGL2,NPTY2 WRITE(9)MNP2,NCHF WRITE(9)(ECH(I),I=1,NCHF) IF(IBETA.EQ.0.AND.NSPN2.NE.0)THEN WRITE(9)(CC(I),I=1,NCHF) ELSE WRITE(9)(CC(I),I=1,NCHF) X ,(L2P(I),I=1,NCHF),(LAT(ITARG(I)),I=1,NCHF) Y ,(ITARG(I),I=1,NCHF),(KJ(I),I=1,NCHF) ENDIF WRITE(9)(VALUE(I),I=1,MNP2) WRITE(9)((WMAT(J,I),J=1,MNP2),I=1,NCHF) IF(IPERT.GT.0)WRITE(9)(((CF(I,J,L),I=1,NCHF),J=1,NCHF),L=1,2) ENDIF C IF(IPRKM.EQ.5)THEN WRITE(12)NSPN2,LRGL2,NPTY2 NAME='S'//NUM(KASE/10)//NUM(KASE-10*(KASE/10)) OPEN(13,FILE=NAME,STATUS='UNKNOWN',ACCESS='DIRECT',RECL=LREC) if((nast+1).gt.2*lrec/mzrec)stop 'record length too long' WRITE(13,REC=1)(NCONAT(I),I=1,NAST),NCHF if(2*nchf.gt.2*lrec/mzrec)stop 'record length too long' WRITE(13,REC=2)(L2P(I),I=1,NCHF),(KJ(I),I=1,NCHF) ENDIF C C INITIALIZE JAJOM DATA FOR UNIT 22 (KAB,JAN94) C IF(IOPT1.GE.10) CALL OUTJJ(0,LRGLAM,MXE) C C WRITE UNPHYSICAL K-MATRIX DATA C IF(IPRKM.EQ.2.AND..NOT.PQRD)THEN NAMKLS='kmatls'//NUM(KASE) OPEN(36,FILE=NAMKLS,FORM='UNFORMATTED',STATUS='UNKNOWN') WRITE(36)NSPN2,LRGL2,NPTY2 WRITE(36)NAST DO I=1,NAST WRITE(36)I,ISAT(I),LAT(I),ENAT(I) ENDDO WRITE(36)NCHF DO I=1,NCHF WRITE(36)I,ITARG(I),LLCH(I),KJ(I),ECH(I) ENDDO WRITE(36)MXE ENDIF IF(IPRKM.EQ.4.AND..NOT.PQRD)THEN WRITE(19)NCHF,NSPN2,LRGL2,NPTY2 DO I=1,NCHF WRITE(19)ITARG(I),LLCH(I) ENDDO IF(IRD0.GE.100)THEN K1=KASE/100 K2=(KASE-100*K1)/10 K3=KASE-100*K1-10*K2 NAME=NUM(K1)//NUM(K2)//NUM(K3) IF(IQDT.EQ.1)THEN OPEN(32,FILE='smtls.'//NAME,FORM='UNFORMATTED' X ,STATUS='UNKNOWN') ELSE OPEN(32,FILE='kmtls.'//NAME,FORM='UNFORMATTED' X ,STATUS='UNKNOWN') ENDIF ENDIF ENDIF C C C START ENERGY LOOP C ***************** C EQSAVE=-999999. C C SEE IF ANY PQ DATA EXISTS TO BE READ C ETOT=EMESH(1) IF(PQRD)CALL READPQ(0,QETEST,ISLP,IOPT1,QJUMP,PQRD) C DO 50 IE=1,MXE C IF(IRAD.LT.2.AND.LRGL2.GT.ISKP(IE).AND.IPRKM.LE.0)GO TO 50 IPERT=IPERTR ETOT=EMESH(IE) IF(WARNE)THEN IF(IPRCENT.EQ.100)THEN IF(ETOT.GT..5*VALUE(1))THEN WRITE(6,690)ETOT,.5*VALUE(1) WARNE=.FALSE. ENDIF ELSE IF(ETOT.GT.0.5*TRACE)THEN !EZERO WRITE(6,691)ETOT,0.5*TRACE WARNE=.FALSE. ENDIF ENDIF ENDIF IF(IPRINT.GT.0)WRITE(6,680)ETOT C C IN IQDT MODE SEE IF WE NEED TO UPDATE C IF(IQDT.GT.0)THEN IF(PQRD)THEN IF(ETOT-EQSAVE.GT.QETEST)THEN CALL READPQ(IE,QETEST,ISLP,IOPT1,QJUMP,PQRD) EQSAVE=ETOT ENDIF ELSE QJUMP=IEE(IE).EQ.0 ENDIF ENDIF C CALL POINTS(IOPT1,QJUMP) C C C CALCULATE OMEGAS C CALL REACT(IOPT1,QJUMP,PQRD) C C C SUPRESS ANY MORE WARNING MESSAGES FOR CURRENT SYMMETRY C IFLAG=ABS(IFLAG) IFLEG=ABS(IFLEG) C 50 CONTINUE C IF(IRAD.NE.0)CLOSE(9,STATUS='KEEP') IF(.NOT.PQRD)THEN IF(IPRKM.EQ.4.AND.IRD0.GE.100)CLOSE(32,STATUS='KEEP') IF(IPRKM.EQ.2)CLOSE(36,STATUS='KEEP') ENDIF C IF(IOPT1.EQ.2)THEN IF(KASE.EQ.KSLP)GOTO 3000 KASE=KASE+1 ENDIF C C END OF ENERGY LOOP, GO TO NEXT SLPI CASE C ****************** C 2000 IF(IOPT1.EQ.1)THEN IF(MORE2.NE.0)THEN KASE=KASE+1 GOTO 1000 ENDIF GOTO 3000 ENDIF C C CASE OF IOPT1=2 C IF(MORE2.NE.0)GOTO 1000 IF(IOPT1.EQ.2)THEN C C CASES NOT FOUND ON UNIT 10 C WRITE(6,660) DO K=KASE,KSLP WRITE(6,661)MSLP(K) ENDDO WRITE(6,662) ENDIF C C END OF SLPI LOOP C **************** C C C PRINT TOTAL OMEGAS C ****************** C 3000 IF(IRAD.EQ.2) GOTO 3200 C IF(IOPT1.GE.10)THEN CALL OUTJJ(IOPT1,LRGLAM,MXE) CLOSE(11,STATUS='KEEP') ENDIF C IF(IOPT1.NE.11)THEN C IF(NSPN2.EQ.0)THEN C IF(NASTD.GT.0.AND.IWT.GE.0)WRITE(6,763) C DO I=1,NAST IF(NASTD.GT.0)LAT(I)=IWD(I) LAT(I)=LAT(I)+1 LAT(I)=LAT(I)*(-1)**ISAT(I) ISAT(I)=0 ENDDO ELSE C C CHECK COMPLETENESS OF PARITY DO I=1,NAST IF(IPAR(I).LT.0)WRITE(6,675)I ISAT(I)=ISAT(I)*(-1)**IPAR(I) ENDDO IF(NASTD.GT.0.AND.IWT.LE.0)WRITE(6,763) ENDIF C C WRITE TERM INFORMATION FOR USE BY STGICF C IF(IPRKM.EQ.4)THEN OPEN(17,FILE='term.dat',FORM='FORMATTED',STATUS='UNKNOWN') WRITE(17,'(I5)') NAST AZ=MAX(NZED-NELC,1) AZSQ=AZ*AZ DO ITT=1,NAST ERYD=AZSQ*ENAT(ITT) WRITE(17,'(3I5,F16.7)') ABS(ISAT(ITT)),LAT(ITT),IPAR(ITT) X ,ERYD ENDDO CLOSE(17,STATUS='KEEP') ENDIF C C WRITE COLLISION STRENGTH OMEGA C IF(NOMWRT.NE.0)THEN IF(BFORM)THEN OPEN(7,FILE='OMEGA',STATUS='UNKNOWN') REWIND(7) WRITE(7,*)NZED,NELC IF(IPRINT.GT.-1)WRITE(6,650) WRITE(7,*)NAST,MXE+IBIGE,NOMWRT WRITE(7,*)(ISAT(I),LAT(I),I=1,NAST) WRITE(7,710)(ENAT(I),I=1,NAST) IF(NOMWRT.LT.0)THEN !GET ROUNDED ENERGIES NREC=1+(NAST-1)/5 DO N=1,NREC BACKSPACE(7) ENDDO READ(7,710)(ENATR(I),I=1,NAST) ENDIF ELSE OPEN(7,FILE='OMEGAU',STATUS='UNKNOWN',FORM='UNFORMATTED') REWIND(7) WRITE(7)NZED,NELC IF(IPRINT.GT.-1)WRITE(6,650) WRITE(7)NAST,MXE+IBIGE,NOMWRT WRITE(7)(ISAT(I),LAT(I),I=1,NAST) WRITE(7)(ENAT(I),I=1,NAST) ENDIF C IF(NOMWRT.LT.0)THEN NTAROP=1 NTAROR=1 ENDIF DO IE=1,MXE C IF(NOMWRT.GT.0)THEN NOMT=NOMWRT ELSE DO IT=NTAROP,NAST IF(EMESH(IE).LT.ENAT(IT))GO TO 31 ENDDO IT=NAST+1 31 NTAROP=IT-1 NOMT=(NTAROP*(NTAROP-2*IONE+1))/2 NOMT=MIN(NOMT,-NOMWRT) NOMT=-NOMT ENDIF C CALL OMEG(IE,EMESH,MXE,ENAT,NAST,OMEGA,NOMT,IONE) C NOMT=ABS(NOMT) IF(IPRINT.GT.-1)WRITE(6,701)EMESH(IE),(OMEGA(N),N=1,NOMT) IF(.NOT.BFORM)WRITE(7)EMESH(IE),(OMEGA(N),N=1,NOMT) IF(BFORM)THEN IF(NOMWRT.LT.0)THEN !GET NOMT CONSISTENT WITH ENATR WRITE(7,700)EMESH(IE) BACKSPACE(7) READ(7,700)E BACKSPACE(7) DO IT=NTAROR,NAST IF(E.LT.ENATR(IT))GO TO 32 ENDDO IT=NAST+1 32 NTAROR=IT-1 NOMTR=(NTAROR*(NTAROR-2*IONE+1))/2 NOMTR=MIN(NOMTR,-NOMWRT) IF(NOMTR.GT.NOMT)THEN DO N=NOMT+1,NOMTR OMEGA(N)=0.0 ENDDO ENDIF NOMT=NOMTR ENDIF WRITE(7,700)EMESH(IE),(OMEGA(N),N=1,NOMT) ENDIF ENDDO C C WRITE INFINITE ENERGY OMEGA (WELL EINF Z-SCALED RYDBERGS). C CURRENTLY, DIPOLE ONLY, BUT LS AND IC. C NOMT=ABS(NOMWRT) IF(IBIGE.EQ.1)THEN IF(BFORM)WRITE(7,700)EINF,(ABS(SLIN(N)),N=1,NOMT) IF(.NOT.BFORM)WRITE(7)EINF,(ABS(SLIN(N)),N=1,NOMT) ENDIF C CLOSE(7,STATUS='KEEP') IF(BFORM)WRITE(6,695) IF(.NOT.BFORM)WRITE(6,694) IF(ELAS.EQ.'YES')WRITE(6,609) C ENDIF C C WRITE THE LINE STRENGTHS FOR INPUT TO STGICF - NOTE THE SIGN OF C SLIN IS THE SIGN OF THE DIPOLE TRANSITION MATRIX ELEMENT C IF(IDIP.GT.0)THEN OPEN(31,FILE='strength.dat',FORM='FORMATTED' X ,STATUS='UNKNOWN') WRITE(31,'(2(I5))') NAST,SIGN(NOMT0,NOMWRT) AZ=MAX(NZED-NELC,1) CONS=THREE/(LOG(EINF*AZ**2)*FOUR) WRITE(31,'(6(1PE12.5))') (CONS*SLIN(N),N=1,NOMT0) CLOSE(31,STATUS='KEEP') ENDIF C C TERMINATOR C IF(IPRKM.EQ.4)THEN WRITE(19)-1,-1,-1,-1 CLOSE(19,STATUS='KEEP') IF(IRD0.LT.100)CLOSE(32,STATUS='KEEP') END IF C C WRITE OMEGDR C IF(NDRMET.GT.0)THEN OPEN(18,FILE='OMEGDR',STATUS='UNKNOWN') REWIND(18) WRITE(18,*)NZED,NELC WRITE(18,*)NAST,MXE,NDRMET WRITE(18,*)(ISAT(I),LAT(I),I=1,NAST) WRITE(18,710)(ENAT(I),I=1,NAST) DO IE=1,MXE WRITE(18,700)EMESH(IE),(OMEGDR(J,IE),J=1,NDRMET) ENDDO C CLOSE(18,STATUS='KEEP') WRITE(6,696) C ENDIF C C WRITE INFO ON ENERGIES AT WHICH S-MATRIX WAS UPDATED IN IQDT MODE. C c IF(IQDT.GT.0.AND.IEQ.NE.1)THEN c OPEN(33,FILE='infqdt',STATUS='UNKNOWN') c WRITE(33,*)(IEE(I),I=1,MXE) c ENDIF C ENDIF C 3200 IF(IRAD.NE.0) THEN WRITE(8)-1,-1,-1 CLOSE(8,STATUS='KEEP') WRITE(6,663) ENDIF IF(IPRKM.EQ.5)THEN WRITE(12)-1,-1,LREC CLOSE(12,STATUS='KEEP') ENDIF C C SUN DUM=DTIME(TARRY) TIME=TARRY(1) C CRAY CRAY CALL SECOND(TIME) C TIME=TIME/60.0 WRITE(6,999) TIME 999 FORMAT(//1X,'CPU TIME=',F9.3,' MIN',5X) C C STOP C C FORMATS C ******* C 600 FORMAT( //10X,'READS IOPT1 = 2 FOLLOWED BY TERMINATOR'//) 601 FORMAT(//5X,'DATA READ FROM UNIT 5'/ 1 10X,'IPRINT = ',I2/ 2 10X,'IRAD = ',I2/ 3 10X,'IPERT = ',I2/ * 10X,'LMX = ',I2/ 4 10X,'AC = ',1PE9.2/ 5 10X,'IMESH = ',I2/ 6 10X,'IOPT1 = ',I2/ * 10X,'IRDEC = ',I2/ * 10X,'IMODE = ',I2/ * 10X,'IQDT =',I3/ * 10X,'IEQ =',I3/ * 10X,'IOMSW =',I3/ * 10X,'NCUTOFF= ',I7/ * 10X,'FNUMIN = ',0PF4.1/ * 10X,'FNUHYB = ',F4.1/ * 10X,'NDRMET = ',I2/ 7 10x,'NTYP1 = ',I2//) 602 FORMAT(/5X,'VALUES OF 10000*IS+100*IL+IP READ FOR IOPT1=2') 6021 FORMAT(5X,'PARAMETERS READ FOR IOPT1 INITIALLY NEGATIVE',/ + 10X,'NASTD =',I3/10X,'NLEV =',20I3) 603 FORMAT(52X,I7) 604 FORMAT(' ') 605 FORMAT(//10X,30('*')//10X, + 'NUMBER OF SLPI CASES = ',I3, + ' EXCEEDS MAXIMUM OF MZSLP'//10X,30('*')//) 606 FORMAT(///5X,'***** DATA ON UNIT 10 INSUFFICIENT ' + //5X,'***** FOR CALCULATION OF ALL RADIATIVE PROBABILTIES'//) 609 FORMAT(/'*** ATTENTION: OMEGA FILE CONTAINS ELASTIC ' X ,'TRANSITIONS BECAUSE DR IS SWITCHED-ON') 640 FORMAT(//' ETOT',3X,'QDT',2X,'IPERT',2X, 1 'INITIAL AND FINAL TARGET LEVELS, AND COLLISION STRENGTHS'/) 641 FORMAT(/10X,10('+'),' RUN WITH IPERT = 0 ',10('+')/) 650 FORMAT(///80('*')/80('*')//20X,'ENERGIES AND TOTAL OMEGAS'/ 1 20X,25('*')/) 660 FORMAT(//10X,30('*')/ 1 10X,'NO DATA ON R-MATRIX FILE FOR'/ 2 10X,'10000*IS+100*IL+IP = '/) 661 FORMAT(10X,I10) 662 FORMAT(/10X,30('*')//) 663 FORMAT(//10X,'RADIATIVE FILE WRITTEN'//) 675 FORMAT(' WARNING: PARITY OF TARGET STATE',I4 X ,' HAS NOT BEEN DETERMINED') 680 FORMAT(///5X,'ETOT = ',1PE14.6/5X,21('=')/) 690 FORMAT(//5X,60('*')/5X,'* ETOT = ',E11.3, + ' LARGER THAN .5*VALUE(1) = ',E11.3,' *',5X, + /5X,'* RESULTS MAY BE INACCURATE.', + ' NO MORE SIMILAR WARNINGS.',5X,'*'/5X,60('*')//) 691 FORMAT(//5X,57('*')/5X,'* ETOT = ',E11.3, + ' LARGER THAN .5*EZERO = ',E11.3,' *',5X, + /5X,'* RESULTS MAY BE INACCURATE.', + ' NO MORE SIMILAR WARNINGS.',2X,'*'/5X,57('*')//) 694 FORMAT(//10X,46('*')/ + 10X,'* COLLISION STRENGTHS WRITTEN TO FILE OMEGAU *'/ + 10X,46('*')//) 695 FORMAT(//10X,45('*')/ + 10X,'* COLLISION STRENGTHS WRITTEN TO FILE OMEGA *'/ + 10X,45('*')//) 696 FORMAT(//8X,49('*')/ + 8X,'* DR COLLISION STRENGTHS WRITTEN TO FILE OMEGDR *'/ + 8X,49('*')//) 697 FORMAT(10X,30('*')/10X,'NASTD = ',I5, + ' IS LARGER THAN MZTAR'/10X,30('*')//) 699 FORMAT(10X,33('*')/10X,'MXE = ',I6, + ' IS LARGER THAN MZMSH'/10X,33('*')//) 698 FORMAT(/10X,62('*')//10X,'STRONG WARNING: CC OMEGAS ARE BEING' X,' USED FOR THE DIPOLE TOP-UP'/25X, X ' RECOMMEND SETTING LCBE=LRGLAM'//10X,62('*')) 6000 FORMAT(///1X,70('+')//10X,'STGF UoS v4.9'/ + 10X,13('*')//5X,'HISTORY OF MODIFICATIONS'// + 10X,'(1) BETTER ACCURACY FOR LARGE L '/ + 10X,'(2) SUM TO INFINITY (TOP-UP) FOR DIPOLE TRANSITIONS'/ + 10X,'(3) USE OF QDT TO GIVE', + ' GAILITIS AVERAGE '/ + 10X,'(4) USE OF IRDEC TO GIVE RADIATIVE DECAYS ' + /10X,'(5) HANDLES NEW BUTTLE FIT' + /10X,'(6) OPENS FILES B00, B01, ....' + /10X,'(7) DATA ON', + ' B FILES REQUIRES NUMEROV INTEGRATIONS IN STGBB, STGBF') 6003 FORMAT(10X,'(8) CORRECTION OF ROUNDING-ERRORS AT THRESHOLDS' + /10X,'(9) PRINTS DIMENSIONS ' + /9X,'(10) COMBINES NEARLY DEGENERATE TARGET LEVELS ' + /9X,'(11) NAMELIST INPUT' + /9X,'(12) REACTANCE MATRIX OUTPUT ' + /9X,'(13) WORD ADDRESSABLE OUTPUT'/9X + ,'(14) PRINTS MAJOR WARNINGS IF IPERT RESET=0 '/9X +,'(15) MANY MINOR AND 1 MAJOR DEVELOPMENT SO IPERT NEVER RESET=0' + /9X,'(16) TOP-UP CONTROL SEPARATED FROM IPERT ' + /9X,'(17) QUADRUPOLE TOP-UP INCLUDED' + /9X,'(18) DIPOLE TOP-UP CAN BE EVALUATED WITH CBe OMEGAS' + /9X,'(19) RADIATIVE DECAYS IN B.P. MODE ADDED' +) 6005 FORMAT(9X,'(20) INFINITE ENERGY OMEGA ADDED (DIPOLE ONLY)' + /9X,'(21) DIMENSIONS FROM INCLUDE, NO PREPROCESSING' + /9X,'(22) OCTUPOLE ETC. TOP-UP (FOR PSEUDO-STATE IONIZATION)' + /9X,'(23) OCTUPOLE ETC. PERTURBING POTENTIALS (FOR DITTO)' + /9X,'(24) DETAILED SQDT, WITH TYPE-I DAMPING, FOR DR/RE' + /9X,'(25) DETAILED MQDT, WITH TYPE-I DAMPING, FOR DR/RE' + /9X,'(26) NEUTRAL CASE ADDED' + /9X,'(27) DARC HD.DAT (AND H.DAT VIA DARC INTERFACE)' + /9X,'(28) PARTITIONED R-MATRIX' +) 6001 FORMAT(// + 5X,'IQDT= 0 (DEFAULT) FOR NON-QDT OPERATION, EXCEPTING GAILITIS'/ + 22X,'AVERAGE WHEN NU.GT.QNMAX - ANY MESH.'// + 5X,'IQDT=-1 FOR QDT APPLIED TO SINGLE CLOSED TARGET-STATE:'/ + 13X,'DETAILED & AVERAGED, DAMPED & UNDAMPED, EXCITATION & DR.'// + 5X,'IQDT=+1 FOR S-MX QDT APPLIED TO ALL CLOSED TARGET-STATES:'/ + 13X,'DETAILED, DAMPED & UNDAMPED, EXCITATION & DR.'// + 5X,'IQDT=+2 DITTO BUT FOR FOR K-MX.'// + 5X,'CASE IQDT .GT. 0 THEN:'// + 5X,'IMODE= 0 (DEFAULT) WRITE UNPHYSICAL K/S-MATRIX TO FILE.'// + 5X,'IMODE=+1 READ (AND INTERPOLATE) K/S-MATRIX FROM FILE.'// + 5X,'IMODE=-1 SINGLE PASS: COMPUTE AND INTERPOLATE (NO FILES).'// + 5X,'IN THIS CASE SET IEQ EQUAL TO THE NUMBER OF COARSE MESH' + ,' ENERGIES.'// +//1X,70('+')/) 6002 FORMAT(//10X,'COMPILED FOR DIMENSIONS -'// + 15X,'CHANNELS MZCHF =',I6/ + 15X,'TARGET STATES MZTAR =',I6/ + 15X,'MULTIPOLES MZLMX =',I6/ + 15X,'SMALL L VALUES MZLP1 =',I6/ + 15X,'OUTER-REGION RADIAL POINTS MZPTS =',I6/ + 15X,'ENERGY-MESH POINTS (PHYS) MZMSH =',I6/ + 15X,'R-MATRIX POLES MZMNP =',I6/ + 15X,'S, L, PI CASES MZSLP =',I6/ + 15X,'COEFFICIENTS FOR THETA MZTET =',I6/ + 15X,'DEGENERATE CHANNELS MZDEG =',I6/ + 15X,'TERMS IN BUTTLE FIT MZNRG =',I6/ + 15X,'METASTABLES FOR DR MZMET =',I6/ + 15X,'RECORD LENGTH FOR ONE WORD MZREC =',I6/ + 15X,'M-WORDS OF INTERNAL MEM. MZMEG =',I6//) C MXTST=(MZTAR*(MZTAR+1))/2 700 FORMAT(1PE14.8,6(1PE11.3)/(14X,6(E11.3))) 701 FORMAT(1PE12.5,6(1PE11.3)/(12X,6(E11.3))) 710 FORMAT(1P5E16.6) 763 FORMAT(//' *********WARNING, STAT. WEIGHTS IN OMEGA FILE ARE ' X,'MEANINGLESS FOR GROUPED TERMS/LEVELS !!'//) C END C C********************************************************** C SUBROUTINE ABG(E0,L,AC,A,BG) C C COMPUTES FUNCTION G(X,L) TO ACCURACY AC. C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (P0=ONE/252.) PARAMETER (P1=1.05) PARAMETER (P2=2.1) C PI=ACOS(-ONE) E=E0 X=ONE/SQRT(-E) C C CALCULATION OF A AND EAC=E*A*C C IF(L.GT.0)GOTO 2 A=ONE EAC=TZERO GOTO 20 2 IF(L.GT.1)GOTO 4 A=ONE+E EAC=E GOTO 20 4 IF(X.LT.DBLE(L+1)) GOTO 12 C=TZERO A=ONE A1=1 A2=-E A3=TWO*E DO 10 I=1,L A2=A2+A3 A1=A1+A2 A=A*A1 C=C+DBLE(I)/A1 10 CONTINUE EAC=E*A*C GOTO 20 C CASE OF X.LT.(L+1) 12 A=ONE A1=TZERO DO 16 I=1,L A=A*(ONE+DBLE(I*I)*E) A2=DBLE(I) DO 14 J=1,L IF(J.EQ.I) GOTO 14 A2=A2*(ONE+DBLE(J*J)*E) 14 CONTINUE A1=A1+A2 16 CONTINUE EAC=E*A1 C C COMPUTE A1=PI*BG/A-E*C=1/(2*X)+PSI(X)-LN(X) C 20 A1=TZERO C C TEST CONVERGENCE OF ASYMPTOTIC EXPANSION C XN=(754.*AC)**(-.125) IF(X.GT.XN)GOTO 40 C C USE RECURRENCE FORMULAE C N=XN-X+1 XN=X+N E=-ONE/(XN*XN) A1=A1-(ONE/X+ONE/XN)/TWO+LOG(XN/X) IF(N.LT.2)GOTO 40 N=N-1 DO 30 I=1,N A1=A1-ONE/(X+DBLE(I)) 30 CONTINUE C C USE ASYMPTOTIC EXPANSION C 40 A1=A1+(((P1*E+ONE)*E+P2)*E+21)*E*P0 C C COMPLETE CALCULATION C BG=(A*A1+EAC)/PI C RETURN END C C********************************************************** C SUBROUTINE ACSUB C IMPLICIT REAL*8 (A-H,O-Z) C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC C ACNUM=(24.*AC)**.166666667 ACJWBK=(6.*AC)**.2 ACZP=16.*AC LACC=0 IF(AC.LT.1.E-3)LACC=2 IF(AC.LT.1.E-4)LACC=4 C RETURN END C*************************************************************** C SUBROUTINE AINVB C CNRB: C COMPUTE K=-A**(-1)*B C USE KAB'S PARTITIONING, BUT SOLVE A*K=-B INSTEAD. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZDEG*MZDEG) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBCBE/RBE(MZCHF,MZCHF),LCBE COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) C DIMENSION IPIV3(MZCHF),IPIVA(MZCHF) DIMENSION TEMP1(MZCHF,MZCHF),TEMP2(MZCHF,MZCHF), X TEMP3(MZCHF,MZCHF),TEMP4(MZCHF,MZCHF) EQUIVALENCE (TEMP1,RMAT),(TEMP2,DFPP),(TEMP3,RBE),(TEMP4,WORK) C NHOLD=NCHOP CTEST IF(IQDT.GT.0) NCHOP=NCHF/2 !MAKE USE OF SYMMETRY OF K NCC=NCHF-NCHOP !=0 IF IQDT>0, UNLESS ABOVE C DO I=1,NCHF IF(IOMIT(I).GT.0)A(I,I)=ONE ENDDO C IF(NCC.GT.0) THEN C C KOO=-[AOO-AOC*ACC**(-1)*ACO]**(-1)*[BOO-AOC*ACC**(-1)*BCO] C DO J=1,NCC JJ=NCHOP+J DO I=1,NCHOP TEMP4(J,I)=A(I,JJ) !TRANSPOSE ENDDO DO I=1,NCC TEMP3(J,I)=A(JJ,NCHOP+I) ENDDO ENDDO C CSTRTNBL CNBL CALL LU(TEMP3,MZCHF,NCC,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,600)IERR CNBL STOP ' ERROR IN LU' CNBL END IF CNBL CALL LUBT(TEMP3,TEMP4,MZCHF,NCHOP,IERR) !TRANSPOSE CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN LUBT' CNBL END IF CENDNBL C CSTRTBL CALL DGETRF(NCC,NCC,TEMP3,MZCHF,IPIV3,INFO) IF(INFO.NE.0)THEN WRITE(6,602)INFO STOP ' ERROR IN DGETRF' ENDIF CALL DGETRS('T',NCC,NCHOP,TEMP3,MZCHF,IPIV3,TEMP4,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN DGETRS' ENDIF CENDBL C C TRANSPOSE BACK C DO I=1,NCHOP DO J=1,NCC TEMP2(I,J)=TEMP4(J,I) ENDDO ENDDO DO I=1,NCHOP DO J=1,NCC TEMP4(I,J)=TEMP2(I,J) ENDDO ENDDO C DO J=1,NCHOP DO I=1,NCC TEMP2(I,J)=A(NCHOP+I,J) !ACO ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP1(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCC CNBL DO I=1,NCHOP CNBL TEMP1(I,J)=TEMP1(I,J)+TEMP4(I,K)*TEMP2(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCC,ONE, X TEMP4,MZCHF,TEMP2,MZCHF,TZERO,TEMP1,MZCHF) CENDBL C DO J=1,NCHOP DO I=1,NCHOP A(I,J)=A(I,J)-TEMP1(I,J) ENDDO ENDDO DO J=1,NCHOP DO I=1,NCC TEMP1(I,J)=B(NCHOP+I,J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP2(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCC CNBL DO I=1,NCHOP CNBL TEMP2(I,J)=TEMP2(I,J)+TEMP4(I,K)*TEMP1(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCC,ONE, X TEMP4,MZCHF,TEMP1,MZCHF,TZERO,TEMP2,MZCHF) CENDBL C DO J=1,NCHOP DO I=1,NCHOP B(I,J)=B(I,J)-TEMP2(I,J) ENDDO ENDDO DO J=1,NCHOP DO I=1,NCC TEMP4(NCHOP+I,J)=A(NCHOP+I,J) !HOLD ACO ENDDO ENDDO C ENDIF C C ENTRY POINT FOR ALL CHANNELS OPEN C DO J=1,NCHOP DO I=1,NCHOP RK(I,J)=-B(I,J) ENDDO ENDDO C CSTRTNBL CNBL CALL LU(A,MZCHF,NCHOP,IERR) !A DESTROYED CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,600)IERR CNBL STOP ' ERROR IN LU' CNBL END IF CNBL CALL LUB(A,RK,MZCHF,NCHOP,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN LUB' CNBL END IF CENDNBL C CSTRTBL CALL DGETRF(NCHOP,NCHOP,A,MZCHF,IPIVA,INFO) IF(INFO.NE.0)THEN WRITE(6,602)INFO STOP ' ERROR IN DGETRF' ENDIF CALL DGETRS('N',NCHOP,NCHOP,A,MZCHF,IPIVA,RK,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN DGETRS' ENDIF CENDBL C C SYMMETRISE OPEN-OPEN PART OF REACTANCE MATRIX C DO I=1,NCHOP-1 DO J=I+1,NCHOP RK(I,J)=(RK(I,J)+RK(J,I))/TWO RK(J,I)=RK(I,J) ENDDO ENDDO C IF(NCC.EQ.0)RETURN C C IF(IRAD.GT.0.OR.IPERT.LT.0.OR.IQDT.GT.0)THEN !IQDT>0 TEST ONLY C C KCO=-ACC**(-1)*[BCO+ACO*KOO] C DO J=1,NCHOP DO I=1,NCC TEMP1(I,J)=TEMP4(NCHOP+I,J) !ACO TEMP2(I,J)=B(NCHOP+I,J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,NCC CNBL TEMP2(I,J)=TEMP2(I,J)+TEMP1(I,K)*RK(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO C CNBL CALL LUB(TEMP3,TEMP2,MZCHF,NCHOP,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN LUB' CNBL END IF CENDNBL C CSTRTBL CALL DGEMM('N','N',NCC,NCHOP,NCHOP,ONE, X TEMP1,MZCHF,RK,MZCHF,ONE,TEMP2,MZCHF) CALL DGETRS('N',NCC,NCHOP,TEMP3,MZCHF,IPIV3,TEMP2,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN DGETRS' ENDIF CENDBL C DO J=1,NCHOP DO I=1,NCC RK(NCHOP+I,J)=-TEMP2(I,J) ENDDO ENDDO C C COPY CLOSED-OPEN TO OPEN-CLOSED C DO J=NCHOP+1,NCHF DO I=1,NCHOP RK(I,J)=RK(J,I) ENDDO ENDDO C ENDIF C IF(IQDT.GT.0.AND.IPERT.GT.0)THEN !TEST ONLY C C KOC=-[AOO-AOC*ACC**(-1)*ACO]**(-1)*[BOC-AOC*ACC**(-1)*BCC] C DO J=1,NCC DO I=1,NCC TEMP1(I,J)=B(NCHOP+I,NCHOP+J) ENDDO ENDDO DO J=1,NCC DO I=1,NCHOP TEMP2(I,J)=B(I,NCHOP+J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCC CNBL DO K=1,NCC CNBL DO I=1,NCHOP CNBL TEMP2(I,J)=TEMP2(I,J)-TEMP4(I,K)*TEMP1(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL CALL LUB(A,TEMP2,MZCHF,NCC,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN LUB' CNBL END IF CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCC,NCC,-ONE, + TEMP4,MZCHF,TEMP1,MZCHF,ONE,TEMP2,MZCHF) CALL DGETRS('N',NCHOP,NCC,A,MZCHF,IPIVA,TEMP2,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN DGETRS' ENDIF CENDBL C DO J=1,NCC DO I=1,NCHOP RK(I,NCHOP+J)=-TEMP2(I,J) ENDDO ENDDO C C SYMMETRIZE "CLOSED"-OPEN AND OPEN-"CLOSED" PART OF REACTANCE MATRIX C DO J=NCHOP+1,NCHF DO I=1,NCHOP RK(I,J)=(RK(I,J)+RK(J,I))/TWO RK(J,I)=RK(I,J) ENDDO ENDDO C ENDIF C IF(IQDT.GT.0)THEN !TEST C C KCC=-ACC**(-1)*[BCC+ACO*KOC] C DO J=1,NCHOP DO I=1,NCC TEMP1(I,J)=TEMP4(NCHOP+I,J) !ACO ENDDO ENDDO DO J=1,NCC DO I=1,NCHOP TEMP2(I,J)=RK(I,NCHOP+J) ENDDO ENDDO DO J=1,NCC DO I=1,NCC TEMP4(I,J)=B(NCHOP+I,NCHOP+J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCC CNBL DO K=1,NCHOP CNBL DO I=1,NCC CNBL TEMP4(I,J)=TEMP4(I,J)+TEMP1(I,K)*TEMP2(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL CALL LUB(TEMP3,TEMP4,MZCHF,NCC,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN LUB' CNBL END IF CENDNBL C CSTRTBL CALL DGEMM('N','N',NCC,NCC,NCHOP,ONE, X TEMP1,MZCHF,TEMP2,MZCHF,ONE,TEMP4,MZCHF) CALL DGETRS('N',NCC,NCC,TEMP3,MZCHF,IPIV3,TEMP4,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN DGETRS' ENDIF CENDBL C DO J=1,NCC DO I=1,NCC RK(NCHOP+I,NCHOP+J)=-TEMP4(I,J) ENDDO ENDDO C C SYMMETRISE "CLOSED"-"CLOSED" PART OF REACTANCE MATRIX C DO I=NCHOP+1,NCHF DO J=I+1,NCHF RK(I,J)=(RK(I,J)+RK(J,I))/TWO RK(J,I)=RK(I,J) ENDDO ENDDO C ENDIF C NCHOP=NHOLD RETURN C CN600 FORMAT(' SR.AINVB: LU RETURNED WITH INFO =',I2) CN601 FORMAT(' SR.AINVB: LUB RETURNED WITH INFO =',I2) 602 FORMAT(//10X,10('*'),' SR. AINVB: DGETRF RETURNED WITH INFO =',I2) 603 FORMAT(//10X,10('*'),' SR. AINVB: DGETRS RETURNED WITH INFO =',I2) END C*************************************************************** C SUBROUTINE ALPHA(NCHOPO) C C NRB; C EVALUATE LONG-RANGE PERTURBING INTEGRALS C IMPLICIT REAL*8 (A-H,O-Y) C INCLUDE 'PARAM' C PARAMETER(TZERO=0.0) C COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN C C C EVALUATE ALPHA INTEGRALS IN IQDT AND NON-IQDT CASES C IF(IQDT.EQ.0.OR.INTPQ.NE.0)THEN CALL ALPHAN(NCHOPO) ELSE CALL ALPHAQ(NCHOPO) ENDIF C C ZERO-OUT INTEGRALS FOR OMITTED CHANNELS (IF NOT ALREADY DONE) C DO J=1,NCHF DO I=1,NCHF IF(IOMIT(I).GT.0.OR.IOMIT(J).GT.0)THEN ASS(I,J)=TZERO ASC(I,J)=TZERO ACS(I,J)=TZERO ACC(I,J)=TZERO ENDIF ENDDO ENDDO C RETURN END C*************************************************************** C SUBROUTINE ALPHAN(NCHOP) C C NRB: WE'S ALPHA WITH INDICES OF FS(K,I),FC(K,J) INTERCHANGED C (THROUGHOUT THE CODE) FOR GREATER SPEED. ALSO USE OF TEMP C FOR A LITTLE SOMETHING EXTRA. 25/07/97 C C C CALCULATES ALPHA INTEGRALS C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C LOGICAL QDT C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1) COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1 COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF) 1 ,FCP(MZCHF) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBLMX/LMX COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) C DIMENSION IOMTT(MZCHF),CNORM(MZCHF),SNORM(MZCHF) C PI=ACOS(-ONE) NCHOP1=NCHOP+1 IOCINT=IABS(ICCINT) JMAX=NCHF IF(IOCINT.NE.1)JMAX=NCHOP C C INITIALISE ALPHA TO ZERO C DO I=1,NCHF DO J=I,NCHF ASS(J,I)=TZERO ASC(J,I)=TZERO ACS(J,I)=TZERO ACC(J,I)=TZERO ENDDO ENDDO C DO I=1,NCHF IOMTT(I)=IOMIT(I) IF(RINF(I).LT.TZERO)IOMTT(I)=1 IF(RINF(I).GT.RZERO.AND.R2ST(I).GT.RTWO)IOMTT(I)=1 CT IF(RINF(I).GT.RZERO.AND.IPERT.GT.0)IOMTT(I)=1 ENDDO C C C CONTRIBUTION FROM RZERO TO RTWO C START LOOP ON RADIAL POINTS C C NRB: THIS RZERO TO RTWO PART IS VERY TIME CONSUMING, C EVEN FOR JUST A FEW HUNDRED POINTS. C IF(KP2.GT.1)THEN C C OPEN-OPEN AND OPEN-CLOSED PARTS C IF(NCHOP.NE.0) THEN DO I=1,NCHOP IF(IOMTT(I).EQ.0)THEN DO J=I,JMAX LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).EQ.0) THEN DO K=1,KP2 WIJ=TBODE(K,LIJ)*BW(J,I) T1=WIJ*FS(K,J) T2=WIJ*FC(K,J) ASS(J,I)=ASS(J,I)+FS(K,I)*T1 ACS(J,I)=ACS(J,I)+FS(K,I)*T2 ASC(J,I)=ASC(J,I)+FC(K,I)*T1 ACC(J,I)=ACC(J,I)+FC(K,I)*T2 ENDDO ENDIF ENDDO ENDIF ENDDO ENDIF C C CLOSED-CLOSED PART C IF(ICCINT.EQ.1.AND.NCHOP.NE.NCHF) THEN DO I=NCHOP1,NCHF IF(IOMTT(I).EQ.0)THEN DO J=I,NCHF LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).EQ.0) THEN DO K=1,KP2 WIJ=TBODE(K,LIJ)*BW(J,I) T1=WIJ*FS(K,J) ASS(J,I)=ASS(J,I)+FS(K,I)*T1 ASC(J,I)=ASC(J,I)+FC(K,I)*T1 ACS(J,I)=ACS(J,I)+FS(K,I)*WIJ*FC(K,J) ENDDO ENDIF ENDDO ENDIF ENDDO ENDIF ENDIF C C C ASYMPTOTIC INTEGRALS FOR R=RTWO TO INFINITY C C NRB: THIS IS FAST COMPARED TO RZERO TO RTWO, EXCEPT CASE C WHEN RZERO APPROXS RTWO. C DO I=1,NCHF IF(R2ST(I).GT.RTWO)IOMTT(I)=1 ENDDO C IF(ICCINT.EQ.1.AND.NCHOP.EQ.0) THEN CALL CCINT(IOMTT,NCHOP) ELSE CALL OOINT(IOMTT,NCHOP) IF(NCHOP.NE.NCHF) THEN IF(IOCINT.EQ.1)CALL OCINT(IOMTT,NCHOP) IF(ICCINT.EQ.1)CALL CCINT(IOMTT,NCHOP) ENDIF ENDIF C C CONVERT TO (P) Q INTEGRALS C IF(IQDT.GT.0.AND.INTPQ.NE.0)THEN C C OPEN-CLOSED C DO J=NCHOP1,NCHF TNORM=SIN(PI*FKNU(J))*C(J)-COS(PI*FKNU(J))*S(J) TNORM=TNORM/FS(1,J) CNORM(J)=TNORM*COS(PI*FKNU(J)) SNORM(J)=TNORM*SIN(PI*FKNU(J)) ENDDO DO I=1,NCHOP DO J=NCHOP1,NCHF ACS(J,I)=ASS(J,I) ACC(J,I)=ASC(J,I) ASS(J,I)=-CNORM(J)*ASS(J,I) ASC(J,I)=-CNORM(J)*ASC(J,I) ACS(J,I)=SNORM(J)*ACS(J,I) ACC(J,I)=SNORM(J)*ACC(J,I) ENDDO ENDDO C C CLOSED-CLOSED C DO I=NCHOP1,NCHF DO J=I,NCHF ASC(J,I)=ASS(J,I) ACS(J,I)=ASS(J,I) ACC(J,I)=ASS(J,I) ASS(J,I)=CNORM(J)*CNORM(I)*ASS(J,I) ASC(J,I)=-CNORM(J)*SNORM(I)*ASC(J,I) ACS(J,I)=-SNORM(J)*CNORM(I)*ACS(J,I) ACC(J,I)=SNORM(J)*SNORM(I)*ACC(J,I) ENDDO ENDDO C ENDIF C C SYMMETRISE ALPHA C DO I=1,NCHF AA=(ASC(I,I)+ACS(I,I))/TWO ASC(I,I)=AA ACS(I,I)=AA ENDDO C IF(NCHF.NE.1) THEN DO I=2,NCHF K=I-1 DO J=1,K ASS(J,I)=ASS(I,J) ACC(J,I)=ACC(I,J) ASC(J,I)=ACS(I,J) ACS(J,I)=ASC(I,J) ENDDO ENDDO ENDIF C IF(IPRINT.GT.1)THEN WRITE(6,750) DO I=1,NCHOP DO J=I,NCHOP LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I) ENDIF ENDDO ENDDO IF(IOCINT.EQ.1)THEN DO I=1,NCHOP DO J=NCHOP1,NCHF LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN WRITE(6,760)J,I,ASS(J,I),ASC(J,I) ENDIF ENDDO ENDDO ENDIF IF(ICCINT.EQ.1)THEN DO I=NCHOP1,NCHF DO J=NCHOP1,NCHF LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I) ENDIF ENDDO ENDDO ENDIF ENDIF C 750 FORMAT(/' J,I AND ASS(J,I), ASC(J,I), ACS(J,I), ACC(J,I)'/) 760 FORMAT(2I5,4E14.6) C RETURN END C********************************************************** C SUBROUTINE ALPHAQ(NCHOP) C C NRB: C CALCULATES ALPHA INTEGRALS FOR MQDT CASE C INTERFACES WITH FR'S CORINT ROUTINE. C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C LOGICAL QDT C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1) C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF) 1 ,FCP(MZCHF) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/NRBDD2/FSP2(MZCHF),FCP2(MZCHF),IFDD2 COMMON/NRBLMX/LMX COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBZED/TZED,LPRTSW C DIMENSION IOMTT(MZCHF) C C C INITIALISE ALPHA TO ZERO C DO J=1,NCHF DO I=J,NCHF ASS(I,J)=TZERO ASC(I,J)=TZERO ACS(I,J)=TZERO ACC(I,J)=TZERO ENDDO ENDDO C IF(ICCINT.NE.1.AND.NCHOP.EQ.0) RETURN C IF(IFDD2.NE.0)STOP'ALPHAQ: NEED DERIVATIVES AT RTWO' C DO I=1,NCHF IOMTT(I)=IOMIT(I)*2 IF(IOMIT(I).LE.0)THEN IF(I.GT.NCHOP.AND.R2ST(I).LT.RTWOC)IOMTT(I)=1 IF(RINF(I).LE.TZERO)IOMTT(I)=2 CT IF(RINF(I).GT.RZERO.AND.IPERT.GT.0)IOMTT(I)=2 ENDIF ENDDO C NCHOP1=NCHOP+1 IOCINT=IABS(ICCINT) JMAX=NCHF IF(IOCINT.NE.1)JMAX=NCHOP C C C CONTRIBUTION FROM RZERO TO RTWO C START LOOP ON RADIAL POINTS C C NRB: THIS RZERO TO RTWO/C PART IS VERY TIME CONSUMING, C EVEN FOR JUST A FEW HUNDRED POINTS. C IF(IRAD.EQ.0)THEN R0=RTWOC KP2T=KP2C ELSE !RTWO ARTIFICIALLY LARGE (BUT LOW-L SO....) R0=RZERO KP2T=1 IF(KP0.NE.KP2T)STOP'KP0 .NE. 1 ??' ENDIF C IF(KP2T.GT.1)THEN C C OPEN-OPEN AND OPEN-CLOSED PARTS C IF(NCHOP.GT.0) THEN DO I=1,NCHOP DO J=I,JMAX LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).LE.1) THEN DO K=1,KP2T WIJ=TBODE(K,LIJ)*BW(J,I) T1=WIJ*FS(K,J) T2=WIJ*FC(K,J) ASS(J,I)=ASS(J,I)+FS(K,I)*T1 ACS(J,I)=ACS(J,I)+FS(K,I)*T2 ASC(J,I)=ASC(J,I)+FC(K,I)*T1 ACC(J,I)=ACC(J,I)+FC(K,I)*T2 ENDDO ENDIF ENDDO ENDDO ENDIF C C CLOSED-CLOSED PART C IF(ICCINT.EQ.1.AND.NCHOP.NE.NCHF) THEN DO I=NCHOP1,NCHF IF(IOMTT(I).LE.0)THEN DO J=I,NCHF LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1.AND.IOMTT(J).LE.0) THEN DO K=1,KP2T WIJ=TBODE(K,LIJ)*BW(J,I) T1=WIJ*FS(K,J) T2=WIJ*FC(K,J) ASS(J,I)=ASS(J,I)+FS(K,I)*T1 ACS(J,I)=ACS(J,I)+FS(K,I)*T2 ASC(J,I)=ASC(J,I)+FC(K,I)*T1 ACC(J,I)=ACC(J,I)+FC(K,I)*T2 ENDDO ENDIF ENDDO ENDIF ENDDO ENDIF ENDIF C C C ASYMPTOTIC INTEGRALS FOR R=RTWO/C TO INFINITY C DO I=1,NCHF IF(RINF(I).GT.RTWO)IOMTT(I)=2 ENDDO C NCH=NCHOP IF(ICCINT.EQ.1)NCH=NCHF DO 55 I=1,NCH IF(IOMTT(I).GT.1)GO TO 55 DO 50 J=I,JMAX IF(IOMTT(J).GT.1)GO TO 50 IF(I.GT.NCHOP.AND.IOMTT(I)+IOMTT(J).GT.0)GO TO 50 LIJ=LAMP(J,I) IF(LIJ.EQ.1.OR.LIJ.GT.LMX+1)GOTO 50 L1=LLCH(I) L2=LLCH(J) E1=EPS(I)/TWO E2=EPS(J)/TWO KTRUE=LIJ IF(KP2T.GT.1)THEN DF1=FSP2(I) DG1=-FCP2(I) DF2=FSP2(J) DG2=-FCP2(J) ELSE DF1=FSP(I) DG1=-FCP(I) DF2=FSP(J) DG2=-FCP(J) ENDIF F1=FS(KP2T,I) G1=-FC(KP2T,I) F2=FS(KP2T,J) G2=-FC(KP2T,J) C CALL CORINT(L1,L2,E1,E2,KTRUE,R0,TZED,F1,DF1,G1,DG1,F2,DF2 X ,G2,DG2,F1F2,G1F2,F1G2,G1G2) C BWIJ=BW(I,J) ASS(J,I)=ASS(J,I)+BWIJ*F1F2 ASC(J,I)=ASC(J,I)-BWIJ*G1F2 ACS(J,I)=ACS(J,I)-BWIJ*F1G2 ACC(J,I)=ACC(J,I)+BWIJ*G1G2 50 CONTINUE 55 CONTINUE C C SYMMETRISE ALPHA C DO I=1,NCHF A=(ASC(I,I)+ACS(I,I))/TWO ASC(I,I)=A ACS(I,I)=A ENDDO C IF(NCHF.NE.1) THEN DO I=2,NCHF K=I-1 DO J=1,K ASS(J,I)=ASS(I,J) ACC(J,I)=ACC(I,J) ASC(J,I)=ACS(I,J) ACS(J,I)=ASC(I,J) ENDDO ENDDO ENDIF C IF(IPRINT.GT.1)THEN WRITE(6,750) WRITE(6,*)'OPEN-OPEN' DO I=1,NCHOP DO J=I,NCHOP LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I) ENDIF ENDDO ENDDO IF(IOCINT.EQ.1)THEN WRITE(6,*)'CLOSED-OPEN' DO I=1,NCHOP DO J=NCHOP1,NCHF LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I) ENDIF ENDDO ENDDO ENDIF IF(ICCINT.EQ.1)THEN WRITE(6,*)'CLOSED-CLOSED' DO I=NCHOP1,NCHF DO J=NCHOP1,NCHF LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN WRITE(6,760)J,I,ASS(J,I),ASC(J,I),ACS(J,I),ACC(J,I) ENDIF ENDDO ENDDO ENDIF ENDIF C 750 FORMAT(/' J,I AND ASS(J,I), ASC(J,I), ACS(J,I), ACC(J,I)'/) 760 FORMAT(2I5,4E14.6) C RETURN END C*********************************************************************** REAL*8 FUNCTION ARGAM(L,A) C IMPLICIT REAL*8 (A-H,O-Z) C C CALCULATES ARGGAMMA(L+1+I*A) C WHERE L IS AN INTEGER NOT LESS THAN ZERO C B=ABS(A) B=250.0D0*B**0.25D0-A*A J0=L+1 C=J0 D=C*C Z=0.0D0 IF(D -B)1,6,6 1 B=SQRT (B) J1=B DO 5 J=J0,J1 D=J D=A/D G1=ABS(D) IF(G1-0.1D0)2,3,3 2 G1=D*D G2=-35.0D0*G1+45.0D0 G2=-G1*G2+63.0D0 G2=-G1*G2+105.0D0 G1=D -D*G1*G2/315.0D0 GO TO 4 3 G1=ATAN (D) 4 Z=Z+G1 5 CONTINUE J0=J1+1 6 D=J0 G0=D*D U=A*A G1=1.0D0/(G0+U) G2=G1*G1 G3=10.0D0*G0*G0-20.0D0*G0*U+2.0D0*U*U G3=G3*G2-21.0D0*G0+7.0D0*U G3=G3*G2+210.0D0 G1=A*G3*G1/2520.0D0 ARGAM=-Z+0.5D0*A*LOG(G0+U)+(D -0.5D0)*ATAN(A/D)-A-G1 RETURN END C*************************************************************** C REAL*8 FUNCTION ARGC(E,L,AC) C C CALCULATES ARG(GAMMA(L+1-I/K)) -1/K -(1/K)*LN(K) - L*PI/2 C NRB: NOT ACTUALLY CALLED BY INJWBK CASE TZED=0. C IMPLICIT REAL*8 (A-H,O-Z) C COMMON /NRBZED/TZED,LPRTSW C IF(TZED.EQ.0.)THEN ARGC=-DBLE(L)*1.570796327 RETURN ENDIF C IF(E.GT.0)GOTO 10 ARGC=-(DBLE(L)+.25)*3.141592654 RETURN C 10 FK=SQRT(E) ET=1./FK IP=L+1 P=IP PP=IP*IP C IF(AC.LT.1.E-4)GOTO 100 A1=10.*SQRT(ET)-ET*ET IF(A1.GT.PP)GOTO 20 X=PP*E XP1=X+1. XH=P*FK A=-1.570796327*(P+DBLE(L)-.5) GOTO 200 20 L1=IP IP=1.+SQRT(A1) P=IP PP=IP*IP X=PP*E XP1=X+1. XH=P*FK A=-1.570796327*(P+DBLE(L)-.5) L2=IP-1 DO 30 I=L1,L2 30 A=A+ATAN(ET/DBLE(I)) GOTO 200 C 100 A1=35.*ET**.25-ET*ET IF(A1.GT.PP)GOTO 120 X=PP*E XP1=X+1. XH=P*FK A=-1.570796327*(P+DBLE(L)-.5) GOTO 140 120 L1=IP IP=1.+SQRT(A1) P=IP PP=IP*IP X=PP*E XP1=X+1. XH=P*FK A=-1.570796327*(P+DBLE(L)-.5) L2=IP-1 DO 130 I=L1,L2 130 A=A+ATAN(ET/DBLE(I)) 140 A=A+.000396825540*FK*E*(7.*(1.-3.*X)*XP1*XP1+ C 2.*E*(1.-10.*X+5.*X*X))*XP1**(-5) C 200 A1=FK*X*X*.1667*PP IF(A1.GT.AC)GOTO 210 A=A-FK*(2.-X)*.25*PP GOTO 220 210 A=A-.5*ET*LOG(XP1) 220 A2=(P-.5)*XH A1=A2*X*X IF(A1.GT.AC)GOTO 230 A=A+A2*(1.-X*.33333333) GOTO 240 230 A=A+(P-.5)*ATAN(XH) 240 ARGC=A+FK/(12.*(1.+X)) C RETURN END C C*************************************************************** C SUBROUTINE BLOCK C C PROVIDES C BLOCK DATA C CALLED AS SUBROUTINE TO AVOID LINKAGE PROBLEMS WITH LIBRARIES C C DATA FOR QUADRATURES - C LAGUERRE AND LEGENDRE QUADRATURES WITH NUMBERS OF POINTS C N = 2, 4, 6, 8 AND 10 C IMPLICIT REAL*8 (A-H,O-Z) C COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15) C DATA XLAG/ 1 .58578644,3.4142136, 2 .32254769,1.7457611,4.5366203,9.3950709, 3 .22284660,1.1889321,2.9927363,5.7751436,9.8374674, 4 15.982874, 5 .17027963,.90370178,2.2510866,4.26670017,7.0459054, 6 10.758516,15.7406786,22.8631317, 7 .13779347,.72945455,1.8083429,3.4014337,5.5524961, 8 8.3301527,11.8437858,16.279258,21.996586,29.920697/ DATA WLAG/ 1 .85355339,.14644661, 2 .60315410,.35741869,.38887909E-1,.53929471E-3, 3 .45896467,.41700083,.11337338,.10399197E-1, 4 .26101720E-3,.89854791E-6, 5 .36918859,.41878678,.17579499,3.3343492E-2,2.7945362E-3, 6 9.0765088E-5,8.4857467E-7,1.0480012E-9, 7 .30844112,.40111993,.21806829,6.2087456E-2,9.5015170E-3, 8 7.5300839E-4,2.8259233E-5,4.2493140E-7,1.8395648E-9, 9 9.9118272E-13/ DATA XLEG,WLEG/.577350269, 1 .339981044,.861136312, 2 .238619186,.661209386,.932469514, 3 .183434642,.525532410,.796666477,.960289856, 4 .148874339,.433395394,.679409568,.865063367,.973906529, 5 1., 6 .652145159,.347854845, 7 .467913935,.360761573,.171324492, 8 .362683783,.313706646,.222381034,.101228536, 9 .295524225,.269266719,.219086363,.149451349,.066671344/ C RETURN END C C*************************************************************** C SUBROUTINE BODE(H,KP2,IPERT,RZERO) C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (ONE=1.0) PARAMETER (T1=14.0) PARAMETER (T2=64.0) PARAMETER (T3=24.0) PARAMETER (T4=28.0) C COMMON/CBODE/WBODE(MZPTS),TBODE(MZPTS,MZLMX+1) COMMON/NRBLMX/LMX C W=T1*H/45 WBODE(1)=W WBODE(KP2)=W W=T2*H/45 M=KP2-1 DO K=2,M,2 WBODE(K)=W ENDDO W=T3*H/45 M=KP2-2 DO K=3,M,4 WBODE(K)=W ENDDO W=T4*H/45 M=KP2-4 DO K=5,M,4 WBODE(K)=W ENDDO C IF(IPERT.EQ.0.OR.LMX.LT.1.OR.KP2.LE.1)RETURN C R=RZERO-H DO K=1,KP2 R=R+H TBODE(K,1)=ONE/R ENDDO DO I=1,LMX IP=I+1 DO K=1,KP2 TBODE(K,IP)=TBODE(K,I)*TBODE(K,1) ENDDO ENDDO DO I=1,LMX IP=I+1 DO K=1,KP2 TBODE(K,IP)=TBODE(K,IP)*WBODE(K) ENDDO ENDDO C RETURN END C C*********************************************************************** C REAL*8 FUNCTION BUT0(NBUT,U) C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C LOGICAL POLE C COMMON/CBUT/FKN(0:MZNRG),UKN(0:MZNRG) C BUT0=0. C C CASE OF U.GT.0.04 IF(U.GT..04)THEN FK=SQRT(U) POLE=.FALSE. DO 10 N=0,NBUT IF(ABS(FK-FKN(N)).GT..3)THEN BUT0=BUT0+1./(U-UKN(N)) ELSE POLE=.TRUE. D1=FK-FKN(N) ENDIF 10 CONTINUE IF(POLE)THEN D2=D1**2 D=.33333333*D1*(1.+.066666667*D2*(1.+.0952381*D2)) BUT0=2.*BUT0+(D+1./(2.*FK-D1))/FK ELSE BUT0=2.*BUT0+TAN(FK)/FK ENDIF C C SUM FOR U.LT..04 ELSE DO 20 N=0,NBUT 20 BUT0=BUT0+1./(U-UKN(N)) C C CASE OF U.LT..04 AND U.GT.-.04 IF(U.GT.-.04)THEN BUT0=2.*BUT0+1.+.33333333*U*(1.+.4*U) C C CASE OF U.LT.-.04 ELSE FK=SQRT(-U) BUT0=2.*BUT0+TANH(FK)/FK ENDIF C ENDIF C RETURN END C*************************************************************** C SUBROUTINE CCINT(IOMTT,NCHOP) C C C CLOSED-CLOSED: C CALCULATES T INTEGRALS USING LAGUERRE QUADRATURE C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT C INCLUDE 'PARAM' C COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) X ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1 COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF) COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBLMX/LMX C DIMENSION TI(30),TDI(30),TPI(30),TJ(30),TDJ(30),TPJ(30) X,IOMTT(MZCHF) C C NCHOP1=NCHOP+1 C DO I=NCHOP1,NCHF IF(IOMTT(I).EQ.0)THEN DO J=I,NCHF IF(IOMTT(J).EQ.0)THEN LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN NLAG=2*LIJ+LACC NLAG=MIN(NLAG,10) BIJ=BW(J,I) C C CAP K FNUI=BB(I,1) FNUJ=BB(J,1) FK=1./FNUI+1./FNUJ C INITIALISE FOR QUADRATURE NS=NLAG/2 M=NS*(NS-1) N1=M+1 N2=M+NLAG CALL TANDTDN(FK,N1,N2,I,TI,TDI,TPI) CALL TANDTDN(FK,N1,N2,J,TJ,TDJ,TPJ) T1=0. T2=0. T3=0. C START QUADRATURE DO N=N1,N2 U=XLAG(N) R=RTWO+U/FK C CALCULATE THETA FUNCTIONS C ADD TO SUM C++ VAX MOD C A1=(R**(-LIJ))*WLAG(N)*EXP(U+TPI+TPJ) A1=(R**(-LIJ))*WLAG(N) U2=.5*U AI=EXP(U2+TPI(N)) AJ=EXP(U2+TPJ(N)) TI(N)=TI(N)*AI TDI(N)=TDI(N)*AI TJ(N)=TJ(N)*AJ TDJ(N)=TDJ(N)*AJ C++ END MOD T1=T1+TI(N)*A1*TJ(N) T2=T2+TDI(N)*A1*TJ(N) T3=T3+TI(N)*A1*TDJ(N) ENDDO F1=1./FK T1=T1*F1 T2=T2*F1 T3=T3*F1 ASS(J,I)=ASS(J,I)+T1*BIJ ASC(J,I)=ASC(J,I)+T2*BIJ ACS(J,I)=ACS(J,I)+T3*BIJ ENDIF ENDIF ENDDO ENDIF ENDDO RETURN END C************************************************************************ SUBROUTINE CORINT(L1,L2,E1,E2,KTRUE,R0,ZCH 1 ,F1,DF1,G1,DG1,F2,DF2,G2,DG2,F1F2,G1F2,F1G2,G1G2) C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (NPTS0=MZPTS+250) C COMPLEX*16 Z,ZZ,AK1,F12,DH,FUN2(NPTS0),FUN3(NPTS0), 1 K21,K22,FUN1(NPTS0),COEF(4),K23,YP,Y0,YM,WP,W0,WM C C F. ROBICHEAUX C THIS SUBROUTINE CALCULATES THE 4 INTEGRALS C INT _R_0^INFTY (F_1,G_1)(F_2,G_2)/R^KTRUE BY DIRECT SOLUTION OF THE C SCHR. EQ IN THE COMPLEX R-PLANE. C IT IS ASSUMED THE F_I,G_I ARE SOLUTIONS OF THE DIFFERENTIAL EQUATION C Y''_I+2(EI+ZCH/R-LI(LI+1)/R^2)Y_I=0 C C THE INPUTS ARE: C ZCH -- THE CHARGE C R0 -- RADIUS TO BEGIN THE INTEGRATION C KTRUE -- THE MULTIPOLE OF THE POTENTIAL (SEE ABOVE) C LI -- INTEGER, THE ANGULAR MOMENTUM OF THE PARTIAL WAVE C EI -- THE ENERGY OF THE PARTIAL WAVE (NOTE: E2RTWOT C FS(MZPTS,I)=S(I) !HOLD, NOT USED? FC(MZPTS,I)=C(I) !HOLD, NOT USED? C RTWOT=RTWOO !RTWOO NOT USED FURTHER? C KP2T=KP2O !KP2O NOT USED FURTHER? ENDIF C C INWARD INTEGRATION FROM R2(I) TO RZERO C (EXCEPT S WHEN RINF.GT.RZERO - OUTWARD) C IF(KP2T.GT.1)THEN IF(RINF(I).LE.RZERO)THEN ! 1.2*RINF(I) SLIGHTLY MORE ACCURATE W2=C(I)*SP(I)-CP(I)*S(I) IF(BDD2.AND.KP2T.GT.KP2C)THEN !KP2T=KP2 CALL NUMSC(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,SP(I) X ,CP(I),I) FSP2(I)=SP(I) FCP2(I)=CP(I) CALL NUMSC(EPS(I),CCT(I),RTWOC,H,KP2C,1,SP(I),CP(I),I) ELSE CALL NUMSC(EPS(I),CCT(I),RTWOT,H,KP2T,1,SP(I),CP(I),I) ENDIF S(I)=FS(1,I) C(I)=FC(1,I) FSP(I)=SP(I) FCP(I)=CP(I) INOUT(I)=0 W0=C(I)*SP(I)-CP(I)*S(I) IF(IPRINT.GT.1.OR.ABS(W0-ONE).GT.10*AC) X WRITE(6,600)I,RINF(I),W0,W2 ELSE IF(IPERT.GT.0)THEN IF(LRGL2.GT.LPRTSW)IPERT=-IPERT IF(IPRINT.GT.0)WRITE(6,720) ENDIF C EVALUATE S BY SERIES AT MIN(0.8*RINF,RZERO) KINF=(RZERO-0.8*RINF(I))/H IF(KINF.LT.0)KINF=0 RINF0=RZERO-KINF*H CALL COULS(LLCH(I),EPS(I),RINF0,S(I),SP(I)) INOUT(I)=1 KINF=KINF+1 IF(KINF.GT.1)THEN IF(KINF.GT.MZPTS)THEN WRITE(6,610)KINF STOP 'SR.COUL: INCREASE MZPTS' ENDIF CALL NUMS(EPS(I),CCT(I),RINF0,H,1,KINF,S(I),SP(I),FST) ENDIF FSP(I)=SP(I) SS=S(I) SSP=SP(I) KPT=MIN(KP2C,KP2T) IF(IPERT.EQ.0)KPT=1 IF(IPRINT.GT.1)KPT=KP2T IF(IRAD.GT.0)KPT=MAX(2,KPT) !fix for F-files IF(BDD2.AND.KPT.GT.KP2C)THEN CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KP2C,SS,SSP,FST) FSP2(I)=SSP CALL NUMS(EPS(I),CCT(I),RTWOC,H,KP2C,KPT,SS,SSP,FST) ELSE CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KPT,SS,SSP,FST) FSP2(I)=SSP ENDIF W2=C(I)*SSP-CP(I)*SS KPT=MIN(KPT,MZPTS) !CASE R2ST(I).GT.RTWO DO K=1,KPT FS(K,I)=FST(K) ENDDO C EVALUATE C IF(BDD2.AND.KP2T.GT.KP2C)THEN CALL NUMS(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,C(I),CP(I) X ,FST) FCP2(I)=CP(I) CALL NUMS(EPS(I),CCT(I),RTWOC,H,KP2C,1,C(I),CP(I),FST) ELSE FCP2(I)=CP(I) CALL NUMS(EPS(I),CCT(I),RTWOT,H,KP2T,1,C(I),CP(I),FST) ENDIF W0=C(I)*FSP(I)-CP(I)*FS(1,I) IF(IPRINT.GT.1.OR.ABS(W0-ONE).GT.50*AC) X WRITE(6,600)-I,RINF(I),W0,W2 FCP(I)=CP(I) KPT=KP2T IF(IPERT.EQ.0.AND.IRAD.GT.0.AND.KP2C.GT.KP2T)THEN KPT=KP2C CX=FST(KP2T) CXP=FCP2(I) CALL NUMS(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,CX,CXP,FST) ENDIF KPT=MIN(KPT,MZPTS) !CASE R2ST(I).GT.RTWO DO K=1,KPT FC(K,I)=FST(K) ENDDO ENDIF ENDIF C C OUTWARD INTEGRATION FROM R2(I) TO RTWO. C IF(IPERT.NE.0.AND.KP2C.GT.KP2T)THEN !KP2C=KP2 FOR IQDT=0 CALL NUMSC(EPS(I),CCT(I),RTWOT,H,KP2T,KP2C,FSP2(I) X ,FCP2(I),I) W2C=FC(KP2C,I)*FSP2(I)-FCP2(I)*FS(KP2C,I) IF(IPRINT.GT.1.OR.ABS(W2C-ONE).GT.50*AC) X WRITE(6,601)I,R2ST(I),W2,W2C ENDIF C C...CASE OF R2ST(I).GT.RTEST, PERTURBATION CANNOT BE USED C NO LONGER ENTER HERE IF DEFAULT NPERT=1/PERT='YES' IS USED. C ELSE IPERT=0 IF(IRAD.EQ.0) THEN CALL SC(EPS(I),LLCH(I),RZERO,AC, X FS(1,I),FSP(I),FC(1,I),FCP(I),IERR) S(I)=FS(1,I) SP(I)=FSP(I) C(I)=FC(1,I) CP(I)=FCP(I) ELSE IF(RINF(I).LT.RZERO) THEN CALL SC(EPS(I),LLCH(I),RZERO,AC,FS(1,I),FSP(I) X ,FC(1,I),FCP(I),IERR) S(I)=FS(1,I) C(I)=FC(1,I) SP(I)=FSP(I) CP(I)=FCP(I) FSP2(I)=FSP(I) FCP2(I)=FCP(I) CALL NUMSC(EPS(I),CCT(I),RZERO,H,1,KP2,FSP2(I) X ,FCP2(I),I) INOUT(I)=0 ELSE WRITE(6,620)ETOT,I,R2ST(I),RTWO,I,RINF(I),RZERO,KP2 STOP 'SR.COUL: NEED C-FUNCTION INWARD FROM RINF' ENDIF ENDIF ENDIF ENDIF J=J+15 ENDDO ENDIF C C CALCULATE MQDT SOLUTIONS AT RZERO C NCHPP1=NCHOP+1 IF(QDT.OR.IQDT.NE.0)THEN IOMSW0=IOMSW IOMSW=MOD(IOMSW,10) NQQ=NQ IF(IQDT.GT.0)NQQ=NCHF IF(IOMSW.LT.0)THEN NCHPP1=1 NQQ=NCHCL ENDIF C DO 1000 I0=NCHPP1,NQQ I=I0 IF(IOMSW.LT.0)I=ICHCL(I0) IF(IOMIT(I).NE.0)GO TO 1000 C ICHAN=I C IF(IOMSW0.NE.IOMSW)THEN IFLEG0=IFLEG IFLEG=1 ENDIF C CALL SC(EPS(I),LLCH(I),RZERO,AC,S(I),SP(I),C(I),CP(I),IERR) C IF(IOMSW0.EQ.IOMSW)IERR=0 C IF(IERR.GT.0)THEN !NOT CONVERGED, MOVE IN & TRY AGAIN c w0=c(i)*sp(i)-s(i)*cp(i) c write(76,*)ie,ierr,i,llch(i),iomit(i),w0 IF(RINF(I).EQ.TZERO.OR.TZED.EQ.TZERO)THEN RSTART=RZERO*.8 ELSEIF(LLCH(I).EQ.0)THEN RSTART=RZERO/2 ELSE RSTART=MIN(1.2*RINF(I),0.8*RZERO) !1.2 for c-func ENDIF c rstart=max(rstart,h) 105 X=1.D0/RSTART WH=ABS(EPS(I)+X*(2.D0*TZED-CCT(I)*X)) IF(RINF(I).EQ.TZERO)WH=WH/16.D0 H0=ACNUM/SQRT(WH-TOLW) if(kp2.gt.1)H0=MIN(H,H0) !else h=0 H0=H0/2 KSTART=(RZERO-RSTART)/H0 c write(*,*)i,llch(i),h,h0,wh,kstart if(kstart.lt.6)then !stop rstart being increased kstart=6 h0=(rzero-rstart)/kstart endif RSTART=RZERO-KSTART*H0 KSTART=KSTART+1 IOMIT(I)=0 IFLEG=IFLEG0 C CALL SC(EPS(I),LLCH(I),RSTART,AC,S(I),SP(I),C(I),CP(I),IERR) C C IF(IERR.EQ.0)THEN !STRICT IF(IOMIT(I).LE.0)THEN !THIS ALLOWS USE OF NEARLY CONVERGED CALL NUMS(EPS(I),CCT(I),RSTART,H0,1,KSTART,S(I),SP(I),FST) CALL NUMS(EPS(I),CCT(I),RSTART,H0,1,KSTART,C(I),CP(I),FST) c W=C(I)*SP(I)-S(I)*CP(I) IF(ABS(W-ONE).GT.100.*AC) !then x IOMIT(I)=1 c write(76,*)ie,ierr,i,llch(i),iomit(i),w0,w c endif IF(IPRINT.GT.1)WRITE(6,631)IE,I,LLCH(I),FKNU(I),rstart,W c else c write(76,*)-ie,ierr,i,llch(i),iomit(i),w0,w ENDIF c allow for big box (l=0) - adjust rzero/n to loop as often as sensible if(iomit(i).gt.0.and.llch(i).eq.0.and.rstart.gt.rzero/3)then rstart=rstart/2 go to 105 endif ENDIF C FS(1,I)=S(I) FC(1,I)=C(I) FSP(I)=SP(I) FCP(I)=CP(I) FSP2(I)=SP(I) FCP2(I)=CP(I) IF(IOMIT(I).GT.0)GO TO 1000 C INOUT(I)=0 IF(KP2.GT.1)THEN KINF=(0.6*RINF(I)-RZERO)/H IF(KINF.GE.KP2)RINF(I)=-RINF(I) IF(IOMIT(I).LE.0.AND.RINF(I).GT.TZERO)THEN IF(KINF.LT.0)KINF=0 RINF0=RZERO+KINF*H KINF=KINF+1 IF(KINF.GT.1)THEN CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KINF,S(I),SP(I),FST) DO K=1,KINF FS(K,I)=FST(K) ENDDO CALL SC(EPS(I),LLCH(I),RINF0,AC,S(I),SP(I),C(I),CP(I) X ,IERR) CP0=CP(I) CALL NUMS(EPS(I),CCT(I),RINF0,H,KINF,1,C(I),CP(I),FST) FCP(I)=CP(I) CP(I)=CP0 DO K=1,KINF FC(K,I)=FST(K) ENDDO ENDIF IF(INTPQ.EQ.0)THEN IFLGW=0 IF(BDD2.AND.KP2.GT.KP2C)THEN IFLGW=1 CALL NUMSC(EPS(I),CCT(I),RINF0,H,KINF,KP2C,SP(I) X ,CP(I),I) FSP2(I)=SP(I) FCP2(I)=CP(I) CALL NUMSC(EPS(I),CCT(I),RTWOC,H,KP2C,KP2,SP(I) X ,CP(I),I) ENDIF IF(IRAD.GT.0.OR.BDD2.AND.KP2.EQ.KP2C)THEN IFLGW=1 CALL NUMSC(EPS(I),CCT(I),RINF0,H,KINF,KP2,SP(I) X ,CP(I),I) IF(KP2C.GT.1)THEN FSP2(I)=SP(I) FCP2(I)=CP(I) ENDIF ENDIF W0=FC(1,I)*FSP(I)-FS(1,I)*FCP(I) W2=W0 IF(IFLGW.GT.0)W2=FC(KP2C,I)*FSP2(I)-FS(KP2C,I)*FCP2(I) IF(IPRINT.GT.1)WRITE(6,600)I,RINF(I),W0,W2 !,r2st(i) IF(ABS(W0-W2).GT.100.*AC)RINF(I)=-RINF(I) ENDIF ENDIF S(I)=FS(1,I) SP(I)=FSP(I) C(I)=FC(1,I) CP(I)=FCP(I) ENDIF IF(RINF(I).GT.RZERO.AND.LRGL2.GT.LPRTSW)IPERT=-IABS(IPERT) 1000 ENDDO IOMSW=IOMSW0 ENDIF C C CALCULATE CLOSED CHANNEL SOLUTIONS AT RTWO C AND PERFORM INWARDS INTEGRATIONS TO RZERO. C CASE R2.GT.RTWO EVALUATE THETA, THETADOT AT RZERO AND C INTEGRATE OUTWARDS. C NCHFF=NCHF IF(INTPQ.EQ.0)NCHPP1=NCHOP1 IF(IOMSW.LT.0)THEN NCHPP1=1 NCHFF=NCHHYB ENDIF C DO I0=NCHPP1,NCHFF I=I0 IF(IOMSW.LT.0)I=ICHHYB(I0) IF(IOMIT(I).EQ.0)THEN ICHAN=I C C... CASE OF R2ST(I).LE.RTEST, PERTURBATION MAY BE USED C IF(R2ST(I).LE.RTEST)THEN IF(R2ST(I).LE.RTWO)THEN KP2T=KP2 RTWOT=RTWO 205 CALL THETA(RTWOT,I,T,TP,TD,TDP,ICONV) C FS(KP2T,I)=T FC(KP2T,I)=TD C C CHECK FUNCTION NOT TOO SMALL FOR NUMT C IF(ABS(T).LT.TOL0.OR.ABS(TD).LT.TOL0)THEN IFLUG=1 KP2T=KP2T-4 IF(KP2T.LT.1)KP2T=1 RTWOT=(KP2T-1)*H+RZERO C IF(KP2T.LT.KP0)STOP 'SR.COUL: KP2T .LT. KP0' DO K=KP2T,KP2T+4 FS(K,I)=TZERO FC(K,I)=TZERO ENDDO IF(KP2T.EQ.1)GO TO 207 GO TO 205 ENDIF C 207 IF(IPRINT.GT.1.AND.KP2T.LT.KP2)WRITE(6,735)I,RTWOT,RTWO FSP(I)=TP FCP(I)=TDP KRA=KP2T KRB=KP0 !=1 TKRA=RTWOT KINF=1 RINF0=RZERO ELSE KINF=0 IF(IPERT.NE.0)THEN KINF=(0.6*RINF(I)-RZERO)/H IF(KINF.GE.KP2)THEN RINF(I)=-ABS(RINF(I)) KINF=0 ENDIF IF(KINF.LT.0)KINF=0 ENDIF RINF0=RZERO+KINF*H KINF=KINF+1 ENDIF C IF(R2ST(I).GT.RTWO.OR.RINF(I).GT.RZERO.AND.IPRINT.GT.0)THEN C C ASSUME SD=0=CD. (W(C,S)=1=-W(S,C) IN SR.SC) C CALL SC(EPS(I),LLCH(I),RINF0,AC,FSA,FSPA,FCA,FCPA,IERR) C IF(KINF.GT.1.AND.IOMIT(I).GT.0)THEN IOMIT(I)=0 CALL SC(EPS(I),LLCH(I),RZERO,AC,FSA,FSPA,FCA,FCPA,IERR) KINF=1 RINF0=RZERO RINF(I)=-RINF(I) ENDIF C SINF=SIN(PI*FKNU(I)) COSF=COS(PI*FKNU(I)) T=FCA*SINF-FSA*COSF TP=FCPA*SINF-FSPA*COSF IF(TP.NE.TZERO)SSP0=T/TP C C RE-NORMALISED ENERGY DENSITY C C W(T,TD)=1 TD=SINF*FSA+COSF*FCA TDP=SINF*FSPA+COSF*FCPA C C W(T,TD)=2/PI*NU**3 C TD=TD*1.570796327*FKNU(I)**3 C TDP=TDP*1.570796327*FKNU(I)**3 C IF(R2ST(I).GT.RTWO)THEN KRA=KINF KRB=KP2 TKRA=RINF0 ICONV=0 FS(KRA,I)=T FSP(I)=TP FC(KRA,I)=TD FCP(I)=TDP ENDIF CNRB ENDIF IF(ICONV.EQ.0)THEN IF(RINF(I).GE.TZERO.AND.IOMIT(I).LE.0)THEN IF(KRA.GT.KRB.OR.IPERT.NE.0.OR.IRAD.GT.0) X CALL NUMT(EPS(I),CCT(I),TKRA,H,KRA,KRB,I) IF(KRA.GT.KRB)INOUT(I)=0 IF(KRA.LE.KRB)INOUT(I)=1 IF(KINF.GT.1)CALL NUMT(EPS(I),CCT(I),TKRA,H,KINF,-1,I) IF(IPRINT.GT.0.AND.RINF(I).GT.RZERO.AND.R2ST(I).LE.RTWO) X THEN SSP2=FS(1,I)/FSP(I) IF(ABS((SSP0-SSP2)/SSP2).GT.100*AC)THEN WRITE(6,640)I,RINF(I),SSP0,SSP2 ENDIF ENDIF ENDIF ELSE IPERT=0 IF(IRAD.GT.0) THEN WRITE(6,630)ETOT,I,LLCH(I),FKNU(I) STOP 630 ENDIF ENDIF C C... CASE OF R2ST(I).GT.RTEST, PERTUBATION CANNOT BE USED C NO LONGER ENTER HERE IF DEFAULT NPERT=1/PERT='YES' IS USED. C ELSE IPERT=0 CALL SC(EPS(I),LLCH(I),RZERO,AC,FSA,FSPA,FCA,FCPA,IERR) SINF=SIN(PI*FKNU(I)) COSF=COS(PI*FKNU(I)) FS(1,I)=FCA*SINF-FSA*COSF FSP(I)=FCPA*SINF-FSPA*COSF IF(IRAD.GT.0) THEN SS=FS(1,I) SSP=FSP(I) CALL NUMS(EPS(I),CCT(I),RZERO,H,1,KP2,SS,SSP,FST) INOUT(I)=1 DO K=1,KP2 FS(K,I)=FST(K) ENDDO ENDIF ENDIF IF(RINF(I).GT.RZERO.AND.LRGL2.GT.LPRTSW)IPERT=-IABS(IPERT) ENDIF ENDDO C IF(IFLUG.GT.0.AND.IPRINT.GT.1)WRITE(6,730) C IF(IPRINT.GT.1)THEN WRITE(6,701)ETOT WRITE(6,705)RTWO,KP2,H WRITE(6,700) IMAX=1 C IMAX=KP2 DO J=1,NCHF DO I=1,IMAX WRITE(6,710)J,I,FS(I,J),FSP(J),FC(I,J),FCP(J) ENDDO ENDDO ENDIF C C IF(IPRTSW.GT.0)IPERT=IABS(IPERT) IF(IPRTSW.LT.0)IPERT=-IABS(IPERT) C RETURN C 600 FORMAT(23X,' I =',I4,', RINF =',F7.2,', W0 =',F9.6, + ', W2 =',F9.6/) 601 FORMAT(23X,' I =',I4,', R2(I)=',F7.2,', W2 =',F9.6, + ', W2C=',F9.6/) c 602 FORMAT(23X,' I =',I4,', RINF =',F7.2,', W0 =',F9.6, c + ', W2 =',F9.6,', R2(I)=',F7.2/) 610 FORMAT('SR.COUL: INCREASE MZPTS TO ',I6) 620 FORMAT(///10X,30('*')//10X,'FOR ETOT = ',E14.6/ + 10X,'(R2ST(',I2,')=',F8.2,').GT.(RTWO = ',F8.2,') AND'/ + 10X,'(RINF(',I2,') = ',F8.2,').GT.(RZERO=',F8.2,')'/ + 10X,'KP2 = ',I4,/ + 10X,'CANNOT CALCULATE RADIATIVE DATA FOR THIS CASE'/ + 10X,'TRY LARGER VALUE OF MZPTS'///) 630 FORMAT(///10X,30('*')//10X,'FOR ETOT = ',E14.6/ + 10X,'CHANNEL ',I2,' HAS'/ + 10X,'CHANNEL ANGULAR MOMENTUM QUANTUM NUMBER = ',I2/ + 10X,'CHANNEL EFFECTIVE QUANTUM NUMBER = ',F8.2/ + 10X,'CANNOT CALCULATE RADIATIVE DATA FOR THIS CASE.' + /10X,'TRY SMALLER VALUE OF QNMAX OR LARGER' +, ' VALUE OF MZTET'///) 631 FORMAT(/5X,'SUBROUTINE COUL, IE=',I5,' ICHAN=',I4,' LL = ',I2, + ' FNU = ', F10.2,' RHO = ',1PE10.3,' W = ',0PF10.6) 640 FORMAT(' ***WARNING: POSSIBLE INACCURACY IN SR.THETA, RINF' X,' EXCEEDS RZERO FOR CHANNEL'/ X 3X,' I =',I3,', RINF =',F7.2,', AT R0 S/SP(SC) =',1PE13.6, + ', S/SP(THETA) =',1PE13.6/) 700 FORMAT(//10X,'COULOMB FUNCTIONS S,SP,C AND CP'/) 701 FORMAT(//10X,' E = ',F10.6/11X,14('-')) 705 FORMAT(//' RTWO = ',1PE12.4,', KP2 = ',I4,', H = ',0PF10.6) 710 FORMAT(2I5,4E15.6) 720 FORMAT(5X,5('*'),' REGULAR COULOMB FUNCTION FROM SERIES ',5('*')/) 730 FORMAT(3X,'I',3X,'RTWOT',8X,'RTWO') 735 FORMAT(I5,2F10.4) C END C C********************************************************** C SUBROUTINE COULFG(LL,EPS,RHO,ACC,F,FP,G,GP,K,IERR,ACTACC) c + absf,absg) C C CALCULATES COULOMB FUNCTIONS F AND G AND THEIR DERIVATIVES C C ORIGINAL VERSION PUBLISHED IN COMP. PHYS. COMM.25, 87, 1982. C PRESENT VERSION MODIFIED TO AVOID UNDERFLOW AND OVERFLOW C CONDITIONS IN THE SUMMATIONS OVER N OF C U(N)=A(N)*RHO**(N+L+1) C AND V(N)=D(N)*RHO**(N+L+1) C U(N) AND V(N) ARE CALCULATED RECURSIVELY. C C C INPUT - C LL=ANGULAR MOMENTUM QUANTUM NUMBER C EPS=Z-SCALED ENERGY IN RYDBERGS C RHO=Z-SCALED RADIAL VARIABLE IN ATOMIC UNITS C ACC=ACCURACY REQUIRED C C OUTPUT - C F=REGULAR FUNCTION C FP=DERIVATIVE OF F C G=IRREGULAR FUNCTION C GP=DERIVATIVE OF G C K=NUMBER OF TERMS NEEDED IN EXPANSION C IERR=ERROR CODE C ACTACC=ACCURACY ACTUALLY ACHIEVED C C CONVERGENCE CRITERION - C VALUE OF WRONSKIAN CONVERGED TO ACCURACY OF 0.5*ACC C C ERROR CODES - C IERR=0, CONVERGED WITH ACTACC.LT.ACC C IERR=1, CONVERGED WITH ACTACC.GT.ACC C IERR=2, NOT CONVERGED WITH 301 TERMS IN MAIN SUMMATION C IERR=3, NOT CONVERGED - DANGER OF OVERFLOW C IMPLICIT REAL*8 (A-H,O-Z) C DOUBLE PRECISION DUBU0,DUBU1,DUBU2,DUBV0,DUBV1,DUBV2, + DUBQ1,DUBF,DUBFP,DUBS,DUBSP,DA4,DP2,DREPS,DFNPLP,DRHO,DP1,DCLP + ,W1D,W2D,DDW1,DDW2,DONE,DTWO c + ,dabsf,dabsg C CNRB: C DO NOT USE ANYTHING LESS THAN *8 ANYWHERE. IF POSSIBLE, USE C EXPLICIT *16 FOR LARGE CASES, ESPECIALLY ON A CRAY. C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (FOUR=4.0) C C INITIALIZATION C PI=ACOS(-ONE) EULER=-0.577215664901532860606512D0 !INELEGANT R2PI=ONE/(TWO*PI) PS0=ONE+TWO*EULER C IERR=0 LP1=LL+1 L2=2*LL L2P1=L2+1 FL=LL FLP1=LP1 FL2P1=L2P1 E2=EPS/TWO R2=TWO*RHO ACC2=TWO*ACC C C INITIALIZE FA=FACTORIAL(2*LL+1) C AND PS=PSI(2*LL+2)+PSI(1) C FA=ONE PS=PS0 C C C CALCULATE ALPHA(N) AND BETA(N) AND INITIALIZE S AND SP C CONTINUE CALCULATION OF FA AND PS C C S AND SP FOR N=0 X3=-L2 X2=L2P1 X1=-TWO*R2**(-LP1) SP=X3*X1 X1=R2*X1 S=X1 c absg=abs(x1) C C INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE P1=FL*E2 P2=P1 Q1=-E2 C C INITIALIZE ALPHA AND BETA ALP1=ONE ALP2=ONE+P2 BET1=TZERO BET2=Q1 C IF(LL.EQ.0)GOTO 20 C C S AND SP FOR N=1 X3=X3+TWO X2=X2-ONE X1=X1/X2 SP=SP+X3*X1 X1=R2*X1 S=S+X1 c absg=absg+abs(x1) C C LOOP FOR N=2 TO 2*LL DO 10 N=2,L2 C C CONTINUE CALCULATION OF FA AND PSI FN=N FA=FN*FA PS=PS+ONE/FN C C CONTINUE CALCULATION OF S AND SP X3=X3+TWO X2=X2-ONE X1=X1/(X2*FN) SP=SP+X3*X1*ALP2 X1=R2*X1 S=S+X1*ALP2 c absg=absg+abs(x1*alp2) C C COMPUTE COEFFICIENTS IN RECURSION FORMULAE P1=P1-E2 P2=P2+P1 Q1=Q1-E2 C NOW HAVE P2=-N*(N-2*LL-1)*EPS/4 C AND Q1=-N*EPS/2 C C NEW ALPHA AND BETA ALP0=ALP1 ALP1=ALP2 ALP2=ALP1+P2*ALP0 BET0=BET1 BET1=BET2 BET2=BET1+P2*BET0+Q1*ALP0 10 CONTINUE C C NORMALIZE S AND SP, COMPLETE CALCULATION OF FA AND PS S=S*FA SP=SP*FA c absg=absg*abs(fa) FA=FL2P1*FA PS=PS+ONE/FL2P1 C C COMPLETE CALCULATION OF ALPHA AND BETA P1=P1-E2 P2=P2+P1 Q1=Q1-E2 ALP0=ALP1 ALP1=ALP2 BET0=BET1 BET1=BET2 BET2=BET1+P2*BET0+Q1*ALP0 C 20 CONTINUE C NOW HAVE ALP1=ALPHA(2*LL+1) C AND BET1=BETA(2*LL+1), BET2=BETA(2*LL+2) C C VALUE OF A=A(EPS,LL) A=ALP1 A4=FOUR*A CL=TWO*A*LOG(ABS(R2)) CLP=TWO*A/RHO C C CALCULATE F AND FP AND CONTINUE CALCULATION OF S AND SP C C CALCULATE A0,A1,D0,D1 A0=(TWO**LP1)/FA A1=-A0/FLP1 PS=TWO*PS*A D0=(BET1-PS)*A0 D1=(BET2-PS-(TWO+ONE/FLP1)*A)*A1 C C INITIALIZE F,FP, CONTINUE CALCULATION OF S,SP C -VALUES FOR N=0 C U0 AND V0 FNPLP1=FLP1 C1=RHO**LL U0=A0*C1 V0=D0*C1 FP=FNPLP1*U0 SP=SP+FNPLP1*V0 U0=U0*RHO V0=V0*RHO F=U0 c absf=abs(f) S=S+V0 c absg=abs(v0) +absg W1D=F*(CLP*F+SP)-FP*S NNN=0 C C - VALUES FOR N=1 C U1 AND V1 FNPLP1=FNPLP1+ONE C1=C1*RHO U1=A1*C1 V1=D1*C1 FP=FP+FNPLP1*U1 SP=SP+FNPLP1*V1 U1=U1*RHO V1=V1*RHO F=F+U1 c absf=absf+abs(u1) S=S+V1 c absg=absg+abs(v1) W2D=F*(CLP*F+SP)-FP*S DDW2=ABS(W2D-W1D) C C INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE P1=-TWO*FLP1 P2=P1 Q1=A4+TWO*A*FL2P1 REPS=RHO*EPS C C CONVERT TO DOUBLE DONE=1 DTWO=2 DUBU0=U0 DUBU1=U1 DUBV0=V0 DUBV1=V1 DUBQ1=Q1 DUBS=S DUBSP=SP DUBF=F DUBFP=FP c dabsf=absf c dabsg=absg DA4=A4 DP2=P2 DREPS=REPS DFNPLP=FNPLP1 DRHO=RHO DP1=P1 DCLP=CLP C W1D=W1 C W2D=W2 C DDW1=DW1 C DDW2=DW2 C LOOP FOR N=2 TO 300 DO 40 N=2,300 C C COMPUTE COEFFICIENTS IN RECURSION FORMULAE DP1=DP1-DTWO DP2=DP2+DP1 DUBQ1=DUBQ1+DA4 C NOW HAVE P2=-N*(N+2*LL+1) C AND DUBQ1=2*A*(2*N+2*LL+1) C C COMPUTE DUBU2=U(N) AND DUBV2=V(N) DUBU2=(DTWO*DUBU1+DREPS*DUBU0)/DP2 DUBV2=(DTWO*DUBV1+DREPS*DUBV0+DUBQ1*DUBU2)/DP2 C C INCREMENT DUBFP AND DUBSP DFNPLP=DFNPLP+DONE DUBFP=DUBFP+DFNPLP*DUBU2 DUBSP=DUBSP+DFNPLP*DUBV2 C C INCREMENT DUBF AND DUBS DUBU2=DUBU2*DRHO DUBV2=DUBV2*DRHO DUBF=DUBF+DUBU2 c dabsf=dabsf+abs(dubu2) DUBS=DUBS+DUBV2 c dabsg=dabsg+abs(dubv2) C C CALCULATE WRONSKIAN W1D=W2D DDW1=DDW2 W2D=DUBF*(DCLP*DUBF+DUBSP)-DUBFP*DUBS DDW2=ABS(W2D-W1D) C C CONVERGENCE TEST K=N+1 IF(DDW1.GT.ACC2)GOTO 30 IF(DDW2.GT.ACC2)GOTO 30 IF(ABS(W2D).LT.1.E10)GOTO 50 C C TEST FOR OVERFLOW 30 IF(ABS(DUBS)+ABS(DUBSP)+ABS(DUBF)+ABS(DUBFP).GT.1.D100)THEN IERR=3 RETURN ENDIF C NEW DUBU0,DUBU1,DUBV0,DUBV1 DUBU0=DUBU1 DUBU1=DUBU2 DUBV0=DUBV1 DUBV1=DUBV2 C 40 CONTINUE C C NOT CONVERGED C IERR=2 ACTACC=ABS(0.25*W2D-1.) GOTO 60 C C CONVERGED C 50 ACTACC=ABS(0.25*W2D-1.) IF(ACTACC.GT.ACC)IERR=1 C C COMPLETE CALCULATION OF G AND GP C 60 S=DUBS SP=DUBSP F=DUBF FP=DUBFP c absf=dabsf c absg=dabsg c absg=absg*r2pi G=(S+CL*F)*R2PI GP=(SP+CL*FP+CLP*F)*R2PI C RETURN C END C********************************************************** C SUBROUTINE COULS(LL,EPS,RHO,S,SP) C C CALCULATES COULOMB FUNCTION S AND ITS DERIVATIVE SP C FROM POWER-SERIES EXPANSION. C NRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Z) C DOUBLE PRECISION C1,D0,D1,D2,DM,DEPS,DRHO,F,FLP1,FNPLP1,FP, + P1,P2,REPS,U0,U1,U2,UM, A,B,C, T0,DZ C CNRB: C DO NOT USE ANYTHING LESS THAN *8 ANYWHERE. IF POSSIBLE, USE C EXPLICIT *16 FOR LARGE CASES, ESPECIALLY ON A CRAY. C LOGICAL T(0:2),TP(0:2) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBZED/TZED,LPRTSW C C INITIALISATIONS C TPI=TWO*ACOS(-ONE) DRHO=RHO DEPS=EPS DZ=TZED FLP1=LL+1 ACC10=.1*AC DO I=0,1 T(I)=.FALSE. TP(I)=.FALSE. ENDDO T0=ONE NSUM=200 IF(TZED.EQ.0)THEN IF(DEPS.LT.0)THEN WRITE(6,*) X 'ERROR: SR.COULS IS NOT CODED FOR NEGATIVE ENERGY NEUTRALS' STOP'SR.COULS IS NOT CODED FOR NEGATIVE ENERGY NEUTRALS' ENDIF T0=SQRT(SQRT(DEPS)) NSUM=400 ENDIF C C POWER-SERIES EXPANSION C ********************** C C VALUES FOR N=0 FNPLP1=FLP1 C1=T0*DRHO**LL U0=C1 D0=FNPLP1*U0 DM=ABS(D0) FP=D0 U0=U0*DRHO UM=ABS(U0) F=U0 C C VALUES FOR N=1 FNPLP1=FNPLP1+ONE C1=C1*DRHO U1=-C1*DZ/FLP1 D1=FNPLP1*U1 DM=MAX(ABS(D1),DM) FP=FP+D1 U1=U1*DRHO UM=MAX(ABS(U1),UM) F=F+U1 C C INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE P1=-TWO*FLP1 P2=P1 REPS=DRHO*DEPS C C LOOP FOR N=2 TO 200 DO 40 N=2,NSUM C COMPUTE COEFFICIENTS IN RECURSION FORMULAE P1=P1-TWO P2=P2+P1 C NOW HAVE P2=-N*(N+2*LL+1) C COMPUTE U2 AND INCREMENT FP FNPLP1=FNPLP1+ONE U2=(TWO*DZ*U1+REPS*U0)/P2 D2=FNPLP1*U2 DM=MAX(ABS(D2),DM) FP=FP+D2 C MODIFY U2 AND INCREMENT F U2=U2*DRHO UM=MAX(ABS(U2),UM) F=F+U2 c write(67,*)n,f,u2,fp,d2 C TEST CONVERGENCE IF(ABS(U2).LT.ABS(F)*ACC10)THEN T(2)=.TRUE. ELSE T(2)=.FALSE. ENDIF IF(ABS(D2).LT.ABS(FP)*ACC10)THEN TP(2)=.TRUE. ELSE TP(2)=.FALSE. ENDIF DO I=0,2 IF(.NOT.T(I))GOTO 21 ENDDO IF(IPRINT.GT.1)THEN UM=UM/ABS(F) WRITE(6,610)LL,EPS,UM ENDIF GOTO 50 21 DO I=0,2 IF(.NOT.TP(I))GOTO 23 ENDDO IF(IPRINT.GT.1)THEN DM=DM/ABS(FP) WRITE(6,620)LL,EPS,DM ENDIF GOTO 50 C NEW U0,U1,T AND TP 23 U0=U1 U1=U2 DO I=0,1 T(I)=T(I+1) TP(I)=TP(I+1) ENDDO 40 CONTINUE C C SERIES NOT CONVERGED WRITE(6,600)LL,EPS,RHO STOP 'COULS: SERIES NOT CONVERGED' C C NORMALISATION C ************* C C NORMALISE FOR FUNCTIONS .5*F AND .5*FP C 50 S=F SP=FP DO K=1,LL C=ONE/DBLE(K*(2*K+1)) S=S*C SP=SP*C ENDDO C C CALCULATE CAP B AND FUNCTIONS S AND SP IF(EPS.GT.0)THEN A=ONE IF(LL.GT.0)THEN A1=DZ A2=-EPS A3=EPS+EPS DO I=1,LL A2=A2+A3 A1=A1+A2 A=A*A1 ENDDO ENDIF IF(EPS.LT.0.01.OR.TZED.EQ.0)THEN B=A ELSE B=A/(ONE-EXP(-TPI/SQRT(EPS))) ENDIF C=SQRT(B) ELSE C=ONE ENDIF IF(TZED.GT.0)C=C*SQRT(TPI) S=S*C SP=SP*C C RETURN C 600 FORMAT(//10X,60('*')//10X,'SERIES IN COULS NOT CONVERGED' + /10X,' LL =',I3,', EPS =',1PE15.5,', RHO =', + E15.5//10X,60('*')//) 610 FORMAT(/5X,'SUBROUTINE COULS, LL = ',I2,', EPS = ', + 1PE12.5,', UM = ',E10.2) 620 FORMAT(/5X,'SUBROUTINE COULS, LL = ',I2,', EPS = ', + 1PE12.5,', DM = ',E10.2) END SUBROUTINE DIAG(N,IUP,Z,D,E,MXMAT) C IMPLICIT REAL*8 (A-H,O-Z) C C BADNELL & BURGESS D.A.M.T.P. CAMBRIDGE C C DIAGONALIZATION OF REAL SYMMETRIC N-BY-N MATRIX Z. C C METHOD: HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM AND SHIFTED C QL ALGORITHM TO DETERMINE THE E-VALUES AND E-VECTORS. C C BASED ON MARTIN, REINSCH & WILKINSON: NUM. MATH. 11, 181-95 (1968). C C INPUT REQUIRED. N, IUP AND Z. ONLY LOWER TRIANGLE OF Z NEED BE SUPPLIED. C MATRIX Z OVERWRITTEN BY EIGENVECTORS OF Z. C IUP=1/-1 ASC/DESCENDING SORT, 0 NO SORT. C MXMAT, IS THE ROW DIMENSION OF Z IN THE CALLING ROUTINE. C C OUTPUT. Z AND D, WHERE Z CONSISTS OF COLUMN EIGENVECTORS C AND D CONSISTS OF CORRESPONDING EIGENVALUES. C C NOTE: E IS A WORKING ARRAY. C PARAMETER (TOL = 1.0D-75) PARAMETER (EPS = 1.0D-15) PARAMETER (ZERO = 0.0D0) PARAMETER (ONE = 1.0D0) PARAMETER (JMAX = 30) C DIMENSION D(N),E(N),Z(MXMAT,N) C C DO 1 I = 1,N D(I) = Z(N,I) 1 CONTINUE IF (N.LE.1) GO TO 20 C C HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM C DO 19 I = N,2,-1 L = I - 1 F = D(I-1) G = ZERO DO 5 K = 1,I-2 G = G + D(K)*D(K) 5 CONTINUE H = G + F*F IF (G.GT.TOL) GO TO 8 E(I) = F H = ZERO DO 7 J = 1,L D(J) = Z(L,J) Z(I,J) = ZERO Z(J,I) = ZERO 7 CONTINUE GO TO 18 8 G = SQRT(H) IF (F.GE.ZERO) G = -G E(I) = G H = H - F*G D(L) = F - G DO 14 J = 1,L E(J) = ZERO 14 CONTINUE DO 15 J = 1,L Z(J,I) = D(J) G = E(J) + Z(J,J)*D(J) DO 13 K = J+1,L G = G + Z(K,J)*D(K) E(K) = E(K) + Z(K,J)*D(J) 13 CONTINUE E(J) = G 15 CONTINUE F = ZERO DO 12 J = 1,L E(J) = E(J)/H F = F + E(J)*D(J) 12 CONTINUE HH = F/(H+H) DO 11 J = 1,L E(J) = E(J) - HH*D(J) 11 CONTINUE DO 17 J = 1,L F = D(J) G = E(J) DO 16 K = J,L Z(K,J) = Z(K,J) - F*E(K) - G*D(K) 16 CONTINUE D(J) = Z(L,J) Z(I,J) = ZERO 17 CONTINUE 18 D(I) = H 19 CONTINUE C C C ACCUMULATE TRANSFORMATION MATRICES C DO 28 I = 2,N L = I - 1 Z(N,L) = Z(L,L) Z(L,L) = ONE H = D(I) IF (H.EQ.ZERO) GO TO 25 DO 21 K = 1,L D(K) = Z(K,I)/H 21 CONTINUE DO 24 J = 1,L G = ZERO DO 22 K = 1,L G = G + Z(K,I)*Z(K,J) 22 CONTINUE DO 23 K = 1,L Z(K,J) = Z(K,J) - G*D(K) 23 CONTINUE 24 CONTINUE 25 DO 27 J = 1,L Z(J,I) = ZERO 27 CONTINUE 28 CONTINUE DO 29 I = 1,N D(I) = Z(N,I) Z(N,I) = ZERO 29 CONTINUE 20 E(1) = ZERO Z(N,N) = ONE C C C SHIFTED QL ALGORITHM TO DETERMINE E-VALUES & E-VECTORS C DO 32 I = 2,N E(I-1) = E(I) 32 CONTINUE E(N) = ZERO B = ZERO F = ZERO DO 54 L = 1,N J = 0 H = EPS*(ABS(D(L))+ABS(E(L))) IF (B.LT.H) B = H DO 36 M = L,N IF (ABS(E(M)).LE.B) GO TO 37 36 CONTINUE 37 IF (M.EQ.L) GO TO 53 38 IF (J.EQ.JMAX) GO TO 62 J = J+ 1 P = E(L) + E(L) G = D(L) H = D(L+1) - G IF (ABS(H).GE.ABS(E(L))) GO TO 43 P = H/P R = SQRT(P*P+ONE) H = P + R IF (P.LT.ZERO) H = P - R D(L) = E(L)/H GO TO 44 43 P = P/H R = SQRT(P*P+ONE) D(L) = E(L)*P/(R+ONE) 44 H = G - D(L) DO 46 I = L+1,N D(I) = D(I) - H 46 CONTINUE F = F + H P = D(M) C = ONE S = ZERO DO 52 I = M-1,L,-1 G = C*E(I) H = C*P IF (ABS(P).LT.ABS(E(I))) GO TO 49 C = E(I)/P R = SQRT(C*C+ONE) E(I+1) = S*P*R S = C/R C = ONE/R GO TO 50 49 C = P/E(I) R = SQRT(C*C+ONE) E(I+1) = S*E(I)*R S = ONE/R C = C/R 50 P = C*D(I) - S*G D(I+1) = H + S*(C*G+S*D(I)) DO 51 K = 1,N H = Z(K,I+1) Z(K,I+1) = S*Z(K,I) + C*H Z(K,I) = C*Z(K,I) - S*H 51 CONTINUE 52 CONTINUE E(L) = S*P D(L) = C*P IF (ABS(E(L)).GT.B) GO TO 38 53 D(L) = D(L) + F 54 CONTINUE C IF(IUP.EQ.0)RETURN C C BEGIN SORTING INTO ASCENDING E-VALUES C DO 61 I = 1,N K = I P = D(I) DO 57 J = I+1,N IF (IUP.GT.0.AND.D(J).GT.P) GO TO 57 IF (IUP.LT.0.AND.D(J).LT.P) GO TO 57 K = J P = D(J) 57 CONTINUE IF (K.EQ.I) GO TO 61 D(K) = D(I) D(I) = P DO 60 J = 1,N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 60 CONTINUE 61 CONTINUE C RETURN C C 62 WRITE(6,100) 100 FORMAT(' FAILED IN DIAG, TOO MANY ITERATIONS') RETURN C END C*************************************************************** C SUBROUTINE EPHASE C C EVALUATE EIGENPHASE SUM C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (MZKIL= 0) C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) C PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) PARAMETER (TWO=2.0) PARAMETER (FOUR=4.0) C COMMON/CEN/ETOT,MXE,NWT,NZ C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) C DIMENSION RK2(MZCHF,MZCHF),DDD(MZCHF),EEE(MZCHF) C DATA ICASE/0/ C IF(ICASE.EQ.0)THEN OPEN(UNIT=34,FILE='ESUM',STATUS='UNKNOWN') ICASE=1 ENDIF C DO J=1,NCHOP DO I=1,NCHOP RK2(I,J)=RK(I,J) ENDDO ENDDO C IUP=0 CALL DIAG(NCHOP,IUP,RK2,DDD,EEE,MZCHF) C SUM=TZERO DO I=1,NCHOP SUM=SUM+ATAN(DDD(I)) ENDDO PI=FOUR*ATAN(ONE) EMIN=TZERO IF(LRGL2.GT.1)EMIN=-0.05 99 CONTINUE IF(SUM.LT.EMIN)THEN SUM=SUM+PI GO TO 99 ENDIF IF(SUM.GT.PI)THEN SUM=SUM-PI GO TO 99 ENDIF IF(IE.EQ.1)WRITE(34,1000)NSPN2,LRGL2,NPTY2 WRITE(34,1001)ETOT,SUM C 1000 FORMAT('#',I3,I4,I2) 1001 FORMAT(1P2E16.8) C RETURN END C*********************************************************************** REAL*8 FUNCTION F21(A,B,C,D,EPS,IFAIL) IMPLICIT REAL*8 (A-H,O-Z) C IPRINT=IFAIL IFAIL=0 T=(A*B*D)/C DD=1.0D0/(1.0D0-D) SUM=1.0D0+T TN1=0.0D0 I=1 3 AI=I T=T*(A+AI)*(B+AI)*D/((C+AI)*(1.0D0+AI)) TN2=T*DD F21=SUM+TN2 SUM=SUM+T AT=ABS(T+TN2-TN1) AS=ABS(F21)*EPS IF(AS-AT)1,2,2 1 TN1=TN2 I=I+1 IF(I-300)3,3,4 4 IF(IPRINT.GT.0)WRITE(6,100) IFAIL=3 100 FORMAT(' FAILED TO CONVERGE IN F21') 2 RETURN END C C********************************************************** C REAL*8 FUNCTION FDIP(EK1,L1,EK2,L2,IFAIL) C IMPLICIT REAL*8 (A-H,O-Z) C C ALAN BURGESS DEPT. OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE C CALCULATES THE FUNCTION I(KAPPA1,L1,KAPPA2,L2,1) DEFINED IN PHIL. C TRANS. ROY. SOC. A226,255,1970, WHERE EK1=KAPPA1**2 AND EK2=KAPPA2**2. C IT IS SUITABLE FOR USE IN EQUATIONS (8),(9),(10) OR (11) OF C J. PHYS. B. 7,L364,1974. C NRB - IFAIL COMMON/NRBZED/TZED,LPRTSW DATA EPS/1.D-4/ C IF(TZED.EQ.0)THEN FDIP=FDIP0(EK1,L1,EK2,L2,EPS,IFAIL) RETURN ENDIF C IPRINT=IFAIL IF(EK1+EK2-1.0D-40) 11,11,12 11 FDIP=0.0D0 IFAIL=1 IF(IPRINT.GT.0)WRITE(6,100)IFAIL RETURN 12 IF(EK1-EK2) 1,1,2 1 EMIN=EK1 EMAX=EK2 GO TO 3 2 EMIN=EK2 EMAX=EK1 3 T=EMIN/EMAX IF(T-0.02944D0) 4,4,5 4 FDIP=FDIP1(EK1,L1,EK2,L2) GO TO 9 5 IF(T-0.16667D0) 7,6,6 6 FDIP=FDIP2(EK1,L1,EK2,L2) GO TO 9 7 FDIP=FDIP1(EK1,L1,EK2,L2) IF(FDIP*FDIP-1.0D-40) 6,6,8 8 IF(FDIP.LT.0.0.OR.FDIP.GT.1.)THEN IFAIL=3 IF(IPRINT.GT.0)WRITE(6,100)IFAIL FDIP=0.0 RETURN ENDIF FA=FDIPA(EK1,L1,EK2,L2) IFAIL=0 IF(FA.EQ.0.0)THEN FA=FDIP0(EK1,L1,EK2,L2,EPS,IFAIL) IFAIL=-IFAIL IF(FA.EQ.0.0)RETURN ENDIF RAT=FDIP/FA IF(RAT.GT.10.)THEN IFAIL=4 IF(IPRINT.GT.0)WRITE(6,100)IFAIL FDIP=0.0 ENDIF RETURN 9 IF(FDIP*FDIP-1.0D-40) 10,10,8 10 IFAIL=2 IF(IPRINT.GT.0)WRITE(6,100)IFAIL RETURN 100 FORMAT('***FDIP FAILURE: IFAIL=',I2) END C*********************************************************************** REAL*8 FUNCTION FDIP0(EK1,L1,EK2,L2,EPS,IFAIL) C IMPLICIT REAL*8 (A-H,O-Z) C C ALAN BURGESS,DEPT OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE C CALCULATES THE FUNCTION I0(K1,L1,K2,L2,1) DEFINED IN PHIL. TRANS. C ROY. SOC. A266,255,1970, WHERE EK1=K1*K1, EK2=K2*K2, AND THE RELATIVE C ACCURACY IS APPROXIMATELY EPS. C IT IS SUITABLE FOR USE IN EQUATIONS (13) ETC. OF J.PHYS.B. 7,L364,1974 C NRB - IFAIL C IPRINT=IFAIL IFAIL=0 IF(L1-L2)1,2,4 1 L=L1 GO TO 5 2 IF(IPRINT.GT.0)WRITE(6,100)L1 IFAIL=1 FDIP0=0.0D0 3 RETURN 4 L=L2 5 EL=L FDIP0=0.5D0/(EL+1.0D0) IF(EK1-EK2)6,3,7 6 E=EK1/EK2 P=L1-L GO TO 8 7 E=EK2/EK1 P=L2-L 8 FDIP0=FDIP0*E**((EL+P+0.5D0)*0.5D0) C TO OBTAIN THE FUNCTION EK1 OF M.J. SEATON, PROC. PHYS. SOC. A68,457, C 1955, REMOVE THE 'C' ON THE NEXT LINE. C FDIP0=1.0D0 IF(E -0.5D0)21,20,20 20 P1=P-0.5D0 T=P1*(EL+1.0D0)*(E -1.0D0) I0=L+1 H0=0.0D0 DO 9 I=1,I0 TI=I H0=H0+1.0D0/TI 9 CONTINUE X=1.0D0-E H=1.0D0-(P+P+H0+LOG(0.25D0*X)) S=1.0D0+T*H A=EL+1.0D0 B=P1 C=1.0D0 D=0.0D0 10 A=A+1.0D0 B=B+1.0D0 C=C+1.0D0 D=D+1.0D0 T=T*A*B*X/(C*D) H=H+P1/(D*B)+EL/(C*A) T1=T*H S=S+T1 IF(ABS(T1)-EPS*ABS(S))13,11,11 11 IF(C-300.0D0)10,12,12 12 IF(IPRINT.GT.0)WRITE(6,101) IFAIL=2 13 FDIP0=FDIP0*S RETURN 21 A=EL+1.0D0 B=P-0.5D0 C=EL+P+1.5D0 F=F21(A,B,C,E,EPS,IFAIL) L=L+1 EL=L IF(P-0.5D0)23,23,24 23 C1=EL+EL+1.0D0 GO TO 25 24 C1=1.0D0 25 DO 22 I=1,L AI=I AII=AI+AI C1=C1*AI*AI*4.0D0/(AII*(AII+1.0D0)) 22 CONTINUE FDIP0=FDIP0*F*C1 RETURN 100 FORMAT(' FAILED IN FDIP0, L1=L2=',I5) 101 FORMAT(' FAILED TO CONVERGE IN FDIP0') END C*********************************************************************** REAL*8 FUNCTION FDIP1(EK1,L1,EK2,L2) C IMPLICIT REAL*8 (A-H,O-Z) C IF(L1-L2)1,2,3 1 L=L1 A1=EK1 A2=EK2 GO TO 4 2 FDIP1=0.0D0 RETURN 3 L=L2 A1=EK2 A2=EK1 4 LP=L+1 ELP=LP B1=SQRT(1.0D0+ELP*ELP*A2)*FMON1(EK1,EK2,L) B2=SQRT(1.0D0+ELP*ELP*A1)*FMON1(EK1,EK2,LP) IF(B1*B2-1.0D-40)5,5,6 5 FDIP1=0.0D0 RETURN 6 FDIP1=(B1-B2)/ELP RETURN END C*********************************************************************** REAL*8 FUNCTION FDIP2(EK1,L1,EK2,L2) C IMPLICIT REAL*8 (A-H,O-Z) C WMAX=200.0D0 ETA1=1.0D0/SQRT(EK1) ETA2=1.0D0/SQRT(EK2) W1=ETA2-ETA1 PI=3.141592653589793D0 A=ABS(W1) B=PI*A IF(B-0.01D0)1,1,2 1 C=3.0D0/(3.0D0-B*(3.0D0-B*(2.0D0-B))) C=SQRT(C) GO TO 5 2 IF(B-14.0D0)4,3,3 3 C=SQRT(B+B) GO TO 5 4 B=B+B C1=1.0D0-EXP(-B) C=SQRT(B/C1) 5 C=0.5D0*C/SQRT(ETA1*ETA2) C2=ETA1+ETA2 C1=4.0D0*ETA1*ETA2/(C2*C2) L=L1 IF(L2-L1)6,6,7 6 L=L2 T1=ETA1 ETA1=ETA2 ETA2=T1 W1=-W1 7 C=C*C1**(L+1) U0=L+1 U1=ETA1 V0=U0 V1=-ETA2 W0=1.0D0 X0=W1/(C2*C2) Y2=-ETA2-ETA2 Y0=-U0*W1+Y2 Y1=ETA2*W1 T1=X0/(1.0D0+W1*W1) Z0=U0*T1 Z1=U1*T1 T=Z0-Z1*W1 Z1=Z0*W1+Z1 Z0=T Q0=-1.0D0+Z0*Y0-Z1*Y1 Q1=Z0*Y1+Z1*Y0 X=W1*X0 8 U0=U0+1.0D0 V0=V0+1.0D0 W0=W0+1.0D0 IF(W0-WMAX)21,21,20 20 FDIP2=0.0D0 RETURN 21 CONTINUE Y0=Y0+Y2 T=Z0*U0-Z1*U1 Z1=Z0*U1+Z1*U0 Z0=T T=Z0*V0-Z1*V1 Z1=Z0*V1+Z1*V0 Z0=T T=Z0*W0-Z1*W1 Z1=Z0*W1+Z1*W0 Z0=T X0=X/(W0*(W0*W0+W1*W1)) Z0=Z0*X0 Z1=Z1*X0 T0=Z0*Y0-Z1*Y1 T1=Z0*Y1+Z1*Y0 Q0=Q0+T0 Q1=Q1+T1 T1=T0*T0+T1*T1 T0=Q0*Q0+Q1*Q1 IF(T0-1.0D+24*T1)8,8,9 9 J1=0 J2=L+1 P=ARGAM(J1,W1)+ARGAM(L,ETA1)-ARGAM(J2,ETA2) IW0=W0 IF(A-1.0D-40)11,11,10 10 P=P+W1*LOG(C2/A) 11 P0=COS(P) P1=SIN(P) T=P0*Q0-P1*Q1 Q1=P0*Q1+P1*Q0 Q0=T FDIP2=C*Q1 RETURN END C C*********************************************************************** C REAL*8 FUNCTION FDIPA(EK1,L1,EK2,L2) IMPLICIT REAL*8 (A-H,O-Z) C C N.R. BADNELL C ASYMPTOTIC EXPRESSION FOR I(KAPPA1,L1,KAPPA2,L2,1) BASED ON A40,1 OF BHT C IF(EK1*EK2.GT.1.0D-50)THEN X1=1.0D0/SQRT(EK1) X2=1.0D0/SQRT(EK2) XP=ABS(X1-X2) IF(XP.GT.1.D2)GO TO 9 PI=ACOS(-1.0D0) XP=EXP(0.5D0*PI*XP) IF(EK1-EK2)1,1,2 1 E=EK1/EK2 IF(L1-L2)3,3,4 3 L=L1 GO TO 7 4 L=L2 GO TO 8 2 E=EK2/EK1 IF(L1-L2)5,5,6 5 L=L1 GO TO 8 6 L=L2 GO TO 7 C A40 7 TL=L T0=1.0D0-E IF(TL*T0.LT.E)GO TO 9 T=PI*TL EE=SQRT(E) F0=SQRT(T*T0*EE)*EE**L TL=L+L+1 FDIPA=F0*XP/TL RETURN C A41 8 T0=1.0D0-E TL=L IF(TL*T0.LT.E)GO TO 9 T0=1.0D0/T0 T=TL*PI EE=SQRT(E) F0=SQRT(T*T0*EE)*EE**(L+1) TL=L+L+1 TL2=L+L+3 FDIPA=F0*XP/(TL*TL2) RETURN ENDIF 9 FDIPA=0.0D0 RETURN END C C*************************************************************** C REAL*8 FUNCTION FKHI(E,L,AC) C C CALCULATES REAL*4 PART OF PSI(L+1+I*GAM) - LN(GAM) C WHERE E = 1/(GAM**2). C THIS IS REQUIRED FOR CALCULATION OF SCRIPT G. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (P0=ONE/252.) PARAMETER (P1=1.05) PARAMETER (P2=2.1) C FKHI=TZERO IF(E.EQ.0)RETURN C AC1=(20.*AC)**.333 C IF(E.GT.AC1)GOTO 100 C C=TZERO IF(L.EQ.0)GOTO 20 A1=ONE A2=-E A3=E+E DO 10 I=1,L A2=A2+A3 A1=A1+A2 C=C+DBLE(I)/A1 10 CONTINUE 20 FKHI=E*((((P1*E+ONE)*E+P2)*E+21)*P0+C) RETURN C 100 AC1=ONE/SQRT(AC1) FL=DBLE(L+1) IF(FL.GT.AC1)GOTO 300 C N=AC1 FL=N+1 L1=L+1 DO 210 I=L1,N FI=I FKHI=FKHI+FI/(ONE+E*FI*FI) 210 CONTINUE FKHI=-FKHI*E C 300 X1=FL*E X=ONE+X1*FL ZE=DCMPLX(FL,ONE/SQRT(E)) ZE=-ONE/(ZE*ZE) FKHI=FKHI+(LOG(X)-(X1/X))/TWO+DBLE((((P1*ZE+ONE)*ZE C +P2)*ZE+21)*ZE)*P0 C RETURN END C*********************************************************************** REAL*8 FUNCTION FMON1(EK1,EK2,L) C IMPLICIT REAL*8 (A-H,O-Z) C IF(EK1+EK2-1.0D-40)28,28,29 28 FMON1=1.0D+50 RETURN 29 CONTINUE VMAX=200.0D0 X1=SQRT(EK1) X2=SQRT(EK2) X3=X1+X2 X4=X3*X3 X5=X1*X2 X6=X2-X1 X7=4.0D0/X4 PI=3.141592653589793D0 IF(EK1-EK2)1,1,2 1 ETA=1.0D0/X2 GO TO 3 2 ETA=1.0D0/X1 3 G=0.5D0*PI*EXP(-PI*ETA) IF(G.EQ.0.0D0)GO TO 20 !NRB A1=1.0D0 A2=1.0D0 MG=0 MA1=0 MA2=0 M=-1 4 M=M+1 EM=M T=EM+EM+1.0D0 G=G*X7/(T*(T+1.0D0)) EMM=EM*EM A1=A1*(1.0D0+EMM*EK1) A2=A2*(1.0D0+EMM*EK2) 30 IF(G-0.015625D0) 31,32,32 31 G=64.0D0*G MG=MG-1 GO TO 30 32 IF(G-64.0D0) 34,34,33 33 G=0.015625D0*G MG=MG+1 GO TO 32 34 IF(A1-64.0D0) 36,36,35 35 A1=0.015625D0*A1 MA1=MA1+1 GO TO 34 36 IF(A2-64.0D0) 38,38,37 37 A2=0.015625D0*A2 MA2=MA2+1 GO TO 36 38 CONTINUE IF(M-L)4,5,5 5 G=G*(T+1.0D0) IF(X1-300.0D0)7,6,6 6 B=PI/X1 A1=1.5D0*A1/(B*(3.0D0-B*(3.0D0-B*(2.0D0-B)))) GO TO 9 7 IF(X1-0.2D0)9,9,8 8 B=-PI/X1 A1=A1/(1.0D0-EXP(B+B)) 9 IF(X2-300.0D0)11,10,10 10 B=PI/X2 A2=1.5D0*A2/(B*(3.0D0-B*(3.0D0-B*(2.0D0-B)))) GO TO 13 11 IF(X2-0.2D0)13,13,12 12 B=-PI/X2 A2=A2/(1.0D0-EXP(B+B)) 13 G=G*SQRT(A1*A2)*(8.0D0)**(MG+MG+MA1+MA2) S0=1.0D0 S1=0.0D0 U=L V=0.0D0 W=U+U+1.0D0 T0=1.0D0 T1=0.0D0 14 U=U+1.0D0 V=V+1.0D0 W=W+1.0D0 IF(V-VMAX)21,21,20 20 FMON1=0.0D0 RETURN 21 CONTINUE U0=U*U*X5+1.0D0 U1=U*X6 T=T0*U0-T1*U1 T1=T0*U1+T1*U0 T0=T T=X7/(V*W) T0=T*T0 T1=T*T1 S0=S0+T0 S1=S1+T1 S=S0*S0+S1*S1 T=T0*T0+T1*T1 SM=1.0D0/S TM=1.0D0/T IF(SM*TM.EQ.0.0D0)GO TO 20 !NRB IF(S-1.0D+24*T)14,15,15 15 FMON1=G*SQRT(S) IV=V RETURN END C*************************************************************** C SUBROUTINE INJWBK(E,L,J) C C COMPUTES ARRAY D WHICH IS HELD IN COMMON/CJWBK/ AND C USED FOR CALCULATION OF JWBK FUNCTIONS. CNRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MX15N=15*MZCHF) C COMMON/CJWBK/D(MX15N) COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/NRBZED/TZED,LPRTSW C D(J+1)=E C IF(TZED.EQ.0)THEN FK=SQRT(E) D(J+2)=FK IF(L.GT.0)THEN D(J+3)=1./FK C=DBLE(L*(L+1)) D(J+4)=C SC=SQRT(C) D(J+5)=SC D(J+6)=(C+.125)/SC D(J+7)=E*C D(J+12)=6.*E*C D(J+14)=-C*C D(J+15)=-L*1.5707963 ELSE D(J+4)=0.0 D(J+15)=0.0 ENDIF RETURN ENDIF C IF(L.GT.0)GOTO 10 C C CASE OF L.EQ.0 D(J+4)=0. IF(E.EQ.0)GOTO 30 C CASE OF L.EQ.0 AND E.GT.0 FK=SQRT(E) D(J+2)=FK D(J+3)=1./FK GOTO 30 C 10 IF(E.GT.0)GOTO 20 C C CASE OF L.GT.0 AND E.EQ.0 C=DBLE(L*(L+1)) D(J+4)=C SC=SQRT(C) D(J+5)=SC D(J+6)=(C+.125)/SC D(J+13)=6.*C D(J+14)=-C*C GOTO 30 C C CASE OF L.GT.0 AND E.GT.0 20 FK=SQRT(E) D(J+2)=FK D(J+3)=1./FK C=DBLE(L*(L+1)) D(J+4)=C SC=SQRT(C) D(J+5)=SC D(J+6)=(C+.125)/SC A=1.+E*C D(J+7)=A A=3.*A D(J+8)=A-1. D(J+9)=A+1. D(J+10)=FK*C D(J+11)=-4.*E D(J+12)=-9.+2.*A D(J+13)=6.*C D(J+14)=-C*C C C TERM IN ARG GAMMA ETC 30 D(J+15)=ARGC(E,L,AC) C RETURN END C*************************************************************** C SUBROUTINE INTBUT(KK,XX,BUTTLE) C C DETRMINE BUTTLE CORRECTION FROM DARC C IMPLICIT REAL*8(A-H,O-Z) C INCLUDE 'PARAM' C COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) C C FX(X)=((X-X2)/(X1-X2))*((X-X3)/(X1-X3))*Y1+((X-X1)/(X2-X1))* X ((X-X3)/(X2-X3))*Y2+((X-X1)/(X3-X1))*((X-X2)/(X3-X2))*Y3 C MM=NBUTD(KK) C IF (MM.EQ.2) THEN X1=EBUTD(1,KK) X2=EBUTD(2,KK) Y1=CBUTD(1,KK) Y2=CBUTD(2,KK) BUTTLE=(XX-X2)/(X1-X2)*Y1+(XX-X1)/(X2-X1)*Y2 RETURN ENDIF C DO M=1,MM IF(XX.LT.EBUTD(M,KK))GO TO 10 ENDDO II=MM GO TO 20 C 10 CONTINUE II=M 20 CONTINUE C IF (II.EQ.1) THEN X1=EBUTD(1,KK) X2=EBUTD(2,KK) X3=EBUTD(3,KK) Y1=CBUTD(1,KK) Y2=CBUTD(2,KK) Y3=CBUTD(3,KK) BUTTLE=FX(XX) RETURN ENDIF C IF (II.EQ.MM) THEN X1=EBUTD(MM-2,KK) X2=EBUTD(MM-1,KK) X3=EBUTD(MM ,KK) Y1=CBUTD(MM-2,KK) Y2=CBUTD(MM-1,KK) Y3=CBUTD(MM ,KK) BUTTLE=FX(XX) RETURN ENDIF C X1=EBUTD(II-1,KK) X2=EBUTD(II ,KK) X3=EBUTD(II+1,KK) Y1=CBUTD(II-1,KK) Y2=CBUTD(II ,KK) Y3=CBUTD(II+1,KK) BUTTLE=FX(XX) RETURN C END C C*************************************************************** C SUBROUTINE JWBK(R,J,S,SP,C,CP) C C COMPUTES FUNCTIONS S AND C AND THEIR DERIVATIVES SP AND C CP USING IJWBK METHOD. C USES DATA IN ARRAY D WHICH IS HELD IN COMMON/CJWBK/ C AND SHOULD HAVE BEEN COMPUTED IN SUBROUTINE INJWBK. CNRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MX15N=15*MZCHF) C COMMON/CJWBK/D(MX15N) COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/NRBZED/TZED,LPRTSW C C C E=D(J+1) C=D(J+4) X=1./R C IF(TZED.EQ.0)THEN IF(C.EQ.0)THEN FK=D(J+2) WH=FK ET=1.0/SQRT(WH) ETP=0. P=FK*R ZET=FK GO TO 110 ELSE XSQ=X*X W=E-C*XSQ A1=0.0625*(X/W)**3 CC=A1*(D(J+14)*XSQ+D(J+12))*X BB=A1*(6.*D(J+14)*XSQ+4.*D(J+12))*X WH=SQRT(W) Z=R*WH ZSQ=Z*Z P=(ZSQ-0.125-.2083333*C/ZSQ)/Z+D(J+15) S=D(J+5) G=Z P=P+D(J+6)*ATAN2(S,G) GO TO 100 ENDIF ENDIF C IF(C.EQ.0)GOTO 30 IF(E.EQ.0)GOTO 70 C C CASE OF C.GT.0 AND E.GT.0 W=E+X*(2.-C*X) WH=SQRT(W) Z=R*WH FK=D(J+2) RK=R*FK RMC=R-C ALP=Z+RK CK=D(J+10) C COMPUTE PHASE P=Z+D(J+15) C LOG TERM B=FK*ALP IF(B.GT.ACJWBK)GOTO 10 B=-B P=P+ALP*((((.2*B+.25)*B+.33333333)*B+.5)*B+1.) GOTO 20 10 P=P+D(J+3)*LOG(1.+B) C ARCTAN TERM 20 S=D(J+5)*(Z-FK*RMC) G=CK*Z+RMC P=P+D(J+6)*ATAN2(S,G) C CAP. PHI TERM P=P+((5.*RMC/(Z*Z))-(Z*D(J+9)+RK*D(J+8)+CK)/ C (ALP*D(J+7)))/(24.*Z) C COMPUTE AMPLITUDE A1=.0625*(X/W)**3 CC=A1*(((D(J+14)*X+D(J+13))*X+D(J+12))*X+D(J+11)) BB=A1*(((6.*D(J+14)*X+5.*D(J+13))*X+4.*D(J+12)) 1 *X+3.*D(J+11)) GOTO 100 C 30 IF(E.EQ.0)GOTO 60 C C CASE OF C.EQ.0 AND E.GT.0 W=2.*X+E WH=SQRT(W) Z=R*WH FK=D(J+2) RK=R*FK ALP=Z+RK C COMPUTE PHASE P=Z+D(J+15) B=FK*ALP IF(B.GT.ACJWBK)GOTO 40 B=-B P=P+ALP*((((.2*B+.25)*B+.33333333)*B+.5)*B+1.) GOTO 50 40 P=P+D(J+3)*LOG(1.+B) 50 P=P+1/(4.*ALP)+(5.*R/(Z*Z)-2.*(Z+ALP)/ALP)/(24.*Z) C COMPUTE AMPLITUDE A1=.0625*(X/W)**3 CC=A1*(-4.*E-3.*X) BB=-12.*A1*(E+X) GOTO 100 C C CASE OF C.EQ.0 AND E.EQ.0 60 W=2.*X WH=SQRT(W) Z=R*WH P=2.*Z*(1.+.046875*X)+D(J+15) WMQ=1./SQRT(WH) ET=(1.+.0234375*X)*WMQ ZET=(1.-.046875*X)*WH ETP=.25*(1.-.0703125*X)*X*WMQ GOTO 110 C C CASE OF E.EQ.0 AND C.GT.0 70 W=X*(2.-C*X) WH=SQRT(W) Z=R*WH RMC=R-C C COMPUTE PHASE P=2.*Z+D(J+15) S=D(J+5)*Z P=P+D(J+6)*ATAN2(S,RMC) P=P-(3.*R+C)/(24.*(RMC+R)*Z) C COMPUTE AMPLITUDE A1=.0625*(X/W)**3 CC=((D(J+14)*X+D(J+13))*X-3.)*X*A1 BB=((6.*D(J+14)*X+5*D(J+13))*X-12.)*X*A1 C C COMPLETE CALCULATION OF S,SP,C AND CP 100 WMQ=1./SQRT(WH) ET=(1.-CC)*WMQ ETP=(.5*(X*X/W)*(TZED-C*X)*(1.-13.*CC)+X*BB)*WMQ ZET=(1.+2.*CC)*WH 110 SI=SIN(P) CO=COS(P) S=ET*SI C=ET*CO SP=ETP*SI+C*ZET CP=ETP*CO-S*ZET C RETURN END C****************************************************************** C SUBROUTINE LU(A,LA,N,IERR) C C ________________________________________________________ C | | C | LU FACTOR A GENERAL MATRIX WITH PARTIAL PIVOTING | C | | C | INPUT: | C | | C | A --ARRAY CONTAINING MATRIX | C | (LENGTH AT LEAST 3 + N(N+1)) | C | | C | LA --LEADING (ROW) DIMENSION OF ARRAY A | C | | C | N --DIMENSION OF MATRIX STORED IN A | C | | C | OUTPUT: | C | | C | A --LU FACTORED MATRIX | C |________________________________________________________| C REAL*8 A(*),R,S,T,TZERO INTEGER E,F,G,H,I,J,K,L,LA,M,N,O,P,IERR C PARAMETER (TZERO=0.0) C IERR=0 C C ---------------- C |*** PACK A ***| C ---------------- H = LA - N IF ( H .EQ. 0 ) THEN ! CASE DIM A = N*N IERR=1 RETURN ENDIF IF ( H .LT. 0 ) THEN IERR=2 RETURN ENDIF I = 0 K = 1 L = N O = N*N 2 IF ( L .EQ. O ) GO TO 4 I = I + H K = K + N L = L + N DO 3 J = K,L 3 A(J) = A(I+J) GOTO 2 C 4 R = TZERO O = N + 1 P = O + 1 L = 5 + N*P I = -N - 3 C --------------------------------------------- C |*** INSERT PIVOT ROW AND COMPUTE 1-NORM ***| C --------------------------------------------- 10 L = L - O IF ( L .EQ. 4 ) GOTO 30 S = TZERO DO 20 K = 1,N J = L - K T = A(I+J) A(J) = T 20 S = S + ABS(T) IF ( R .LT. S ) R = S I = I + 1 GOTO 10 30 A(1) = 1230 A(2) = N A(3) = R I = 5 - P K = 1 40 I = I + P IF ( K .EQ. N ) GOTO 110 E = N - K M = I + 1 H = I L = I + E C --------------------------------------- C |*** FIND PIVOT AND START ROW SWAP ***| C --------------------------------------- DO 50 J = M,L 50 IF ( ABS(A(J)) .GT. ABS(A(H)) ) H = J G = H - I J = I - K A(J) = G + K T = A(H) A(H) = A(I) A(I) = T K = K + 1 IF ( T .EQ. TZERO ) GOTO 100 C ----------------------------- C |*** COMPUTE MULTIPLIERS ***| C ----------------------------- DO 60 J = M,L 60 A(J) = A(J)/T F = I + E*O 70 J = K + L H = J + G T = A(H) A(H) = A(J) A(J) = T L = E + J IF ( T .EQ. TZERO ) GOTO 90 H = I - J C ------------------------------ C |*** ELIMINATE BY COLUMNS ***| C ------------------------------ M = J + 1 DO 80 J = M,L 80 A(J) = A(J) - T*A(J+H) 90 IF ( L .LT. F ) GOTO 70 GOTO 40 100 A(1) = -1230 GOTO 40 110 IF ( A(I) .EQ. TZERO ) A(1) = -1230 RETURN END C****************************************************************** C SUBROUTINE LUB(A,B,LB,NB,IERR) C ________________________________________________________ C | | C | SOLVE A GENERAL LU FACTORED SYSTEM | C | | C | INPUT: | C | | C | A --LU'S OUTPUT | C | | C | B --RIGHT SIDE (DESTROYED) | C | | C | LB --LEADING (ROW) DIMENSION OF ARRAY B | C | | C | NB --DIMENSION OF MATRIX STORED IN B | C | | C | OUTPUT: | C | | C | B --SOLUTION | C |________________________________________________________| C REAL*8 A(*),B(LB,*),T,TZERO,ONE INTEGER I,J,K,L,M,N,LB,NB,IB,I1,IERR C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C IERR=0 C I1 = NINT(A(1)) IF ( ABS(I1) .NE. 1230 ) THEN IERR=1 !ERROR, MUST FACTOR BEFORE SOLVING RETURN ENDIF C ----------------------------- C |*** FORWARD ELIMINATION ***| C ----------------------------- DO 20 IB = 1,NB N = NINT(A(2)) M = N + 1 J = 4 - M IF ( I1 .LT. 0 ) GOTO 80 K = 1 30 J = J + M IF ( A(J+K) .EQ. TZERO ) GOTO 80 IF ( K .EQ. N ) GOTO 50 L = NINT(A(J)) T = B(L,IB) B(L,IB) = B(K,IB) B(K,IB) = T K = K + 1 IF ( T .EQ. TZERO ) GOTO 30 DO 40 I = K,N 40 B(I,IB) = B(I,IB) - T*A(I+J) GOTO 30 C -------------------------------------- C |*** BACK SUBSTITUTION BY COLUMNS ***| C -------------------------------------- 50 T = B(K,IB)/A(J+K) 60 B(K,IB) = T IF ( K .EQ. 1 ) GO TO 20 K = K - 1 DO 70 I = 1,K 70 B(I,IB) = B(I,IB) - T*A(I+J) J = J - M GOTO 50 C ----------------------------- C |*** COMPUTE NULL VECTOR ***| C ----------------------------- 80 K = 0 90 K = K + 1 J = J + M IF ( A(J+K) .NE. TZERO ) GOTO 90 DO 100 I = 1,N 100 B(I,IB) = TZERO T = ONE GOTO 60 20 CONTINUE RETURN END C****************************************************************** C SUBROUTINE LUBS(A,B,LB,NB,IERR) C ________________________________________________________ C | | C | SOLVE AN LU FACTORED SYMMETRIC SYSTEM WITHOUT PIVOTING | C | | C | INPUT: | C | | C | A --LUS'S OUTPUT | C | | C | B --RIGHT SIDE (DESTROYED) | C | | C | LB --LEADING (ROW) DIMENSION OF ARRAY B | C | | C | NB --DIMENSION OF MATRIX STORED IN B | C | | C | OUTPUT: | C | | C | B --SOLUTION | C |________________________________________________________| C REAL*8 A(*),B(LB,*),T,TZERO,ONE INTEGER I,J,K,L,N,LB,NB,IB,I1,IERR,KB,NB0 C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C IERR=0 NB0=ABS(NB) C I1 = NINT(A(1)) IF ( ABS(I1) .NE. 1233 ) THEN IERR=1 !ERROR, MUST FACTOR BEFORE SOLVING RETURN ENDIF C ----------------------------- C |*** FORWARD ELIMINATION ***| C ----------------------------- DO 20 IB = 1,NB0 KB=1 IF(NB.LT.0)KB=IB N = NINT(A(2)) L = 3 K=1 IF ( I1 .LT. 0 ) GOTO 80 30 IF ( K .EQ. N ) GOTO 50 T = B(K,IB)/A(K+L) J = L L = L + N - K K = K + 1 IF ( T .EQ. TZERO ) GOTO 30 DO 40 I = K,N 40 B(I,IB) = B(I,IB) - T*A(I+J) GOTO 30 C ----------------------------------- C |*** BACK SUBSTITUTION BY ROWS ***| C ----------------------------------- 50 B(N,IB) = B(N,IB)/A(K+L) 60 IF ( K .EQ. KB ) GO TO 20 J = K K = K - 1 L = L + K - N T = B(K,IB) DO 70 I = J,N 70 T = T - B(I,IB)*A(I+L) B(K,IB) = T/A(K+L) GOTO 60 C ----------------------------- C |*** COMPUTE NULL VECTOR ***| C ----------------------------- 80 IF ( A(K+L) .EQ. TZERO ) GOTO 90 L = L + N - K K = K + 1 GOTO 80 90 DO 100 I = 1,N 100 B(I,IB) = TZERO B(K,IB) = ONE GOTO 60 20 CONTINUE IF(NB.LT.0)THEN DO J=1,IB DO I=J,IB B(J,I)=B(I,J) ENDDO ENDDO ENDIF RETURN END C****************************************************************** C SUBROUTINE LUBT(A,B,LB,NB,IERR) C ________________________________________________________ C | | C | SOLVE THE TRANSPOSE OF A GENERAL LU FACTORED SYSTEM | C | | C | INPUT: | C | | C | A --LU'S OUTPUT | C | | C | B --RIGHT SIDE (DESTROYED) | C | | C | LB --LEADING (ROW) DIMENSION OF ARRAY B | C | | C | NB --DIMENSION OF MATRIX STORED IN B | C | | C | OUTPUT: | C | | C | B --SOLUTION | C |________________________________________________________| C REAL*8 A(*),B(LB,*),T,TZERO,ONE INTEGER I,J,K,L,M,N,LB,NB,IB,I1,IERR C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C IERR=0 C I1 = NINT(A(1)) IF ( ABS(I1) .NE. 1230 ) THEN IERR=1 !ERROR, MUST FACTOR BEFORE SOLVING RETURN ENDIF C DO 10 IB = 1,NB N = NINT(A(2)) M = N + 1 IF ( I1 .LT. 0 ) GOTO 80 T = TZERO J = 4 K = 1 C ------------------------- C |*** SKIP OVER ZEROS ***| C ------------------------- 20 IF ( B(K,IB) .NE. TZERO ) GOTO 30 K = K + 1 IF ( K .LE. N ) GOTO 20 GO TO 10 C --------------------------- C |*** FORE SUBSTITUTION ***| C --------------------------- 30 J = J - M + M*K 40 B(K,IB) = (B(K,IB)-T)/A(J+K) IF ( K .EQ. N ) GOTO 60 T = TZERO J = J + M DO 50 I = 1,K 50 T = T + A(I+J)*B(I,IB) K = K + 1 GOTO 40 C --------------------------- C |*** BACK SUBSTITUTION ***| C --------------------------- 60 IF ( K .EQ. 1 ) GO TO 10 J = J - M T = B(K-1,IB) DO 70 I = K,N 70 T = T - B(I,IB)*A(I+J) K = K - 1 I = A(J) B(K,IB) = B(I,IB) B(I,IB) = T GOTO 60 C ----------------------------- C |*** COMPUTE NULL VECTOR ***| C ----------------------------- 80 I = 5 + N + M*N L = M 90 I = I - M - 1 L = L - 1 IF ( A(I) .NE. TZERO ) GOTO 90 K = L J = I - K DO 100 I = 1,N 100 B(I,IB) = TZERO B(K,IB) = ONE 110 IF ( K .EQ. N ) GOTO 60 T = TZERO J = J + M DO 120 I = L,K 120 T = T - A(I+J)*B(I,IB) K = K + 1 B(K,IB) = T/A(J+K) GOTO 110 10 CONTINUE RETURN END C****************************************************************** C SUBROUTINE LUS(A,LA,N,W,IERR) C C ________________________________________________________ C | | C | LU FACTOR A SYMMETRIC MATRIX WITHOUT PIVOTING | C | | C | INPUT: | C | | C | A --ARRAY CONTAINING MATRIX | C | (ONLY THE LOWER HALF NEED BE DEFINED) | C | | C | LA --LEADING (ROW) DIMENSION OF ARRAY A | C | | C | N --MATRIX DIMENSION | C | | C | W --WORK ARRAY WITH LENGTH AT LEAST N | C | | C | OUTPUT: | C | | C | A --INVERSE (IN LOWER HALF ONLY) | C |________________________________________________________| C REAL*8 A(*),W(*),R,S,T INTEGER G,H,I,J,K,L,M,N REAL*8 TZERO C PARAMETER (TZERO=0.0) C IERR=0 C C ---------------- CNRB |*** PACK A ***| C ---------------- H=LA-N I=0 M=0 L=N G=(N*(N+1))/2 2 IF(L.EQ.G)GO TO 4 K=L+1 M=M+1 L=L+N-M I=I+H+M DO J=K,L A(J)=A(I+J) ENDDO GO TO 2 C C ------------------------ C |*** COMPUTE 1-NORM ***| C ------------------------ 4 DO 10 I = 1,N 10 W(I) = TZERO I = -N K = 0 R = TZERO S = TZERO 20 I = I + N - K K = K + 1 J = K S = ABS(A(I+J)) 30 IF ( J .EQ. N ) GOTO 40 J = J + 1 T = ABS(A(I+J)) S = S + T W(J) = W(J) + T GOTO 30 40 S = S + W(K) IF ( R .LT. S ) R = S IF ( K .LT. N ) GOTO 20 J = 3 + (N+N*N)/2 C ----------------------------------- C |*** SHIFT MATRIX DOWN 3 SLOTS ***| C ----------------------------------- 50 A(J) = A(J-3) J = J - 1 IF ( J .GT. 3 ) GOTO 50 A(1) = 1233 A(2) = N A(3) = R H = N K = 4 60 IF ( H .EQ. 1 ) GOTO 90 C -------------------------- C |*** SAVE PIVOT ENTRY ***| C -------------------------- S = A(K) K = K + H G = K H = H - 1 M = H IF ( S .EQ. TZERO ) GOTO 100 J = 0 70 J = J - M M = M - 1 L = G + M T = A(G+J)/S C --------------------------- C |*** ELIMINATE BY ROWS ***| C --------------------------- DO 80 I = G,L 80 A(I) = A(I) - T*A(I+J) G = L + 1 IF ( M .GT. 0 ) GOTO 70 GOTO 60 90 IF ( A(K) .NE. TZERO ) RETURN A(1) = -1233 RETURN 100 A(1) = -1233 GOTO 60 END C********************************************************** C SUBROUTINE MESH C C CALCULATES ENERGY MESH FOR CASE OF IMESH=2 C OR IMESH=-S WHERE S=2*TOTAL SPIN +1 C C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,KAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENATK(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR) X,IWD(MZTAR),IWT COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW DIMENSION ENAT(MZTAR) C C C PARAMETERS READ FOR IMESH=2 C *************************** C C DQN INTERVAL FOR EFFECTIVE QUANTUM NUMBER C C QNMAX LARGEST ALLOWED VALUE OF EFFECTIVE QUANTUM NUMBER C C EMIN LOWEST VALUE OF ETOT C C EMAX HIGHEST VALUE OF ETOT C C DEOPEN INTERVAL IN ETOT FOR ALL CHANNELS OPEN C C ALL ENERGIES ARE Z-SCALED AND RELATIVE TO GROUND ENERGY C C IRDEC RADIATIVE DECAYS INCLUDED FOR IRDEC=1 C WRITE(6,600) WRITE(6,605)DQN,QNMAX,EMIN,EMAX,DEOPEN C C CASE OF IMESH = -TOTAL SPIN (ADDED 9.06.88) C C NOTE CHANGES TO /CINPUT/ C NAST REPLACED BY KAST C ENAT .. .. ENATK C FORM NEW VALUE NAST FOR USE ONLY BY SUBROUTINE MESH WHERE C NAST=NO. OF STATES WHICH CAN FORM CHANNELS FOR TOTAL C SPIN GIVEN BY ABS(IMESH) C ENAT=CORRESPONDING ARRAY OF TARGET ENERGIES C NOTE SPECIAL TREATMENT IF DEGENERATE LEVELS HAVE BEEN COMBINED C IN SUBROUTINE SCALE1 C IF IMESH IS .GT. 0 NAST, ENAT COPIED FROM KAST, ENATK C IF (IMESH .LT. 0)THEN ISP=ABS(IMESH) ISP1=ISP-1 ISP2=ISP+1 IMESH=2 NAST=0 IF (NASTD .EQ. 0)THEN DO 1 I=1,KAST ISATI=ISAT(I) IF (ISATI .GE. ISP1 .AND. ISATI .LE. ISP2) THEN NAST=NAST+1 ENAT(NAST)=ENATK(I) END IF 1 CONTINUE ELSE N2=0 DO 2 ID=1,KAST N1=N2+1 N2=NLEV(ID)+N1-1 DO 3 IN=N1,N2 ISATN=ISAT(IN) IF (ISATN .GE. ISP1 .AND. ISATN .LE. ISP2) THEN NAST=NAST+1 ENAT(NAST)=ENATK(ID) GO TO 2 END IF 3 CONTINUE 2 CONTINUE END IF ELSE NAST=KAST DO 4 I=1,KAST ENAT(I)=ENATK(I) 4 CONTINUE END IF C WRITE(6,'('' NAST='',I4)') NAST C WRITE(6,'(1X,5F12.6)')(ENAT(I),I=1,NAST) C C CASE OF EMIN.GE.ENAT(NAST) (ADDED 9.12.87) IF(EMIN.GE.ENAT(NAST))THEN F=EMAX-EMIN IF(F.LT.0)THEN IE=0 GOTO 400 ENDIF J=1+F/DEOPEN F=F/DBLE(J) E=EMIN IE=1 EMESH(IE)=E IF(IE+J.GT.MZMSH)GOTO 500 DO 5 K=1,J IE=IE+1 E=E+F 5 EMESH(IE)=E GOTO 400 ENDIF C C INITIALISATIONS QNINT=1./DQN SE=QNMAX**(-2) E=MAX(EMIN,-SE) C E=MAX(EMIN,ENAT(1)-SE) !ENAT(1) USUALLY ZERO.... IE=0 IF(EMAX.LT.E)GOTO 400 C C FIND NC1, LOWEST LEVEL ABOVE EMIN DO 10 N=1,NAST IF(EMIN.GE.ENAT(N))GOTO 10 NC1=N GOTO 20 10 CONTINUE IE=IE+1 EMESH(IE)=EMIN WRITE(6,650) WRITE(6,640)IE,EMESH(IE) GOTO 300 20 WRITE(6,610)NC1 C C FIND NC2, HIGHEST LEVEL BELOW EMAX DO 30 N=NAST,1,-1 IF(ENAT(N).GT.EMAX)GOTO 30 NC2=N GOTO 40 30 CONTINUE GOTO 50 40 WRITE(6,620)NC2 C C RPS-BRAKE - WE'93MAY2: C IF(IOPT1.LE.9) GO TO 50 IF(ENAT(NC1)-SE.GE.EMIN) GO TO 50 WRITE(6,605) EMIN=ENAT(NC1)+.000001 C C ENERGIES IN RANGE EMIN TO ENAT(NC2) C ************************************ C 50 IF(IPRINT.GT.0)WRITE(6,625) EN=-1 DO 160 N=NC1,NC2 ENM=EN EN=ENAT(N) IF(EN.EQ.ENM)GOTO 160 C C RANGE UP TO (EN-SE) IF((EN-SE).GT.E)THEN F=1./SQRT(EN-E) D=.999*(QNMAX-F) J=2+D*QNINT D=D/DBLE(J-1) IF(IPRINT.GT.0)WRITE(6,660) IF((IE+J).GT.MZMSH)GOTO 500 DO 110 K=1,J IE=IE+1 EMESH(IE)=EN-F**(-2) IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,N,F 110 F=F+D E=EN-QNMAX**(-2) ENDIF C C RANGE UP TO EN C...FIND NEXT HIGHER THRESHOLD DO 120 M=N+1,NAST IF(ENAT(M).NE.EN)THEN C---- MM=M C---- EM=ENAT(M) GOTO 140 ENDIF 120 CONTINUE C... NO NEXT THRESHOLD, USE DEOPEN 125 F=.999*(ENAT(N)-E) J=2+F/DEOPEN F=F/DBLE(J-1) IF(IPRINT.GT.0)WRITE(6,690) IF((IE+J).GT.MZMSH)GOTO 500 DO 130 K=1,J IE=IE+1 EMESH(IE)=E IF(IPRINT.GT.0)WRITE(6,680)IE,E,N 130 E=E+F E=ENAT(NAST) GOTO 300 C... USING NEXT HIGHER THRESHOLD 140 F1=1./SQRT(EM-E) F2=1./SQRT(EM-EN) D=.999*(F2-F1) C---- C MODIFICATION FOR NEAR-DEGENERATE CHANNELS (KAB,JAN94) IF(F2.GT.QNMAX) THEN D=QNMAX-F1-DQN IF(D.LT.0.0) GO TO 155 ENDIF C---- J=2+D*QNINT D=D/DBLE(J-1) F=F1 IF(IPRINT.GT.0)WRITE(6,660) IF((IE+J).GT.MZMSH)GOTO 500 DO 150 K=1,J IE=IE+1 EMESH(IE)=EM-F**(-2) IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F 150 F=F+D IF(IPRINT.GT.0)WRITE(6,660) E=EN C---- IF(F2.LE.QNMAX) GO TO 160 E=EM-QNMAX**(-2) 155 MM=MM+1 IF(MM.GT.NAST) GO TO 125 EM=ENAT(MM) GO TO 140 C---- 160 CONTINUE C C C ENERGIES IN RANGE ENAT(NC2) TO EMAX C *********************************** C C FIND NEXT HIGHER THRESHOLD DO 210 M=NC2+1,NAST IF(ENAT(M).NE.EN)THEN C---- MM=M C---- EM=ENAT(M) GOTO 220 ENDIF 210 CONTINUE GOTO 280 C C RANGE UP TO MIN(EMAX,(EM-SE)) 220 IF((EM-SE).GT.E)THEN IF((EM-SE).GT.EMAX)THEN C... CASE OF EMAX.LT.(EM-SE) F1=1./SQRT(EM-E) F2=1./SQRT(EM-EMAX) D=F2-F1 J=2+D*QNINT D=D/DBLE(J-1) F=F1-D IF(IPRINT.GT.0)WRITE(6,660) IF((IE+J).GT.MZMSH)GOTO 500 DO 230 K=1,J F=F+D IE=IE+1 EMESH(IE)=EM-F**(-2) 230 IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F IF(IPRINT.GT.0)WRITE(6,660) GOTO 400 ELSE C... CASE OF EMAX.GT.(EM-SE) F=1./SQRT(EM-E) D=.999*(QNMAX-F) J=2+D*QNINT D=D/DBLE(J-1) F=F-D IF(IPRINT.GT.0)WRITE(6,660) IF((IE+J).GT.MZMSH)GOTO 500 DO 240 K=1,J IE=IE+1 F=F+D EMESH(IE)=EM-F**(-2) 240 IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F E=EM-QNMAX**(-2) ENDIF ENDIF C C FIND NEXT HIGHER THRESHOLD C C---- N=MM C---- C N=M EN=EM DO 250 M=N+1,NAST IF(ENAT(M).NE.EN)THEN EM=ENAT(M) MM=M GOTO 260 ENDIF 250 CONTINUE GOTO 280 260 M=MM F1=1./SQRT(EM-E) F2=1./SQRT(EM-EMAX) D=F2-F1 C---- IF(F2.GT.QNMAX) THEN D=QNMAX-F1-DQN IF(D.LT.0.0) GO TO 275 ENDIF C---- J=2+D*QNINT D=D/DBLE(J-1) F=F1-D IF(IPRINT.GT.0)WRITE(6,660) IF((IE+J).GT.MZMSH)GOTO 500 DO 270 K=1,J F=F+D IE=IE+1 EMESH(IE)=EM-F**(-2) 270 IF(IPRINT.GT.0)WRITE(6,630)IE,EMESH(IE),N,M,F IF(IPRINT.GT.0)WRITE(6,660) C GOTO 400 C---- IF(F2.LE.QNMAX) GO TO 400 E=EM-QNMAX**(-2) 275 MM=MM+1 IF(MM.GT.NAST) GO TO 280 EM=ENAT(MM) GO TO 260 C---- C C C UP TO EMAX USING DEOPEN 280 F=EMAX-E J=2+F/DEOPEN F=F/DBLE(J-1) E=E-F IF(IPRINT.GT.0)WRITE(6,690) IF((IE+J).GT.MZMSH)GOTO 500 DO 290 K=1,J E=E+F IE=IE+1 EMESH(IE)=E 290 IF(IPRINT.GT.0)WRITE(6,680)IE,E,N GOTO 400 C C C C ALL CHANNELS OPEN C ***************** C 300 IF(IPRINT.GT.0)WRITE(6,650) J=1 IF(IE+J.GT.MZMSH)GOTO 500 IE=IE+1 E=ENAT(NAST) EMESH(IE)=E IF(IPRINT.GT.0)WRITE(6,640)IE,E F=EMAX-E J=1+F/DEOPEN F=F/DBLE(J) IF((IE+J).GT.MZMSH)GOTO 500 DO 310 K=1,J E=E+F IE=IE+1 EMESH(IE)=E 310 IF(IPRINT.GT.0)WRITE(6,640)IE,E C C TASK COMPLETED C ************** C 400 MXE=IE WRITE(6,670)MXE RETURN C 500 WRITE(6,675) MXE=IE+J WRITE(6,670)MXE STOP C C FORMATS 600 FORMAT(//1X,70('*')//20X,'ENERGY MESH'/20X,11('*')/) 605 FORMAT(//' DQN = ',F10.6/' QNMAX = ',F10.6/ + ' EMIN = ',F10.6/' EMAX = ',F10.6/' DEOPEN = ',F10.6//) 610 FORMAT(' LOWEST LEVEL ABOVE EMIN, NC1 = ',I3) 620 FORMAT(' HIGHEST LEVEL BELOW EMAX, NC2 = ',I3) 625 FORMAT(/' VALUES OF - IE, E = EMESH(IE), N = LOWEST' + ,' LEVEL ABOVE E,'/15X,'M = LEVEL USED FOR EFFECTIVE', +' QUANTUM NUMBER'/15X,'AND FNU = EFFECTIVE QUANTUM NUMBER'/ + /3X,'IE',4X,'EMESH',17X,'N',4X,'M',4X,'FNU'/) 630 FORMAT(I5,F12.6,10X,2I5,F12.6) 640 FORMAT(I5,F12.6) 650 FORMAT(/31X,'ALL OPEN'/) 660 FORMAT() 670 FORMAT(/' NUMBER OF ENERGIES, MXE = ',I5/) 675 FORMAT(///10X,64('*')/10X, +'NUMBER OF ENERGIES EXCEEDS MAXIMUM OF MZMSH ALLOWED BY' +,' DIMENSIONS' /10X,64('*')//) 680 FORMAT(I5,F12.6,10X,I5) 690 FORMAT(/36X,'USING DEOPEN') C END C*************************************************************** C SUBROUTINE MQDTK C C NRB: C CALCULATION OF K-PHYS FROM K-UNPHYS IN QDT, ALL CHANNELS OPEN. C STGF VERSION HAS NO DAMPING SINCE THIS WOULD MAKE K COMPLEX. C EITHER USE STGFDAMP OR GO VIA THE S/KHI-MATRIX ROUTE (SR.MQDTS). C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZDEG*MZDEG) PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X,IPAR(MZTAR),NEWAR COMMON/CEN/ETOT,MXE,NWT,NZ C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF) COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) C DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF) X ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF) DIMENSION IPIV(MZDEG) C EQUIVALENCE (P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC) C C PI=ACOS(-ONE) C IF(IOMSW.LT.0)THEN NCC=NCHCL ELSE NCC=NCHF-NCHOP DO N=1,NCC ICHCL(N)=NCHOP+N ENDDO ENDIF C IF(NCC.GT.MZDEG)THEN WRITE(6,610)NCC STOP 'INCREASE MZDEG' ENDIF C C INITIALIZE KCC C DO N2=1,NCC DO N1=1,NCC A(N1,N2)=P(ICHCL(N1),ICHCL(N2)) ENDDO ENDDO C C A-FDEC (FDEC=-TAN(PI*NU)) C DO N=1,NCC PINU=FKNU(ICHCL(N))*PI FDEC=-TAN(PINU) IF(IOMIT(ICHCL(N)).LT.0)FDEC=-FDEC A(N,N)=A(N,N)-FDEC ENDDO C DO N=1,NCC IF(IOMIT(ICHCL(N)).GT.0)A(N,N)=ONE ENDDO C C INITIALIZE KCO C DO N2=1,NCHOP DO N1=1,NCC IF(FKNU(ICHCL(N1)).LE.NCUTOFF)THEN B(N1,N2)=P(ICHCL(N1),N2) ELSE B(N1,N2)=TZERO ENDIF ENDDO ENDDO C CSTRTNBL CNBL CALL LUS(A,MZCHF,NCC,WORK,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,600) CNBL STOP 'ERROR IN LUS' CNBL END IF CNBL CALL LUBS(A,B,MZCHF,NCHOP,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601) CNBL STOP 'ERROR IN LUBS' CNBL END IF CENDNBL C CSTRTBL CALL DSYTRF('L',NCC,A,MZCHF,IPIV,WORK,LWORK,INFO) IF (INFO.NE.0) THEN WRITE(6,602) INFO STOP 'FAILURE IN BLAS ROUTINE DSYTRF' ENDIF CALL DSYTRS('L',NCC,NCHOP,A,MZCHF,IPIV,B,MZCHF,INFO) IF (INFO.NE.0) THEN WRITE(6,603) INFO STOP 'FAILURE IN BLAS ROUTINE DSYTRS' ENDIF CENDBL C C C CLOSE-OFF (SOME) OPEN CHANNELS TO FORM PHYSICAL K-MATRIX C (THERE MAY BE NO SUBSEQUENT CALL TO SQDT) C DO K=1,NCC KI=ICHCL(K) IF(FKNU(KI).LE.NCUTOFF)THEN DO I=1,NCHOP POLD(I,K)=-P(I,KI) ENDDO ELSE DO I=1,NCHOP POLD(I,K)=TZERO ENDDO ENDIF ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL RK(I,J)=P(I,J) CNBL ENDDO CNBL DO K=1,NCC CNBL DO I=1,J CNBL RK(I,J)=RK(I,J)+POLD(I,K)*B(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO C C SYMMETRIZE C CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL RK(J,I)=RK(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL DO J=1,NCHOP DO I=1,NCHOP RK(I,J)=P(I,J) ENDDO ENDDO C CALL DGEMM('N','N',NCHOP,NCHOP,NCC,ONE,POLD,MZCHF X ,B,MZCHF,ONE,RK,MZCHF) C CENDBL C C C STORE ORIGINAL P,Q C DO J=1,NCHF DO I=1,NCHF POLD(I,J)=P(I,J) QOLD(I,J)=Q(I,J) ENDDO ENDDO C C RETURN CN600 FORMAT(' SR.MQDTK: LUS RETURNED WITH INFO =',I6) CN601 FORMAT(' SR.MQDTK: LUBS RETURNED WITH INFO =',I6) 602 FORMAT(//10X,10('*'),' SR.MQDTK: DSYTRF RETURNED WITH INFO =',I6) 603 FORMAT(//10X,10('*'),' SR.MQDTK: DSYTRS RETURNED WITH INFO =',I6) 610 FORMAT(//10X,10('*'),' SR.MQDTK: NUMBER OF MQDT CLOSED', X ' CHANNELS, NCC = ',I4/20X,' LARGER THAN DIMENSION', X ' VALUE OF DEG = MZDEG'//) END C*************************************************************** C SUBROUTINE MQDTS C C NRB: C CALCULATION OF OMEGA FROM KHI-MX IN QDT, ALL CHANNELS OPEN. C OPTIONAL (TYPE-I) RADIATION DAMPING - BELL & SEATON OR HICKMAN-ROBICHEAUX. C DR N CUT-OFF AT NCUTOFF; EXCITATION IS THEN **UNDAMPED** ABOVE NCUTOFF. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZDEG*MZDEG) PARAMETER (ZERO=(0.0,0.0)) PARAMETER (ZONE=(1.0,0.0)) PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (QUART=0.25) PARAMETER (BIG=150.0) C CHARACTER ELAS*3 C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X,IPAR(MZTAR),NEWAR COMMON/CEN/ETOT,MXE,NWT,NZ C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF) COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG) CBL X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG) COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) COMMON/NRBZED/TZED,LPRTSW C DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF) X ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF) DIMENSION ZKHICO(MZDEG,MZCHF),ZKHI(MZCHF) DIMENSION IPIV(MZDEG) C EQUIVALENCE (P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC) EQUIVALENCE (ZKHICO,ZKHIOC) C C IF(IOMSW.LT.0)THEN NCC=NCHCL ELSE NCC=NCHF-NCHOP DO N=1,NCC ICHCL(N)=NCHOP+N ENDDO ENDIF C IF(NCC.GT.MZDEG)THEN WRITE(6,610)NCC STOP 'INCREASE MZDEG' ENDIF C PI=ACOS(-ONE) TPI=TWO*PI CONST=TPI IF(TZED.GT.TZERO)CONST=CONST/DBLE((NZED-NELC)**2) IONE=1 IF(ELAS.EQ.'YES')IONE=0 C C INITIALIZE KHICC C DO N2=1,NCC DO N1=1,NCC ZKHICC(N1,N2)=DCMPLX(P(ICHCL(N1),ICHCL(N2)) X ,Q(ICHCL(N1),ICHCL(N2))) ENDDO ENDDO C C ZKHICC-ZFDEC C ITARGN=0 DO N=1,NCC NNN=ICHCL(N) C C RADIATIVE DECAYS; RECALCULATE ARDEC (DEPENDS ON ETOT) IF NECESS. C IF(IRDEC*NEWAR.GT.0.AND..NOT.QDT X .AND.ITARG(NNN).NE.ITARGN)THEN ITARGN=ITARG(NNN) KVEC=((ITARG(NNN)-IONE)*(ITARG(NNN)-1-IONE))/2 ARDEC(ITARG(NNN))=TZERO DO JLOOP=1,ITARG(NNN)-1 KVEC=KVEC+1 IF(ETOT-(ENAT(ITARG(NNN))-ENAT(JLOOP)).LE.ENAT(1))THEN ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))+ARAD(KVEC) ENDIF ENDDO ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))*CONST ENDIF C TPINU=FKNU(NNN)*TPI IF(IOMIT(NNN).LT.0)TPINU=-TPINU IF(IRDEC.EQ.0.OR.FKNU(NNN).GT.NCUTOFF)THEN C NONE ZFDEC=EXP(DCMPLX(TZERO,-TPINU)) ELSEIF(IRDEC.EQ.1)THEN C BELL & SEATON T=ARDEC(ITARG(NNN))*(FKNU(NNN)**3)/TWO T=MIN(T,BIG) FDEC=EXP(T) ZFDEC=FDEC*EXP(DCMPLX(TZERO,-TPINU)) ELSEIF(IRDEC.EQ.2)THEN C HICKMAN-ROBICHEAUX TR=ONE/FKNU(NNN)**2 TI=-ARDEC(ITARG(NNN))/TPI ZFKNU=DCMPLX(ONE,TZERO)/SQRT(DCMPLX(TR,TI)) C IF(IQDT.EQ.2)THEN CK Z=DCMPLX(PI,TZERO) CK ZFDEC=-TAN(Z*ZFKNU) C ELSE Z=DCMPLX(TZERO,-TPI)*ZFKNU TR=DBLE(Z) TR=MIN(TR,BIG) TI=DIMAG(Z) Z=DCMPLX(TR,TI) IF(IOMIT(NNN).LT.0)Z=-Z !?? ZFDEC=EXP(Z) C ENDIF ENDIF ZKHICC(N,N)=ZKHICC(N,N)-ZFDEC ENDDO C DO N=1,NCC IF(IOMIT(ICHCL(N)).GT.0)ZKHICC(N,N)=ZONE ENDDO C C INITIALIZE KHICO C DO N2=1,NCHOP DO N1=1,NCC CK IF(FKNU(ICHCL(N1)).LE.NCUTOFF)THEN ZKHICO(N1,N2)=DCMPLX(P(ICHCL(N1),N2),Q(ICHCL(N1),N2)) CK ELSE CK ZKHICO(N1,N2)=TZERO CK ENDIF ENDDO ENDDO C CSTRTNBL CNBL CALL ZLUS(ZKHICC,MZDEG,NCC,WORK,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,600) CNBL STOP 'ERROR IN ZLUS' CNBL END IF CNBL CALL ZLUBS(ZKHICC,ZKHICO,MZDEG,NCHOP,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601) CNBL STOP 'ERROR IN ZLUBS' CNBL END IF CENDNBL C CSTRTBL CALL ZSYTRF('L',NCC,ZKHICC,MZDEG,IPIV,ZWORK,MWORK,INFO) IF (INFO.NE.0) THEN WRITE(6,602) INFO STOP ENDIF CALL ZSYTRS('L',NCC,NCHOP,ZKHICC,MZDEG,IPIV,ZKHICO,MZDEG,INFO) IF (INFO.NE.0) THEN WRITE(6,603) INFO STOP ENDIF CENDBL C C C CLOSE-OFF ALL OPEN CHANNELS IF THERE IS TO BE NO SUBSEQUENT CALL C TO SQDT C IF(.NOT.QDT)THEN C C INITIALIZE DR PROBABILITY C DO I=1,NCHOP PDR(I)=ONE ENDDO C C FORM PHYSICAL S-MATRIX C DO J=1,NCHOP DO I=1,J ZKHI(I)=DCMPLX(P(I,J),Q(I,J)) ENDDO DO K=1,NCC CK IF(FKNU(ICHCL(K)).LE.NCUTOFF) DO I=1,J ZKHI(I)=ZKHI(I)- X DCMPLX(P(I,ICHCL(K)),Q(I,ICHCL(K)))*ZKHICO(K,J) ENDDO ENDDO DO I=1,J PP=ZKHI(I)*CONJG(ZKHI(I)) PDR(J)=PDR(J)-PP PDR(I)=PDR(I)-PP IF(I.EQ.J)THEN PDR(I)=PDR(I)+PP ZKHI(I)=ZKHI(I)-DCMPLX(ONE,TZERO) ENDIF RK(I,J)=ZKHI(I)*CONJG(ZKHI(I)) ENDDO ENDDO C C SYMMETRIZE AND ADJUST WEIGHTING C T=QUART*NWT DO J=1,NCHOP PDR(J)=PDR(J)*T DO I=1,J RK(I,J)=T*RK(I,J) RK(J,I)=RK(I,J) ENDDO ENDDO C C ELSE C C STORE ORIGINAL P,Q C DO J=1,NCHF DO I=1,NCHF POLD(I,J)=P(I,J) QOLD(I,J)=Q(I,J) ENDDO ENDDO C C NOW JUST CONTRACT C DO J=1,NCHOP DO I=1,J ZKHI(I)=DCMPLX(POLD(I,J),QOLD(I,J)) ENDDO DO K=1,NCC CK IF(FKNU(NCHOP+K).LE.NCUTOFF)THEN DO I=1,J ZKHI(I)=ZKHI(I)- X DCMPLX(POLD(I,ICHCL(K)),QOLD(I,ICHCL(K)))*ZKHICO(K,J) ENDDO CK ENDIF ENDDO DO I=1,J P(I,J)=DBLE(ZKHI(I)) P(J,I)=P(I,J) Q(I,J)=DIMAG(ZKHI(I)) Q(J,I)=Q(I,J) ENDDO ENDDO C ENDIF C RETURN CN600 FORMAT(' SR.MQDTS: ZLUS RETURNED WITH INFO =',I6) CN601 FORMAT(' SR.MQDTS: ZLUBS RETURNED WITH INFO =',I6) 602 FORMAT(//10X,10('*'),' SR. MQDTS: ZSYTRF RETURNED WITH INFO =',I6) 603 FORMAT(//10X,10('*'),' SR. MQDTS: ZSYTRS RETURNED WITH INFO =',I6) 610 FORMAT(//10X,10('*'),' SR. MQDTS: NUMBER OF MQDT CLOSED', X ' CHANNELS, NCC = ',I4/20X,' LARGER THAN DIMENSION', X ' VALUE OF DEG = MZDEG'//) END C*************************************************************** C SUBROUTINE NUMS(E,C,R1,HP,N1,N2,F,FP,FST) C C NUMEROV INTEGRATION OF COULOMB FUNCTION F. C INTEGRATION FROM POINT N1 TO N2. C INTERVAL HP IS POSITIVE. C INPUT FUNCTIONS F,FP AT N1 WHERE FP IS R-DERIVATIVE. C OUTPUT FUNCTIONS F,FP AT N2 AND C INTERMEDIATE POINTS STORED IN FST(I) FOR I.LE. MZPTS CNRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (THREE=3.0) PARAMETER (FOUR=4.0) PARAMETER (SIX=6.0) PARAMETER (SEVEN=7.0) PARAMETER (TEN=10.0) PARAMETER (TWELVE=12.0) PARAMETER (P1=ONE/30.) PARAMETER (P2=ONE/40.) PARAMETER (P3=SEVEN/15.) PARAMETER (P4=TWO/15.) PARAMETER (P5=ONE/360.) PARAMETER (P6=ONE/20.) PARAMETER (P7=ONE/120.) PARAMETER (P8=ONE/TWELVE) C COMMON/NRBZED/TZED,LPRTSW DIMENSION FST(MZPTS) C V(X)=EQ+X*(Q2*TZED-X*CQ) C N21=N2-N1 C F1=F F1P=FP IF(N1.LE.MZPTS)FST(N1)=F1 IF(N21.EQ.0)RETURN C IP=IABS(N21) INC=N21/IP H=HP*INC K=N1 IP=IP-1 C C FUNCTIONS AT K=(N1+INC) C Q=H*H EQ=E*Q Q2=TWO*Q CQ=C*Q C X1=ONE/R1 CX=C*X1 HX=H*X1 A1=-TWO*HX*HX*H U1P=A1*(ONE*tzed-CX) A1=-A1*HX U1PP=A1*(TWO*tzed-THREE*CX) A1=-A1*HX*SIX U1PPP=A1*(ONE*tzed-TWO*CX) U1=V(X1) C R2=R1+H X2=ONE/R2 U2=V(X2) C A2=ONE+U2*P1 B1=ONE+U1*(P2*U1-P3)-P4*U1P-P2*U1PP 1 +P5*(FOUR*U1*U1P-U1PPP) C1=H*(ONE+U1*(P5*U1-P4) 1 -P6*U1P-P7*U1PP) C F2=(B1*F1+C1*F1P)/A2 K=K+INC IF(K.LE.MZPTS)FST(K)=F2 C C U3=U2 U2=U1 F3=F2 F2=F1 X3=X2 IF(IP.EQ.0)GOTO 20 C C CONTINUE INTEGRATION C EQ=EQ*P8 Q2=Q2*P8 CQ=CQ*P8 U2=U2*P8 U3=U3*P8 R3=R2 C DO M=1,IP U1=U2 U2=U3 F1=F2 F2=F3 R3=R3+H X3=ONE/R3 U3=V(X3) D3=ONE/(ONE+U3) D2=(TWO-TEN*U2)*D3 D1=(ONE+U1)*D3 F3=D2*F2-D1*F1 K=K+INC IF(K.LE.MZPTS)FST(K)=F3 ENDDO C U2=TWELVE*U2 U3=TWELVE*U3 EQ=TWELVE*EQ Q2=TWELVE*Q2 CQ=TWELVE*CQ C C CALCULATE FINAL DERIVATIVE C 20 H=-H CX=C*X3 HX=H*X3 A1=-TWO*HX*HX*H U3P=A1*(tzed*ONE-CX) A1=-A1*HX U3PP=A1*(tzed*TWO-THREE*CX) A1=-A1*HX*SIX U3PPP=A1*(tzed*ONE-TWO*CX) A2=ONE+U2*P1 B3=ONE+U3*(P2*U3-P3)-P4*U3P-P2*U3PP 1 +P5*(FOUR*U3*U3P-U3PPP) C3=H*(ONE+U3*(P5*U3-P4)-P6*U3P 1 -P7*U3PP) F3P=(A2*F2-B3*F3)/C3 C F=F3 FP=F3P C RETURN END C*************************************************************** C SUBROUTINE NUMSC(E,C,R1,HP,N1,N2,SP,CP,I) C C NRB: C NUMEROV INTEGRATION OF COULOMB FUNCTIONS S AND C. C INTEGRATION FROM POINT N1 TO N2. C INTERVAL HP IS POSITIVE. C I/O FUNCTIONS IN ARRAYS FS,FC C I/O DERIVATIVES IN SP,CP (NOT IN ARRAYS) CNRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (THREE=3.0) PARAMETER (FOUR=4.0) PARAMETER (SIX=6.0) PARAMETER (SEVEN=7.0) PARAMETER (TEN=10.0) PARAMETER (TWELVE=12.0) PARAMETER (P1=ONE/30.) PARAMETER (P2=ONE/40.) PARAMETER (P3=SEVEN/15.) PARAMETER (P4=TWO/15.) PARAMETER (P5=ONE/360.) PARAMETER (P6=ONE/20.) PARAMETER (P7=ONE/120.) PARAMETER (P8=ONE/TWELVE) C COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF) 1 ,FCP(MZCHF) COMMON/NRBZED/TZED,LPRTSW C V(X)=EQ+X*(Q2*TZED-X*CQ) C N21=N2-N1 C IF(N21.EQ.0)RETURN C IP=IABS(N21) INC=N21/IP H=HP*INC K=N1 IP=IP-1 K0=MIN(K,MZPTS) C F1=FS(K0,I) F1P=SP G1=FC(K0,I) G1P=CP C C FUNCTIONS AT K=(N1+INC) C Q=H*H EQ=E*Q Q2=TWO*Q CQ=C*Q C X1=ONE/R1 CX=C*X1 HX=H*X1 A1=-TWO*HX*HX*H U1P=A1*(ONE*tzed-CX) A1=-A1*HX U1PP=A1*(TWO*tzed-THREE*CX) A1=-A1*HX*SIX U1PPP=A1*(ONE*tzed-TWO*CX) U1=V(X1) C R2=R1+H X2=ONE/R2 U2=V(X2) C A2=ONE+U2*P1 B1=ONE+U1*(P2*U1-P3)-P4*U1P-P2*U1PP 1 +P5*(FOUR*U1*U1P-U1PPP) C1=H*(ONE+U1*(P5*U1-P4) 1 -P6*U1P-P7*U1PP) C F2=(B1*F1+C1*F1P)/A2 G2=(B1*G1+C1*G1P)/A2 K=K+INC IF(K.LE.MZPTS)THEN FS(K,I)=F2 FC(K,I)=G2 ENDIF C U3=U2 U2=U1 F3=F2 F2=F1 G3=G2 G2=G1 X3=X2 IF(IP.EQ.0)GOTO 20 C C CONTINUE INTEGRATION C EQ=EQ*P8 Q2=Q2*P8 CQ=CQ*P8 U2=U2*P8 U3=U3*P8 R3=R2 C DO M=1,IP U1=U2 U2=U3 F1=F2 F2=F3 G1=G2 G2=G3 R3=R3+H X3=ONE/R3 U3=V(X3) D3=ONE/(ONE+U3) D2=(TWO-TEN*U2)*D3 D1=(ONE+U1)*D3 F3=D2*F2-D1*F1 G3=D2*G2-D1*G1 K=K+INC IF(K.LE.MZPTS)THEN FS(K,I)=F3 FC(K,I)=G3 ENDIF ENDDO C U2=TWELVE*U2 U3=TWELVE*U3 EQ=TWELVE*EQ Q2=TWELVE*Q2 CQ=TWELVE*CQ C C CALCULATE FINAL DERIVATIVE C 20 H=-H CX=C*X3 HX=H*X3 A1=-TWO*HX*HX*H U3P=A1*(ONE*tzed-CX) A1=-A1*HX U3PP=A1*(TWO*tzed-THREE*CX) A1=-A1*HX*SIX U3PPP=A1*(ONE*tzed-TWO*CX) A2=ONE+U2*P1 B3=ONE+U3*(P2*U3-P3)-P4*U3P-P2*U3PP 1 +P5*(FOUR*U3*U3P-U3PPP) C3=H*(ONE+U3*(P5*U3-P4)-P6*U3P 1 -P7*U3PP) F3P=(A2*F2-B3*F3)/C3 G3P=(A2*G2-B3*G3)/C3 C SP=F3P CP=G3P C RETURN END C*************************************************************** C SUBROUTINE NUMT(E,C,R1,HP,N1,N2,I) C C NUMEROV INTEGRATION OF COULOMB FUNCTIONS. C THE INTERVAL HP IS POSITIVE. C INTEGRATION FROM TABULAR POINT N1 TO TABULAR POINT N2. C FUNCTIONS THETA,THETP STORED IN ARRAYS FS,FSP C FUNCTIONS THETAD,THETADP STORED IN ARRAYS FC,FCP C STARTS WITH FUNCTIONS AND DERIVATIVES AT N1 STORED IN FS, FSP, FC, FCP C CALCULATES FUNCTIONS AT ALL POINTS TO N2 AND THE DERIVATIVE AT THE C POINT N2. C NRB: C MINOR MODS FOR MQDT OPERATION. C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (THREE=3.0) PARAMETER (FOUR=4.0) PARAMETER (SIX=6.0) PARAMETER (SEVEN=7.0) PARAMETER (TEN=10.0) PARAMETER (TWELVE=12.0) PARAMETER (P1=ONE/30.) PARAMETER (P2=ONE/40.) PARAMETER (P3=SEVEN/15.) PARAMETER (P4=TWO/15.) PARAMETER (P5=ONE/360.) PARAMETER (P6=ONE/20.) PARAMETER (P7=ONE/120.) PARAMETER (P8=ONE/TWELVE) C COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF) 1 ,FCP(MZCHF) COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF) COMMON/NRBDD2/FSP2(MZCHF),FCP2(MZCHF),IFDD2 COMMON/NRBZED/TZED,LPRTSW C V(X)=EQ+X*(Q2*TZED-X*CQ) C N21=ABS(N2)-N1 C C RENORMALISE FOR CASE OF N2.EQ.N1 C IF(N21.NE.0)GOTO 5 W=FS(N1,I)*FCP(I)-FSP(I)*FC(N1,I) IF(W.le.tzero)then if(w.lt.tzero)then w1=tzero else RETURN endif else W1=ONE/SQRT(W) endif FS(N1,I)=FS(N1,I)*W1 FC(N1,I)=FC(N1,I)*W1 FSP(I)=FSP(I)*W1 FCP(I)=FCP(I)*W1 FSP2(I)=FSP(I) FCP2(I)=FCP(I) BB(I,2)=BB(I,2)*W1 NM=MSUM(I) DO M=3,NM BB(I,M)=BB(I,M)*W1 BG(I,M)=BG(I,M)*W1 ENDDO RETURN C C INTEGRATIONS FOR N2.NE.N1 C 5 IP=IABS(N21) IS=N21/IP H=HP*IS K=N1 IP=IP-1 C F1=FS(N1,I) F1P=FSP(I) G1=FC(N1,I) G1P=FCP(I) C C FUNCTIONS AT K=(N1+IS) C Q=H*H EQ=E*Q Q2=TWO*Q CQ=C*Q C C Q=0.0 !FOR XI SOLUTION C X1=ONE/R1 CX=C*X1 HX=H*X1 A1=-TWO*HX*HX*H U1P=A1*(ONE*tzed-CX) A1=-A1*HX U1PP=A1*(TWO*tzed-THREE*CX) A1=-A1*HX*SIX U1PPP=A1*(ONE*tzed-TWO*CX) U1=V(X1) C R2=R1+H X2=ONE/R2 U2=V(X2) C A2=ONE+U2*P1 B1=ONE+U1*(P2*U1-P3)-P4*U1P-P2*U1PP 1 +P5*(FOUR*U1*U1P-U1PPP) C1=H*(ONE+U1*(P5*U1-P4) 1 -P6*U1P-P7*U1PP) B2=P1*Q D1=Q*(-P3+P2*U1+P5*U1P) !FOR XI DELETE P2*U1 E1=H*Q*(-P4+P5*U1) C F2=(B1*F1+C1*F1P)/A2 G2=(B1*G1+C1*G1P+D1*F1+E1*F1P-B2*F2)/A2 K=K+IS FS(K,I)=F2 FC(K,I)=G2 C C U3=U2 U2=U1 F3=F2 F2=F1 G3=G2 G2=G1 X3=X2 IF(IP.EQ.0)GOTO 20 C C CONTINUE INTEGRATION C EQ=EQ*P8 Q2=Q2*P8 CQ=CQ*P8 U2=U2*P8 U3=U3*P8 Q=Q*P8 R3=R2 C DO M=1,IP U1=U2 U2=U3 F1=F2 F2=F3 G1=G2 G2=G3 R3=R3+H X3=ONE/R3 U3=V(X3) D3=ONE/(ONE+U3) D2=(TWO-TEN*U2)*D3 D1=(ONE+U1)*D3 F3=D2*F2-D1*F1 G3=D2*G2-D1*G1-Q*D3*(F3+TEN*F2+F1) K=K+IS FC(K,I)=G3 FS(K,I)=F3 ENDDO C U2=TWELVE*U2 U3=TWELVE*U3 EQ=TWELVE*EQ Q2=TWELVE*Q2 CQ=TWELVE*CQ Q=TWELVE*Q C C CALCULATE FINAL DERIVATIVE C 20 H=-H CX=C*X3 HX=H*X3 A1=-TWO*HX*HX*H U3P=A1*(ONE*tzed-CX) A1=-A1*HX U3PP=A1*(TWO*tzed-THREE*CX) A1=-A1*HX*SIX U3PPP=A1*(ONE*tzed-TWO*CX) A2=ONE+U2*P1 B3=ONE+U3*(P2*U3-P3)-P4*U3P-P2*U3PP 1 +P5*(FOUR*U3*U3P-U3PPP) C3=H*(ONE+U3*(P5*U3-P4)-P6*U3P 1 -P7*U3PP) B2=P1*Q D3=Q*(-P3+P2*U3+P5*U3P) !FOR XI DELETE P2*U3 E3=H*Q*(-P4+P5*U3) F3P=(A2*F2-B3*F3)/C3 G3P=(A2*G2-B3*G3+B2*F2-D3*F3-E3*F3P)/C3 C C RE-NORMALISE CLOSED-CHANNEL FUNCTIONS C IF(N1.GT.ABS(N2))THEN AMAX=ONE/MAX(ABS(F3),ABS(G3),ABS(F3P),ABS(G3P)) AF3=F3*AMAX AG3=G3*AMAX AF3P=F3P*AMAX AG3P=G3P*AMAX W1=AF3*AG3P-AF3P*AG3 if(w1.le.tzero)then w1=tzero else W1=AMAX/SQRT(W1) endif FSP2(I)=FSP(I)*W1 FCP2(I)=FCP(I)*W1 FSP(I)=F3P*W1 FCP(I)=G3P*W1 ELSE FSP2(I)=F3P FCP2(I)=G3P RETURN ENDIF IPMX=IP+2 IF(N2.LT.0)IPMX=MZPTS DO J=1,IPMX FS(J,I)=FS(J,I)*W1 FC(J,I)=FC(J,I)*W1 ENDDO C C RE-NORMALISE COEFFICIENTS C BB(I,2)=BB(I,2)*W1 NM=MSUM(I) DO M=3,NM BB(I,M)=BB(I,M)*W1 BG(I,M)=BG(I,M)*W1 ENDDO C RETURN END C*************************************************************** C SUBROUTINE OCINT(IOMTT,NCHOP) C C C OPEN-CLOSED: C CALCULATES S INTEGRALS USING LAGUERRE QUADRATURE C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT C INCLUDE 'PARAM' C COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) X ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1 COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBLMX/LMX C DIMENSION ZAI(30),ZPI(30),ZTAJ(30),ZTDAJ(30),ZTPJ(30),ZR(30) X,IOMTT(MZCHF) C C NCHOP1=NCHOP+1 C X=RTWO B=SQRT(2.*X) ZB=(0.,1.)/B DO I=1,NCHOP IF(IOMTT(I).EQ.0)THEN DO J=NCHOP1,NCHF IF(IOMTT(J).EQ.0)THEN LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN BIJ=BW(J,I) NLAG=2*LIJ+LACC NLAG=MIN(NLAG,10) ZFK=DCMPLX(FKNU(I),1./FKNU(J)) ZG=.5*ZFK*B C ZA1=1./ZG ZA2=1.+ZG ZA2=ZA2*ZA2 ZA3=ZB*ZG C NS=NLAG/2 M=NS*(NS-1) N1=M+1 N2=M+NLAG NP = 0 DO N=N1,N2 NP = NP + 1 U=XLAG(N) ZET=ZA1*(SQRT(ZA2+ZA3*U)-1.) ZMUM=-.5*ZET/(ZB*(1.+ZET*ZG)) ZET=ZET*ZET ZR(NP)=ZET*X ENDDO CALL ZPHIN(I,ZR,N1,N2,ZAI,ZPI) CALL ZTHETAS(J,ZA1,ZA2,ZA3,ZB,ZG,N1,N2,ZTAJ,ZTDAJ,ZTPJ) C ZS3=0. ZSD3=0. NP = 0 DO N=N1,N2 NP = NP + 1 U=XLAG(N) ZET=ZA1*(SQRT(ZA2+ZA3*U)-1.) ZMUM=-.5*ZET/(ZB*(1.+ZET*ZG)) ZB1=(ZR(NP)**(-LIJ))*WLAG(N)*ZMUM* X EXP((0.,1.)*ZPI(NP)+ZTPJ(NP)+U)*ZAI(NP) ZS3=ZS3+ZB1*ZTAJ(NP) ZSD3=ZSD3+ZB1*ZTDAJ(NP) ENDDO ZS3=ZS3*BIJ ZSD3=ZSD3*BIJ ACC(J,I)=ACC(J,I)+DBLE(ZSD3) ACS(J,I)=ACS(J,I)+DIMAG(ZSD3) ASC(J,I)=ASC(J,I)+DBLE(ZS3) ASS(J,I)=ASS(J,I)+DIMAG(ZS3) ENDIF ENDIF ENDDO ENDIF ENDDO RETURN END C*************************************************************** C SUBROUTINE OMEG(IE,EMESH,MXE,ENAT,NAST,OMEGA,NOMWRT,IONE) C C USE MEMORY FOR SUMMING OMEGA, WITH OVERFLOW ONTO DISK C (ADAPTED BY NRB, FROM KAB, FOR ELASTIC TRANSITIONS C AND USE OF NOMT=ABS(NOMWRT) TO REDUCE I/O) C IE = 0 TO INITIALIZE C IE .GT.0 TO RETRIEVE OMEGA FOR ENERGY IE C IF NOMWRT .LT. 0 THEN RECOVER -NOMWRT NON-ZERO OMEGAS FOR C FINAL WRITE RUNNING DOWN THE COLUMNS C IF NOMWRT .GT. 0 THEN RECOVER NOMWRT OMEGAS (INC ZEROES) FOR C FINAL WRITE RUNNING ALONG THE ROWS C (EXC ZEROES CAN BE IMPLEMENTED BY SWITCHING JJJJ BELOW) C EMESH(MXE) = ENERGY MESH C ENAT(NAST) = EXCITATION THRESHOLDS: NEEDED TO MINIMISE STORAGE C OMEGA(NOMT)= RETURNS OMEGA MATRIX AS AN ARRAY C /MEMORY/ STORAGE IN OMEM(MXOM) C MPOS(IE) = LAST POSITION OCCUPIED IN OMEM AT ENERGY IE, OR C IF MPOS.LT.0 = -RECORD NUMBER ON DA SCRATCH FILE C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) C PARAMETER (MZKIL= 0) C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (MXOM=MZMEG*1000000+MZKIL*1000) C COMMON/MEMORY/OMEM(MXOM+1),MPOS(0:MZMSH),ITMAX,JTMAX COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR) X ,OMST(MXTST),ITOP C DIMENSION EMESH(MXE),ENAT(NAST),OMEGA(MXTST) C NOMT=ABS(NOMWRT) N=0 IF(NOMWRT.GT.0)THEN DO I=1,NAST DO J=I+IONE,NAST N=N+1 OMEGA(N)=TZERO ENDDO IF(N.GE.NOMT)GO TO 20 ENDDO I=NAST ENDIF IF(NOMWRT.LT.0)THEN DO J=1+IONE,NAST DO I=1,J-IONE N=N+1 OMEGA(N)=TZERO ENDDO IF(N.GE.NOMT)GO TO 20 ENDDO J=NAST ENDIF C C INITIALISE C 20 IF(IE.EQ.0) THEN IF(NOMWRT.GT.0)THEN ITMAX=I JTMAX=NAST ELSE ITMAX=NAST JTMAX=J ENDIF MPOS(0)=0 NPOS=0 NREC=0 NST=1 DO I=1,MXE 4 IF(NST.LE.NAST)THEN IF(EMESH(I).GE.ENAT(NST)) THEN NP=MIN(NST,ITMAX,JTMAX) NTRAN=(NP*(NP+1-2*IONE))/2 IF(NST.GT.ITMAX)NTRAN=NTRAN+(NST-ITMAX)*ITMAX NST=NST+1 GO TO 4 ENDIF ENDIF NPOS=NPOS+NTRAN IF(NPOS.LE.MXOM) THEN MPOS(I)=NPOS ELSE NREC=NREC+1 MPOS(I)=-NREC ENDIF ENDDO C MMM=MIN(NPOS,MXOM) DO N=1,MMM OMEM(N)=TZERO ENDDO C IF(NREC.GT.0) THEN MMEG=NPOS/1000000 MMEG=MMEG+1 NPOS=MXOM WRITE(6,100)MMEG NLEN=MIN(NOMT,(NAST*(NAST+1-2*IONE))/2) OPEN(1,STATUS='SCRATCH',ACCESS='DIRECT',RECL=MZREC*NLEN, X FORM='UNFORMATTED') DO MREC=1,NREC CALL OMWRIT(OMEGA,NLEN,MREC) ENDDO ENDIF C WRITE(6,101)MXOM,NPOS C ELSE C C FINALLY, RETRIEVE AND RETURN OMEGA C IF(MPOS(IE).EQ.0) THEN DO N=1,NOMT OMEGA(N)=TZERO ENDDO GO TO 25 ENDIF C JJJJ=NAST !INC ZEROES NOMWRT.GT.0 C JJJJ=JTMAX !EXC ZEROES NOMWRT.GT.0 C IF(MPOS(IE).GT.0) THEN M=MPOS(IE-1) K=0 DO JT=1+IONE,JJJJ IP=MIN(JT-IONE,ITMAX) DO IT=1,IP M=M+1 IF(NOMWRT.GT.0)THEN K=JT+1-IONE+(JJJJ+1-IONE)*(IT-1)-(IT*(IT+1))/2 ELSE K=K+1 ENDIF OMEGA(K)=OMEM(M) ENDDO IF(M.GE.MPOS(IE)) GO TO 25 ENDDO ELSE MREC=-MPOS(IE) CALL OMREAD(OMEGA,NOMT,MREC) IF(NOMWRT.GT.0)THEN DO I=1,NOMT OMST(I)=OMEGA(I) ENDDO M=0 DO JT=1+IONE,JJJJ IP=MIN(JT-IONE,ITMAX) DO IT=1,IP M=M+1 K=JT+1-IONE+(JJJJ+1-IONE)*(IT-1)-(IT*(IT+1))/2 OMEGA(K)=OMST(M) ENDDO IF(M.GE.NOMT) GO TO 25 ENDDO ENDIF ENDIF ENDIF C C 25 RETURN C 100 FORMAT(//' ****OPENING SCRATCH FILE, COULD AVOID' X ,' BY INCREASING MZMEG TO:',I4//) 101 FORMAT(//' MXOM =', I9,' USED =',I9//) END C C************************************************************************ SUBROUTINE OMREAD(OMEGA,NOMT,IE) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION OMEGA(NOMT) C READ(1,REC=IE)OMEGA C RETURN END C************************************************************************ SUBROUTINE OMWRIT(OMEGA,NOMT,IE) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION OMEGA(NOMT) C WRITE(1,REC=IE)OMEGA C RETURN END C*************************************************************** C SUBROUTINE OOINT(IOMTT,NCHOP) C C C OPEN-OPEN: C CALCULATES P AND Q INTEGRALS USING LAGUERRE AND/OR LEGENDRE QUADRATURE C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT C INCLUDE 'PARAM' C COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) X ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHPP,NCHPP1 COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBLMX/LMX C DIMENSION ZAI(30),ZPI(30),ZAJ(30),ZPJ(30),ZR(30) DIMENSION ZAI1(30),ZPI1(30),ZAJ1(30),ZPJ1(30),ZR1(30) DIMENSION ZAI2(30),ZPI2(30),ZAJ2(30),ZPJ2(30),ZR2(30) DIMENSION IOMTT(MZCHF) C C NCHOP1=NCHOP+1 C X=RTWO B=SQRT(8.*X) ZB=(0.,1.)/B DO I=1,NCHOP IF(IOMTT(I).EQ.0)THEN DO J=I,NCHOP IF(IOMTT(J).EQ.0)THEN LIJ=LAMP(J,I) IF(LIJ.NE.1.AND.LIJ.LE.LMX+1) THEN NLAG=2*LIJ+LACC NLAG=MIN(NLAG,10) BIJ=BW(J,I) NS=NLAG/2 M=NS*(NS-1) N1=M+1 N2=M+NLAG C FK=FKNU(I)+FKNU(J) G=FK*.125*B IF(FK.GT.0)THEN GM=1./G G2=1.+G G2=G2*G2 ENDIF NP = 0 DO N=N1,N2 NP = NP + 1 U=XLAG(N) A1=FK*U IF(A1.LE.ACZP)THEN ZET=1.+.5*ZB*U ELSE ZET=(SQRT(G2+ZB*G*U)-1.)*GM ENDIF ZMU=-8.*ZB*(G+1./ZET) ZET=ZET*ZET ZR(NP)=ZET*X ENDDO CALL ZPHIN(I,ZR,N1,N2,ZAI,ZPI) CALL ZPHIN(J,ZR,N1,N2,ZAJ,ZPJ) NP = 0 ZP3= 0. DO N=N1,N2 NP = NP + 1 U=XLAG(N) A1=FK*U IF(A1.LE.ACZP)THEN ZET=1.+.5*ZB*U ELSE ZET=(SQRT(G2+ZB*G*U)-1.)*GM ENDIF ZMU=-8.*ZB*(G+1./ZET) ZP3=ZP3+ZAI(NP)*ZAJ(NP)* X EXP((0.,1.)*(ZPI(NP)+ZPJ(NP))+U)* X (ZR(NP)**(-LIJ))*WLAG(N)/ZMU ENDDO ZP3 = ZP3*BIJ ALP=RTWO*(FKNU(I)-FKNU(J)) IF(ALP.GE.2.) THEN FK=FKNU(I)-FKNU(J) ZMUM=(0.,1.)/FK C NP = 0 C DO N=N1,N2 NP = NP + 1 U=XLAG(N) ZR(NP)=X+U*ZMUM ENDDO CALL ZPHIN(I,ZR,N1,N2,ZAI,ZPI) CALL ZPHIN(J,ZR,N1,N2,ZAJ,ZPJ) ZQ3=0. NP = 0 DO N=N1,N2 NP = NP + 1 U=XLAG(N) ZQ3=ZQ3+ZAI(NP)*ZAJ(NP)* X EXP((0.,1.)*(ZPI(NP)-ZPJ(NP))+U)* X (ZR(NP)**(-LIJ))*WLAG(N) ENDDO ZQ3=ZQ3*ZMUM*BIJ ELSE FK=FKNU(I)-FKNU(J) IF(FK.EQ.0.)THEN ZA=1. ELSE ZA=(0.,1.)/(1.+FK*X) ENDIF C NS=NLAG/2 J1=(NS*(NS-1))/2 J2=J1+NS J1=J1+1 JP = 0 DO JJ=J1,J2 JP = JP + 1 V=XLEG(JJ) ZR1(JP)=X*(1.+ZA*(1.-V)/(1.+V)) ZR2(JP)=X*(1.+ZA*(1.+V)/(1.-V)) ENDDO CALL ZPHIN(I,ZR1,J1,J2,ZAI1,ZPI1) CALL ZPHIN(J,ZR1,J1,J2,ZAJ1,ZPJ1) CALL ZPHIN(I,ZR2,J1,J2,ZAI2,ZPI2) CALL ZPHIN(J,ZR2,J1,J2,ZAJ2,ZPJ2) C ZQ3=0. JP = 0 DO JJ=J1,J2 JP = JP + 1 V=XLEG(JJ) ZF=ZAI1(JP)*ZAJ1(JP)* X EXP((0.,1.)*(ZPI1(JP)-ZPJ1(JP)))* X (ZR1(JP)**(-LIJ))/(1.+V)**2 ZF=ZF+ZAI2(JP)*ZAJ2(JP)* X EXP((0.,1.)*(ZPI2(JP)-ZPJ2(JP)))* X (ZR2(JP)**(-LIJ))/(1.-V)**2 ZQ3=ZQ3+ZF*WLEG(JJ) ENDDO ZQ3=2.*X*ZA*ZQ3*BIJ ENDIF ASS(J,I)=ASS(J,I)+.5*DBLE(ZQ3-ZP3) ACS(J,I)=ACS(J,I)+.5*DIMAG(ZP3+ZQ3) ASC(J,I)=ASC(J,I)+.5*DIMAG(ZP3-ZQ3) ACC(J,I)=ACC(J,I)+.5*DBLE(ZP3+ZQ3) ENDIF ENDIF ENDDO ENDIF ENDDO C RETURN END C*************************************************************** C SUBROUTINE OUTJJ(IOPT1,LRGLAM,MXE) C C TO SUPPLY NON-K-MATRIX DATA FOR JAJOM ON UNITS 22,23 (FORMATTED). C C IOPT1=0 FOR INITIALISATION, FOR EACH S L PI SYMMETRY C =10 FOR JAJOM WITH ALGEBRAIC RECOUPLING WITHOUT,(WITH TOP-UP) C =12 FOR JAJOM WITH TERM COUPLING (COUPLING COEFFS READ IN STGF) C LRGLAM .GT. 0 FOR TOP-UP C MXE = TOTAL NUMBER OF ENERGIES, HELD IN /CMESH/ C /CINPUT/ CONTAINS BASIC COLLISION DATA. C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) C PARAMETER(JOUT=22,IOJM=5,NOX=0,IFACT=60,NTC=MZTAR*MZTAR) C CHARACTER*1 PARITY(0:1),LSPECT(0:6) C COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X ,IPAR(MZTAR),NEWAR COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH C DIMENSION ILT(MZSLP),IST(MZSLP) DIMENSION FJ(MZLP1) CTCC DIMENSION IDF(NTC),ITF(NTC),FCF(NTC) C DATA LSPECT/'S','P','D','F','G','H','I'/, PARITY/'e','o'/ DATA J2F,N2F/2*0/ DATA ISLM/0/, KCOUNT/0/ C SAVE ISLM,KCOUNT,ILT,IST C AZ=MAX(NZED-NELC,1) AZAZ=AZ*AZ C C INITIALIZE ... C ISLM = COUNTER ON ILT,IST SYMMETRIES C KCOUNT = COUNTER ON MATRIX ELEMENTS OUTPUT ON UNIT 11 C IPAR(NAST) = TARGET PARITIES C IF(IOPT1.EQ.0) THEN DO 1 I=1,ISLM IF(LRGL2.EQ.ILT(I).AND.NSPN2.EQ.IST(I)) GO TO 2 1 CONTINUE ISLM=ISLM+1 ILT(ISLM)=LRGL2 IST(ISLM)=NSPN2 2 N=1 NCHOP=0 D=0.0 IF(IMESH.EQ.2) D=1./QNMAX**2 DO 5 I=1,MXE 4 IF(EMESH(I).GT.ENAT(N)-D.AND.N.LT.NAST) THEN N=N+1 NCHOP=NCHOP+NCONAT(N) NUM=NCHOP*(NCHOP+1) GO TO 4 ENDIF KCOUNT=KCOUNT+NUM 5 CONTINUE RETURN ENDIF C C OPEN UNITS JOUT(=22),23,25 C IF(MXE.EQ.0.OR.ISLM.EQ.0.OR.KCOUNT.EQ.0) GO TO 42 C OPEN(JOUT,FILE='JJDAT',STATUS='UNKNOWN') REWIND(JOUT) C CSPEC NOT NEEDED BY CURRENT IP JAJOM AND THIS STGF CSPEC OPEN(23,FILE='JOMSPECS',STATUS='UNKNOWN') CSPEC REWIND(23) C CTCC READ DIRECTLY FROM TCC.DAT IN JAJOM CTCC OPEN(25,FILE='TCC.DAT',STATUS='UNKNOWN') CTCC REWIND(25) C C FIND NAOP = NUMBER OF STATES ENERGETICALLY ALLOWED; C MNSPN,MXSPN = MINIMUM,MAXIMUM TARGET STATE 2S+1; C JCHAN= NUMBER OF CHANNELS IN INTERMEDIATE COUPLING. C JCHAN=0 NAOP=0 MNSPN=999 MXSPN=0 DELE=0. IF (IMESH.EQ.2) DELE=1/(QNMAX*QNMAX) DO 9 I=1,NAST IF(EMESH(MXE).LT.ENAT(I)-DELE) GO TO 6 NAOP=I MNSPN=MIN(MNSPN,ISAT(I)) MXSPN=MAX(MXSPN,ISAT(I)) K=2*LAT(I)+1 JHIGH=K+ISAT(I)-1 JLOW=ABS(K-ISAT(I))+1 9 JCHAN=JCHAN + ((JHIGH+JLOW)/2) * (1+(JHIGH-JLOW)/2) C C WRITE OUT JAJOM INPUT C CARDS A1-A2 C 6 IF(NAOP.EQ.0) GO TO 42 IREFL=1 ITOP=0 IF(LRGLAM.GT.0) ITOP=1 MAT=2 IONQ=NZED-NELC IPART=0 K=NAOP IF(IRDEC.GT.0) K=1 DO 7 I=1,K 7 ARDEC(I)=0.0 WRITE(JOUT,'(2X,I2,2I3,10I5)') * NZED,NELC,NAOP,IREFL,8,7,ITOP,MAT,IONQ,IPART,IRDEC,IMESH DO 8 I=1,NAOP K=ISAT(I) IF(IPAR(I).EQ.1) K=-K 8 WRITE(JOUT,1002) I, K,LAT(I),ENAT(I)*AZAZ, * ISAT(I),LSPECT(LAT(I)),PARITY(IPAR(I)),ARDEC(I) C C CARDS B1-B4 C WRITE(JOUT,1004) IMESH,DEOPEN,QNMAX,DQN,'CHI',IOPT1, *LRANG2,ISLM,NOX,(I,I=0,LRANG2-1) WRITE(JOUT,'(18I4)') (IST(I),ILT(I),I=1,ISLM) C C CARDS C1-C4 C WRITE(JOUT,2003) NZED,NELC,RA,LAMAX,KCOUNT, * MXE,MXE IF(IMESH.EQ.1)THEN DE=EMESH(2)-EMESH(1) WRITE(JOUT,2004)1,EMESH(1)*AZAZ,0,DE*AZAZ ELSE WRITE(JOUT,2004)(K,EMESH(K)*AZAZ,K=1,MXE) ENDIF WRITE(JOUT,2005) EMESH(MXE)*AZAZ C C FIND ALLOWED TOTAL J VALUES (FJ(JJFSL)) C JJFSL=0 J2=MOD(MNSPN,2) 22 IZ=MNSPN IF(IZ.EQ.2) IZ=0 23 L2=ABS(J2-IZ) 24 DO 25 I=1,ISLM IF(IZ.EQ.IST(I)-1 .AND.L2.EQ.2*ILT(I)) GO TO 26 25 CONTINUE GO TO 27 26 L2=L2+2 IF(L2.LE.J2+IZ) GO TO 24 IZ=IZ+2 IF(IZ.LE.MXSPN) GO TO 23 JJFSL=JJFSL+1 FJ(JJFSL)=0.5*J2 J2=J2+2 GO TO 22 C C CARDS E1-E2 C 27 IFIT=JJFSL+1 JPUN=NAOP+1 WRITE(JOUT,'(5H F.S.,2I5,I3)') JJFSL,IFIT,JPUN IF(JJFSL.EQ.0) THEN WRITE(6,*)' NO J VALUES -- SYMMETRIES SLPI INCOMPLETE' GO TO 41 ENDIF WRITE(JOUT,'(7X,13F5.1)') (FJ(J),J=1,JJFSL) C CTCC CARDS F1-F2: TERM COUPLING COEFFICIENTS TO BE READ BY JAJOM C ELSE LET JAJOM READ DIRECTLY FROM TCC.DAT FILE. C WRITE(6,*) C BUT SKIP TERM LIST CTCC READ(25,*,END=32) NTER CTCC IF(NTER.GT.0) READ(25,'(I4)') (K,I=1,NTER) CTCC 31 READ(25,1106)J2F,N2F CTCC 32 CONTINUE C WRITE(JOUT,1106) J2F,N2F C CTCC IF (N2F.EQ.0) GO TO 33 CTCC READ(25,1107) (ITF(I),IDF(I),FCF(I),I=1,N2F) CTCC WRITE(JOUT,1107) (ITF(I),IDF(I),FCF(I),I=1,N2F) CTCC WRITE(6,1108)N2F,J2F CTCC GO TO 31 CTCC 33 CONTINUE C WRITE(JOUT,1106) NOX,NOX 41 WRITE(JOUT,'("ENDDATA")') C C FINALISE OUTPUT TO JAJOM, WRITE PROCESSOR DATA FOR JAJOM ONTO 23 CSPEC ONLY NEEDED BY JAJOM NOT SETUP TO READ CHI-MX FROM IP STGF C CSPEC NEST=MIN(1+(KCOUNT-1)/1000,9999) CSPEC WRITE(23,1313) NEST,MXE,JCHAN,NAOP,IOJM,IFACT,NAST CSPEC WRITE(6,1313) NEST,MXE,JCHAN,NAOP,IOJM,IFACT,NAST C NOTE PARAMETRICALLY FIXED IOJM AND IFACT. C 42 WRITE(6,1099) MXE,NAOP,ISLM,KCOUNT,'CHI',JCHAN CLOSE(JOUT) C CSPEC CLOSE(23) CTCC CLOSE(25) C RETURN C 1002 FORMAT(3I4,F20.8,I3,2A1,1P,E16.6) 1004 FORMAT(' IMESH=',I2,' DE=',F8.6,' QNMAX=',F7.3,' DQN=',F8.6,1X, *A3,'-MTRX OPT=',I2/3I5/(20I3)) 1099 FORMAT(/I9,' ENERGIES',I6,' STATES',I6,' SL-SYMMETRIES'/I9,1X, * A3,'-MATRIX ELEMENTS (TOTAL)',I8,' PAIR-COUPLING CHANNELS'/) 1106 FORMAT(7X,I3,I5) CTCC 1107 FORMAT(5(I3,I2,F9.6)) CTCC 1108 FORMAT(I5,' TERM COUPLING COEFFICIENTS PASSED ON FOR 2J =',I3) CSPEC 1313 FORMAT(' 11 12 13 -1'/6I5,' R CDC',I5,' JOMSPECS') 2003 FORMAT(' Z=',I2,' N=',I2,' RA=',F8.4,' LAMAX=',I2,' COUNT=',I8/ * 2I5) 2004 FORMAT(4(I5,F13.7)) 2005 FORMAT(1PE13.6,'EEEE') END C*************************************************************** C SUBROUTINE PETFSC C C NRB; C PERTURB S AND C WHERE F=S+C*K C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (RMONE=-1.0) PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) C COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF) COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) C C C CALCULATE PERTURBED FUNCTIONS C C OPEN-OPEN DO J=1,NCHOP DO I=1,NCHOP CS(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J) CSP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J) CC(I,J)=S(I)*ACC(I,J)-C(I)*ASC(I,J) CCP(I,J)=SP(I)*ACC(I,J)-CP(I)*ASC(I,J) CSPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J) CCPP(I,J)=SPP(I)*ACC(I,J)-CPP(I)*ASC(I,J) DS(I,J)=CS(I,J) DC(I,J)=CC(I,J) DSP(I,J)=CSP(I,J) DCP(I,J)=CCP(I,J) ENDDO ENDDO DO I=1,NCHOP CS(I,I)=CS(I,I)+S(I) CSP(I,I)=CSP(I,I)+SP(I) CC(I,I)=CC(I,I)+C(I) CCP(I,I)=CCP(I,I)+CP(I) CSPP(I,I)=CSPP(I,I)+SPP(I) CCPP(I,I)=CCPP(I,I)+CPP(I) ENDDO C CLOSED-OPEN IF(NCHOP.EQ.NCHF)GOTO 270 DO J=1,NCHOP DO I=NCHOP1,NCHF CS(I,J)=C(I)*ASS(I,J)-S(I)*ACS(I,J) CSP(I,J)=CP(I)*ASS(I,J)-SP(I)*ACS(I,J) CC(I,J)=C(I)*ASC(I,J)-S(I)*ACC(I,J) CCP(I,J)=CP(I)*ASC(I,J)-SP(I)*ACC(I,J) CSPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J) CCPP(I,J)=CPP(I)*ASC(I,J)-SPP(I)*ACC(I,J) DS(I,J)=CS(I,J) DC(I,J)=CC(I,J) DSP(I,J)=CSP(I,J) DCP(I,J)=CCP(I,J) ENDDO ENDDO C OPEN-CLOSED DO J=NCHOP1,NCHF DO I=1,NCHOP CC(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J) CCP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J) CCPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J) DC(I,J)=CC(I,J) DCP(I,J)=CCP(I,J) ENDDO ENDDO C CLOSED- CLOSED DO J=NCHOP1,NCHF DO I=NCHOP1,NCHF CC(I,J)=C(I)*ASS(I,J)-S(I)*ACS(I,J) CCP(I,J)=CP(I)*ASS(I,J)-SP(I)*ACS(I,J) CCPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J) DC(I,J)=CC(I,J) DCP(I,J)=CCP(I,J) ENDDO ENDDO DO I=NCHOP1,NCHF CC(I,I)=CC(I,I)+S(I) CCP(I,I)=CCP(I,I)+SP(I) ENDDO C 270 CONTINUE IF(NCHHYB.GT.0)THEN DO N=1,NCHHYB I=ICHHYB(N) CC(I,I)=S(I) !SINCE ALPHA=0 CCP(I,I)=SP(I) CS(I,I)=TZERO CSP(I,I)=TZERO ENDDO ENDIF C C CALCULATE MATRICES A AND B C DO J=1,NCHF DO I=1,NCHF A(I,J)=CC(I,J) ENDDO CSTRTNBL CNBL DO K=1,NCHF CNBL DO I=1,NCHF CNBL A(I,J)=A(I,J)-RMAT(I,K)*CCP(K,J) CNBL ENDDO CNBL ENDDO CENDNBL ENDDO DO J=1,NCHOP DO I=1,NCHF B(I,J)=CS(I,J) ENDDO CSTRTNBL CNBL DO K=1,NCHF CNBL DO I=1,NCHF CNBL B(I,J)=B(I,J)-RMAT(I,K)*CSP(K,J) CNBL ENDDO CNBL ENDDO CENDNBL ENDDO CSTRTBL CALL DGEMM('N','N',NCHF,NCHF,NCHF,RMONE,RMAT,MZCHF,CCP,MZCHF, X ONE,A,MZCHF) CALL DGEMM('N','N',NCHF,NCHOP,NCHF,RMONE,RMAT,MZCHF,CSP,MZCHF, X ONE,B,MZCHF) CENDBL C RETURN END C*************************************************************** C SUBROUTINE PETKMX C C NRB: C EVALUATE PERTURBATION TO K-MATRIX (K->K+Y, Y=-) SO (UNDAMPED) C S-MATRIX IS UNITARY, IMPORTANT FOR DR. C (INCLUDES KB'S REWRITE OF DO LOOPS) C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZDEG*MZDEG) PARAMETER (TWO=2.0) PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) C COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) COMMON/NRBZED/TZED,LPRTSW C DIMENSION TEMP3(MZCHF,MZCHF),TEMP4(MZCHF,MZCHF) DIMENSION Y(MZCHF,MZCHF),IPIV(MZCHF) C EQUIVALENCE (Y,RMAT),(TEMP4,DCP) EQUIVALENCE (WORK,TEMP3) C C C Y=-(F/V/F), F HAS K-MATRIX NORMALISATION, C V IS PERTURBATION POTENTIAL C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL Y(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCHOP CNBL DO I=1,NCHOP CNBL Y(I,J)=Y(I,J)+ACC(I,K)*RK(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,ACC,MZCHF,RK,MZCHF, X TZERO,Y,MZCHF) CENDBL C DO J=1,NCHOP DO I=1,NCHOP ACC(I,J)=Y(I,J) Y(I,J)=ASS(I,J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL Y(I,J)=Y(I,J)+RK(I,K)*ACS(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL Y(I,J)=Y(I,J)+ASC(I,K)*RK(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL Y(I,J)=Y(I,J)+RK(I,K)*ACC(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL (DSYMM A LITTLE SLOWER, SO IF NOT USING SYMM MEMORY ELSEWISE) CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,ACS,MZCHF, X ONE,Y,MZCHF) CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,ASC,MZCHF,RK,MZCHF, X ONE,Y,MZCHF) CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,ACC,MZCHF, X ONE,Y,MZCHF) CENDBL C C TEST IF(IPERT.LE.-22)THEN ISIGN=1 IF(TZED.GT.0)ISIGN=-1 DO J=1,NCHOP DO I=1,J Y(J,I)=Y(I,J) ENDDO ENDDO DO J=1,NCHOP DO I=1,NCHOP TEMP3(I,J)=-ISIGN*(ACS(I,J)+ACC(I,J)) ENDDO ENDDO DO I=1,NCHOP TEMP3(I,I)=ONE+TEMP3(I,I) ENDDO IF(TZED.EQ.0)CALL VERT(TEMP3,MZCHF,NCHOP,IPIV,IERR) DO J=1,NCHOP DO I=1,NCHOP TEMP4(I,J)=TZERO ENDDO DO K=1,NCHOP DO I=1,NCHOP TEMP4(I,J)=TEMP4(I,J)+Y(I,K)*TEMP3(K,J) ENDDO ENDDO ENDDO DO J=1,NCHOP DO I=1,J Y(I,J)=(TEMP4(I,J)+TEMP4(J,I))/TWO Y(J,I)=Y(I,J) !FOR DGEMM AND NO FINAL SYMM ENDDO ENDDO ENDIF C END TEST C IF(NCHOP.LT.NCHF)THEN C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO K=NCHOP1,NCHF CNBL TEMPA=RK(K,J) !=RK(J,K) CNBL TEMPB=ASS(K,J) !=ASS(J,K) CNBL DO I=1,J CNBL Y(I,J)=Y(I,J)+ASS(I,K)*TEMPA+RK(I,K)*TEMPB CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL K1=NCHF-NCHOP1+1 CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,RK(1,NCHOP1),MZCHF X ,ASS(1,NCHOP1),MZCHF,ONE,Y,MZCHF) CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,ASS(1,NCHOP1),MZCHF X ,RK(1,NCHOP1),MZCHF,ONE,Y,MZCHF) CENDBL C C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TZERO CNBL ENDDO CNBL DO K=NCHOP1,NCHF CNBL TEMPA=RK(K,J) CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TEMP3(I,J)+ACS(I,K)*TEMPA CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,ACS(1,NCHOP1),MZCHF X ,RK(1,NCHOP1),MZCHF,TZERO,TEMP3,MZCHF) CENDBL C C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL TEMPB=TEMP3(K,J) CNBL DO I=1,J CNBL Y(I,J)=Y(I,J)+RK(I,K)*TEMPB CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF X ,TEMP3,MZCHF,ONE,Y,MZCHF) CENDBL C C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TZERO CNBL ENDDO CNBL DO K=NCHOP1,NCHF CNBL TEMPB=ASC(K,J) !=ACS(J,K) CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TEMP3(I,J)+RK(I,K)*TEMPB CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,RK(1,NCHOP1),MZCHF X ,ACS(1,NCHOP1),MZCHF,TZERO,TEMP3,MZCHF) CENDBL C C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL TEMPA=RK(K,J) CNBL DO I=1,J CNBL Y(I,J)=Y(I,J)+TEMP3(I,K)*TEMPA CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,TEMP3,MZCHF X ,RK,MZCHF,ONE,Y,MZCHF) CENDBL C C CSTRTNBL CNBL DO L=NCHOP1,NCHF CNBL DO I=1,NCHOP CNBL TEMP3(I,L)=TZERO CNBL ENDDO CNBL DO K=NCHOP1,NCHF CNBL TEMPB=ASS(K,L) CNBL DO I=1,NCHOP CNBL TEMP3(I,L)=TEMP3(I,L)+RK(I,K)*TEMPB CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO K=NCHOP1,NCHF CNBL TEMPB=RK(K,J) CNBL DO I=1,J CNBL Y(I,J)=Y(I,J)+TEMP3(I,K)*TEMPB CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL L1=0 DO L=NCHOP1,NCHF L1=L1+1 K1=0 DO K=NCHOP1,NCHF K1=K1+1 TEMP4(L1,K1)=ASS(K,L) ENDDO ENDDO CALL DGEMM('N','N',NCHOP,K1,L1,ONE,RK(1,NCHOP1),MZCHF X ,TEMP4,MZCHF,TZERO,TEMP3,MZCHF) CALL DGEMM('N','T',NCHOP,NCHOP,K1,ONE,TEMP3,MZCHF X ,RK(1,NCHOP1),MZCHF,ONE,Y,MZCHF) CENDBL C ENDIF C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL Y(J,I)=Y(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C RETURN END C*************************************************************** C SUBROUTINE PETRAD(INOUT) C C NRB: C FOR CASE OF IRAD.NE.0, EVALUATE PERTURBATIONS TO RADIATIVE C DATA AND WRITE REACTANCE MATRIX AND FUNCTIONS TO UNIT 9 C PUT FUNCTIONS IN CS,CSP,CSPP - ORIGINAL CONTENTS DESTROYED C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT C INCLUDE 'PARAM' C PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) PARAMETER (TWO=2.0) C C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF) 1 ,FCP(MZCHF) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CQDT/R2ST(MZCHF),QDT,NQ C COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) C DIMENSION INOUT(MZCHF),TEMP(MZCHF) C AR=ONE/RZERO AR2=AR*AR AR3=AR2*AR IF(IPERT.GT.0) THEN C C USE A AS WORKSPACE - ORIGINAL CONTENTS DESTROYED DO J=1,NCHOP DO I=1,NCHOP A(I,J)=C(I)*RK(I,J) ENDDO ENDDO DO I=1,NCHOP A(I,I)=A(I,I)+S(I) ENDDO DO J=1,NCHOP DO I=NCHOP1,NCHF A(I,J)=S(I)*RK(I,J) ENDDO ENDDO C C INITIALISE DFPP TO V * F DO J=1,NCHOP DO I=1,NCHF DFPP(I,J)=TZERO ENDDO ENDDO DO J=1,NCHOP DO K=1,NCHF DO I=1,NCHF TEMP(I)=TZERO IF(LAMP(I,K).EQ.2) THEN TEMP(I)=AR2 ELSE IF(LAMP(I,K).EQ.3) THEN TEMP(I)=AR3 ENDIF ENDDO DO I=1,NCHF DFPP(I,J)=DFPP(I,J)-BW(I,K)*TEMP(I)*A(K,J) ENDDO ENDDO ENDDO C DO J=1,NCHOP DO K=1,NCHF RKK=RK(K,J) DO I=1,NCHF CS(I,J)=CS(I,J)+CC(I,K)*RKK CSP(I,J)=CSP(I,J)+CCP(I,K)*RKK CSPP(I,J)=CSPP(I,J)+CCPP(I,K)*RKK DS(I,J)=DS(I,J)+DC(I,K)*RKK DSP(I,J)=DSP(I,J)+DCP(I,K)*RKK ENDDO ENDDO DO I=1,NCHF DSP(I,J)=DSP(I,J)+BSTO*DS(I,J) DFPP(I,J)=DFPP(I,J)+(AR*(AR*CCT(I)-TWO)-EPS(I))*DS(I,J) CSP(I,J)=CSP(I,J)+BSTO*CS(I,J) ENDDO ENDDO ELSE DO J=1,NCHOP DO I=1,NCHOP CS(I,J)=C(I)*RK(I,J) CSP(I,J)=(CP(I)+BSTO*C(I))*RK(I,J) CSPP(I,J)=CPP(I)*RK(I,J) ENDDO ENDDO DO I=1,NCHOP CS(I,I)=CS(I,I)+S(I) CSP(I,I)=CSP(I,I)+SP(I)+BSTO*S(I) CSPP(I,I)=CSPP(I,I)+SPP(I) ENDDO DO J=1,NCHOP DO I=NCHOP1,NCHF CS(I,J)=S(I)*RK(I,J) CSP(I,J)=(SP(I)+BSTO*S(I))*RK(I,J) CSPP(I,J)=SPP(I)*RK(I,J) ENDDO ENDDO ENDIF C WRITE(9) QDT WRITE(9) NCHOP,(IOMIT(I),I=1,NCHOP) WRITE(9)((RK(I,J),J=1,NCHOP),I=1,NCHF) WRITE(9)((CS(I,J),J=1,NCHOP),I=1,NCHF) WRITE(9)((CSP(I,J),J=1,NCHOP),I=1,NCHF) WRITE(9)((CSPP(I,J),J=1,NCHOP),I=1,NCHF) C DO I=1,NCHOP IF(INOUT(I).EQ.0)THEN WRITE(9)INOUT(I),FS(1,I),FS(2,I),FC(1,I),FC(2,I) ELSE WRITE(9)INOUT(I),FS(1,I),FS(2,I),FC(KP2,I),FC(KP2-1,I) ENDIF ENDDO DO I=NCHOP1,NCHF IF(INOUT(I).EQ.0)THEN WRITE(9)INOUT(I),FS(KP2,I),FS(KP2-1,I) ELSE WRITE(9)INOUT(I),FS(1,I),FS(2,I) ENDIF ENDDO C IF(IPERT.GT.0) THEN WRITE(9)((DS(I,J),J=1,NCHOP),I=1,NCHF) WRITE(9)((DSP(I,J),J=1,NCHOP),I=1,NCHF) WRITE(9)((DFPP(I,J),J=1,NCHOP),I=1,NCHF) ENDIF C RETURN END C*************************************************************** C SUBROUTINE PETTMX C C NRB: C HAVING EVALUATED K-MATRIX PERTURBATION (Y) VIA CALL TO PETKMX, C NOW NEGLECT Y**2 AND K**N*Y**M (N+M>2) TERMS, WHICH REDUCES TO A C PERTURBATION OF THE T-MATRIX. THE S-MATRIX IS NOT UNITARY SO DO C **NOT** USE FOR DR. I DON'T SEE WHY ANYONE WOULD WANT TO USE THIS...... C (INCLUDES KB'S REWRITE OF DO LOOPS) C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZDEG*MZDEG) C PARAMETER (ONE=1.0) PARAMETER (RMONE=-1.0) PARAMETER (TZERO=0.0) C COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) C DIMENSION TEMP3(MZCHF,MZCHF) DIMENSION Y(MZCHF,MZCHF),P(MZCHF,MZCHF),Q(MZCHF,MZCHF) X ,D(MZCHF,MZCHF) C EQUIVALENCE (Y,RMAT),(P,CSP),(Q,CC),(D,CCP) EQUIVALENCE (WORK,TEMP3) C C C PERTURB (IN EFFECT) T-MATRIX. C C B=Y-RK*Y*RK CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL D(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCHOP CNBL DO I=1,NCHOP CNBL D(I,J)=D(I,J)+Y(I,K)*RK(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,Y,MZCHF,RK,MZCHF, X TZERO,D,MZCHF) CENDBL C C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL B(I,J)=Y(I,J) CNBL ENDDO CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL B(I,J)=B(I,J)-RK(I,K)*D(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL B(J,I)=B(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL DO J=1,NCHOP DO I=1,NCHOP B(I,J)=Y(I,J) ENDDO ENDDO CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,RMONE,RK,MZCHF,D,MZCHF, X ONE,B,MZCHF) CCENDBL C C D=Y*RK+RK*Y CSTRTNBL CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL D(I,J)=D(I,J)+RK(I,K)*Y(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL D(J,I)=D(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,Y,MZCHF, X ONE,D,MZCHF) CENDBL C C P=P+A*B*A, Q=Q+A*D*A CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TEMP3(I,J)+B(I,K)*A(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL P(I,J)=P(I,J)+A(I,K)*TEMP3(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL P(J,I)=P(I,J) CNBL ENDDO CNBL ENDDO C CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCHOP CNBL DO I=1,NCHOP CNBL TEMP3(I,J)=TEMP3(I,J)+D(I,K)*A(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL Q(I,J)=Q(I,J)+A(I,K)*TEMP3(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL Q(J,I)=Q(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,B,MZCHF,A,MZCHF, X TZERO,TEMP3,MZCHF) CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,A,MZCHF,TEMP3,MZCHF, X ONE,P,MZCHF) CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,D,MZCHF,A,MZCHF, X TZERO,TEMP3,MZCHF) CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,A,MZCHF,TEMP3,MZCHF, X ONE,Q,MZCHF) CENDBL C C RETURN END C*************************************************************** C SUBROUTINE POINTS(IOPT1,QJUMP) C C CALCULATES CHANNELS ENERGIES, NUMBER OF OPEN CHANNELS C AND TABULAR POINTS. C NRB: C SUBSTANTIALLY REVISED FOR MQDT C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (TINY=-1.D-6) PARAMETER (XEPS=0.1D0) PARAMETER (TZERO=0.0D0) PARAMETER (ONE=1.0) PARAMETER (ALF=ONE/137.036) C LOGICAL QDT,WARN,QJUMP C COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CPTOLD/RTWOO,KP2O COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CWARN/WARN COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF) COMMON/NRBKUT/KUTPS,NCHOPT COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN C COMMON/NRBZED/TZED,LPRTSW !NOT DAMPED C DIMENSION TEMPH(MZCHF) C C TZED=1.0D0 !FOR DAMPED C KP0=1 QDT=.FALSE. IQ=0 AZ=MAX(NZED-NELC,1) C C FOR IRAD.GT.0, HOLD OLD KP2, RTWO AND H C IF(IRAD.GT.0)THEN KP2OLD=KP2 RTWOLD=RTWO HOLD=H ENDIF C C INITIALIZE IOMIT C IF(.NOT.QJUMP)THEN DO I=1,NCHOPT IOMIT(I)=0 ENDDO DO I=NCHOPT+1,NCHF IOMIT(I)=1 ENDDO ENDIF C C SET-UP FOR CHANNEL ENERGIES EPS AND NUMBER OF OPEN CHANNELS NCHOP C NCHOP=0 NCHCL=0 NCHHYB=0 DO I=1,NCHF COLD IF(.NOT.QJUMP)IOMIT(I)=0 E=ETOT-ECH(I) IF(IWORD.NE.1)THEN T=ALF*E*AZ/2 E=E-T*T ENDIF IF(E.GT.TINY.AND.E.LT.0.)E=TZERO IF(TZED.EQ.TZERO)THEN IF(E.LE.-TINY.AND.E.GE.0)E=TZERO IF(E.EQ.TZERO)IOMIT(I)=1 ENDIF IF(E.GE.TZERO)THEN IF(IOPT1.GE.10)THEN QDT=IMESH.EQ.2 NQ=NCHOP+1 ENDIF NCHOP=NCHOP+1 FKNU(I)=SQRT(E) ELSE FKNU(I)=1.D0/SQRT(-E) IF(IOMSW.LT.0)THEN !SYNC. WITH SR.SC FOR HYBRID/DROP IF(FKNU(I).LT.FNUHYB )THEN C .or.FKNU(I).LT.LLCH(I)+XEPS NCHHYB=NCHHYB+1 ICHHYB(NCHHYB)=I ELSE NCHCL=NCHCL+1 ICHCL(NCHCL)=I ENDIF ENDIF ENDIF EPS(I)=E ENDDO C NCHOP1=NCHOP+1 C C SET QDT FOR CASE OF QNMAX.GT.0 C NQ=NCHOP IF((QNMAX.GT.TZERO.OR.IQDT.LT.0).AND.NCHOP.LT.NCHF)THEN DO I=NCHOP1,NCHF IF(ABS(ECH(I)-ECH(NCHOP1)).GT.ABS(TINY))GO TO 121 IF(IQDT.LT.0)NQ=I FL5=DBLE(LLCH(I))+.5D0 IF(QNMAX.GT.TZERO.AND.FKNU(I)+0.00002D0.GT.MAX(QNMAX,FL5))THEN QDT=.TRUE. NQ=I ELSE IF(IQDT.GE.0)GOTO 121 ENDIF ENDDO 121 IF((QDT.AND.IQDT.EQ.0).OR.IQDT.LT.0)THEN IF(NQ.GT.NCHOP)THEN NCHOP1=NQ+1 IPERT=0 IF(IPRINT.GT.0)WRITE(6,630)NCHOP,NQ ENDIF ENDIF ENDIF IF(IQDT.GT.0)NCHOP1=NCHF+1 C C IF NOT UPDATING S-MATRIX THEN C IF(QJUMP)RETURN C C C CALCULATION OF RTWO C INCLUDES CALCULATION OF INNER POINTS OF INFLECTION RINF C RTWO=RZERO RIMX=TZERO C C (1) OPEN CHANNELS C FOR OPEN CHANNELS RTWO IS DEFINED BY CONVERGENCE CRITERION C FOR THE JWBK METHOD. C c write(77,*)etot DO I=1,NCHOP RINF(I)=RZERO R2=RZERO IF(IOMIT(I).GT.0)GO TO 138 E=EPS(I) C=CC(I) L=LLCH(I) EC=E*C CNRB RINF(I)=C/(TZED+SQRT(TZED+EC)+(1.D0-TZED)*1.D-4)+1.D-4 !KEEP NON-ZERO WHEN L=0 IF(RINF(I).GT.RIMX)RIMX=RINF(I) C IF(L-1)131,132,133 131 IF(AC.GE.1.D-3)THEN CONST=12.D0 ELSE CONST=56.D0 ENDIF CE=CONST*E CNRB R2=CONST/(TZED+SQRT(TZED+CE)+(1.D0-TZED)*1.D-4) C GOTO 138 132 IF(AC.GE.1.D-3)THEN R2=3.9D0*RINF(I) ELSE R2=16.D0*RINF(I) ENDIF GOTO 138 133 IF(AC.GE.1.D-3)THEN R2=RINF(I)*(1.2D0+5.7D0/DBLE(L)) ELSE R2=RINF(I)*(1.4D0+9.8D0/DBLE(L)) ENDIF 138 CONTINUE c if(r2.lt.rone)r2=rone R2ST(I)=R2 IF(RTWO.LT.R2)RTWO=R2 c write(77,*)i,llch(i),eps(i),rinf(i),r2 ENDDO C C (2) CLOSED CHANNELS (STRONGLY CLOSED FOR QDT.EQ..TRUE.) C FOR CLOSED CHANNELS RTWO IS EQUAL TO THE OUTER POINT OF C INFLECTION, EXCEPT FOR THE CASE OF FNU.LT.(LL+1) C ROMN=RTWO DO I=NCHOP+1,NCHF IF(TZED.EQ.TZERO.OR.IOMIT(I).GT.0)THEN RINF(I)=TZERO R2ST(I)=RZERO ELSE FNU=FKNU(I) FLP1=LLCH(I) FLP1=FLP1+0.5D0 IF(FNU.LT.FLP1)THEN RINF(I)=TZERO R2=RZERO C R2=R2+FLP1 ! +3*FLP1 TO CONVERGE HIGH-L ELSE A1=SQRT(FNU*FNU-CC(I)) R2=FNU*(FNU+A1) RINF(I)=FNU*(FNU-A1)+1.D-4 !KEEP NON-ZERO WHEN L=0 IF(R2.GT.RZERO.AND.R2.LT.ROMN)ROMN=R2 ENDIF IF(RINF(I).GT.RIMX)RIMX=RINF(I) IF(RTWO.LT.R2.AND.(I.GE.NCHOP1.OR.INTPQ.NE.0))RTWO=R2 R2ST(I)=R2 c write(77,*)i,llch(i),fknu(i),rinf(i),r2 ENDIF ENDDO IF(RONE.GT.RTWO)RTWO=RONE IF(ROMN.LT.RZERO)ROMN=RZERO IF(RIMX.LT.RZERO)RIMX=RZERO c write(77,*)rtwo C C CASE OF IRAD.GT.0 C IF(IRAD.GT.0)THEN C CHECK VALUE OF RTWO IF(RTWO.GT.RTWOLD)THEN IF(WARN)WRITE(6,600)ETOT,RTWOLD WARN=.FALSE. ENDIF C RE-INSTATE OLD KP2,RTWO AND H KP2=KP2OLD RTWO=RTWOLD H=HOLD RTWOO=RTWOLD KP2O=KP2OLD RETURN ENDIF C C DETERMINE SAFE STARTING POINT FOR CORINT C IF(IQDT.GT.0.AND.IPERT.NE.0.AND.INTPQ.EQ.0)THEN IF(ROMN.GE.RIMX)THEN RTWOC=ROMN ELSE RTWOC=RIMX ENDIF c if(rone.gt.2.0)rtwoc=rone IF(RTWOC.GT.RTWO)RTWO=RTWOC ENDIF C C FIND INTERVAL AND TABULAR POINTS BETWEEN RZERO AND RTWO C IF(RTWO.LE.RZERO)THEN KP2=1 H=TZERO RTWOO=RTWO RTWOC=RTWO KP2C=1 RETURN ENDIF C WM=TZERO DO 170 I=1,NCHOPT IF(IOMIT(I).GT.0)GO TO 170 C=CC(I) E=EPS(I) X=1.D0/RZERO W=ABS(E+X*(2.D0*TZED-C*X)) IF(RINF(I).EQ.TZERO)W=W/16.D0 IF(W.GT.WM)WM=W X=1.D0/RTWO WH=W W=ABS(E+X*(2.D0*TZED-C*X)) IF(RINF(I).EQ.TZERO)W=W/16.D0 IF(W.GT.WM)WM=W IF(W.GT.WH)WH=W IF(C.GT.RZERO.AND.C.LT.RTWO)THEN W=ABS(E+TZED/C) IF(RINF(I).EQ.TZERO)W=W/16.D0 IF(W.GT.WM)WM=W IF(W.GT.WH)WH=W ENDIF H=ACNUM/SQRT(WH-TINY) IF(IPRINT.GT.2)WRITE(6,621)I,H TEMPH(I)=H 170 CONTINUE C H=ACNUM/SQRT(WM) IF(ABS(RTWO-RZERO).LT.(2.D0*H))THEN R2MAX=R2ST(1) IMAX=1 IF(NCHOP.EQ.1) GO TO 190 DO I=2,NCHOP IF(R2MAX.LT.R2ST(I)) THEN R2MAX=R2ST(I) IMAX=I END IF ENDDO 190 RTWO=RZERO+2.01D0*H R2ST(IMAX)=RTWO ENDIF C N=(RTWO-RZERO)/H N=4*((N-1)/4)+5 KP2=N HO=H H=(RTWO-RZERO)/DBLE(KP2-1) C C IF NOT ENOUGH OUTER-REGION POINTS, SEE IF WE CAN DROP DEEPLY CLOSED C CHANNELS (E.G. RMPS) AND THEREBY INCREASE H AND SO RETAIN ALL OPEN CHANNELS C IF(KP2.GT.MZPTS)THEN IF(IPRINT.GT.0)WRITE(6,612)RTWO,KP2,H 195 DO I=NCHOPT,NCHOP+1,-1 IF(RINF(I).EQ.TZERO)THEN IF(TEMPH(I).LT.HO)THEN IF(IPRINT.GT.1)WRITE(6,613)I,TEMPH(I) TEMPH(I)=999.D0 IOMIT(I)=1 H=999.D0 DO J=1,NCHF H=MIN(H,TEMPH(J)) ENDDO N=(RTWO-RZERO)/H N=4*((N-1)/4)+5 KP2=N HO=H-TINY H=(RTWO-RZERO)/DBLE(KP2-1) IF(KP2.GT.MZPTS)GO TO 195 IF(IPRINT.GT.1)WRITE(6,614)H GO TO 196 ENDIF ENDIF ENDDO ENDIF C C CHECK DIMENSIONS FOR NUMBER OF OUTER-REGION POINTS C 196 KP2O=KP2 RTWOO=RTWO C IF(KP2.GT.MZPTS)THEN IPERTO=IPERT KP2=4*((MZPTS-1)/4)+1 RTWO=(KP2-1)*H+RZERO C C MODIFICATION BY NRB 30/7/92 TO OVERCOME PROBLEM WITH SMALL NEGATIVE C ENERGIES, NEGLECT C-C AND C-O CONTRIBUTION FROM RTWO TO INFINITY C FOR AFFECTED (BOUND) CHANNEL RATHER THAN SWITCHING OFF PERTURBATION C COMPLETELY. ALSO, STOP NOW IF DIMENSION PROBLEM ON OPEN CHANNEL. C SEE ADDITIONAL CODING IN SR.ALPHA, SR.COUL, SR.NUMT. C C IF(NPERT.EQ.0)IPERT=0 C IF(IPERTO.NE.0)THEN IF(IPRINT.GT.0.AND.NPERT.EQ.1)WRITE(6,610)RTWOO,KP2O,RTWO,KP2 IF(IPRINT.GT.0.AND.NPERT.EQ.0)WRITE(6,611)RTWOO,KP2O,RTWO,KP2 IF(IQDT.LE.0)THEN DO I=1,NCHF IF(R2ST(I).GT.RTWO)THEN IF(RINF(I).GT.RZERO.AND.EPS(I).GT.0.1D0) X WRITE(6,619)I,EPS(I) IF(IPRINT.GT.0)WRITE(6,620)I,R2ST(I) ENDIF ENDDO ELSE DO I=1,NCHOP IF(R2ST(I).GT.RTWO)THEN IF(RINF(I).GT.RZERO.AND.EPS(I).GT.0.01D0) X WRITE(6,619)I,EPS(I) IF(IPRINT.GT.0)WRITE(6,620)I,R2ST(I) ENDIF ENDDO DO I=NCHOP+1,NCHF IF(RINF(I).GT.RTWO)THEN IF(IPRINT.GT.0)WRITE(6,620)I,R2ST(I) ENDIF ENDDO ENDIF ENDIF ENDIF C C SET-UP CORINT POINTS C IF(IQDT.GT.0.AND.IPERT.NE.0.AND.INTPQ.EQ.0)THEN c rtwoc=rzero N=(RTWOC-RZERO)/H+1.D-6 IF(N.LT.2)THEN RTWOC=RZERO KP2C=1 ELSE KP2C=4*((N-1)/4)+5 IF(KP2C.GT.KP2)KP2C=KP2 RTWOC=(KP2C-1)*H+RZERO ENDIF c write(77,*)'kp2c=',kp2c,' rtwoc=',rtwoc,' rtwo=',rtwo ELSE KP2C=KP2 ENDIF C C WEIGHTS FOR BODE RULE INTEGRATION C CALL BODE(H,KP2C,IPERT,RZERO) C C 600 FORMAT(2X,' **WARNING** FOR ETOT = ', 1 F10.5,' RTWO REDUCED TO MAXIMUM VALUE OF',F7.2 + /10X,' NO MORE SIMILAR WARNINGS GIVEN'/) 610 FORMAT(/10X,'USE OF PERTURBATION REQUIRES RTWO = ', + F8.2,', KP2 = ',I5,/10X,'WHICH IS LARGER THAN MAXIMUM OF ', + 'MZPTS ALLOWED BY DIMENSIONS'/10X,'NEGLECT CLOSED-CLOSED' X,' CLOSED-OPEN AND OPEN-OPEN CONTRIBUTION FROM R .GT.' X,' RTWO = ',F8.2,' KP2 = ',I5/10X,'(FROM R .GT. RZERO' X,' IF RINF GT. RZERO)') 611 FORMAT(/10X,'USE OF PERTURBATION REQUIRES RTWO = ', + F8.2,', KP2 = ',I5,/10X,'WHICH IS LARGER THAN MAXIMUM OF ', + 'MZPTS ALLOWED BY DIMENSIONS'/10X,'SET IPERT = 0' X,' RTWO = ',F8.2,' KP2 = ',I5) 612 FORMAT(/10X,'USE OF PERTURBATION REQUIRES RTWO = ', + F8.2,', KP2 = ',I5,/10X,'WHICH IS LARGER THAN MAXIMUM OF ', + 'MZPTS ALLOWED BY DIMENSIONS'/10X,'ATTEMPTING TO DROP', X ' DEEPLY-CLOSED CHANNELS SO AS TO INCREASE'/10X, X 'THE STEP LENGTH, CURRENTLY H=',F8.5) 613 FORMAT(/10X,'DROP CHANNEL I =',I5,3X,' STEP =',F8.5) 614 FORMAT(/10X,'NEW STEP H =',F8.5/) 619 FORMAT(10X,'CHANNEL ',I3,' EPS = ',1PE11.2, + ' OUTER REGION CONTRIBUTION DROPPED') 620 FORMAT(10X,'CHANNEL ',I3,' REQUIRES RTWO = ',F8.2, + ' FOR USE OF PERTURBATION') 621 FORMAT(10X,'CHANNEL ',I3,' REQUIRES H = ',F11.6, + ' FOR USE OF PERTURBATION') 630 FORMAT(/1X,5('*'),' QDT USED'/7X,'NCHOP = ',I3/ + 7X,'NQ = ',I3/) C RETURN END C*************************************************************** C SUBROUTINE PQ C C NRB: C CALCULATE MATRICES P AND Q, C TRANSMISSION MATRIX IS -2*I*(P+I*Q), I=SQRT(-1) C NOTE: UNOPTIMIZED BLAS MXATRIX MULTIPLICATIONS ARE SLOWER THAN C NON-BLAS BECAUSE THE LATTER ONLY COMPUTES HALF THE PRODUCT. C ALSO, MATRIX INVERSION IS FASTER THAN AX=B BECAUSE C Q = 1- INVERSE A, AND WE ONLY DO HALF THE PRODUCT FOR P. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZDEG*MZDEG) PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) C C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) C DIMENSION IPIV(MZCHF) DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF) C EQUIVALENCE (P,CSP),(Q,CC) C C A=(1+RK**2)**(-1) C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL A(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL A(I,J)=A(I,J)+RK(I,K)*RK(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL A(J,I)=A(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,RK,MZCHF, X TZERO,A,MZCHF) CENDBL C DO I=1,NCHOP A(I,I)=A(I,I)+ONE ENDDO C CSTRTNBL CNBL CALL VERTS(A,MZCHF,NCHOP,WORK,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,100) CNBL STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.PQ' CNBL END IF CENDNBL C CSTRTBL CALL DSYTRF('L',NCHOP,A,MZCHF,IPIV,WORK,LWORK,INFO) IF (INFO.NE.0) THEN WRITE(6,602) INFO STOP 'FAILURE IN BLAS ROUTINE DSYTRF' ENDIF CALL DSYTRI('L',NCHOP,A,MZCHF,IPIV,WORK,INFO) IF (INFO.NE.0) THEN WRITE(6,603) INFO STOP 'FAILURE IN BLAS ROUTINE DSYTRI' ENDIF CENDBL C DO J=1,NCHOP DO I=J,NCHOP A(J,I)=A(I,J) ENDDO ENDDO C C P=RK*A C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL P(I,J)=TZERO CNBL ENDDO CNBL DO K=1,NCHOP CNBL DO I=1,J CNBL P(I,J)=P(I,J)+RK(I,K)*A(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL P(J,I)=P(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL DGEMM('N','N',NCHOP,NCHOP,NCHOP,ONE,RK,MZCHF,A,MZCHF, X TZERO,P,MZCHF) CENDBL C C Q=1-A (=RK*P) C C NRB: REMOVED UNNECESSARY MATRIX MULTIPLICATION C DO J=1,NCHOP DO I=1,NCHOP Q(I,J)=-A(I,J) ENDDO ENDDO DO I=1,NCHOP Q(I,I)=Q(I,I)+ONE ENDDO C RETURN C 100 FORMAT(' THE MATRIX: 1 + K^2 HAS NO INVERSE IN SUBROUTINE ' 1 ,'PQ - MUST STOP') 602 FORMAT(//10X,10('*'),' SR.PQ: DSYTRF RETURNED WITH INFO =',I2) 603 FORMAT(//10X,10('*'),' SR.PQ: DSYTRI RETURNED WITH INFO =',I2) C END C*************************************************************** C SUBROUTINE PRUNE(ABVTHR,BELTHR) C CNRB C PRUNE UNDESIREABLE ENERGIES C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW DIMENSION EMESH0(MZMSH) C IF(ABVTHR.LT.0.OR.BELTHR.LT.0.)RETURN C C HOLD MXE0=MXE C IT0=1 DO IE=1,MXE0 IFLAGE=0 EMESH0(IE)=EMESH(IE) DO 2 IT=IT0,NAST IF(EMESH(IE).LT.ENAT(IT)-BELTHR)GO TO 1 IF(EMESH(IE).GT.ENAT(IT)+ABVTHR)GO TO 2 IFLAGE=1 2 CONTINUE 1 IF(IFLAGE.NE.0)EMESH0(IE)=-EMESH(IE) IT0=IT-1 ENDDO C MXE=0 IF(IPRINT.GE.0)THEN WRITE(6,*)' ' WRITE(6,*)'ORIGINAL MESH POINTS DROPPED:' ENDIF ID=0 DO IE=1,MXE0 IF(EMESH0(IE).GT.0.)THEN MXE=MXE+1 EMESH(MXE)=EMESH0(IE) ELSE IF(IPRINT.GE.0)THEN ID=ID+1 WRITE(6,100)ID,IE,-EMESH0(IE) ENDIF ENDIF ENDDO C RETURN 100 FORMAT(2I6,1PE16.8) END C C*************************************************************** C SUBROUTINE RAD C C NRB: EXTENDED TO JK- AND JJ-COUPLING. C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (THREE=3.0) PARAMETER (FOUR=4.0) PARAMETER (SIX=6.0) PARAMETER (EINF=1.0D6) PARAMETER (CON1=.007297353) PARAMETER (CON2=4.134D16) PARAMETER (TINY=1.D-6) C CHARACTER ELAS*3 C COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X,IPAR(MZTAR),NEWAR COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS C AZ=MAX(NZED-NELC,1) IONE=1 IF(ELAS.EQ.'YES')IONE=0 PI=ACOS(-ONE) C C RADIATIVE PROBABILITIES C K=0 IC0=0 IF(IONE.EQ.1)IC0=NCONAT(1) C DO I=1+IONE,NAST JC0=0 DO 130 J=1,I-IONE K=K+1 IF(NOMWRT.GE.0)KS=I+1-IONE+(NAST+1-IONE)*(J-1)-(J*(J+1))/2 IF(NOMWRT.LT.0)KS=K IF(I.EQ.J)THEN ARAD(K)=TZERO SLIN(KS)=TZERO GO TO 130 ENDIF IF(NSPN2.NE.0)THEN IF(IABS(ISAT(I)).NE.IABS(ISAT(J)).OR. X LAT(I)+LAT(J).EQ.0.OR.ABS(LAT(I)-LAT(J)).GT.1)THEN ARAD(K)=TZERO SLIN(KS)=TZERO ENDIF ENDIF IF(ARAD(K).GE.TZERO)GOTO 30 DO IC=IC0+1,IC0+NCONAT(I) DO JC=JC0+1,JC0+NCONAT(J) IF(ABS(CF(IC,JC,1)).LT.TINY)THEN ARAD(K)=TZERO SLIN(KS)=TZERO ELSE IF(NSPN2.NE.0)THEN !LS SLIN(KS)=DBLE(2*LRGL2+1)*(CF(IC,JC,1)**2) + /(WSQ(LAT(I),LAT(J),LLCH(IC),LLCH(JC),LRGL2,ISIGN) + *DBLE(2*LAT(I)+1)*MAX(LLCH(IC),LLCH(JC))) WGT=DBLE(IABS(ISAT(I))*(2*LAT(I)+1)) ISLN=(-1)**(LAT(I)+LLCH(IC)+LRGL2+1) IF(ISIGN.LT.0)ISLN=-ISLN IF(CF(IC,JC,1).LT.TZERO)ISLN=-ISLN SLIN(KS)=SLIN(KS)*ISLN ELSE !JK OR JJ IF(LAT(I)+LAT(J).EQ.0.OR.ABS(LAT(I)-LAT(J)).GT.2)THEN SLIN(KS)=TZERO ELSE IF(KFLAG.GE.0.AND.KJ(IC).EQ.KJ(JC))THEN !JK-NRB SLIN(KS)=DBLE(KJ(IC)+1)*(CF(IC,JC,1)**2) + /(WSQ2(LAT(I),LAT(J),2*LLCH(IC),2*LLCH(JC),KJ(IC), + ISIGN)*DBLE(LAT(I)+1)*MAX(LLCH(IC),LLCH(JC))) WGT=DBLE(LAT(I)+1) ELSEIF(KFLAG.LT.0)THEN !JJ-NRB IC2=2*(L2P(IC)/2)+1 !2J-VALENCE JC2=2*(L2P(JC)/2)+1 !2J-VALENCE IF(IC2.EQ.JC2)THEN W3J=DBLE(IC2+1)/(DBLE((IC2+2)*IC2)) ELSE IC3=MIN(IC2,JC2) W3J=DBLE((IC3+3)*(IC3+1))/DBLE(2*(IC3+2)) ENDIF c write(6,*)LLCH(IC),LLCH(JC),ic2,jc2,w3j SLIN(KS)=DBLE(LRGL2+1)*(CF(IC,JC,1)**2) + /(WSQ2(LAT(I),LAT(J),IC2,JC2,LRGL2,ISIGN)* + W3J*DBLE(LAT(I)+1)) WGT=DBLE(LAT(I)+1) ENDIF ENDIF ENDIF C C ENER GIES ARE UNSCALED ATOMIC (NOT RYDBERGS) UNITS HERE. C ARAD(K)=((CON1*(ENAT(I)-ENAT(J)))**3)*ABS(SLIN(KS)) SLIN(KS)=SLIN(KS)*WGT*LOG(EINF*AZ**2) GOTO 30 ENDIF ENDDO ENDDO 30 JC0=JC0+NCONAT(J) 130 ENDDO IC0=IC0+NCONAT(I) ENDDO C C CHECK COMPLETENESS OF ARAD C DO K=1,(NAST*(NAST-2*IONE+1))/2 IF(ARAD(K).LT.TZERO)THEN IEND=0 RETURN ENDIF ENDDO IEND=1 C C CALCULATE ARDEC= = 2*PI*ARAD/Z**2 C C=TWO*PI/AZ**2 K=0 DO I=1+IONE,NAST A=TZERO DO J=1,I-IONE K=K+1 A=A+ARAD(K) ENDDO ARDEC(I)=A*C ENDDO C C WRITES C IF(IRDEC.GT.0)WRITE(6,600) WRITE(6,605)(I,ISAT(I),LAT(I),IPAR(I),I=1,NAST) WRITE(6,610) C K=0 DO I=1+IONE,NAST DO J=1,I-IONE K=K+1 IF(NOMWRT.GE.0)KS=I+1-IONE+(NAST+1-IONE)*(J-1)-(J*(J+1))/2 IF(NOMWRT.LT.0)KS=K IF(ARAD(K).GT.TZERO)THEN S=SLIN(KS)*THREE/(LOG(EINF*AZ**2)*FOUR) GF=TWO*S*(ENAT(I)-ENAT(J))/THREE WRITE(6,620)I,J,ARAD(K),ARAD(K)*CON2,S,GF ENDIF ENDDO ENDDO C WRITE(6,630)(I,ARDEC(I),I=2,NAST) WRITE(6,640) C RETURN C C FORMATS 600 FORMAT(//72('+')//2X,'*** OMEGA AND/OR OMEGDR' + ,' CALCULATED ALLOWING FOR RADIATIVE DECAYS ***') 605 FORMAT(//72('+')// + 25X,'TARGET STATES'//12X,'INDEX',5X,'2*S+1',7X, + 'L',8X,'PARITY'/20X,'OR P OR 2*J' +//(I15,3I10)) 610 FORMAT(//10X,'RADIATIVE PROBABILITIES (ATOMIC UNITS,' + ,' NOT Z-SCALED)'//14X,'I',9X,'J',13X,'A(I,J)',15X,'*SEC' X ,18X,'S',14X,'GF'/) 620 FORMAT(I15,I10,1P2E21.4,0PF20.6,F15.6) 630 FORMAT(///14X,'I',11X,'ARDEC(I)'//(I15,1PE20.4)) 640 FORMAT(//72('+')//) C END C*************************************************************** C SUBROUTINE REACT(IOPT1,QJUMP,PQRD) C C NRB: HEAVILY REWORKED C CALCULATION OF REACTANCE MATRIX. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT,QJUMP,PQRD LOGICAL NEWBUT CHARACTER ELAS*3 C INCLUDE 'PARAM' C PARAMETER (MZKIL= 0) C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (MXOM=MZMEG*1000000+MZKIL*1000) PARAMETER (MXF=5) !(MZLMX+1)/2) C PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) PARAMETER (TWO=2.0) PARAMETER (FOUR=4.0) PARAMETER (QUART=0.25) C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CALP/ASS(MZCHF,MZCHF),ASC(MZCHF,MZCHF),ACS(MZCHF,MZCHF) 1 ,ACC(MZCHF,MZCHF) COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X,IPAR(MZTAR),NEWAR COMMON/CEN/ETOT,MXE,NWT,NZ C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CLOGB/NEWBUT COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/CNTRLS/ISGPT,ITRMN,ITRMX COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT COMMON/COULSC/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF) 1 ,FCP(MZCHF) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2), X INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2), X MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF), X KTOPA(MXTST),KTOPB(MXTST),LRGLMN COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) COMMON/MEMORY/OMEM(MXOM+1),MPOS(0:MZMSH),ITMAX,JTMAX COMMON/NRBCBE/RBE(MZCHF,MZCHF),LCBE COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET COMMON/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF) COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG) CBL X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG) COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBREC/LREC,IET(MZTAR) COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR) X ,OMST(MXTST),ITOP C DIMENSION Y(MZCHF,MZCHF),P(MZCHF,MZCHF),Q(MZCHF,MZCHF) X ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF) DIMENSION INOUT(MZCHF),SIGPW(MXTST) C EQUIVALENCE (Y,RMAT),(P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC) C CONSIG=87.97351 AZ=MAX(NZED-NELC,1) AZAZ=AZ*AZ C C C IN IQDT MODE SEE IF WE CAN CUT TO THE CHASE C IF(IQDT.GT.0)THEN IF(QJUMP)THEN IF(NCHOP.EQ.0)RETURN IPERTO=IPERT NCHOPO=NCHOP NCHOP=NCHF IF(IQDT.EQ.2)GO TO 2000 GO TO 1000 ELSE COLD IEE(IE)=IE ENDIF ENDIF C IF(LRGL2.GT.ISKP(IE).AND.IPRKM.GT.0)THEN IF(IQDT.GT.0)THEN NCHOPO=NCHOP NCHOP=NCHF ENDIF DO J=1,NCHOP DO I=1,NCHOP RK(I,J)=TZERO ENDDO ENDDO GO TO 3000 ENDIF C C C CALCULATE INITIAL R-MATRIX C CALL RINIT C C C COULOMB FUNCTIONS AT RZERO C C S(I) IS REGULAR FUNCTION FOR OPEN CHANNELS, DECAYING C (REAL) FUNCTION THETA FOR CLOSED CHANNELS. C C(I) IS IRREGULAR FUNCTION FOR OPEN CHANNELS, C THETAD = ENERGY DERIVATIVE OF DECAYING FUNCTIONS FOR C CLOSED CHANNELS. C IN IQDT MODE ALL CHANNELS ARE TREATED AS OPEN. C CALL COUL(INOUT) C NCHOPO=NCHOP C C RESET IPERT AND NCHOP FOR QDT CASE IF(QDT.OR.IQDT.NE.0) THEN IPERTO=IPERT IF(IQDT.GT.0)THEN NCHOP=NCHF ELSE C NRB: IPERT SHOULD ALREADY HAVE BEEN ZEROED BY POINTS, BUT CHECK IF(IPERT.NE.0)STOP 'REACT: IPERT???' IPERT=0 NCHOP=NQ ENDIF IF(IOMSW.LT.0)THEN NCC=NCHCL ELSE NCC=NCHOP-NCHOPO DO N=1,NCC ICHCL(N)=NCHOPO+N ENDDO ENDIF DO N=1,NCC I=ICHCL(N) IF(FKNU(I).LT.FNUMIN)IOMIT(I)=1 ENDDO ENDIF IF(NCHOP.EQ.0) THEN IF(IRAD.NE.0)THEN WRITE(9) QDT WRITE(9) NCHOP ENDIF ISTOT=NSPN2 IF(NPTY2.EQ.1) ISTOT=-ISTOT IF(IPRKM.EQ.1)WRITE(20,660) NCHOP,ISTOT,LRGL2,ETOT RETURN ENDIF C C CALCULATE REACTANCE MATRIX C AR=ONE/RZERO DO I=1,NCHF IF(IOMIT(I).LE.0)THEN IF(IQDT.EQ.0.OR.INTPQ.EQ.0)THEN S(I)=FS(1,I) SP(I)=FSP(I)-BSTO*S(I) ELSE SP(I)=SP(I)-BSTO*S(I) ENDIF HAM=AR*(AR*CCT(I)-TWO)-EPS(I) SPP(I)=HAM*S(I) COLD IF(I.LT.NCHOP1.OR.IPERT.GT.0) THEN IF(IQDT.EQ.0.OR.INTPQ.EQ.0)THEN C(I)=FC(1,I) CP(I)=FCP(I)-BSTO*C(I) ELSE CP(I)=CP(I)-BSTO*C(I) ENDIF CPP(I)=HAM*C(I) ELSE S(I)=TZERO SP(I)=TZERO SPP(I)=TZERO C(I)=TZERO CP(I)=TZERO CPP(I)=TZERO DO J=1,NCHF RMAT(I,J)=TZERO c rmat(j,i)=tzero ENDDO ENDIF ENDDO C C EVALUATE PERTURBATION INTEGRALS (ALL IPERT) C IF(IPERT.NE.0)CALL ALPHA(NCHOPO) C C..CASE OF IPERT.GT.0 (PERTURB S & C) C IF(IPERT.GT.0)THEN C CALL PETFSC C ELSE C C..CASE OF IPERT.LE.0 C C CALCULATE MATRICES A AND B DO J=1,NCHOP DO I=1,NCHF A(I,J)=-RMAT(I,J)*CP(J) B(I,J)=-RMAT(I,J)*SP(J) ENDDO ENDDO DO I=1,NCHOP A(I,I)=A(I,I)+C(I) B(I,I)=B(I,I)+S(I) ENDDO DO J=NCHOP1,NCHF DO I=1,NCHF A(I,J)=-RMAT(I,J)*SP(J) ENDDO ENDDO DO I=NCHOP1,NCHF A(I,I)=A(I,I)+S(I) ENDDO IF(NCHHYB.GT.0)THEN DO N=1,NCHHYB J=ICHHYB(N) DO I=1,NCHF A(I,J)=-RMAT(I,J)*SP(J) B(I,J)=TZERO ENDDO A(J,J)=A(J,J)+S(J) ENDDO ENDIF C ENDIF C..... C C COMPLETE CALCULATION OF REACTANCE MATRIX C C CALL AINVB C C C FOR CASE OF IRAD.NE.0, EVALUATE PERTURBATIONS TO RADIATIVE C DATA AND WRITE REACTANCE MATRIX AND FUNCTIONS TO UNIT 9 C NOTE: COULD CALL PETRAD AFTER CALL PETKMX BUT LITTLE TO BE C GAINED. INSTEAD WE FORCE IPERT>0 (DEFAULT) WHEN IRAD>0. C IF(IRAD.GT.0.AND.IOPT1.LT.10) THEN C CALL PETRAD(INOUT) C IF(IRAD.EQ.2) RETURN ENDIF C C C USE VARIATIONAL METHOD FOR IPERT<0 (PERTURB K-MX [-2] OR T-MX [-1]) C EITHER WAY WE NEED THE PERTURBATION (Y) TO THE K-MX FIRST, SO C IF(IPERT.LT.0)CALL PETKMX C C PERTURB K-MATRIX. C IF(IPERT.LE.-2)THEN DO J=1,NCHOP DO I=1,NCHOP RK(I,J)=RK(I,J)+Y(I,J) ENDDO ENDDO ENDIF C C OPTIONALLY GO VIA K-UNPHYS->K-PHYS C (FIRST PUT RK IN P AND Q, THEN VARIOUS WRITES....) C 3000 IF(ABS(IQDT).EQ.2)THEN DO J=1,NCHOP DO I=1,NCHOP P(I,J)=RK(I,J) Q(I,J)=TZERO ENDDO ENDDO IF(IQDT.EQ.2.AND..NOT.PQRD.AND.IPRKM.EQ.0.AND.IJBIN.NE.0)THEN MPTY=IABS(NSPN2)*10000+100*LRGL2+NPTY2 IF(NSPN2.LT.0)MPTY=-MPTY WRITE(21) IE,MPTY,NCHOP,ETOT WRITE(21) (IOMIT(I),I=1,NCHOP) WRITE(21) ((P(I,J),I=J,NCHOP),J=1,NCHOP), X ((Q(I,J),I=J,NCHOP),J=1,NCHOP) ENDIF IF(IPRKM.EQ.2)THEN WRITE(36)ETOT,((P(I,J),J=1,I),I=1,NCHOP) !LOWER HALF ENDIF IF(IPRKM.EQ.4)THEN WRITE(32)((P(I,J),I=1,J),J=1,NCHOP) !UPPER HALF IF(IE.EQ.1)WRITE(6,999)IABS(NSPN2),LRGL2,NPTY2 999 FORMAT(/72('*')/3X,'WROTE DATA TO KMTLS.DAT FOR NSPN2 = ',I3 1 ,3X,'LRGL2 = ',I3,3X,'NPTY2 = ',I3/72('*')) IF(IPRINT.GE.2)THEN !SO UNPHYSICAL HERE WRITE(6,707)ETOT,(J,J=1,NCHOP) WRITE(6,*) DO I=1,NCHOP WRITE(6,710)I,(P(I,J),J=1,NCHOP) ENDDO ENDIF ENDIF IF(IMODE.LT.0.OR.LRGL2.GT.ISKP(IE).OR.NCHOPO.EQ.0 X .OR.NOMWRT.EQ.0)GO TO 666 ENDIF C 2000 IF(ABS(IQDT).EQ.2)THEN NCHOP=NCHOPO IF(QDT)NCHOP=NQ NCHOP1=NCHOP+1 C IF(NCHOP.LT.NCHF)THEN C CALL MQDTK C ELSE DO J=1,NCHF DO I=1,NCHF RK(I,J)=P(I,J) POLD(I,J)=P(I,J) QOLD(I,J)=Q(I,J) ENDDO ENDDO ENDIF C ENDIF C C OPTIONALLY GET EIGENPHASE SUM C IF(IPRINT.GT.0)CALL EPHASE C C GET NEW P,Q MATRICES (ALL CASES OF IPERT/IQDT) C SUCH THAT TRANSMISSION MATRIX IS -2*I*(P+I*Q), I=SQRT(-1) C CALL PQ C C NOW, PERTURB (IN EFFECT) T-MATRIX, ALTHOUGH I CAN'T SEE WHY-NRB. C IF(IPERT.EQ.-1)CALL PETTMX C C C WRITE REACTANCE MATRIX (SO IPERT=-1 IS THE UNPERTURBED MATRIX) C IF(IPRINT.GT.0)THEN IF(IPRINT.GE.2)THEN WRITE(6,668) WRITE(6,669)(I,ITARG(I),LLCH(I),FKNU(I),I=1,NCHOPO) WRITE(6,*) WRITE(6,669)(I,ITARG(I),LLCH(I),FKNU(I),I=NCHOPO+1,NCHF) ENDIF WRITE(6,707)ETOT,(J,J=1,NCHOP) WRITE(6,*) DO I=1,NCHOP WRITE(6,710)I,(RK(I,J),J=1,NCHOP) ENDDO IF(IQDT.NE.2.AND.(IRAD.GT.0.OR.IPERT.LT.0))THEN WRITE(6,*) DO I=NCHOP1,NCHF WRITE(6,710)I,(RK(I,J),J=1,NCHOP) ENDDO ENDIF ENDIF C C WRITE K-MATRICES TO DIFFERENTIAL CROSS SECTION CODE C IF(IPRKM.NE.0)THEN ISTOT=NSPN2 IF(NPTY2.EQ.1)ISTOT=-ISTOT ETRYD=AZAZ*ETOT ENDIF IF(IPRKM.EQ.1)THEN IF(NSPN2.NE.0)THEN !LS-COUPLING WRITE(20,660)NCHOP,ISTOT,LRGL2,ETRYD DO I=1,NCHOP WRITE(20,670)ITARG(I),LLCH(I) ENDDO ELSE WRITE(20,660)NCHOP,LRGL2,NPTY2,ETRYD IF(KFLAG.GE.0)THEN !JK-COUPLING DO I=1,NCHOP WRITE(20,671)ITARG(I),LLCH(I),KJ(I) ENDDO ELSE !JJ-COUPLING DO I=1,NCHOP WRITE(20,671)ITARG(I),LLCH(I),2*IABS(K2P(I))-1 !2*J ENDDO ENDIF ENDIF DO I=1,NCHOP DO IP=1,NCHOP WRITE(20,680)RK(I,IP) ENDDO ENDDO ENDIF C CTBD: WRITE PARTIAL WAVE LIST TO A SEQUENTIAL FILE AND THE K-MATRICES C TO A DIRECT ACCESS FILE FOR USE BY THE PARTIAL CROSS SECTION CODE IF(IPRKM.EQ.3) STOP 'SR.REACT: IPRKM=3 NOT ACTIVE YET' C C C NOW P AND Q SUCH THAT KHI=P+I*Q (=1-T) C DO J=1,NCHOP DO I=1,NCHOP T=P(I,J) P(I,J)=-TWO*Q(I,J) Q(I,J)=TWO*T IF(I.LE.NCHOPO.AND.J.LE.NCHOPO)THEN TT=P(I,J)**2+Q(I,J)**2 IF(I.NE.J.AND.TT.GT.ONE)WRITE(6,695)ETOT,IPERT,I,J,TT IF(I.EQ.J.AND.TT.GT.FOUR)WRITE(6,695)ETOT,IPERT,I,J,TT ENDIF ENDDO ENDDO DO I=1,NCHOP P(I,I)=ONE+P(I,I) ENDDO C C OUTPUT KHI MATRICES FOR JAJOM (KAB,94) C IF(IOPT1.GT.9.OR.(IQDT.GT.0.AND.IQDT.EQ.1.AND..NOT.PQRD)) THEN IF(NSPN2.EQ.0.AND.IOPT1.GT.9)THEN WRITE(6,*)'***ERROR: IOPT1>9 REQUESTS (LS) OUTPUT FOR JAJOM' X , ' BUT NSPN2=0. I.E. B.P. DATA BEING PROCESSED!' WRITE(6,*)' DELETE RECUPH.DAT AND RE-RUN STG3' STOP ENDIF IF(IJBIN.NE.0) THEN IF(IOPT1.GT.9)THEN C FOR JAJOM CONSISTENCY MPTY=NSPN2*1000+LRGL2 IF(NPTY2.EQ.1) MPTY=-MPTY KNUM=(NCHOP*(NCHOP+1))/2 WRITE(21) IE,MPTY,KNUM,ETOT WRITE(21) ((P(I,J),I=J,NCHOP),J=1,NCHOP), X ((Q(I,J),I=J,NCHOP),J=1,NCHOP) IF(IOPT1.EQ.11)RETURN ELSEIF(IPRKM.EQ.0)THEN C LS, BP, NX ETC. MPTY=IABS(NSPN2)*10000+100*LRGL2+NPTY2 IF(NSPN2.LT.0)MPTY=-MPTY WRITE(21) IE,MPTY,NCHOP,ETOT WRITE(21) (IOMIT(I),I=1,NCHOP) WRITE(21) ((P(I,J),I=J,NCHOP),J=1,NCHOP), X ((Q(I,J),I=J,NCHOP),J=1,NCHOP) ENDIF ENDIF IF(IPRKM.EQ.4)THEN IF(NCHOP.GT.MZDEG)THEN WRITE(6,*)'***INCREASE MZDEG TO AT LEAST: ',NCHOP STOP '***INCREASE MZDEG' ENDIF DO J=1,NCHOP DO I=1,J ZKHICC(I,J)=DCMPLX(P(I,J),Q(I,J)) ENDDO ENDDO WRITE(32)((ZKHICC(I,J),I=1,J),J=1,NCHOP) !UPPER HALF IF(IE.EQ.1)WRITE(6,998)IABS(NSPN2),LRGL2,NPTY2 998 FORMAT(/72('*')/3X,'WROTE DATA TO SMTLS.DAT FOR NSPN2 = ',I3 1 ,3X,'LRGL2 = ',I3,3X,'NPTY2 = ',I3/72('*')) ENDIF ENDIF C IF(IQDT.NE.2.AND.IMODE.LT.0.OR. X LRGL2.GT.ISKP(IE).OR.NCHOPO.EQ.0.OR.NOMWRT.EQ.0)GO TO 666 C C C....I/QDT CASE (MQDT ENTRY POINT FOR S-MX) C 1000 IF(QDT.OR.(IQDT.NE.0.AND.NCHOP.GT.NCHOPO))THEN C C REVERT TO ORIGINAL IPERT, NCHOP C NCHOP=NCHOPO IPERT=IPERTO !SHOULD BE UNNECESSARY.... C C TREATED CHANNELS ASSOCIATED WITH ALL CLOSED TARGET STATES AS OPEN, NOW C CLOSE THEM OFF (IF QDT=.TRUE. LEAVE LOWEST TARGET UNTIL SQDT) C IF(IQDT.GT.0.AND.IQDT.NE.2)THEN IF(QDT)NCHOP=NQ C IF(NCHOP.LT.NCHF) CALL MQDTS C ENDIF C C TREATED CHANNELS ASSOCIATED WITH SINGLE (LOWEST) CLOSED TARGET AS OPEN, C NOW CLOSE THOSE OFF. C IF(IQDT.LE.0.OR.QDT)THEN IF(QDT)NCHOP=NCHOPO C CALL SQDTS C ENDIF C NCHOP1=NCHOP+1 C.... ELSE C C CALCULATE COLLISION STRENGTHS FOR NON-I/QDT CASE AND STORE IN RK C T=NWT*QUART DO J=1,NCHOP P(J,J)=P(J,J)-ONE DO I=1,NCHOP RK(I,J)=(P(I,J)**2+Q(I,J)**2)*T ENDDO P(J,J)=P(J,J)+ONE ENDDO IF(NDRMET.GT.0)THEN DO J=1,NCHOP PDR(J)=T DO I=1,NCHOP PDR(J)=PDR(J)-(P(I,J)**2+Q(I,J)**2)*T ENDDO ENDDO ENDIF C C WRITE ELASTIC S-MATRIX FOR STGD C IF(IPRKM.EQ.5)THEN NTAROP=ITARG(NCHOP) NCH2=0 NREC0=2 DO N=1,NTAROP IF(NCONAT(N).GT.0)THEN M=(NCONAT(N)*(NCONAT(N)+1))/2 IF(M.GT.MZDEG)THEN WRITE(6,*)'***INCREASE MZDEG TO AT LEAST: ',M STOP '***INCREASE MZDEG' ENDIF if(m.gt.lrec/(2*mzrec))stop 'record length too long' if(ie.lt.iet(n))stop 'iet energy mesh mis-match' NREC=NREC0+IE-IET(N)+1 NCH1=NCH2+1 NCH2=NCH2+NCONAT(N) K=0 DO J=NCH1,NCH2 DO I=J,NCH2 K=K+1 ZVAL(K)=DCMPLX(P(I,J),Q(I,J)) ENDDO ENDDO WRITE(13,REC=NREC)(ZVAL(K),K=1,M) NREC0=NREC0+MXE-IET(N)+1 ENDIF ENDDO ENDIF C.... ENDIF C C RESTORE P AND Q WHEN WORKING WITH UNPHYSICAL K-MATRIX. C IF(ABS(IQDT).EQ.2)THEN DO J=1,NCHF DO I=1,NCHF P(I,J)=POLD(I,J) Q(I,J)=QOLD(I,J) ENDDO ENDDO ENDIF C C SKIP OMEGA PROCESSING IF NOT REQUIRED C IF(NOMWRT.EQ.0)GO TO 666 C C WRITE COLLISION STRENGTH C IF(IPRINT.GT.0)THEN WRITE(6,640) DO J=1,NCHOP DO I=1,J WRITE(6,650)ETOT,NSPN2,LRGL2,NPTY2,ITARG(I),LLCH(I), X ITARG(J),LLCH(J),RK(I,J) ENDDO ENDDO ENDIF C.... C EVALUATE CBE COLLISION STRENGTH C IF(LCBE.GE.0.AND.LRGL2.GE.LCBE)THEN DO J=1,NCHOP DO I=1,J IF(LAMP(I,J).EQ.2)THEN IFAIL=IPRINT F=FDIP(EPS(I),LLCH(I),EPS(J),LLCH(J),IFAIL) IF(IFAIL.NE.0.AND.IPRINT.GE.0) X WRITE(6,655)IFAIL,I,J,EPS(I),LLCH(I),EPS(J),LLCH(J) RBE(I,J)=NWT*(BW(I,J)*F)**2 ELSE RBE(I,J)=TZERO ENDIF RBE(J,I)=RBE(I,J) ENDDO ENDDO C C WRITE CBE AND CC OMEGA'S C IF(IPRINT.GT.-2)THEN WRITE(6,720) DO J=1,NCHOP DO I=1,J IF(LAMP(I,J).EQ.2.AND.RK(I,J).NE.0.)WRITE(6,721)I,J,ITARG(I) X ,ITARG(J),RK(I,J),RBE(I,J),RBE(I,J)/RK(I,J) ENDDO ENDDO ENDIF C C REPLACE OMEGA-CC BY OMEGA-CBE FOR TOP-UP C IF(LRGL2.GE.LRGLAM-1.AND.LRGLAM.GE.0)THEN DO J=1,NCHOP DO I=1,J IF(LAMP(I,J).EQ.2)THEN RK(I,J)=ABS(RBE(I,J)) RK(J,I)=RK(I,J) ENDIF ENDDO ENDDO ENDIF C.... ENDIF C C FOR LRGL2.GE.LRGLMN (SEE TOP1), TAKE OUT ALLOWED TRANSITIONS C WITH LLCH.GT.LITLAM. IN LS, LRGLMN=LRGLAM BUT IS SMALLER FOR BP. C IF(LRGLAM.GE.0.AND.LRGL2.GE.LRGLMN)THEN DO 100 I=1,INDM IT1=NTOP(I,1) IT2=NTOP(I,2) IF(IT1.LT.0)GO TO 150 I2=NTCHAN(IT2,2) IF(I2.GT.NCHOP)GOTO 100 I1=NTCHAN(IT1,2) IF(I1*I2.EQ.0)GO TO 100 IF(MAX(LLCH(I1),LLCH(I2)).GT.LITLAM(I))RK(I1,I2)=TZERO 150 IF(NSPN2.EQ.0)THEN IFTOP=0 IF(IT1.GT.0)IFTOP=1 IF(IT2.LT.0.AND.LRGL2.GT.LRGLAM)IFTOP=-1 !QUADRUPOLE ETC. IF(IFTOP.NE.0)THEN IT1=ABS(IT1) IT2=ABS(IT2) DO I1=NTCHAN(IT1,1),NTCHAN(IT1,2) DO I2=NTCHAN(IT2,1),NTCHAN(IT2,2) IF(IFTOP.GT.0.AND.MAX(LLCH(I1),LLCH(I2)).GT.LITLAM(I) X .OR.IFTOP.LT.0)RK(I1,I2)=TZERO ENDDO ENDDO ENDIF ENDIF 100 CONTINUE ENDIF C C C STORE OMEGA RESULTS IN COMPACT FORM C C MXTST=(MZTAR*(MZTAR+1))/2 C C IT AND JT ARE TARGET STATES C OMEGA(IT,JT) FOR JT.GT.IT STORED IN C OMST(IJST)=OMEGA(ITST(IJST),JTST(IJST)) C C NUMBER OF OPEN TARGET LEVELS IF(NCHOP.EQ.0)GO TO 666 C NTAROP=ITARG(NCHOP) IONE=1 IF(ELAS.EQ.'YES')IONE=0 NOMT=(NTAROP*(NTAROP-2*IONE+1))/2 JTMAX=NTAROP IF(NOMWRT.LT.0.AND.-NOMWRT.LT.NOMT)THEN NOMT=-NOMWRT K=0 DO J=1+IONE,NTAROP DO I=1,J-IONE K=K+1 ENDDO IF(K.GE.NOMT)GO TO 11 ENDDO 11 JTMAX=MIN(J,NTAROP) ENDIF IF(NOMWRT.GT.0.AND.NOMWRT.LT.(NAST*(NAST-2*IONE+1))/2)THEN K=0 DO J=1+IONE,NTAROP IP=MIN(ITMAX,J-IONE) DO I=1,IP K=K+1 ENDDO ENDDO NOMT=K ENDIF DO J=1,NAST DO I=1,J KTST(I,J)=0 ENDDO ENDDO C IJST=0 J2=IONE*NCONAT(1) DO 130 JT=1+IONE,JTMAX IF(NCONAT(JT).EQ.0)GOTO 130 J1=J2+1 J2=J2+NCONAT(JT) I2=0 DO 120 IT=1,JT-IONE IF(NCONAT(IT).EQ.0)GOTO 120 I1=I2+1 I2=I2+NCONAT(IT) IJST=IJST+1 OMT=TZERO KTST(IT,JT)=IJST DO J=J1,J2 DO I=I1,I2 OMT=OMT+RK(I,J) ENDDO ENDDO OMST(IJST)=OMT ITST(IJST)=IT JTST(IJST)=JT 120 CONTINUE 130 CONTINUE C C STORE DR OMEGA(IT,IE) BY INITIAL METASTABLE STATE IT AND ENERGY C I.E. SUMMED OVER ALL FINAL STATES. (ELAS='YES' HERE). C IF(NDRMET.GT.0.AND.NCHOP.LT.NCHF)THEN IF(QDT.OR.IQDT.NE.0)THEN ITT=MIN(NDRMET,NTAROP) I2=0 DO 135 IT=1,ITT IF(NCONAT(IT).EQ.0)GO TO 135 I1=I2+1 I2=I2+NCONAT(IT) DO I=I1,I2 OMEGDR(IT,IE)=OMEGDR(IT,IE)+PDR(I) ENDDO 135 CONTINUE ENDIF ENDIF C C TOP-UP NOW CONTROLLED BY LRGLAM C IF(LRGLAM.GE.0)CALL TOP2 C C WRITE TARGET STATES AND COLLISION STRENGTHS C IF(ISGPT.NE.0)WRITE(14,776) IF(IPRINT.GT.-2)WRITE(6,777) IF(IPRINT.GT.-2) X WRITE(6,601)ETOT,QDT,IPERT,(ITST(K),JTST(K),OMST(K),K=1,IJST) C C ADD TO OMEGA C IF(NOMT.GT.0)THEN IFLG=0 IF(MPOS(IE).GT.0) THEN K=MPOS(IE-1) DO JT=1+IONE,JTMAX ITP=MIN(JT-IONE,ITMAX) DO IT=1,ITP K=K+1 KK=KTST(IT,JT) IF(KK.GT.0)THEN OMEM(K)=OMEM(K)+OMST(KK) IF(OMST(KK).GT.1.0E-10)IFLG=1 ENDIF ENDDO ENDDO ELSEIF(MPOS(IE).LT.0) THEN NREC=-MPOS(IE) CALL OMREAD(OMEGA,NOMT,NREC) K=0 DO JT=1+IONE,JTMAX ITP=MIN(JT-IONE,ITMAX) DO IT=1,ITP K=K+1 KK=KTST(IT,JT) IF(KK.GT.0)THEN OMEGA(K)=OMEGA(K)+OMST(KK) IF(OMST(KK).GT.1.0E-10)IFLG=1 ENDIF ENDDO ENDDO CALL OMWRIT(OMEGA,NOMT,NREC) ENDIF IF(IFLG.EQ.1.AND.LRGL2.GT.ISKP0)ISKP(IE)=LRGL2+LINC ENDIF C C CALCULATE THE PARTIAL CROSS SECTIONS C IF(ISGPT*ITRMN*ITRMX.NE.0)THEN IF(NOMWRT.GT.0)THEN SIGPWT=TZERO K=0 DO IT=1,ITMAX DO JT=IT+IONE,NAST K=K+1 IF(K.GE.ITRMN.AND.K.LE.ITRMX) THEN ITST(K)=IT JTST(K)=JT KK=KTST(IT,JT) IF(KK.GT.0)THEN WWI=ISAT(IT)*(2*LAT(IT)+1) IF(NSPN2.EQ.0) WWI=LAT(IT)+1 EKI=AZAZ*(ETOT-ENAT(IT)) SIGPW(K)=CONSIG*OMST(KK)/(WWI*EKI) SIGPWT=SIGPWT+SIGPW(K) ELSE SIGPW(K)=TZERO ENDIF ENDIF ENDDO ENDDO ENDIF IF(NOMWRT.LT.0)THEN SIGPWT=TZERO K=0 DO JT=1+IONE,NAST DO IT=1,JT-IONE K=K+1 IF(K.GE.ITRMN.AND.K.LE.ITRMX) THEN ITST(K)=IT JTST(K)=JT KK=KTST(IT,JT) IF(KK.GT.0)THEN WWI=ISAT(IT)*(2*LAT(IT)+1) IF(NSPN2.EQ.0) WWI=LAT(IT)+1 EKI=AZAZ*(ETOT-ENAT(IT)) SIGPW(K)=CONSIG*OMST(KK)/(WWI*EKI) SIGPWT=SIGPWT+SIGPW(K) ELSE SIGPW(K)=TZERO ENDIF ENDIF ENDDO ENDDO ENDIF WRITE(14,6011) ETOT,(ITST(K),JTST(K),SIGPW(K),K=ITRMN,ITRMX) WRITE(14,6012) ITRMN,ITRMX,SIGPWT ENDIF C C 666 IPERT=IABS(IPERT) C C RETURN C C FORMATS C 600 FORMAT(' SR.REACT: MATRIX HAS NO INVERSE IN VERT') 601 FORMAT(F9.5,L3,I6,2X,3(I3,I3,1PE11.3)/(20X,3(I3,I3,E11.3))) 640 FORMAT(//7X,'ENERGY',13X,'S',2X,'L',1X,'PI',6X,'TI', 1 1X,'LI',4X,'TJ',1X,'LJ',7X,'OMEGA'/) 650 FORMAT(5X,E14.6,5X,3I3,5X,2I3,3X,2I3,5X,E14.6) 655 FORMAT(' FDIP FAILURE: IFAIL=',I2,' FOR I,J=',2I4,' E,L=' X ,2(1PE13.5,I3)) 660 FORMAT(3I5,1PE14.8) 668 FORMAT(/2X,'I',2X,'T',3X,'L'3X,'K/NU') 669 FORMAT(I3,I3,I4,F7.2) 670 FORMAT(2I5) 671 FORMAT(3I5) 680 FORMAT(E15.6) 695 FORMAT(' T-MATRIX VIOLATES UNITARITY FOR ETOT=',F12.8,3X, X'IPERT=',I2,4X,'I,J=',2I3,4X,'T**2=',F7.4) 707 FORMAT(/' REACTANCE MATRIX FOR ETOT = ',F10.6// 1 (I9,6I11)) 710 FORMAT(I3,1P7E11.3/(3X,7E11.3)) 720 FORMAT(//3X,'I',3X,'J',4X,' IT',1X,' JT',7X X,'OMEGA-CC',2X,'OMEGA-CBE',6X,'CBE/CC') 721 FORMAT(2I4,3X,2I4,4X,2(1PE11.3),0PF12.5) 776 FORMAT(//' ETOT',3X, 1 'INITIAL AND FINAL TARGET LEVELS, AND CROSS SECTIONS (Mb)'/) 777 FORMAT(//' ETOT',3X,'QDT',2X,'IPERT',2X, 1 'INITIAL AND FINAL TARGET LEVELS, AND COLLISION STRENGTHS'/) 6011 FORMAT(F9.5,1X,3(I3,I3,1PE13.5)/(10X,3(I3,I3,E13.5))) 6012 FORMAT('THE TOTAL CROSS SECTION FOR TRANSITIONS',I3,' TO ', X I3,' EQUALS ',1PE13.5,' Mb') C END C*************************************************************** C SUBROUTINE READ1 C C READS DATA INDEPENDENT OF SLPI FROM R-MATRIX FILE, FILA C C THE FOLLOWING DATA ARE READ _ C NZ = NUCLEAR CHARGE C NELC = NUMBER OF ELECTRONS IN TARGET C NAST = NUMBER OF TARGET STATES C LRANG2 = TOTAL NUMBER OF SMALL L/BIG K VALUES C LAMAX = MAXIMUM LAMBDA FOR MULTIPOLE POTENTIALS C RA = R-MATRIX RADIUS C BSTO = LOGARITHMIC DERIVATIVE C FOR I = 1,NAST - C ENAT(I) = TARGET ENERGIES C LAT(I) = TARGET ORBITAL ANGULAR MOMENTA C ISAT(I) = VALUES OF (2*S+1) FOR TARGET STATES C FOR I = 1,3 AND L = 1,LRANG2 - C COEFF(I,L) = BUTTLE CORRECTION FITS C FOR I=1,NBUTD(L) FOR L=1,LRANG2 DARC BUTTLE CORRECTION C EBUTD(I,L),CBUTD(I,L) C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C LOGICAL EX C COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZ,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) COMMON/NRBLMX/LMX COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT C C READ AND DIMENSION CHECKS C IF(IWORD.EQ.2)GO TO 50 READ(10)NELC,NZ,LRANG2,LAMAX,NAST,RA,BSTO C IF(LRANG2.LT.0)THEN !FROM DARC DSTG2 VIA DTO3. LRANG2=-LRANG2 KFLAG=-1 ENDIF C IF(LAMAX.GT.MZLMX)THEN WRITE(6,614)LAMAX,MZLMX LAMAX=MZLMX ENDIF C IF(LMX.GT.LAMAX)THEN WRITE(6,615)LMX,LAMAX LMX=LAMAX ENDIF C IF(NAST.LT.0)THEN IPRCENT=0 NAST=-NAST ELSE IPRCENT=100 ENDIF C IF(NAST.GT.MZTAR)THEN WRITE(6,610)NAST STOP '*** DIMENSION EXCEEDED: INCREASE MZTAR' ENDIF C READ(10)(ENAT(I),I=1,NAST) READ(10)(LAT(I),I=1,NAST) READ(10)(ISAT(I),I=1,NAST) C IF(LRANG2.GT.MZLP1)THEN WRITE(6,620)LRANG2,MZLP1 STOP '*** DIMENSION EXCEEDED: INCREASE MZLP1' ENDIF C READ(10)((COEFF(I,L),I=1,3),L=1,LRANG2) C IF(IPRCENT.NE.100)THEN !FOR PARTITIONED READ(10)IPRCENT,NRANG2 IF(NRANG2.GT.MZNRG)THEN WRITE(6,625)NRANG2,MZNRG STOP '*** DIMENSION EXCEEDED: INCREASE MZNRG' ENDIF DO L = 1,LRANG2 READ (10) (EIGENS(N,L),N=1,NRANG2) READ (10) (ENDS(N,L),N=1,NRANG2) ENDDO ENDIF C INQUIRE(FILE='DBUT.DAT',EXIST=EX) IF(EX)THEN IWORD=-1 IB=11 OPEN(11,FILE='DBUT.DAT',FORM='UNFORMATTED') GO TO 51 ENDIF C RETURN C C DARC 50 READ(10) READ(10)NELC,NZ,NRANG2,LRANG2,NAST,RA,BSTO C IF(NAST.GT.MZTAR)THEN WRITE(6,610)NAST STOP '*** DIMENSION EXCEEDED: INCREASE MZTAR' ENDIF C READ(10)(ENAT(I),I=1,NAST) READ(10)(LAT(I),I=1,NAST) C DO I=1,NAST LAT(I)=ABS(LAT(I))-1 ISAT(I)=0 ENDDO C IF(LRANG2.GT.MZLP1)THEN WRITE(6,620)LRANG2,MZLP1 STOP '*** DIMENSION EXCEEDED: INCREASE MZLP1' ENDIF C IB=10 C 51 DO L=1,LRANG2 READ(IB)NBUTD(L) IF(NBUTD(L).GT.MZNRG)THEN WRITE (6,699) NBUTD(L),MZNRG STOP '*** DIMENSION EXCEEDED: INCREASE MZNRG' ENDIF READ(IB)(EBUTD(I,L),I=1,NBUTD(L)) READ(IB)(CBUTD(I,L),I=1,NBUTD(L)) ENDDO C IF(IB.EQ.11)CLOSE(11) C RETURN C 610 FORMAT(///20X,'TOO MANY TARGET STATES'// 1 10X,'VALUE READ FOR NAST IS ',I3// 2 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZTAR'//) 614 FORMAT(///20X,'WARNING TOO MANY MULTIPOLES PRESENT VIZ.',I3// 2 20X,'MAXIMUM ALLOWED BY DIMENSIONS IS:',I3//) 615 FORMAT(///20X,'WARNING TOO MANY MULTIPOLES REQUESTED VIZ.',I3// 2 20X,'MAXIMUM AVAILABLE/ALLOWED BY DIMENSIONS IS:',I3//) 620 FORMAT(///20X,'TOO MANNY BUTTLE COEFFICIENTS'// 1 10X,'VALUE READ FOR LRANG2 IS ',I3// 2 10X,'MAXIMUM VALUE ALLOWED BY DIMENSIONS IS MZLP1 =',I3//) 625 FORMAT(//' ******* NRANG2 = ',I4,' LARGER THAN ', + 'MZNRG = ',I4//) 699 FORMAT(//' ******* NBUT = ',I4,' LARGER THAN ', + 'MZNRG = ',I4//) C END C*************************************************************** C SUBROUTINE READ2(IOPT1) C C READS R-MATRIX DATA FOR ONE SLPI CASE, FROM FILA C C THE FOLLOWING DATA ARE READ - C LRGL2 = TOTAL ORBITAL ANGULAR MOMENTUM/ 2J C NSPN2 = TOTAL (2*S+1)/0 C NPTY2 = TOTAL PARITY C NCHAN = NUMBER OF CHANNELS C MNP2 = NUMBER OF R-MATRIX POLES C MORE2 = ZERO TO TERMINATE SLPI CASES C FOR I = 1,NAST - C NCONAT(I) = NUMBER OF CHANNELS FOR TARGET STATE I C FOR I = 1,NCHAN - C L2P(I), KJ(I) = SMALL L AND BIG jK FOR CHANNEL I C = K-1, 0 FROM DSTG2/DARC C FOR I = 1,NCHAN AND N = 1,NCHAN AND M = 1,LAMAX - C CF(I,N,M) = COEFFICIENTS IN MULTIPOLE POTENTIALS C FOR I = 1,MNP2 - C VALUE(I) = R-MATRIX POLE ENERGIES C FOR K = 1,NCHAN AND I = 1,MNP2 - C WMAT(I,K) = R-MATRIX AMPLITUDES C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) C COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZ,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X,IPAR(MZTAR),NEWAR COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR) X,IWD(MZTAR),IWT COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT C C READ AND DIMENSION CHECKS C IF(IWORD.NE.2)THEN READ(10,END=999)LRGL2,NSPN2,NPTY2,NCHAN,MNP2,MORE2 ELSE !DARC READ(10,END=999)LRGL2,NPTY2,NCHAN,MNP2,NCFGP,LAMAX MORE2=1 LRGL2=ABS(LRGL2)-1 NSPN2=0 IF(NPTY2.EQ.-1)THEN NPTY2=1 ELSE NPTY2=0 ENDIF KFLAG=-2 ENDIF C READ(10)(NCONAT(I),I=1,NASTR) ! NAST? IF(NCHAN.GE.MZCHF)THEN !.GE. FOR SR.LU WRITE(6,600)NSPN2,LRGL2,NPTY2,NCHAN STOP '*** DIMENSION EXCEEDED: INCREASE MZCHF' ENDIF C IF(NSPN2.NE.0)READ(10)(L2P(I),I=1,NCHAN) IF(NSPN2.EQ.0)THEN IF(KFLAG.EQ.1)READ(10,ERR=997)(L2P(I),I=1,NCHAN), X (KJ(I),I=1,NCHAN) IF(KFLAG.NE.1)READ(10)(L2P(I),I=1,NCHAN) ENDIF C IF(LAMAX.GT.0) !DIMENSION TEST ON LAMAX NOW IN SR.READ1 XREAD(10)(((CF(I,N,M),I=1,NCHAN),N=1,NCHAN),M=1,LAMAX) C IF(iabs(MNP2).GT.MZMNP)THEN WRITE(6,610)NSPN2,LRGL2,NPTY2,MNP2 STOP '*** DIMENSION EXCEEDED: INCREASE MZMNP' ENDIF C IF(IPRCENT.NE.100)READ(10)TRACE C IF(MNP2.GE.0)THEN READ(10)(VALUE(I),I=1,MNP2) READ(10)((WMAT(I,K),K=1,NCHAN),I=1,MNP2) ELSE !DIVIDED WMAT - CPB MNP2=-MNP2 C write(0,*)'get read2 div',NCHAN,MNP2 READ(10)(VALUE(I),I=1,MNP2) KK=0 13 READ(10)ILOW,IUPPER,NDIV READ(10)((WMAT(I-ILOW+1+KK,K),K=1,NCHAN),I=ILOW,IUPPER) KK=KK+IUPPER-ILOW+1 IF(ILOW.NE.1) GO TO 13 ENDIF C IF(IWORD.EQ.2)THEN !DARC DO I=1,NCHAN L2P(I)=2*L2P(I) !2*kappa IF(L2P(I).LT.0)L2P(I)=-L2P(I)-1 !K, analogue of L L2P(I)=L2P(I)-1 !K-1 ENDDO ENDIF IF(KFLAG.LT.0)THEN !L2P(I)=K-1 DO I=1,NCHAN LLCH(I)=(L2P(I)+1)/2 !CHANNEL ORB ANG K2P(I)=LLCH(I) IF(LLCH(I)*2.NE.L2P(I)+1)K2P(I)=-K2P(I)-1 !KAPPA KJ(I)=0 !AS JJ COUPLING ENDDO ELSE DO I=1,NCHAN LLCH(I)=L2P(I) !CHANNEL ORB ANG ENDDO ENDIF C C GROUP TOGETHER CHANNELS BELONGING TO DEGENERATE LEVELS C AND PRESERVE THE READ VALUES OF NCONAT IN /CDEGEN/ IF(IOPT1.GT.9) NASTR=NAST IF(NASTD.GT.0)THEN DO I=1,NASTR NCNATR(I)=NCONAT(I) ENDDO IF(IOPT1.LT.10)THEN N1=1 DO I=1,NASTD NCON=0 N2=NLEV(I)+N1-1 DO IN=N1,N2 NCON=NCON+NCNATR(IN) ENDDO NCONAT(I)=NCON N1=N2+1 ENDDO ENDIF ENDIF C C TARGET PARITIES C K=1 DO I=1,NAST IF(NCONAT(I).NE.0)THEN IF(IPAR(I).LT.0)IPAR(I)=ABS(NPTY2-LLCH(K)+2*(LLCH(K)/2)) K=K+NCONAT(I) ENDIF ENDDO C IF (NSPN2.EQ.0.AND.KFLAG.EQ.0) THEN C C RECOVER THE K CHANNEL NUMBERS (BASED ON SR.NJCHAN) IF C NOT READ FROM H.DAT C NJCHA = 0 C C LOOP OVER THE TARGET STATES. C DO 4 I = 1,NAST C C LOOP OVER THE ONLY TWO POSSIBLE 2K VALUES, THAT IS LRGL2-1,LRGL2+1 C IFIN = 3 IF (LRGL2.EQ.0) IFIN = 1 DO 3 K = 1,IFIN,2 JK = ABS(LRGL2-2+K) C C RECOVER THE RANGE OF L(INCIDENT) VALUES. C LMIN = ABS(LAT(I)-JK) LMAX = LAT(I) + JK C C CHECK IF LMIN IS AN INTEGER. C IF (MOD(LMIN,2).NE.0) GOTO 3 C C CHECK THE PARITY OF LMIN. C LP = LMIN/2 + IPAR(I) IF (MOD(LP,2).NE.NPTY2) LMIN = LMIN + 2 C LP = (LMIN+LMAX)/2 IF (MOD(LP,2).EQ.1) LMAX = LMAX - 2 IF (LMIN.GT.LMAX) GOTO 3 C C STORE THE 2K-VALUES IN KJ. C LMIN = LMIN + 1 LMAX = LMAX + 1 DO 2 L = LMIN,LMAX,4 NJCHA = NJCHA + 1 KJ(NJCHA) = JK 2 CONTINUE 3 CONTINUE 4 CONTINUE C C END RECOVERY OF K QUANTUM NUMBER C ENDIF C RETURN C 999 MORE2=-777 RETURN C 997 WRITE(6,*)'***SR.READ2 ERROR, TRY SETTING KLAG=0' STOP '***SR.READ2 ERROR, TRY SETTING KLAG=0' C 600 FORMAT(///20X,'TOO MANY CHANNELS FOR (IS, IL, IP) = (', 1 3I3,')'//10X,'VALUE READ FOR NCHAN IS ',I4// 2 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZCHF'//) 610 FORMAT(///20X,'TOO MANY R-MATRIX STATES FOR (IS, IL, IP) = (', * 3I3,')'//10X,'VALUE READ FOR MNP2 IS ',I5// 3 10X,'MAXIMUM ALLOWED BY DIMENSIONS IS MZMNP'//) C END C*************************************************************** C SUBROUTINE READPQ(IE,QETEST,ISLP,IOPT1,QJUMP,PQRD) C C NRB: C CALCULATE, READ AND/OR INTERPOLATE MATRICES P AND Q, C WHICH MAY BE UNPHYSICAL K OR S. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL PQRD,QJUMP C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CMESH/EMAX,EMIN,DEOPEN,DQN,QNMAX,EMESH(MZMSH),IMESH COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) C DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF) DIMENSION P1(MZCHF,MZCHF),Q1(MZCHF,MZCHF) DIMENSION P2(MZCHF,MZCHF),Q2(MZCHF,MZCHF) DIMENSION IOMIT1(MZCHF),IOMIT2(MZCHF) C EQUIVALENCE (P,CSP),(Q,CC),(P2,CCPP),(Q2,DS) C SAVE IE1,IE2,MPTY1,MPTY2,E1,E2,IOMIT1,IOMIT2,P1,Q1 C C IF(IE.EQ.0)THEN C IF(IMODE.LT.0)THEN C C CALCULATE UNPHYSICAL P,Q C CALL POINTS(IOPT1,.FALSE.) CALL REACT(IOPT1,.FALSE.,.TRUE.) C IF(NCHOP.NE.NCHF)STOP'READPQ: NCHOP.NE.NCHF' E2=ETOT IE2=1 MPTY2=0 !NOT NEEDED? DO J=1,NCHF IOMIT2(J)=IOMIT(J) DO I=J,NCHF P2(I,J)=P(I,J) Q2(I,J)=Q(I,J) ENDDO ENDDO C ELSE C C FIRST ENERGY READ FOR THIS SYMMETRY, AND POSSIBLY FIRST READ AT ALL. C IF IOPT1=2 WE FIRST NEED TO FIND THE CORRECT SYMMETRY. C NCHF SHOULD BE EQUAL TO NCHF THROUGHOUT THE IQDT=1 PROBLEM. C IF(IOPT1.EQ.2)REWIND(21) 1 READ(21,END=100)IE2,MPTY2,NCHOPP,E2 READ(21) (IOMIT2(I),I=1,NCHOPP) READ(21)((P2(I,J),I=J,NCHOPP),J=1,NCHOPP), X ((Q2(I,J),I=J,NCHOPP),J=1,NCHOPP) IF(IE2.NE.1)THEN C HIGH ENERGY OF OLD SLP IF(MPTY2.NE.ISLP)GO TO 1 ELSE C NO SEARCH ON SLP IF IOPT1.NE.2 SO STOP IF MIS-MATCH IF(MPTY2.NE.ISLP)THEN IF(IOPT1.EQ.2)GO TO 1 WRITE(6,*)' CHECK JBIN? MIS-MATCH ON SYMMETRIES IN PQ DATA:' X ,MPTY2,ISLP STOP 'READPQ' ENDIF ENDIF ENDIF C QJUMP=.TRUE. PQRD=.TRUE. E1=999999. RETURN C ENDIF C C SEE IF WE NEED TO READ NEW DATA OR JUST INTERPOLATE EXISTING PQ. C IF(ETOT.GT.E1-QETEST .AND. ETOT.LT.E2+QETEST)GO TO 3 C C MOVE P2,Q2 TO P1,Q1 ETC. C 2 E1=E2 IE1=IE2 MPTY1=MPTY2 DO J=1,NCHF IOMIT1(J)=IOMIT2(J) DO I=J,NCHF P1(I,J)=P2(I,J) Q1(I,J)=Q2(I,J) ENDDO ENDDO C IF(IMODE.LT.0)THEN C C CALCULATE NEW P,Q BUT FIRST FIND APPROPRIATE ENERGY C DO I=IE1+1,MXE IF(IEE(I).NE.0)GO TO 20 ENDDO STOP ' READPQ CANNOT FIND NEXT ENERGY' 20 IE2=I E2=EMESH(I) MPTY2=0 !NOT NEEDED? ETT=ETOT ETOT=E2 C CALL POINTS(IOPT1,.FALSE.) CALL REACT(IOPT1,.FALSE.,.TRUE.) C IF(NCHOP.NE.NCHF)STOP'READPQ: NCHOP.NE.NCHF' ETOT=ETT DO J=1,NCHF IOMIT2(J)=IOMIT(J) DO I=J,NCHF P2(I,J)=P(I,J) Q2(I,J)=Q(I,J) ENDDO ENDDO GO TO 3 ENDIF C C READ A NEW P,Q SET C READ(21,END=100)IE2,MPTY2,NCHOPP,E2 IF(IE2.LT.IE1)THEN !WE HAVE MOVED ONTO THE NEXT SYMMETRY SO BACKSPACE(21) E2=999999. GO TO 100 ENDIF IF(MPTY2.NE.ISLP)THEN !NO SEARCH ON SLP HERE SO STOP IF MIS-MATCH WRITE(6,*)' CHECK JBIN? MIS-MATCH ON SYMMETRIES IN PQ DATA:' X ,MPTY2,ISLP STOP 'READPQ' ENDIF IF(NCHOPP.NE.NCHF)STOP'READPQ: NCHOP.NE.NCHF' READ(21) (IOMIT2(I),I=1,NCHF) READ(21)((P2(I,J),I=J,NCHF),J=1,NCHF), X ((Q2(I,J),I=J,NCHF),J=1,NCHF) C !SEE IF THIS ENERGY IS ENOUGH, IF(ETOT.GT.E2+QETEST)GO TO 2 ! ELSE MOVE AND RE-READ C C NOW FORM NEW P,Q (SIMPLE LINEAR INTERPOLATION), CHECK ENERGIES O.K. C 3 IF(ETOT.LT.E1-2.*QETEST.OR.ETOT.GT.E2+2.*QETEST)THEN WRITE(6,*)' CHECK JBIN? ENERGY MIS-MATCH, E1,E2,ETOT' X ,E1,E2,ETOT STOP 'ENERGY MIS-MATCH' ENDIF C C WATCH-OUT FOR MIS-MATCH IN OMITTED CHANNELS C IFOM=0 DO J=1,NCHF IOMIT(J)=IOMIT1(J)+IOMIT2(J) IF(IOMIT(J).EQ.1)THEN IF(IFOM.NE.0)THEN !IF THERE'S MORE THAN MORE CASE...... c write(75,*)etot,ifom,j ELSE IFOM=J !USE ONE WITH LOWEST CHANNEL OMITTED ENDIF ENDIF ENDDO IF(IFOM.NE.0)THEN !DON'T INTERPOLATE, INSTEAD C IF(ABS(E2-ETOT).LT.ABS(ETOT-E1))THEN ! USE NEAREST IF(IOMIT2(IFOM).EQ.1)THEN ! USE OMITTED, MORE STABLE T2=-ONE T1=TZERO DO J=1,NCHF IOMIT(J)=IOMIT2(J) ENDDO ELSE T1=ONE T2=TZERO DO J=1,NCHF IOMIT(J)=IOMIT1(J) ENDDO ENDIF ELSE !INDEED, SAFE TO INTERPOLATE T1=(E2-ETOT)/(E2-E1) T2=(E1-ETOT)/(E2-E1) ENDIF C C NOW FORM NEW P,Q C DO J=1,NCHF DO I=J,NCHF P(I,J)=T1*P1(I,J)-T2*P2(I,J) Q(I,J)=T1*Q1(I,J)-T2*Q2(I,J) P(J,I)=P(I,J) Q(J,I)=Q(I,J) ENDDO ENDDO C C ZERO-OUT OMITTED CHANNELS (IF ANY IOMIT(ICHAN)=1). C IF(IQDT.GT.0)THEN DO J=1,NCHF IF(IOMIT(J).EQ.1)THEN DO I=1,NCHF P(I,J)=TZERO Q(I,J)=TZERO P(J,I)=TZERO Q(J,I)=TZERO ENDDO IF(IQDT.EQ.1)P(J,J)=ONE ENDIF ENDDO ELSE DO I=1,NCHF IOMIT(I)=0 ENDDO ENDIF C RETURN C C 100 IF(IE.EQ.0)THEN !PQ FILE DOES NOT EXIST PQRD=.FALSE. REWIND(21) ELSE C NO MORE DATA AVAILABLE, PRINT WARNING, AND CONTINUE WITH OLD P,Q. WRITE(6,*)' ****NO MORE PQ DATA ON FILE FOR THIS SYMMETRY' X ,' USING LAST ENERGY' ENDIF C RETURN END C*************************************************************** C SUBROUTINE RINIT C C NRB: USES WMAT WITH INDEXES INTERCHANGED COMPARED TO CPC. C C INITIALIZE CALCULATION OF R-MATRIX. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL NEWBUT C INCLUDE 'PARAM' C PARAMETER (MXNCH1=MZCHF/10+1) !FOR DGEMM C PARAMETER (MXNCH1=1) !FOR DDOT & NON-BLAS C PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) C COMMON/CEN/ETOT,MXE,NWT,NZ C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CLOGB/NEWBUT COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT C COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) C DIMENSION TEMP1(MZMNP),TEMP2(MZMNP,MXNCH1) C DATA IDIV/0/ !FOR NON-DGEMM SYMMETRISE C C INITIALISE C DO I=1,NCHF DO J=1,NCHF RMAT(J,I)=TZERO ENDDO ENDDO C C INITIALISE DIAGONAL ELEMENTS TO BUTTLE CORRECTION C IF(IWORD.EQ.1)THEN IF(NEWBUT)THEN RA2=RZERO*RZERO DO I=1,NCHF L=L2P(I)+1 NBUT=COEFF(3,L) RMAT(I,I)=COEFF(1,L)*BUT0(NBUT,COEFF(2,L)+RA2*EPS(I)) ENDDO ELSE DO I=1,NCHF L=L2P(I)+1 E=EPS(I) RMAT(I,I)=COEFF(1,L)+E*(COEFF(2,L)+E*COEFF(3,L)) ENDDO ENDIF ELSE !DARC DO I=1,NCHF L=L2P(I)+1 E=ETOT-ECH(I) !EPS(I) CALL INTBUT(L,E,BUTT) RMAT(I,I)=BUTT ENDDO ENDIF C C NOW ADD-IN ANY PARTITIONED CORRECTION C EZERO=TZERO IF(IPRCENT.NE.100)THEN EZERO=ONE/(TRACE-ETOT) DO I=1,NCHF RMAT(I,I)=RMAT(I,I)+SI(I)*EZERO L=L2P(I)+1 DO N=NRANG1(L),NRANG2 V=ONE/(EIGENS(N,L)-ETOT) RMAT(I,I)=RMAT(I,I)+ENDS(N,L)*(V-EZERO) ENDDO ENDDO ENDIF C C PRELIMINARY SET-UP C DO K=1,MNP2 TEMP1(K)=ONE/(VALUE(K)-ETOT)-EZERO ENDDO C C FORM R-MATRIX (TIME CONSUMING) C CSTRTBL C USE DGEMM, HOPEFULLY FROM HIGHLY OPTIMZED LIBRARY. C SINCE IT COMPUTES THE WHOLE MATRIX MULTIPLY, WE DIVIDE C IT IDIV TIMES TO COMPUTE THE UPPER HALF ONLY AND SO C REDUCE THE TIME/MEMORY BY APPROX FACTOR 2. C . IDIV=MIN(10,NCHF/20+1) 1 T=NCHF T=T/IDIV NCHFI=NINT(T) NCHF0=NCHF-IDIV*NCHFI C IF(NCHF0.GT.0)THEN IDIV=IDIV+1 ELSEIF(NCHF0.EQ.0)THEN NCHF0=NCHFI ELSE NCHF0=NCHFI+NCHF0 ENDIF C IF(NCHF0.GT.MXNCH1)THEN !NCHF *AND* MZCHF ARE SMALL IDIV=NCHF/MXNCH1 GO TO 1 ENDIF C NCHF2=0 C DO ID=1,IDIV C DO I=1,NCHF0 II=NCHF2+I DO K=1,MNP2 TEMP2(K,I)=TEMP1(K)*WMAT(K,II) ENDDO ENDDO C NCHF1=NCHF2+1 NCHF2=NCHF2+NCHF0 C CALL DGEMM('T','N',NCHF2,NCHF0,MNP2,ONE,WMAT,MZMNP X ,TEMP2,MZMNP,ONE,RMAT(1,NCHF1),MZCHF) C NCHF0=NCHFI C ENDDO C C OR DDOT TO GENERATE UPPER HALF RMAT (CASE ONLY NON-OPTIMIZED DGEMM) C CBL DO I=1,NCHF CBL DO K=1,MNP2 CBL TEMP2(K,1)=TEMP1(K)*WMAT(K,I) CBL ENDDO CBL DO J=1,I CBL RMAT(J,I)=RMAT(J,I)+DDOT(MNP2,TEMP2(1,1),1,WMAT(1,J),1) CBL ENDDO CBL ENDDO CENDBL C CSTRTNBL CNBL DO I=1,NCHF CNBL DO K=1,MNP2 CNBL TEMP2(K,1)=TEMP1(K)*WMAT(K,I) CNBL ENDDO CNBL DO J=1,I CNBL DO K=1,MNP2 CNBL RMAT(J,I)=RMAT(J,I)+TEMP2(K,1)*WMAT(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C C SYMMETRISE U->L (IF NECESSARY) C IF(IDIV.NE.1)THEN DO I=2,NCHF DO J=1,I-1 RMAT(I,J)=RMAT(J,I) ENDDO ENDDO ENDIF C RETURN END C*************************************************************** C SUBROUTINE SC(E,L,R,AC,S,SP,C,CP,IERR) C C COULOMB FUNCTIONS S AND C FROM C POWER SERIES EXPANSIONS. C NRB: C MODIFIED TO HANDLE DEEPLY BOUND CHANNELS. C NEUTRAL CASE TO BE ADDED. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (XEPS=1.E-1) PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBZED/TZED,LPRTSW C PI=ACOS(-ONE) TPI=TWO*PI C C NEUTRAL CASE C IF(TZED.EQ.0)THEN C IF(E.LT.0)THEN WRITE(6,*)'USE STGFDAMP FOR NEUTRAL MQDT' STOP 'USE STGFDAMP FOR NEUTRAL MQDT' ENDIF C CALL SC0(E,L,R,AC,ZS,S,SP,ZC,C,CP,IERR) C RETURN ENDIF C C POWER SERIES FOR F AND G (POSITIVE IONS ONLY) C CALL COULFG(L,E,R,AC,F,FP,G,GP,K,IERR,ACT) C FNU=E IF(E.LT.TZERO)FNU=ONE/SQRT(-E) C IF(IERR.GT.0)THEN !NOT (SUFFICIENTLY) CONVERGED IF(IFLEG.LE.0)THEN IF(IERR.EQ.1)WRITE(6,610)ICHAN,L,FNU,K,ACT IF(IERR.EQ.2)WRITE(6,600)ICHAN,L,FNU,ACT IF(IERR.EQ.3)WRITE(6,602)ICHAN,L,FNU IFLEG=-1 ENDIF IF(IERR.GT.1)THEN IF(IFLEG.LE.0)THEN WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***' IFLEG=-1 ENDIF IOMIT(ICHAN)=1 C ALLOW EXECUTION TO PROCEED AND OMIT LATER S=0.5 SP=-0.05 C=100. CP=-10. RETURN ELSE TEST=10.*AC IF(ABS(ACT).GT.TEST)THEN IF(IFLEG.LE.0)THEN WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***' IFLEG=-1 ENDIF IOMIT(ICHAN)=1 RETURN ENDIF ENDIF ENDIF C C CASE OF E.GE.0 C IF(E.GE.0)THEN C C CALCULATE CAP. A A=ONE IF(L.GT.0)THEN A1=ONE A2=-E A3=E+E DO I=1,L A2=A2+A3 A1=A1+A2 A=A*A1 ENDDO ENDIF C CALCULATE SCRIPT G AND COULOMB FUNCTION H AND DERIVATIVE SG=A*FKHI(E,L,AC)/PI H=-G-SG*F HP=-GP-SG*FP C CALCULATE CAP B IF(E.LT.0.01)THEN B=A ELSE B=A/(ONE-EXP(-TPI/SQRT(E))) ENDIF C ELSE C C CASE OF E.LT.0 C CALL ABG(E,L,AC,A,BG) C IF(A.LT.TZERO.OR.(FNU-XEPS).LT.L)THEN IF(IFLAG.LE.0)THEN WRITE(6,*)' WARNING, N.LT.L+0.1 IN SUBROUTINE SC', X ' ICHAN,E,N,L = ',ICHAN,E,FNU,L IF(IOMSW.GT.0)WRITE(6,*)' ***OMITTING THIS CHANNEL***',ICHAN WRITE(6,*)'***NO MORE SIMILAR WARNINGS FOR THIS SYMMETRY***' IFLAG=-1 ENDIF IF(A.LT.TZERO)THEN A=-A IF(IOMSW.eq.0)IOMIT(ICHAN)=-1 ENDIF IF(IOMSW.ne.0)THEN !SYNC. WITH SR.POINTS FOR DROP/HYBRID IOMIT(ICHAN)=1 IERR=-3 ENDIF ENDIF C H=-(G+BG*F) HP=-(GP+BG*FP) B=A ENDIF C C COMPLETE CALCULATION OF S AND C C C1=SQRT(B*PI/TWO) S=C1*F SP=C1*FP C1=C1/B C=H*C1 CP=HP*C1 C W=C*SP-S*CP IF(IERR.EQ.0.AND.ABS(W-ONE).GT.100*AC.AND.IOMIT(ICHAN).LE.0) X WRITE(*,630)L,E,R,W,ICHAN,IOMIT(ICHAN) !COULFG, ABG SHOULD TRAP C RETURN C 600 FORMAT(///10X,'SERIES IN COULFG NOT CONVERGED'/5X,'ICHAN= ',I3, +', SMALL L = ',I3,', EPS/NU = ',1PE12.4,', ACTACC = ',1PE12.4//) 602 FORMAT(///10X,'SERIES IN COULFG NOT CONVERGED'/5X,'ICHAN= ',I3 +,', SMALL L = ',I3,', EPS/NU = ',1PE12.4//) 610 FORMAT(//5X,'*** FUNCTIONS FROM COULFG INACCURATE ***'/ +5X,'ICHAN= ',I3,', SMALL L =',I3,', EPS/NU = ',1PE12.4,', K = ', +I3,', ACTACC = ',E12.4//) 630 FORMAT(/5X,'SUBROUTINE SC, LL = ',I2,', EPS = ', + 1PE12.5,', R = ',E10.3,', W = ',0PF10.6,' FOR ICHAN=',I4, +' WITH IOMIT=',I2) C END C********************************************************** C SUBROUTINE SC0(EPS,LL,RHO,AC,ZS,S,SP,ZC,C,CP,IERR) C CNRB C CALCULATES REGULAR AND IRREGULAR SPHERICAL BESSEL FUNCTIONS C S AND C AND THEIR DERIVATIVES SP, CP FROM POWER-SERIES EXPANSION. C ZS AND ZC ARE THE COMLPEX CONSTANTS TO BE MULTIPLED BY, CASE EPS.LT.0 C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (ZI=(0.0,1.0)) C COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBZED/TZED,LPRTSW C C INITIALISATIONS C IF(TZED.NE.0)THEN WRITE(6,*)'ERROR: SC0 IS FOR NEUTRALS ONLY' STOP 'ERROR: SC0 IS FOR NEUTRALS ONLY' ENDIF IF(EPS.EQ.TZERO)THEN IERR=-1 S=TZERO SP=TZERO C=TZERO CP=TZERO ZS=ONE ZC=ONE IOMIT(ICHAN)=1 RETURN ENDIF C IERR=0 ACC10=.1*AC DEPS=ABS(EPS) T0=SQRT(SQRT(DEPS)) LAM=-3*LL C C LOOP OVER C AND S GENERATION C DO LLL=-1,0 C LAM=LAM+2*LL FLP1=LAM+1+LLL C C POWER-SERIES EXPANSION C ********************** C C VALUES FOR N=0 FNPLP1=FLP1 C1=RHO**(LAM+LLL) U0=C1 D0=FNPLP1*U0 DM=ABS(D0) FP=D0 U0=U0*RHO UM=ABS(U0) F=U0 C C INITIALIZE FOR COEFFICIENTS IN RECURSION FORMULAE P1=-TWO*FLP1 P2=P1 REPS=RHO*EPS C C LOOP FOR N=2 TO 400, 2 DO N=2,400,2 C COMPUTE COEFFICIENTS IN RECURSION FORMULAE P1=P1-TWO P2=P2+P1 C NOW HAVE P2=-N*(N+LAM) C COMPUTE U2 AND INCREMENT FP FNPLP1=FNPLP1+TWO U2=REPS*U0/P2 D2=FNPLP1*U2 DM=MAX(ABS(D2),DM) FP=FP+D2 C MODIFY U2 AND INCREMENT F U2=U2*RHO UM=MAX(ABS(U2),UM) F=F+U2 C TEST CONVERGENCE IF(ABS(U2).LT.ABS(F)*ACC10.AND.ABS(D2).LT.ABS(FP)*ACC10)THEN IF(IPRINT.GT.1)THEN UM=UM/ABS(F) DM=DM/ABS(FP) IF(EPS.GT.TZERO)THEN WRITE(6,610)ICHAN,LL,EPS,UM WRITE(6,620)ICHAN,LL,EPS,DM ELSE FNU=ONE/SQRT(-EPS) WRITE(6,611)ICHAN,LL,FNU,UM WRITE(6,621)ICHAN,LL,FNU,DM ENDIF ENDIF GO TO 50 ELSE C NEW U0 U0=U2 P1=P1-TWO P2=P2+P1 ENDIF ENDDO C C SERIES NOT CONVERGED WRITE(6,600)LL,EPS,RHO IERR=3 RETURN C STOP 'SC0: SERIES NOT CONVERGED' C 50 IF(LLL.EQ.-1)THEN C=F/T0 CP=FP/T0 ELSE S=F*T0 SP=FP*T0 ENDIF C C END LOOP OVER C AND S ENDDO C C NORMALIZE FOR FUNCTIONS .5*F AND .5*FP C CON=ONE DO K=1,LL CON=CON*DBLE(K*(2*K+1)) ENDDO C=C*CON CP=CP*CON S=S/CON SP=SP/CON C C CALCULATE CAP A A=ONE IF(LL.GT.0)THEN CON=2*LL+1 C=C/CON CP=CP/CON A1=TZED A2=-DEPS A3=DEPS+DEPS DO I=1,LL A2=A2+A3 A1=A1+A2 A=A*A1 ENDDO ENDIF CON=SQRT(A) S=S*CON SP=SP*CON C=C/CON CP=CP/CON C W=C*SP-S*CP IF(ABS(W-ONE).GT.100*AC)THEN IF(EPS.GT.TZERO)THEN WRITE(6,630)ICHAN,LL,EPS,RHO,W ELSE FNU=ONE/SQRT(-EPS) WRITE(6,631)ICHAN,LL,FNU,RHO,W ENDIF IERR=1 ENDIF C C COMPLEX COEFFICIENT IF(EPS.LT.TZERO)THEN ZZ=SQRT(ZI) ZS=ZZ*ZI**LL ZC=ONE/ZS ELSE ZS=ONE ZC=ONE ENDIF C RETURN C 600 FORMAT(//10X,60('*')//10X,'SERIES IN SC0 NOT CONVERGED' + /10X,' LL =',I3,', EPS =',1PE15.5,', RHO =', + E15.5//10X,60('*')//) 610 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,' LL = ',I2,', EPS = ', + 1PE12.5,', UM = ',E10.2) 611 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,' LL = ',I2,', FNU = ', + 0PF10.2,', UM = ',E10.2) 620 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,' LL = ',I2,', EPS = ', + 1PE12.5,', DM = ',E10.2) 621 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,' LL = ',I2,', FNU = ', + 0PF10.2,', DM = ',E10.2) 630 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,' LL = ',I2,', EPS = ', + 1PE12.5,', RHO = ',E10.3,', W = ',0PF10.6) 631 FORMAT(/5X,'SUBROUTINE SC0, ICHAN=',I3,' LL = ',I2,', FNU = ', + 0PF10.2,', RHO = ',E10.3,', W = ',0PF10.6) END C C*************************************************************** C SUBROUTINE SCALE1(IOPT1) C C CONVERTS R-MATRIX TARGET DATA TO Z-SCALED FORM C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C LOGICAL NEWBUT C C COMMON BLOCKS FROM ASYMPTOTIC ROUTINE COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CENAT1/ENAT1 COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CLOGB/NEWBUT COMMON/CBUT/FKN(0:MZNRG),UKN(0:MZNRG) COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT C C COMMON BLOCK FROM SUBROUTINE READ C NOTE USE OF NZED IN PLACE OF NZ COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) C C C COMMON BLOCK FOR RADIATIVE DECAYS COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X,IPAR(MZTAR),NEWAR C COMMON BLOCK FOR DEGENERATE TARGET LEVELS COMMON/CDEGEN/ENATR(MZTAR),NASTD,NASTR,NLEV(MZTAR),NCNATR(MZTAR) X,IWD(MZTAR),IWT C DIMENSION INDEX(MZTAR),AVENGY(MZTAR) C C Z-SCALING FACTORS C AZ=MAX(NZED-NELC,1) AZ1=ONE/AZ AZ2=AZ1*AZ1 TAZ2=2*AZ2 AZAZ=AZ*AZ C C Z-SCALED PARTITIONED DATA C IF(IPRCENT.NE.100)THEN WRITE(6,3085)IPRCENT DO L=1,LRANG2 DO N=1,NRANG2 ENDS(N,L)=AZ1*ENDS(N,L)**2 EIGENS(N,L)=AZ2*EIGENS(N,L) ENDDO ENDDO ENDIF C C Z-SCALED TARGET ENERGIES, RELATIVE TO ZERO FOR TARGET GROUND STATE C ENAT1=ENAT(1) COLD IF(NAST.EQ.1)GOTO 20 DO I=1,NAST ENAT(I)=TAZ2*(ENAT(I)-ENAT1) ENDDO C C TEST FOR DEGENERACY AND FORM AVERAGED TARGET ENERGY LEVELS C IF (NASTD.GT.0) THEN NASTR=0 DO N=1,NASTD NASTR=NASTR+NLEV(N) ENDDO IF(NASTR.NE.NAST)THEN WRITE(6,640)NASTR,NAST,(NLEV(N),N=1,NASTD) STOP 'LEVEL INCONSISTANCY ON GROUPING...' END IF C COLD AVENGY(1)=0.0 COLD N1=NLEV(1)+1 COLD INDEX(1)=NLEV(1) N1=1 DO J=1,NASTD N=NLEV(J) N2=N+N1-1 INDEX(J)=N2 ENSUM=TZERO ARSUM=TZERO WTSUM=TZERO DO IN=N1,N2 IF(IWT.LT.0)THEN WT=LAT(IN)+1 ELSEIF(IWT.EQ.0)THEN WT=1 ELSE WT=ISAT(IN)*(2*LAT(IN)+1) ENDIF ENSUM=ENAT(IN)*WT+ENSUM WTSUM=WTSUM+WT IF(IRDEC.GT.0)ARSUM=ARSUM+ARDEC(IN) ENDDO AVENGY(J)=ENSUM/WTSUM IWD(J)=WTSUM-0.5 IF(IRDEC.GT.0)ARDEC(J)=ARSUM IF(IOPT1.GT.9)THEN C REPLACE ENERGY BY AVERAGE FOR BUNCHED TERMS BUT KEEP ALL ID'S DO IN=N1,N2 ENATR(IN)=ENAT(IN) ENAT(IN)=AVENGY(J) ENDDO ENDIF N1=N2+1 ENDDO ENDIF C COL20 ENAT(1)=0. NASTR=NAST C C RA AND BSTO RZERO=RA*AZ BSTO=BSTO/RZERO C C BUTTLE CORRECTION C IF(IWORD.EQ.1)THEN IF(COEFF(3,1).GT.-10000)THEN NEWBUT=.FALSE. AA=RZERO*AZ2 DO M=1,3 AA=AA*AZAZ DO L=1,LRANG2 COEFF(M,L)=COEFF(M,L)*AA ENDDO ENDDO ELSE NEWBUT=.TRUE. DO L=1,LRANG2 NBUT=-INT(COEFF(3,L))/10000 IF(NBUT.GT.MZNRG)THEN WRITE(6,699)NBUT,MZNRG STOP '*** DIMENSION EXCEEDED: INCREASE MZNRG' ENDIF COEFF(3,L)=NBUT COEFF(1,L)=RZERO*COEFF(1,L) ENDDO C C INITIALISE FKN AND UKN PI=ACOS(-ONE) G=-PI/TWO DO I=0,MZNRG G=G+PI FKN(I)=G UKN(I)=G*G ENDDO ENDIF ELSE !DARC DO L=1,LRANG2 DO N=1,NBUTD(L) EBUTD(N,L)=EBUTD(N,L)*TAZ2 CBUTD(N,L)=CBUTD(N,L)*RZERO ENDDO ENDDO ENDIF C C WRITE TARGET PROPERTIES C WRITE(6,650)NZED,NELC WRITE(6,655) DO J=1,NAST WRITE(6,660)J,ISAT(J),LAT(J),ENAT(J) ENDDO C C IF THERE ARE DEGENERATE LEVELS PRINT THE AVERAGED ENERGIES C PUT THEM IN /CINPUT/ AND PRESERVE THE ENERGIES READ FROM C THE H FILE IN /CDEGEN/ C IF(NASTD.NE.0)THEN C C PRESERVE THE ENERGIES READ FROM THE H-FILE IN /CDEGEN/ IF(IOPT1.GT.9) THEN C C MORE CODING FROM VALF (HES) C IF THERE ARE BUNCHED TERMSPUT ENERGIES IN CINPUT WRITE(6,665) DO J=1,NAST C ENAT(J)=AVENGY(J) WRITE(6,'(3X,I14,F14.8,9X,F12.6)') J,ENAT(J),ENATR(J) ENDDO C ELSE C DO I=1,NAST ENATR(I)=ENAT(I) ENDDO INR1=1 DO IND=1,NASTD N=NLEV(IND) INR2=INR1+N-1 IF(N.GT.1)WRITE(6,664)INR1,INR2 INR1=INR2+1 ENDDO WRITE(6,665)IWT AV1=AVENGY(1) DO J=1,NASTD ENAT(J)=AVENGY(J)-AV1 WRITE(6,666)INDEX(J),J,ENAT(J) ENDDO ENDIF C NAST=NASTD END IF C WRITE(6,670)RZERO,BSTO WRITE(6,680)AC C 640 FORMAT(///5X,'*****INCORRECT DATA ',/ 1 5X,'EXPECT ',I3, 'LEVELS FROM NLEV DATA BUT NAST IS', 2 I3,/5X,'NLEV=',20I3) 650 FORMAT(' ',10X,'NUCLEAR CHARGE =',I3,', NUMBER OF TARGET ', 1 ' ELECTRONS =',I3/11X,53('*')//) 655 FORMAT(20X,'TARGET STATES -'/20X,15('*')// 1 10X,'INDEX',5X,'2*S+1',5X,'TOTAL L',5X,'SCALED ENERGY'/ 2 20X,'OR P OR 2*J'/) 660 FORMAT(3X,3I10,7X,F12.6) 664 FORMAT(/' LEVELS ',I3,' TO ',I3,' ARE COMBINED') 665 FORMAT(//' IWT=',I2,8X,'EQUIVALENT TARGET STATES -'/15X,26('*')// 1 12X,'OLD INDEX',5X,'NEW INDEX',7X,'SCALED ENERGY'//) 666 FORMAT(3X,2I14,9X,F12.6) 670 FORMAT(//5X,'RZERO = ',F10.4,3X,'BSTO = ',F10.4/) 680 FORMAT(5X,'AC = ',E12.4) 699 FORMAT(//' ******* NBUT = ',I4,' LARGER THAN ', + 'MZNRG = ',I4//) 3085 FORMAT (/'***** PARTITIONED R-MATRIX IN USE: ',I2, X'% OF E-SOLUTIONS IN USE.'//) RETURN END C*************************************************************** C SUBROUTINE SCALE2 C C CONVERTS R-MATRIX DATA TO Z-SCALED FORM C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (MXF=5) !(MZLMX+1)/2) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C CHARACTER ELAS*3 C C COMMON BLOCKS FROM ASYMPTOTIC ROUTINE COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/NRBKUT/KUTPS,NCHOPT C C COMMON BLOCK FROM SUBROUTINE READ C NOTE USE OF NZED IN PLACE OF NZ COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CENAT1/ENAT1 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW C COMMON/CNTRLS/ISGPT,ITRMN,ITRMX COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2), X INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2), X MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF), X KTOPA(MXTST),KTOPB(MXTST),LRGLMN COMMON/DBUT/EBUTD(MZNRG,MZLP1),CBUTD(MZNRG,MZLP1),NBUTD(MZNRG) X ,K2P(MZCHF) COMMON /NRBLMX/LMX COMMON /NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT C C STATISTICAL WEIGHT * 2 (OR * 4 FOR NON-EXCHANGE CASE) C LRGL2=2*J FOR B.P. C NWT=(2*LRGL2+1) IF(NSPN2.EQ.0)THEN NWT=NWT+1 IF(LINC.EQ.1)LINC=2 ELSE IF(NSPN2.LT.0)NWT=-2*NWT NWT=NWT*NSPN2*2 ENDIF C C Z-SCALING FACTORS C AZ=MAX(NZED-NELC,1) AZ1=ONE/AZ AZ2=AZ1*AZ1 TAZ2=2*AZ2 AZHR=ONE/SQRT(AZ) AZAZ=AZ*AZ C C CHANNELS C NCHF=NCHAN DO I=1,NCHF LL=LLCH(I) CC(I)=DBLE(LL*(LL+1)) ENDDO I=0 NCHOPT=0 DO 50 J=1,NAST K=NCONAT(J) IF(K.EQ.0)GOTO 50 IF(J.LE.KUTPS)NCHOPT=NCHOPT+K I0=I M=0 JK=-1 DO L=1,K I=I+1 ITARG(I)=J ECH(I)=ENAT(J) IF(NSPN2.NE.0)THEN IF(LLCH(I).LT.M)THEN WRITE(6,669) WRITE(6,670)(I,ITARG(I),LLCH(I),I=1,NCHOPT) WRITE(6,645)J,(LLCH(I0+N),N=1,K) STOP '***INPUT ERROR IN SR.SCALE2***' ENDIF ELSE IF(KJ(I).EQ.JK.AND.LLCH(I).LT.M)THEN IF(KFLAG.GE.0)THEN WRITE(6,671) WRITE(6,672)(I,ITARG(I),LLCH(I),KJ(I),I=1,NCHOPT) ELSE WRITE(6,673) WRITE(6,672)(I,ITARG(I),LLCH(I),K2P(I),I=1,NCHOPT) ENDIF WRITE(6,646)J,(LLCH(I0+N),N=1,K) STOP '***INPUT ERROR IN SR.SCALE2***' ENDIF ENDIF M=LLCH(I) JK=KJ(I) ENDDO 50 CONTINUE C C R-MATRIX C VALUE AND WMAT C DO I=1,NCHF DO N=1,MNP2 WMAT(N,I)=WMAT(N,I)*AZHR ENDDO ENDDO IF(IPRINT.GT.3)WRITE(6,635) DO N=1,MNP2 VALUE(N)=TAZ2*(VALUE(N)-ENAT1) IF(IPRINT.GT.3)WRITE(6,640)N,VALUE(N),(WMAT(N,I),I=1,NCHF) ENDDO C C PARTITIONED C IF(IPRCENT.NE.100)THEN TRACE=TAZ2*(TRACE-ENAT1) IF(IPRINT.GT.-2)WRITE(6,641)TRACE !EZERO DO L=1,LRANG2 NRANG1(L)=NRANG2+1 DO N=1,NRANG2 IF(EIGENS(N,L).GT.VALUE(1))THEN NRANG1(L)=N GO TO 55 ENDIF ENDDO 55 ENDDO DO I=1,NCHF L=L2P(I)+1 SI(I)=TZERO DO N=1,NRANG2 SI(I)=SI(I)+ENDS(N,L) ENDDO ENDDO ENDIF C C COEFFICIENTS IN POTENTIAL C IF(IPERT.EQ.0.AND.LRGLAM.LT.0)GOTO 160 IF(IPRINT.GT.2.AND.IPERT.NE.0)WRITE(6,655) C C LAMP(I,J) AND BW(I,J) C DO J=1,NCHF DO I=1,NCHF LAMP(I,J)=1 ENDDO ENDDO IF(LAMAX.EQ.0)GOTO 160 C C LOOK FOR DIPOLE C IABW=IABS(IWORD) A1=ONE/RZERO A2=A1/2 AZZ=ONE IF(NCHF.GT.1)THEN DO J=2,NCHF J1=J-1 DO 130 I=1,J1 CF(I,J,1)=CF(I,J,1)*IABW BU1=-CF(I,J,1) IF(ABS(BU1).LT.1.D-6)GOTO 130 LAMP(I,J)=2 BW(I,J)=BU1 P=A2*BU1 IF(IPRINT.GT.2.AND.IPERT.NE.0) X WRITE(6,660)ITARG(I),I,ITARG(J),J,P 130 CONTINUE ENDDO ENDIF IF(LAMAX.EQ.1)GOTO 160 C C LOOK FOR QUADRUPOLE C IF(IPRINT.GT.2.AND.IPERT.NE.0)WRITE(6,665) A2=A2*A1 AZZ=AZZ*AZ DO J=1,NCHF DO 150 I=1,J CF(I,J,2)=CF(I,J,2)*IABW BU2=-CF(I,J,2) IF(ABS(BU2).LT.1.D-6)GOTO 150 LAMP(I,J)=3 BU2=BU2*AZZ BW(I,J)=BU2 CF(I,J,2)=AZZ*CF(I,J,2) P=BU2*A2 IF(IPRINT.GT.2.AND.IPERT.NE.0) X WRITE(6,660)ITARG(I),I,ITARG(J),J,P 150 CONTINUE ENDDO IF(LAMAX.EQ.2)GOTO 160 C C LOOK FOR OCTUPOLE ETC. C IF(IPRINT.GT.2.AND.IPERT.NE.0)WRITE(6,666) DO L=3,LAMAX A2=A2*A1 AZZ=AZZ*AZ DO J=1,NCHF DO 155 I=1,J CF(I,J,L)=CF(I,J,L)*IABW BUL=-CF(I,J,L) IF(ABS(BUL).LT.1.D-6)GOTO 155 C SKIP IF LOWER MULTIPOLE EXISTS IF(LAMP(I,J).NE.1)GO TO 155 LAMP(I,J)=L+1 !FOR DEGENERATE ENERGY TOP-UP P=TZERO IF(L.LE.LMX)THEN BUL=BUL*AZZ BW(I,J)=BUL CF(I,J,L)=AZZ*CF(I,J,L) P=BUL*A2 IF(IPRINT.GT.2.AND.IPERT.NE.0) X WRITE(6,660)ITARG(I),I,ITARG(J),J,P ENDIF 155 CONTINUE ENDDO ENDDO C 160 CONTINUE C C SYMMETRIZE C DO I=1,NCHF DO J=I,NCHF LAMP(J,I)=LAMP(I,J) BW(J,I)=BW(I,J) ENDDO ENDDO C C WRITE SLPI AND CHANNEL DATA C WRITE(6,600)NSPN2,LRGL2,NPTY2 IF(ISGPT.NE.0) WRITE(14,600) NSPN2,LRGL2,NPTY2 IF(NSPN2.NE.0)THEN WRITE(6,669) WRITE(6,670)(I,ITARG(I),LLCH(I),I=1,NCHF) ELSEIF(KFLAG.GE.0)THEN WRITE(6,671) WRITE(6,672)(I,ITARG(I),LLCH(I),KJ(I),I=1,NCHF) ELSE WRITE(6,673) WRITE(6,672)(I,ITARG(I),LLCH(I),K2P(I),I=1,NCHF) ENDIF C 600 FORMAT(///80('+')//12X,'(2S+1) L/2J P =',3I3/12X,24('*')//) 635 FORMAT(//' N, VALUE(N) AND WMAT(N,I)'/) 640 FORMAT(I5,E12.3,5X,9E12.3,(/5X,9E12.3)) 641 FORMAT(/'PARTITIONED R-MATRIX, EZERO=',F10.6,' Z**2 RYD'/) 645 FORMAT(//'CHANNEL L MUST BE ASCENDING WITHIN A TERM:',I5/ X(20I3)) 646 FORMAT(//'CHANNEL L MUST BE ASCENDING WITHIN A LEVEL (FIXED-K):' X,I5/(20I3)) 655 FORMAT(/' PERTURBATION P FOR MULTIPOLE POTENTIAL'// 1 ' - DIPOLE PART'/) 660 FORMAT(2(I5,I3),E12.4) 665 FORMAT(/' - QUADRUPOLE PART'/) 666 FORMAT(/' - OCTUPOLE ETC. PART'/) 669 FORMAT(12X,'CHANNEL',2X,'TARGET',4X,'SMALL', 1 /12X,'INDEX ',3X,'INDEX ',5X,'L'/) 670 FORMAT(7X,I8,I9,I10) 671 FORMAT(12X,'CHANNEL',2X,'TARGET',4X,'SMALL', 1 /12X,'INDEX ',3X,'INDEX ',5X,'L',5X,'2K'/) 672 FORMAT(7X,I8,I9,I10,I7) 673 FORMAT(12X,'CHANNEL',2X,'TARGET',4X,'SMALL', 1 /12X,'INDEX ',3X,'INDEX ',5X,'L',4X,'KAPPA'/) C RETURN END C*************************************************************** C SUBROUTINE SQDTS C C NRB: C CALCULATION OF OMEGA FROM KHI-MX IN QDT, OPTIONAL GAILITIS AVERAGE, C OPTIONAL (TYPE-I) RADIATION DAMPING. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C LOGICAL QDT C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZDEG*MZDEG) PARAMETER (ZERO=(0.0,0.0)) PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (QUART=0.25) PARAMETER (BIG=150.0) C CHARACTER ELAS*3 C COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CDEC/ARAD(MXTST),ARDEC(MZTAR),SLIN(MXTST),IRDEC,IEND X,IPAR(MZTAR),NEWAR COMMON/CEN/ETOT,MXE,NWT,NZ C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/COMEGA/OMEGA(MXTST),IE,NOMWRT COMMON/CQDT/R2ST(MZCHF),QDT,NQ COMMON/NRBDR/PDR(MZCHF),OMEGDR(MZMET,MZMSH),NDRMET COMMON/NRBKHI/ZKHICC(MZDEG,MZDEG),ZKHIOC(MZCHF,MZDEG),ZVAL(MZDEG) CBL X,ZVL(MZDEG,MZDEG),ZVR(MZDEG,MZDEG),RWORK(2*MZDEG) COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) COMMON/NRBZED/TZED,LPRTSW C DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF) X ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF) C EQUIVALENCE (P,CSP),(Q,CC),(POLD,DSP),(QOLD,DC) C C NCC=NQ-NCHOP IF(NCC.GT.MZDEG)THEN WRITE(6,601)NCC STOP ENDIF C PI=ACOS(-ONE) TPI=TWO*PI CONST=TPI IF(TZED.GT.TZERO)CONST=CONST/DBLE((NZED-NELC)**2) IONE=1 IF(ELAS.EQ.'YES')IONE=0 C C DIAGONALISE KHICC C DO N2=1,NCC DO N1=1,NCC ZKHICC(N1,N2)=DCMPLX(P(NCHOP+N1,NCHOP+N2) X ,Q(NCHOP+N1,NCHOP+N2)) ENDDO ENDDO C CSTRTNBL CALL ZEIGEN(ZKHICC,ZVAL,NCC,AC) CENDNBL CSTRTBL - CURRENTLY NOT IN USE AS NCC IS SMALL HERE CBL CALL ZGEEV('N','V',NCC,ZCHICC,MZDEG,ZVAL,ZVL,MZDEG,ZVR,MZDEG, CBL X ZWORK,MWORK,RWORK,INFO) CBL IF (INFO.NE.0) THEN CBL WRITE(6,'("ZGEEV CALLED, INFO=",I5)') INFO CBL STOP CBL ENDIF CBL LWOPT=INT(ZWORK(1)) CBL IF (LWOPT.GT.MWORK) THEN CBL WRITE(6,'("ZGEEV: OPTIMAL WORK SPACE LENGTH =",I5)') LWOPT CBL ENDIF CBL DO N1=1,NCC CBL DO N2=1,NCC CBL ZKHICC(N2,N1)=ZVR(N2,N1) CBL ENDDO CBL ENDDO CENDBL C C CALCULATE ZKHIOC C DO N2=1,NCC DO N1=1,NCHOP ZKHIOC(N1,N2)=ZERO ENDDO DO K=1,NCC DO N1=1,NCHOP ZKHIOC(N1,N2)=ZKHIOC(N1,N2)+ X DCMPLX(P(N1,NCHOP+K),Q(N1,NCHOP+K))*ZKHICC(K,N2) ENDDO ENDDO ENDDO C C RADIATIVE DECAYS; RECALCULATE ARDEC (DEPENDS ON ETOT) IF NECESS. C IF(IRDEC.GT.0)THEN NNN=NCHOP+1 IF(NEWAR.GT.0)THEN KVEC=((ITARG(NNN)-IONE)*(ITARG(NNN)-1-IONE))/2 ARDEC(ITARG(NNN))=TZERO DO JLOOP=1,ITARG(NNN)-1 KVEC=KVEC+1 IF(ETOT-(ENAT(ITARG(NNN))-ENAT(JLOOP)).LE.ENAT(1))THEN ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))+ARAD(KVEC) ENDIF ENDDO ARDEC(ITARG(NNN))=ARDEC(ITARG(NNN))*CONST ENDIF T=ARDEC(ITARG(NNN))*(FKNU(NNN)**3) T=MIN(T,BIG) FDEC=EXP(T) ELSE FDEC=ONE ENDIF C C INITIALIZE DR PROBABILITY C DO I=1,NCHOP PDR(I)=ONE ENDDO C C IF(QDT)THEN C C CALCULATE AVERAGE COLLISION STRENGTH C DO J=1,NCHOP P(J,J)=P(J,J)-ONE !-T DO I=1,J RK(I,J)=P(I,J)**2+Q(I,J)**2 PDR(I)=PDR(I)-RK(I,J) PDR(J)=PDR(J)-RK(I,J) ENDDO PDR(J)=PDR(J)+RK(J,J)-TWO*P(J,J)-ONE P(J,J)=P(J,J)+ONE ENDDO DO K=1,NCC VV=ABS(ZVAL(K)) IF((ONE-VV).LT.AC) THEN VV=FDEC-ONE DO M=1,NCHOP VV=VV+ABS(ZKHIOC(M,K))**2 ENDDO ELSE VV=FDEC-VV**2 ENDIF DO J=1,NCHOP DO I=1,J T=ABS(ZKHIOC(I,K)*ZKHIOC(J,K))**2/VV RK(I,J)=RK(I,J)+T PDR(I)=PDR(I)-T PDR(J)=PDR(J)-T ENDDO PDR(J)=PDR(J)+T ENDDO ENDDO DO K1=1,NCC-1 DO K2=K1+1,NCC IF((ONE-ABS(ZVAL(K1))).LT.AC.AND. X (ONE-ABS(ZVAL(K2))).LT.AC) THEN ZVV=ZVAL(K1)*CONJG(ZVAL(K1)-ZVAL(K2))+FDEC-ONE DO M=1,NCHOP ZVV=ZVV+ABS(ZKHIOC(M,K1))**2 ENDDO ELSE ZVV=FDEC-ZVAL(K1)*CONJG(ZVAL(K2)) ENDIF DO J=1,NCHOP DO I=1,J T=TWO*DBLE(ZKHIOC(I,K1)*ZKHIOC(J,K1)* X CONJG(ZKHIOC(I,K2)*ZKHIOC(J,K2))/ZVV) RK(I,J)=RK(I,J)+T PDR(I)=PDR(I)-T PDR(J)=PDR(J)-T ENDDO PDR(J)=PDR(J)+T ENDDO ENDDO ENDDO C ELSE C C DETAILED OMEGA C TPINU=FKNU(NCHOP+1)*TPI ZFDEC=SQRT(FDEC)*EXP(DCMPLX(TZERO,-TPINU)) DO J=1,NCHOP DO I=1,J ZKHI=DCMPLX(P(I,J),Q(I,J)) DO K=1,NCC ZKHI=ZKHI-ZKHIOC(I,K)*ZKHIOC(J,K)/(ZVAL(K)-ZFDEC) ENDDO PP=ZKHI*CONJG(ZKHI) PDR(J)=PDR(J)-PP PDR(I)=PDR(I)-PP IF(I.EQ.J)THEN PDR(I)=PDR(I)+PP ZKHI=ZKHI-DCMPLX(ONE,TZERO) ENDIF RK(I,J)=ZKHI*CONJG(ZKHI) ENDDO ENDDO C ENDIF C C SYMMETRIZE AND ADJUST WEIGHTING C T=QUART*NWT DO J=1,NCHOP PDR(J)=PDR(J)*T DO I=1,J RK(I,J)=T*RK(I,J) RK(J,I)=RK(I,J) ENDDO ENDDO C C IF REALLY MQDT RESTORE ORIGINAL P,Q C IF(IQDT.GT.0.AND.NQ.LT.NCHF)THEN DO J=1,NCHF DO I=1,NCHF P(I,J)=POLD(I,J) Q(I,J)=QOLD(I,J) ENDDO ENDDO ENDIF C RETURN 601 FORMAT(//10X,10('*'),' NUMBER OF DEGENERATE CLOSED', X ' CHANNELS, NCC = ',I2/20X,' LARGER THAN DIMENSION', X ' VALUE OF DEG = MZDEG'//) END C********************************************************** C SUBROUTINE TANDTDN(FK,N1,N2,I,TA,TDA,TP) C C C CALCULATES THETA AND THETAD =THETA DOT FOR R REAL C THETA = TA*EXP(TP) C THETAD = TDA*EXP(TP) C TP = FNU*LOG(R) - R/FNU C NRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15) COMMON/NRBZED/TZED,LPRTSW C DIMENSION TP(30),TA(30),TDA(30) C MI=MSUM(I) E=BG(I,1) F2=BG(I,2) FNU=BB(I,1) C DO N=N1,N2 U=XLAG(N) R=RTWO+U/FK X=2.*R/FNU Y=1./X AS=1. S=BB(I,2) CX=0. DO L=3,MI AS=AS*Y S=S+BB(I,L)*AS CX=CX+BG(I,L)*AS ENDDO C DLR=LOG(R)*TZED TP(N)=-.5*X+FNU*DLR TA(N)=S TDA(N)=E*((DLR+R*F2)*S+CX) ENDDO C RETURN END C********************************************************** C SUBROUTINE THETA(R,I,T,TP,TD,TDP,ICONV) C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C CNRB C NEUTRAL CASE ADDED C COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF) COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/NRBZED/TZED,LPRTSW C LOGICAL FLAG C PI=ACOS(-ONE) FNU=FKNU(I) LL=LLCH(I) M=FNU+LL+12 C IF(M.LE.MZTET)GOTO 10 IF(TZED.EQ.0)THEN M=MZTET !SHOULD CONVERGE AT M=LL GO TO 10 ENDIF WRITE(6,700)I,M GOTO 102 C 10 F1=ONE/FNU F2=F1*F1 X=TWO*R*F1 Y=ONE/X FL=DBLE(LL) C R1=ONE/R A=TZED*FNU*R1-F1 B=TZED*LOG(R)+R*F2 C=TZED*R1+F2 D=-R1 E=FNU**3/TWO C BB(I,1)=FNU BB(I,2)=ONE BG(I,1)=E BG(I,2)=F2 C YN=ONE A1=FL-FNU*TZED A2=FL+FNU*TZED+ONE BN=-TWO*FNU-ONE C BET=ONE GAM=TZERO W0=C C S=ONE U=TZERO CX=TZERO CY=TZERO C C N=0 FLAG=.FALSE. DO 20 MN=3,M N=N+1 A1=A1+ONE A2=A2-ONE BN=BN+TWO CN=A1*A2 DN=BN*TZED+F1*CN GAM=CN*GAM+DN*BET BET=CN*BET YN=YN*Y U=U+BET*YN CY=CY+GAM*YN AN=ONE/DBLE(N) GAM=GAM*AN BET=BET*AN S=S+BET*YN CX=CX+GAM*YN W1=C*S*S+D*(S*CY-U*CX) BB(I,MN)=BET BG(I,MN)=GAM IF(W1.EQ.TZERO)GO TO 30 AC0=(W1-W0)/W1 c write(6,*)mn,ac0 IF(ABS(AC0).LT.10*AC)THEN IF(FLAG)THEN GO TO 30 ELSE FLAG=.TRUE. END IF ELSE FLAG=.FALSE. END IF 20 W0=W1 C-NRB IF(R*F1.GT.150.)THEN T=TZERO TP=TZERO TD=TZERO TDP=TZERO ICONV=0 RETURN ENDIF C-NRB C C NOT CONVERGED GOTO 100 C C SUMMATIONS CONVERGED C 30 P=EXP(-R*F1)*R**FNU C 30 P=EXP(-R*F1/TWO) IF(TZED.GT.0)P=P*R**(FNU/TWO) IF(ABS(P).GT.1.D-100)THEN CFACT=ONE/P ELSE CFACT=TZERO ENDIF BB(I,2)=BB(I,2)*CFACT DO 40 J=3,N+2 BB(I,J)=BB(I,J)*CFACT BG(I,J)=BG(I,J)*CFACT 40 CONTINUE C T=P*S TP=P*(A*S+D*U) TD=P*E*(B*S+CX) TDP=P*E*((A*B+C)*S+B*D*U+A*CX+D*CY) N2=N+2 MSUM(I)=N2 ICONV=0 RETURN C C RELAX TEST FOR ENERGIES CASE A POSSIBLY NEGATIVE IN SC 100 IF(FNU.GE.DBLE(LL+1))GO TO 101 C C PROCEED BUT PRINT WARNING IF(ABS(AC0).GT.1.E2*AC.AND.NCHOP.GT.0) XWRITE(6,650)M,I,EPS(I),LL,AC0,AC GO TO 30 C C USE SUBROUTINE SC AND SET IPERT = 0 101 IF(TZED.GT.0)WRITE(6,610)N IF(TZED.EQ.0)THEN WRITE(6,611) STOP 'FAILURE FOR NEUTRAL THETA - TOO CLOSE TO THRESHOLD?' ENDIF 102 IF(NPERT.GT.0)THEN WRITE(6,750)IABS(IPERT)+2,IABS(IPERT) STOP 750 ENDIF CALL SC(EPS(I),LLCH(I),RZERO,AC,FSA,FSPA,FCA,FCPA,IERR) SINF=SIN(PI*FKNU(I)) COSF=COS(PI*FKNU(I)) T=FCA*SINF-FSA*COSF TP=FCPA*SINF-FSPA*COSF IPERT=0 ICONV=1 RETURN C 700 FORMAT(//10X,30('*')/10X,'SUBROUTINE THETA'/ 1 10X,'FOR I=',I3,' REQUIRE M=',I4/ 2 10X,'WHICH IS LARGER THAN MAXIMUM VALUE OF MZTET ALLOWED BY ' 3 ,'DIMENSIONS'/10X,'USING SUBROUTINE SC WITH IPERT = 0'/10X, 4 30('*')) 750 FORMAT(//' EXECUATION HALTED BECAUSE IPERT=',I3,' RESET IPERT=',I3 X,' OR FIX INDICATED PROBLEM') 650 FORMAT(//10X,30('*')//10X,'SUBROUTINE THETA'//'M=',I3,' SUMMATIONS X NOT',' CONVERGED FOR CHANNEL',I3,' E .LT. -(L+1)**(-2): E,L=' X,F10.6,I5//' CHECK ACCURACY AC0 WITH REQUIRED AC: AC0,AC=' X,2F10.6//10X,30('*')) 610 FORMAT(//10X,30('*')//10X,'SUBROUTINE THETA'// 1' SUMMATIONS NOT CONVERGED WITH ',I4,' TERMS'/ 2 /10X,'USING SUBROUTINE SC WITH IPERT = 0'/10X,30('*')) 611 FORMAT(//10X,30('*')//10X,'SUBROUTINE THETA'// 1'FAILURE FOR NEUTRAL CASE - TOO CLOSE TO THRESHOLD?'/ 2 10X,30('*')) END C********************************************************** C SUBROUTINE TOP1(LLL) C C NRB: C DETERMINE MULTIPOLE TOP-UP (LS AND BP) C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (MXF=5) !(MZLMX+1)/2) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (SIX=6.0) PARAMETER (TOLE=1.E-10) C COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2), + INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2), + MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF), + KTOPA(MXTST),KTOPB(MXTST),LRGLMN C LRGLAM=LLL LRGLMN=LRGLAM !LOWEST LRGL2 THAT MAY CONTAIN OMEGAS TO BE STRUCK OUT C C FIND ALLOWED TRANSITIONS C ************************ C (THIS IS DONE AND NEEDED FOR EVERY LRGL2 IF LRGLAM.GE.0) C DO 20 I1=1,NCHF DO 20 I2=I1,NCHF C C DIPOLE C IF(LAMP(I1,I2).EQ.2)THEN IT1=ITARG(I1) IT2=ITARG(I2) DO I=1,INDM IF(IABS(NTOP(I,1)).EQ.IT1.AND.IABS(NTOP(I,2)).EQ.IT2)THEN NTOP(I,1)=IT1 NTOP(I,2)=IT2 LLM=MIN(LAT(IT1),LAT(IT2)) IF(NSPN2.EQ.0)THEN LRGLMN=MIN(LRGLMN,LRGLAM-2*LLM) LLM=-LLM+1 !NO K/J TOP-UP ENDIF LITLAM(I)=LRGLAM+LLM IF(NSPN2.EQ.0)LITLAM(I)=LITLAM(I)/2 GO TO 20 ENDIF ENDDO INDM=INDM+1 NTOP(INDM,1)=IT1 NTOP(INDM,2)=IT2 LLM=MIN(LAT(IT1),LAT(IT2)) IF(NSPN2.EQ.0)THEN LRGLMN=MIN(LRGLMN,LRGLAM-2*LLM) LLM=-LLM+1 !NO K/J TOP-UP ENDIF LITLAM(INDM)=LRGLAM+LLM IF(NSPN2.EQ.0)LITLAM(INDM)=LITLAM(INDM)/2 C C QUADRUPOLE, OCTUPOLE C ELSEIF(LAMP(I1,I2).GE.3)THEN IT1=-ITARG(I1) IT2=-ITARG(I2) DO I=1,INDM IF(IABS(NTOP(I,1)).EQ.-IT1.AND.IABS(NTOP(I,2)).EQ.-IT2)THEN IF(NTOP(I,1).LT.0)LITLAM(I)=MIN(LITLAM(I),LAMP(I1,I2)-1) GO TO 20 ENDIF ENDDO INDM=INDM+1 NTOP(INDM,1)=IT1 NTOP(INDM,2)=IT2 LITLAM(INDM)=LAMP(I1,I2)-1 ENDIF 20 CONTINUE C C CALCULATE INVERSE CHANNEL LIST C NC=0 DO IT=1,NAST IF(NCONAT(IT).EQ.0)THEN NTCHAN(IT,1)=0 NTCHAN(IT,2)=0 ELSE NC=NC+1 NTCHAN(IT,1)=NC NC=NC+NCONAT(IT)-1 NTCHAN(IT,2)=NC ENDIF ENDDO C IF(LRGL2.LT.(LRGLAM-1).OR.LRGL2.GT.LRGLAM)RETURN C C INITIALISATIONS FOR LRGL2.GE.(LRGLAM-1) C *************************************** C C INITIALISE TOPA, TOPB C DO I=1,INDM TOPA(I)=TZERO TOPB(I)=TZERO ENDDO C C PRINT CHANNEL LIST C WRITE(6,600)LRGLAM DO I=1,INDM WRITE(6,610)I,NTOP(I,1),NTOP(I,2),LITLAM(I) ENDDO C C CASE OF LRGL2.EQ.(LRGLAM-1) C *************************** C IF(LRGL2.EQ.(LRGLAM-1))THEN WRITE(6,620) C C TOP-UP IN SMALL L (BYPASSED BY BP - NOT NEEDED) C DO 70 I=1,INDM IF(LITLAM(I).NE.LRGLAM)GOTO 70 IT1=NTOP(I,1) IF(IT1.LT.0)GO TO 70 IT2=NTOP(I,2) IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 70 DELE=ENAT(IT2)-ENAT(IT1) IF(DELE.LT.TOLE)GO TO 70 IF(LLCH(NTCHAN(IT1,2)).EQ.LRGLAM)THEN TOPA(I)=ONE/(DBLE(LRGLAM**2)*DELE) NTOPA(I,1)=NTCHAN(IT1,2) NTOPA(I,2)=NTCHAN(IT2,1) WRITE(6,630)I,NTOPA(I,1),NTOPA(I,2),TOPA(I) ENDIF DELE=-DELE IF(LLCH(NTCHAN(IT2,2)).EQ.LRGLAM)THEN TOPB(I)=ONE/(DBLE(LRGLAM**2)*DELE) NTOPB(I,1)=NTCHAN(IT1,1) NTOPB(I,2)=NTCHAN(IT2,2) WRITE(6,631)I,NTOPB(I,1),NTOPB(I,2),TOPB(I) ENDIF 70 CONTINUE RETURN ENDIF C C CASE OF LRGL2.EQ.LRGLAM C *********************** C IF(LRGL2.EQ.LRGLAM)THEN WRITE(6,620) C C TOP-UP IN SMALL L (LS AND BP) C DO 100 I=1,INDM LAM=LITLAM(I) IT1=NTOP(I,1) IF(IT1.LT.0)GO TO 100 IT2=NTOP(I,2) IF(NCONAT(IT1).EQ.0.OR.NCONAT(IT2).EQ.0)GOTO 100 DO 152 I1=NTCHAN(IT1,2),NTCHAN(IT1,1),-1 DO 151 I2=NTCHAN(IT2,2),NTCHAN(IT2,1),-1 IF(NSPN2.EQ.0.AND.KFLAG.GE.0.AND.KJ(I1).NE.KJ(I2))GO TO 151 LL1=LLCH(I1) LL2=LLCH(I2) DELE=MAX(ENAT(IT2)-ENAT(IT1),TOLE) IF(LL1.EQ.LAM.AND.LL2.EQ.LL1-1)THEN NTOPA(I,1)=I1 NTOPA(I,2)=I2 IF(NSPN2.NE.0)THEN !LS-NRB TOPA(I)=ONE/(DBLE(LAM*LAM)*DELE* + WSQ(LAT(IT1),LAT(IT2),LL1,LL2,LRGLAM,ISIGN)) ELSEIF(KFLAG.GE.0)THEN !JK-NRB W=DBLE(LRGL2+1)/DBLE(2*KJ(I1)+2) TOPA(I)=ONE/(DBLE(LAM*LAM)*DELE* + W*WSQ2(LAT(IT1),LAT(IT2),2*LL1,2*LL2,KJ(I1),ISIGN)) ELSE !JJ-NRB JV1=2*(L2P(I1)/2)+1 !2J-VALENCE JV2=2*(L2P(I2)/2)+1 !2J-VALENCE IF(JV1.EQ.JV2)THEN W=DBLE(JV2+1)/(DBLE((JV2+2)*JV2)) ELSE JV3=MIN(JV1,JV2) W=DBLE((JV3+3)*(JV3+1))/DBLE(2*(JV3+2)) ENDIF W=W/DBLE(2*MAX(LL1,LL2)) c write(6,*)ll1,ll2,jv1,jv2,w TOPA(I)=ONE/(DBLE(LAM*LAM)*DELE* + W*WSQ2(LAT(IT1),LAT(IT2),JV1,JV2,LRGL2,ISIGN)) ENDIF WRITE(6,630)I,NTOPA(I,1),NTOPA(I,2),TOPA(I) GO TO 100 ENDIF DELE=-DELE IF(LL2.EQ.LAM.AND.LL1.EQ.LL2-1)THEN NTOPB(I,2)=I2 NTOPB(I,1)=I1 IF(NSPN2.NE.0)THEN !LS-NRB TOPB(I)=ONE/(DBLE(LAM*LAM)*DELE* + WSQ(LAT(IT1),LAT(IT2),LL1,LL2,LRGLAM,ISIGN)) ELSEIF(KFLAG.GE.0)THEN !JK-NRB W=DBLE(LRGL2+1)/DBLE(2*KJ(I1)+2) TOPB(I)=ONE/(DBLE(LAM*LAM)*DELE* + W*WSQ2(LAT(IT1),LAT(IT2),2*LL1,2*LL2,KJ(I1),ISIGN)) ELSE !JJ-NRB JV1=2*(L2P(I1)/2)+1 !2J-VALENCE JV2=2*(L2P(I2)/2)+1 !2J-VALENCE IF(JV1.EQ.JV2)THEN W=DBLE(JV2+1)/(DBLE((JV2+2)*JV2)) ELSE JV3=MIN(JV1,JV2) W=DBLE((JV3+3)*(JV3+1))/DBLE(2*(JV3+2)) ENDIF W=W/DBLE(2*MAX(LL1,LL2)) c write(6,*)ll1,ll2,jv1,jv2,w TOPB(I)=ONE/(DBLE(LAM*LAM)*DELE* + W*WSQ2(LAT(IT1),LAT(IT2),JV1,JV2,LRGL2,ISIGN)) ENDIF WRITE(6,631)I,NTOPB(I,1),NTOPB(I,2),TOPB(I) GO TO 100 ENDIF 151 CONTINUE 152 CONTINUE 100 CONTINUE C C TOP-UP IN LARGE L (LS ONLY) C C NRB: THIS IS NEGLIGIBLE, SO WON'T BOTHER WITH BP VERSION . C (IF BOTHERED THEN TOP-UP AT LRGLAM .EQ. LRGL2-2 SO THE LAST C LRGL2 IS THEN CYCLED THRU TO TOP-UP REMAINING K/J.) C IF(NSPN2.EQ.0)RETURN C WRITE(6,640) DO 200 I=1,INDM IT1=NTOP(I,1) IF(IT1.LT.0)GO TO 200 IT2=NTOP(I,2) C IF(NTCHAN(IT1,1).EQ.0.OR.NTCHAN(IT2,1).EQ.0)THEN MTOPA(I,1)=0 MTOPA(I,2)=-1 MTOPB(I,1)=0 MTOPB(I,2)=-1 GOTO 200 ENDIF C L=LLCH(NTCHAN(IT2,1))+1 DO 110 N=NTCHAN(IT1,1),NTCHAN(IT1,2) IF(LLCH(N).EQ.L)THEN MTOPA(I,1)=N GOTO 120 ENDIF 110 CONTINUE 120 IF(LLCH(NTCHAN(IT1,2)).GT.LITLAM(I))THEN MTOPA(I,2)=NTCHAN(IT1,2)-1 ELSE MTOPA(I,2)=NTCHAN(IT1,2) ENDIF IF(MTOPA(I,2).LT.MTOPA(I,1))THEN MTOPA(I,1)=0 MTOPA(I,2)=-1 ENDIF C L=LLCH(NTCHAN(IT1,1))+1 DO 130 N=NTCHAN(IT2,1),NTCHAN(IT2,2) IF(LLCH(N).EQ.L)THEN MTOPB(I,1)=N GOTO 140 ENDIF 130 CONTINUE 140 IF(LLCH(NTCHAN(IT2,2)).GT.LITLAM(I))THEN MTOPB(I,2)=NTCHAN(IT2,2)-1 ELSE MTOPB(I,2)=NTCHAN(IT2,2) ENDIF IF(MTOPB(I,2).LT.MTOPB(I,1))THEN MTOPB(I,1)=0 MTOPB(I,2)=-1 ENDIF C LAT1=LAT(IT1) LAT2=LAT(IT2) C KTOPA(I)=NTCHAN(IT2,1) LL1=-2 IF(MTOPA(I,1).GT.0)LL1=LL1+LLCH(MTOPA(I,1))!ARRAY OUT OF BOUNDS C IF(MTOPA(I,1).EQ.0)THEN NN.EQ.0 AND THE LOOP IS SKIPPED LL2=LLCH(KTOPA(I))-2 M=0 NN=MTOPA(I,2)-MTOPA(I,1)+1 DO 160 N=1,NN LL1=LL1+2 LL2=LL2+2 MAXL=LAT2+LL2 IF(MAXL.GT.LRGL2)THEN F=0. W=1./WSQ(LAT1,LAT2,LL1,LL2,LRGL2,ISIGN) DO 150 L=LRGL2+1,MAXL 150 F=F+W*WSQ(LAT1,LAT2,LL1,LL2,L,ISIGN) M=M+1 IF(M.LE.MXF)THEN FTOPA(I,M)=F I1=MTOPA(I,1)+M-1 I2=KTOPA(I)+M-1 WRITE(6,650)I,I1,I2,FTOPA(I,M) ENDIF ELSE KTOPA(I)=KTOPA(I)+1 MTOPA(I,1)=MTOPA(I,1)+1 ENDIF 160 CONTINUE C IF(M.GT.MXF)THEN !DROP SILENTLY AS SMALL C WRITE(6,661)M Cc STOP '***ERROR: DIMENSION EXCEEDED IN TOP1' C ENDIF C KTOPB(I)=NTCHAN(IT1,1) LL1=LLCH(KTOPB(I))-2 LL2=-2 IF(MTOPB(I,1).GT.0)LL2=LL2+LLCH(MTOPB(I,1)) !ARRAY OUT OF BOUNDS C IF(MTOPB(I,1).EQ.0)THEN NN.EQ.0 AND THE LOOP IS SKIPPED NN=MTOPB(I,2)-MTOPB(I,1)+1 M=0 DO 180 N=1,NN LL1=LL1+2 LL2=LL2+2 MAXL=LAT1+LL1 IF(MAXL.GT.LRGL2)THEN F=0. W=1./WSQ(LAT1,LAT2,LL1,LL2,LRGL2,ISIGN) DO 170 L=LRGL2+1,MAXL 170 F=F+W*WSQ(LAT1,LAT2,LL1,LL2,L,ISIGN) M=M+1 IF(M.LE.MXF)THEN FTOPB(I,M)=F I1=KTOPB(I)+M-1 I2=MTOPB(I,1)+M-1 WRITE(6,651)I,I1,I2,FTOPB(I,M) ENDIF ELSE KTOPB(I)=KTOPB(I)+1 MTOPB(I,1)=MTOPB(I,1)+1 ENDIF 180 CONTINUE C IF(M.GT.MXF)THEN !DROP SILENTLY AS SMALL C WRITE(6,661)M Cc STOP '***ERROR: DIMENSION EXCEEDED IN TOP1' C ENDIF 200 CONTINUE ENDIF C RETURN C 600 FORMAT(//10X,'TOP-UP FOR (LARGE L).GT.',I2, + ', (SMALL L).GT.LITLAM'// + 15X,'ALLOWED TRANSITIONS ARE'// + 15X,'INDEX TARGET STATES LITLAM') 610 FORMAT(I18,I9,I5,I12) 620 FORMAT(/15X,'TOP-UP IN SMALL L FOR'/ + 15X,'INDEX CHANNELS') 630 FORMAT(I18,I9,I5,10X,'TOPA = ',1PE12.4) 631 FORMAT(I18,I9,I5,10X,'TOPB = ',1PE12.4) 640 FORMAT(/15X,'TOP-UP IN LARGE L FOR'/15X,'INDEX CHANNELS') 650 FORMAT(I18,I9,I5,9X,'FTOPA = ',1PE12.4) 651 FORMAT(I18,I9,I5,9X,'FTOPB = ',1PE12.4) 661 FORMAT(/'***INCREASE INTERNAL PARAMETER MXF TO ***',I3) C END C********************************************************** C SUBROUTINE TOP2 C C NRB: C APPLY MULIPOLE TOP-UP (LS AND BP) C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (MXTST=(MZTAR*MZTAR+MZTAR)/2) PARAMETER (MXF=5) !(MZLMX+1)/2) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) C COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CINPUT/ 1 LAMAX,LRANG2,LRGL2,MNP2,NAST,NCHAN,NELC,NPTY2,NSPN2,NZED,MORE2, 2 ISAT(MZTAR),LAT(MZTAR),L2P(MZCHF),NCONAT(MZTAR),KJ(MZCHF),KFLAG COMMON/CINPTX/BSTO,RA, 4 CF(MZCHF,MZCHF,MZLMX),COEFF(3,MZLP1),ENAT(MZTAR) 5 ,WMAT(MZMNP,MZCHF),VALUE(MZMNP) C *** NOTE CHANGE OF CC TO CCT IN /CHAN/ *** COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CCT(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW COMMON/CTOP/LRGLAM,LITLAM(MXTST),NTOP(MXTST,2),NTCHAN(MZTAR,2), + INDM,TOPA(MXTST),TOPB(MXTST),NTOPA(MXTST,2),NTOPB(MXTST,2), + MTOPA(MXTST,2),MTOPB(MXTST,2),FTOPA(MXTST,MXF),FTOPB(MXTST,MXF), + KTOPA(MXTST),KTOPB(MXTST),LRGLMN COMMON/NRBRCT/ X S(MZCHF),SP(MZCHF),C(MZCHF),CP(MZCHF),SPP(MZCHF),CPP(MZCHF) X,A(MZCHF,MZCHF),B(MZCHF,MZCHF),RK(MZCHF,MZCHF) X,CS(MZCHF,MZCHF),CSP(MZCHF,MZCHF),CC(MZCHF,MZCHF) X,CCP(MZCHF,MZCHF),CSPP(MZCHF,MZCHF),CCPP(MZCHF,MZCHF) X,DS(MZCHF,MZCHF),DSP(MZCHF,MZCHF),DC(MZCHF,MZCHF) X,DCP(MZCHF,MZCHF),DFPP(MZCHF,MZCHF) X,RMAT(MZCHF,MZCHF) COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR) X ,OMST(MXTST),ITOP C NTAROP=ITARG(NCHOP) C C DIPOLE TOP-UP IN SMALL L (LS AND BP) C IF(LRGL2.EQ.(LRGLAM-1).OR.LRGL2.EQ.LRGLAM)THEN C DO 3000 I=1,INDM IT2=NTOP(I,2) IF(IT2.LT.0)GO TO 3000 IF(IT2.GT.NTAROP)GOTO 3000 IT1=NTOP(I,1) IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 3000 IF(TOPA(I).NE.TZERO)THEN K=KTST(IT1,IT2) I1=NTOPA(I,1) I2=NTOPA(I,2) OMST(K)=OMST(K)+RK(I1,I2)*(1+(LITLAM(I)**2)* X EPS(I2))*TOPA(I) ENDIF IF(TOPB(I).NE.TZERO)THEN K=KTST(IT1,IT2) I1=NTOPB(I,1) I2=NTOPB(I,2) OMST(K)=OMST(K)+RK(I1,I2)*(1+(LITLAM(I)**2)* X EPS(I1))*TOPB(I) ENDIF 3000 CONTINUE ENDIF C C DIPOLE TOP-UP IN LARGE L (LS ONLY, SEE TOP1) C IF(LRGL2.EQ.LRGLAM.AND.NSPN2.NE.0)THEN C DO 4000 I=1,INDM IT2=NTOP(I,2) IF(IT2.LT.0)GO TO 4000 IF(IT2.GT.NTAROP)GOTO 4000 IT1=NTOP(I,1) IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 4000 K=KTST(IT1,IT2) I1=MTOPA(I,1)-1 I2=KTOPA(I)-1 NN=MTOPA(I,2)-MTOPA(I,1)+1 NN=MIN(NN,MXF) !C.F. TOP1 DO 4100 N=1,NN I1=I1+1 I2=I2+1 4100 OMST(K)=OMST(K)+RK(I1,I2)*FTOPA(I,N) I1=KTOPB(I)-1 I2=MTOPB(I,1)-1 NN=MTOPB(I,2)-MTOPB(I,1)+1 NN=MIN(NN,MXF) !C.F. TOP1 DO 4200 N=1,NN I1=I1+1 I2=I2+1 4200 OMST(K)=OMST(K)+RK(I1,I2)*FTOPB(I,N) 4000 CONTINUE ENDIF C C NRB: C QUADRUPOLE, OCTUPOLE TOP-UP (LS AND BP) C IF(LRGL2.EQ.LRGLAM)THEN TXTRP=DBLE(LRGL2) IF(NSPN2.EQ.0)TXTRP=TXTRP/TWO IF(IPRINT.GE.0)WRITE(6,801)ETOT C DO 5000 I=1,INDM IT2=NTOP(I,2) IF(IT2.GT.0)GO TO 5000 IT2=-IT2 IF(IT2.GT.NTAROP)GO TO 5000 IT1=NTOP(I,1) IT1=-IT1 IF(NCONAT(IT1)*NCONAT(IT2).EQ.0)GO TO 5000 K=KTST(IT1,IT2) IF(K.EQ.0)GO TO 5000 TK2MIN=ETOT-ENAT(IT2) TK2MAX=ETOT-ENAT(IT1) C C INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN C L.LT.2*TK2MIN/(TK2MAX-TK2MIN) C IF(ITOP.EQ.-1)THEN AQ=TK2MIN/TK2MAX O1=ONE+TXTRP/DBLE(LITLAM(I)-1) O1=O1/TWO IF(AQ.GT.0.99)THEN OMST(K)=OMST(K)*O1 IF(IPRINT.GE.0)WRITE(6,803)IT1,IT2,AQ,O1 GO TO 5000 ENDIF O2=ONE/(ONE-AQ) BQ=AQ*O2 IF(TXTRP.GT.TWO*BQ)THEN OMST(K)=OMST(K)*O2 IF(IPRINT.GE.0)WRITE(6,804)IT1,IT2,BQ,O2 GO TO 5000 ENDIF T=TXTRP/(BQ*TWO) O3=O2*T+O1*(ONE-T) OMST(K)=OMST(K)*O3 IF(IPRINT.GE.0)WRITE(6,802)IT1,IT2,AQ,BQ,O1,O2,O3 ELSE C C INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN C ENERGY-RATIO EXCEEDS J-RATIO C AQ=TK2MIN/TK2MAX BQ=TXTRP/(TXTRP+1) BQ=BQ**(2*LITLAM(I)-1) O1=ONE/(ONE-AQ) IF(AQ.LT.BQ)THEN OMST(K)=OMST(K)*O1 IF(IPRINT.GE.0)WRITE(6,803)IT1,IT2,AQ,O1 ELSE O2=ONE+TXTRP/DBLE(LITLAM(I)-1) O2=O2/TWO O3=O1*((ONE-AQ)/(ONE-BQ))**2 X +O2*(AQ-BQ)*(TWO-AQ-BQ)/(ONE-BQ)**2 OMST(K)=OMST(K)*O3 IF(IPRINT.GE.0)WRITE(6,802)IT1,IT2,AQ,BQ,O1,O2,O3 ENDIF ENDIF 5000 CONTINUE ENDIF C RETURN C 801 FORMAT(//'2**LAM-POLE TOP-UP',3X,'I1',3X,'I2',6X,'AQ',8X,'BQ' X,8X,'O1',8X,'O2',8X,'O3'/F9.5) 802 FORMAT(18X,2I5,5F10.3) 803 FORMAT(18X,2I5,F10.3,10X,F10.3) 804 FORMAT(18X,2I5,10X,F10.3,10X,F10.3) C END C C ****************************************************************** C SUBROUTINE VERT(V,LV,N,W,IERR) C C ________________________________________________________ C | | C | INVERT A GENERAL MATRIX | C | | C | INPUT: | C | | C | V --ARRAY CONTAINING MATRIX | C | | C | LV --LEADING (ROW) DIMENSION OF ARRAY V | C | | C | N --DIMENSION OF MATRIX STORED IN ARRAY V | C | | C | W --INTEGER WORK ARRAY WITH AT LEAST N-1 | C | ELEMENTS | C | | C | OUTPUT: | C | | C | V --INVERSE | C | | C | BUILTIN FUNCTIONS: ABS | C |________________________________________________________| C REAL*8 V(LV,*),S,T REAL*8 TZERO,ONE INTEGER W(*),I,J,K,L,M,N,P,IERR C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C IERR=0 C IF ( N .EQ. 1 ) GOTO 110 L = 0 M = 1 10 IF ( L .EQ. N ) GOTO 90 K = L L = M M = M + 1 C --------------------------------------- C |*** FIND PIVOT AND START ROW SWAP ***| C --------------------------------------- P = L IF ( M .GT. N ) GOTO 30 S = ABS(V(L,L)) DO 20 I = M,N T = ABS(V(I,L)) IF ( T .LE. S ) GOTO 20 P = I S = T 20 CONTINUE W(L) = P 30 S = V(P,L) V(P,L) = V(L,L) IF ( S .EQ. TZERO ) GOTO 120 C ----------------------------- C |*** COMPUTE MULTIPLIERS ***| C ----------------------------- V(L,L) = -ONE S = ONE/S DO 40 I = 1,N 40 V(I,L) = -S*V(I,L) J = L 50 J = J + 1 IF ( J .GT. N ) J = 1 IF ( J .EQ. L ) GOTO 10 T = V(P,J) V(P,J) = V(L,J) V(L,J) = T IF ( T .EQ. TZERO ) GOTO 50 C ------------------------------ C |*** ELIMINATE BY COLUMNS ***| C ------------------------------ IF ( K .EQ. 0 ) GOTO 70 DO 60 I = 1,K 60 V(I,J) = V(I,J) + T*V(I,L) 70 V(L,J) = S*T IF ( M .GT. N ) GOTO 50 DO 80 I = M,N 80 V(I,J) = V(I,J) + T*V(I,L) GOTO 50 C ----------------------- C |*** PIVOT COLUMNS ***| C ----------------------- 90 L = W(K) DO 100 I = 1,N T = V(I,L) V(I,L) = V(I,K) 100 V(I,K) = T K = K - 1 IF ( K .GT. 0 ) GOTO 90 RETURN 110 IF ( V(1,1) .EQ. TZERO ) GOTO 120 V(1,1) = ONE/V(1,1) RETURN 120 IERR=1 RETURN END C C ****************************************************************** C SUBROUTINE VERTS(V,LV,N,W,IERR) C C ________________________________________________________ C | | C | INVERT A SYMMETRIC MATRIX WITHOUT PIVOTING | C | | C | INPUT: | C | | C | V --ARRAY CONTAINING MATRIX | C | (ONLY THE LOWER HALF NEED BE DEFINED) | C | | C | LV --LEADING (ROW) DIMENSION OF ARRAY V | C | | C | N --MATRIX DIMENSION | C | | C | W --WORK ARRAY WITH LENGTH AT LEAST N | C | | C | OUTPUT: | C | | C | V --INVERSE (IN LOWER HALF ONLY) | C |________________________________________________________| C REAL*8 V(*),W(*),S,T INTEGER G,H,I,J,K,L,M,N,LV,IERR REAL*8 TZERO,ONE C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C IERR=0 C C ---------------- CNRB |*** PACK V ***| C ---------------- H=LV-N I=0 M=0 L=N G=(N*(N+1))/2 2 IF(L.EQ.G)GO TO 4 K=L+1 M=M+1 L=L+N-M I=I+H+M DO J=K,L V(J)=V(I+J) ENDDO GO TO 2 C 4 H = N K = 1 10 IF ( H .EQ. 1 ) GOTO 40 C -------------------------- C |*** SAVE PIVOT ENTRY ***| C -------------------------- S = V(K) K = K + H G = K H = H - 1 M = H IF ( S .EQ. TZERO ) GOTO 50 J = 0 20 J = J - M M = M - 1 L = G + M T = V(G+J)/S C --------------------------- C |*** ELIMINATE BY ROWS ***| C --------------------------- DO 30 I = G,L 30 V(I) = V(I) - T*V(I+J) G = L + 1 IF ( M .GT. 0 ) GOTO 20 GOTO 10 40 IF ( V(K) .NE. TZERO ) GOTO 60 IERR=2 RETURN 50 IERR=1 RETURN C ------------------------------------------ C |*** SOLVE FOR ROWS OF INVERSE MATRIX ***| C ------------------------------------------ 60 G = N + N DO 150 M = 1,N L = ((G-M)*(M-1))/2 H = L K = M DO 70 I = M,N 70 W(I) = TZERO W(M) = ONE 80 IF ( K .EQ. N ) GOTO 100 T = W(K)/V(K+L) J = L L = L + N - K K = K + 1 IF ( T .EQ. TZERO ) GOTO 80 DO 90 I = K,N 90 W(I) = W(I) - T*V(I+J) GOTO 80 C ----------------------------------- C |*** BACK SUBSTITUTION BY ROWS ***| C ----------------------------------- 100 W(N) = W(N)/V(K+L) 110 IF ( K .EQ. M ) GOTO 130 J = K K = K - 1 L = L + K - N T = W(K) DO 120 I = J,N 120 T = T - W(I)*V(I+L) W(K) = T/V(K+L) GOTO 110 130 DO 140 I = M,N 140 V(I+H) = W(I) 150 CONTINUE C ------------------ CNRB |*** UNPACK V ***| C ------------------ H=LV-N I=(N-1)*H+(N*(N-1))/2 M=N-1 L=(N*(N+1))/2 K=L 200 IF(I.EQ.0)RETURN DO J=L,K,-1 V(I+J)=V(J) ENDDO I=I-H-M L=K-1 M=M-1 K=K-N+M GO TO 200 C END C C********************************************************** C REAL*8 FUNCTION WSQ(A,B,C,D,F,ISIGN) C C CALCULATES 3*(2*F+1)*W(A,B,C,D,1,F)**2 WHERE W IS RACAH COEFFICIENT. C NRB: C ISIGN IS THE SIGN OF W BEFORE SQUARING. C IMPLICIT INTEGER(A-N) IMPLICIT REAL*8 (W) C C ISIGN=(-1)**(F-A-C) C IF(B-A)10,20,30 C 10 IF(D-C)11,12,13 20 IF(D-C)21,22,23 30 IF(D-C)31,32,33 C 11 WSQ=.75*DBLE((2*F+1)*(B+D+F+2)*(B+D+F+3)*(B+D-F+1)*(B+D-F+2))/ + DBLE((B+1)*(2*B+1)*(2*B+3)*(D+1)*(2*D+1)*(2*D+3)) RETURN 12 WSQ=.75*DBLE((2*F+1)*(B+D+F+2)*(-B+D+F)*(B-D+F+1)*(B+D-F+1))/ + DBLE((B+1)*(2*B+1)*(2*B+3)*D*(D+1)*(2*D+1)) ISIGN=-ISIGN RETURN 13 WSQ=.75*DBLE((2*F+1)*(-B+D+F-1)*(-B+D+F)*(B-D+F+1)*(B-D+F+2))/ + DBLE((B+1)*(2*B+1)*(2*B+3)*D*(2*D-1)*(2*D+1)) RETURN C 21 WSQ=.75*DBLE((2*F+1)*(B+D+F+2)*(-B+D+F+1)*(B-D+F)*(B+D-F+1))/ + DBLE(B*(B+1)*(2*B+1)*(D+1)*(2*D+1)*(2*D+3)) ISIGN=-ISIGN RETURN 22 G=-(B*(B+1)+D*(D+1)-F*(F+1)) IF(G.LT.0)ISIGN=-ISIGN WSQ=.75*DBLE((2*F+1)*G*G)/ !(2*F+1) IS NOT SQUARED-NRB + DBLE(B*(B+1)*(2*B+1)*D*(D+1)*(2*D+1)) RETURN 23 WSQ=.75*DBLE((2*F+1)*(B+D+F+1)*(-B+D+F)*(B-D+F+1)*(B+D-F))/ + DBLE(B*(B+1)*(2*B+1)*D*(2*D-1)*(2*D+1)) RETURN C 31 WSQ=.75*DBLE((2*F+1)*(-B+D+F+1)*(-B+D+F+2)*(B-D+F-1)*(B-D+F))/ + DBLE(B*(2*B-1)*(2*B+1)*(D+1)*(2*D+1)*(2*D+3)) RETURN 32 WSQ=.75*DBLE((2*F+1)*(B+D+F+1)*(-B+D+F+1)*(B-D+F)*(B+D-F))/ + DBLE(B*(2*B-1)*(2*B+1)*D*(D+1)*(2*D+1)) RETURN 33 WSQ=.75*DBLE((2*F+1)*(B+D+F)*(B+D+F+1)*(B+D-F-1)*(B+D-F))/ + DBLE(B*(2*B-1)*(2*B+1)*D*(2*D-1)*(2*D+1)) RETURN C END C********************************************************** C REAL*8 FUNCTION WSQ2(A,B,C,D,F,ISIGN) C C CALCULATES 3*(2F+1)*W(A,B,C,D,1,F)**2 WHERE W IS RACAH COEFFICIENT. C NRB: C ISIGN IS THE SIGN OF W BEFORE SQUARING, C*** AND *** A,B,C,D,E,F ARE INPUT TWICE THEIR ACTUAL VALUE. C IMPLICIT INTEGER(A-N) IMPLICIT REAL*8 (W) C C ISIGN=(-1)**((F-A-C)/2) C IF(B-A)10,20,30 C 10 IF(D-C)11,12,13 20 IF(D-C)21,22,23 30 IF(D-C)31,32,33 C 11 WSQ2=.75*DBLE((F+1)*(B+D+F+4)*(B+D+F+6)*(B+D-F+2)*(B+D-F+4))/ + DBLE((B+2)*(B+1)*(B+3)*(D+2)*(D+1)*(D+3))/4. RETURN 12 WSQ2=.75*DBLE((F+1)*(B+D+F+4)*(-B+D+F)*(B-D+F+2)*(B+D-F+2))/ + DBLE((B+2)*(B+1)*(B+3)*D*(D+2)*(D+1))/2. ISIGN=-ISIGN RETURN 13 WSQ2=.75*DBLE((F+1)*(-B+D+F-2)*(-B+D+F)*(B-D+F+2)*(B-D+F+4))/ + DBLE((B+2)*(B+1)*(B+3)*D*(D-1)*(D+1))/4. RETURN C 21 WSQ2=.75*DBLE((F+1)*(B+D+F+4)*(-B+D+F+2)*(B-D+F)*(B+D-F+2))/ + DBLE(B*(B+2)*(B+1)*(D+2)*(D+1)*(D+3))/2. ISIGN=-ISIGN RETURN 22 G=-(B*(B+2)+D*(D+2)-F*(F+2)) IF(G.LT.0)ISIGN=-ISIGN WSQ2=.75*DBLE((F+1)*G*G)/ !(F+1) IS NOT SQUARED-NRB + DBLE(B*(B+2)*(B+1)*D*(D+2)*(D+1)) RETURN 23 WSQ2=.75*DBLE((F+1)*(B+D+F+2)*(-B+D+F)*(B-D+F+2)*(B+D-F))/ + DBLE(B*(B+2)*(B+1)*D*(D-1)*(D+1))/2. RETURN C 31 WSQ2=.75*DBLE((F+1)*(-B+D+F+2)*(-B+D+F+4)*(B-D+F-2)*(B-D+F))/ + DBLE(B*(B-1)*(B+1)*(D+2)*(D+1)*(D+3))/4 RETURN 32 WSQ2=.75*DBLE((F+1)*(B+D+F+2)*(-B+D+F+2)*(B-D+F)*(B+D-F))/ + DBLE(B*(B-1)*(B+1)*D*(D+2)*(D+1))/2. RETURN 33 WSQ2=.75*DBLE((F+1)*(B+D+F)*(B+D+F+2)*(B+D-F-2)*(B+D-F))/ + DBLE(B*(B-1)*(B+1)*D*(D-1)*(D+1))/4. RETURN C END C****************************************************************** C SUBROUTINE ZEIGEN(A,VAL,N,DELTA) C C DIAGONALISATION OF COMPLEX SYMMETRIC MATRIX C USING METHOD DESCRIBED BY M.J.SEATON, COMPUTER JOURNAL, VOL.12, C PAGE 156, 1969. C IMPLICIT REAL*8 (A-H,O-Z) C COMPLEX*16 A,X,VAL,C,S,H,P,Q,CIM,ZERO,ZONE c logical bflag C INCLUDE 'PARAM' C PARAMETER (ZERO=(0.0,0.0)) PARAMETER (ZONE=(1.0,0.0)) PARAMETER (CIM=(0.0,1.0)) PARAMETER (TZERO=0.0) PARAMETER (QUART=0.25) PARAMETER (HALF=0.5) PARAMETER (TWO=2.0) C DIMENSION A(MZDEG,MZDEG),X(MZDEG,MZDEG),VAL(MZDEG) C DATA IROTM/20/ C SQ(H)=H* CONJG(H) C C TEST FOR QUICK RETURN C IF(N.LE.0)RETURN C IF(N.EQ.1)THEN VAL(1)=A(1,1) A(1,1)=ZONE RETURN ENDIF C IF(N.EQ.2)THEN Q=A(1,2) P = (A(1,1)-A(2,2))*HALF FL= ABS(P*P+Q*Q) V=-QUART*LOG(SQ(P-CIM*Q)/FL) T= CONJG(P)*Q+CONJG(Q)*P U=-QUART * ATAN2(T/FL,(SQ(P)-SQ(Q))/FL) S= SIN(U)*COSH(V) +CIM*COS(U)*SINH(V) C= COS(U)*COSH(V) -CIM*SIN(U)*SINH(V) H=(S*P+C*Q)*S*TWO VAL(1)=A(1,1)-H VAL(2)=A(2,2)+H A(1,1)=C A(1,2)=S A(2,1)=-S A(2,2)=C RETURN ENDIF C C GENERAL CASE C DELTA2=DELTA*DELTA NM1=N-1 C C INITIAL D1,D2 AND X C D1=TZERO H=ZERO DO I=1,N X(I,I)=ZONE D1=D1+SQ(A(I,I)) H=H+A(I,I) ENDDO D1=D1-SQ(H)/DBLE(N) C D2=TZERO DO I=1,NM1 IP1=I+1 DO J=IP1,N X(I,J)=ZERO X(J,I)=ZERO D2=D2+SQ(A(I,J)) ENDDO ENDDO c c identity test c bflag=.true. if(abs(d1).lt.delta2.and.d2.lt.delta2)then c write(6,*)d1,d2 if(d1.eq.tzero)return !must return bflag=.false. endif C D1 = (N-1)*(D1*HALF+D2)*DELTA2/DBLE((N+1)) C C BEGIN ROTATIONS C DO 1010 IROT=1,IROTM DO 1000 IP=1,NM1 IPP1=IP+1 DO 1000 IQ=IPP1,N C C ROTATION CONSTANTS C Q=A(IP,IQ) P = (A(IP,IP)-A(IQ,IQ))*HALF FL = ABS(P*P+Q*Q) BETA = LOG(SQ(P-CIM*Q)/FL)*HALF T=( CONJG(P)*Q+P* CONJG(Q))/FL D=(SQ(P)-SQ(Q))/FL U=-QUART*ATAN2(T,D) C T=TZERO D=TZERO DO I=1,N IF(I.NE.IP.AND.I.NE.IQ)THEN D=D+SQ(A(IP,I))+SQ(A(IQ,I)) T=T+SQ(A(IP,I)+CIM*A(IQ,I)) ENDIF ENDDO T=D-T FN= SQRT(D*D-T*T) GAMMA=LOG((D+T)/FN) C C ITERATION FOR V C V0=-HALF*(BETA+GAMMA) DO ITERV=1,100 V=V0-(FL*SINH((V0+BETA)*TWO)+FN*SINH(V0+GAMMA))/ * (TWO*FL*COSH((V0+BETA)*TWO)+FN*COSH(V0+GAMMA)) IF(ABS(V-V0).LT.DELTA*0.1) GO TO 580 V0=V ENDDO WRITE(6,5010) DELTA C C NEW A,X AND D2 C 580 V=HALF*V S= SIN(U)*COSH(V) +CIM*COS(U)*SINH(V) C= COS(U)*COSH(V) -CIM*SIN(U)*SINH(V) H = (S*P+C*Q)*S*TWO A(IP,IP)=A(IP,IP)-H A(IQ,IQ)=A(IQ,IQ)+H A(IP,IQ)=(C*C-S*S)*Q+TWO*C*S*P D2=D2-SQ(A(IQ,IP))+SQ(A(IP,IQ)) A(IQ,IP)=A(IP,IQ) C DO I=1,N H=X(I,IP) X(I,IP)=H*C-X(I,IQ)*S X(I,IQ)=H*S+X(I,IQ)*C IF(I.NE.IP.AND.I.NE.IQ)THEN H=A(IP,I) A(IP,I)=C*H-A(IQ,I)*S A(IQ,I)=S*H+A(IQ,I)*C D2=D2-SQ(A(I,IP))-SQ(A(I,IQ))+SQ(A(IP,I))+SQ(A(IQ,I)) A(I,IP)=A(IP,I) A(I,IQ)=A(IQ,I) ENDIF ENDDO C C TEST CONVERGENCE IF(D2.LT.D1) GO TO 610 C C END ROTATIONS C 1000 CONTINUE C C RECALCULATE D2 C D2=TZERO DO I=1,NM1 IP1=I+1 DO J=IP1,N D2=D2+SQ(A(I,J)) ENDDO ENDDO C 1010 CONTINUE c if(bflag) xWRITE(6,5020)IROTM,DELTA C C EIGENVALUES AND EIGENVECTORS C 610 DO I=1,N VAL(I)=A(I,I) DO J=1,N A(I,J)=X(I,J) ENDDO ENDDO C RETURN C 5010 FORMAT(//10X,'*** SUBROUTINE ZEIGEN ***'// + ' WARNING - NO CONVERGENCE IN ITERATIONS FOR V'/ + ' ACCURACY PARAMETER DELTA = ',1PE9.2/ + ' NEXT VALUE OF AVERAGED OMEGA MAY BE INCORRECT'//) 5020 FORMAT(//11X,'*** SUBROUTINE ZEIGEN ***' + /' NO CONVERGENCE FOR IROTM =',I3/' DELTA =',1PE11.2/ + ' NEXT VALUE OF AVERAGED OMEGA MAY BE INCORRECT'//) C END C****************************************************************** C SUBROUTINE ZLUBS(A,B,LB,NB,IERR) C ________________________________________________________ C | | C | SOLVE A COMPLEX LU FACTORED SYMMETRIC SYSTEM | C | WITHOUT PIVOTING | C | | C | INPUT: | C | | C | A --ZLUS'S OUTPUT | C | | C | B --RIGHT SIDE (DESTROYED) | C | | C | LB --LEADING (ROW) DIMENSION OF ARRAY B | C | | C | NB --DIMENSION OF MATRIX STORED IN B | C | | C | OUTPUT: | C | | C | B --SOLUTION | C |________________________________________________________| C COMPLEX*16 A(*),B(LB,*),T REAL*8 TZERO,ONE INTEGER I,J,K,L,N,LB,NB,IB,I1,IERR,KB,NB0 C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C IERR=0 NB0=ABS(NB) C I1 = NINT(DBLE(A(1))) IF ( ABS(I1) .NE. 1237 ) THEN IERR=1 !ERROR, MUST FACTOR BEFORE SOLVING RETURN ENDIF C ----------------------------- C |*** FORWARD ELIMINATION ***| C ----------------------------- DO 20 IB = 1,NB0 KB=1 IF(NB.LT.0)KB=IB N = NINT(DBLE(A(2))) L = 3 K = 1 IF ( I1 .LT. 0 ) GOTO 80 30 IF ( K .EQ. N ) GOTO 50 T = B(K,IB)/A(K+L) J = L L = L + N - K K = K + 1 IF ( ABS(T) .EQ. TZERO ) GOTO 30 DO 40 I = K,N 40 B(I,IB) = B(I,IB) - T*A(I+J) GOTO 30 C ----------------------------------- C |*** BACK SUBSTITUTION BY ROWS ***| C ----------------------------------- 50 B(N,IB) = B(N,IB)/A(K+L) 60 IF ( K .EQ. KB ) GO TO 20 J = K K = K - 1 L = L + K - N T = B(K,IB) DO 70 I = J,N 70 T = T - B(I,IB)*A(I+L) B(K,IB) = T/A(K+L) GOTO 60 C ----------------------------- C |*** COMPUTE NULL VECTOR ***| C ----------------------------- 80 IF ( ABS(A(K+L)) .EQ. TZERO ) GOTO 90 L = L + N - K K = K + 1 GOTO 80 90 DO 100 I = 1,N 100 B(I,IB) = TZERO B(K,IB) = ONE GOTO 60 20 CONTINUE IF(NB.LT.0)THEN DO J=1,IB DO I=J,IB B(J,I)=B(I,J) ENDDO ENDDO ENDIF RETURN END C****************************************************************** C SUBROUTINE ZLUS(A,LA,N,W,IERR) C C ________________________________________________________ C | | C | LU FACTOR A SYMMETRIC COMPLEX MATRIX WITHOUT PIVOTING | C | | C | INPUT: | C | | C | A --COMPLEX ARRAY CONTAINING MATRIX | C | (ONLY THE LOWER HALF NEED BE DEFINED) | C | | C | LA --LEADING (ROW) DIMENSION OF ARRAY A | C | | C | N --MATRIX DIMENSION | C | | C | W --REAL WORK ARRAY WITH LENGTH AT LEAST N | C | | C | OUTPUT: | C | | C | A --INVERSE (IN LOWER HALF ONLY) | C |________________________________________________________| C COMPLEX*16 A(*),Y,Z INTEGER G,H,I,J,K,L,M,N REAL*8 R,S,T,W(*),TZERO C PARAMETER (TZERO=0.0) C IERR=0 C C ---------------- CNRB |*** PACK A ***| C ---------------- H=LA-N I=0 M=0 L=N G=(N*(N+1))/2 2 IF(L.EQ.G)GO TO 4 K=L+1 M=M+1 L=L+N-M I=I+H+M DO J=K,L A(J)=A(I+J) ENDDO GO TO 2 C C ------------------------ C |*** COMPUTE 1-NORM ***| C ------------------------ 4 DO 10 I = 1,N 10 W(I) = TZERO I = -N K = 0 R = TZERO S = TZERO 20 I = I + N - K K = K + 1 J = K S = ABS(A(I+J)) 30 IF ( J .EQ. N ) GOTO 40 J = J + 1 T = ABS(A(I+J)) S = S + T W(J) = W(J) + T GOTO 30 40 S = S + W(K) IF ( R .LT. S ) R = S IF ( K .LT. N ) GOTO 20 J = 3 + (N+N*N)/2 C ----------------------------------- C |*** SHIFT MATRIX DOWN 3 SLOTS ***| C ----------------------------------- 50 A(J) = A(J-3) J = J - 1 IF ( J .GT. 3 ) GOTO 50 A(1) = 1237 A(2) = N A(3) = R H = N K = 4 60 IF ( H .EQ. 1 ) GOTO 90 C -------------------------- C |*** SAVE PIVOT ENTRY ***| C -------------------------- Z = A(K) K = K + H G = K H = H - 1 M = H IF ( ABS(Z) .EQ. TZERO ) GOTO 100 J = 0 70 J = J - M M = M - 1 L = G + M Y = A(G+J)/Z C --------------------------- C |*** ELIMINATE BY ROWS ***| C --------------------------- DO 80 I = G,L 80 A(I) = A(I) - Y*A(I+J) G = L + 1 IF ( M .GT. 0 ) GOTO 70 GOTO 60 90 IF ( ABS(A(K)) .NE. TZERO ) RETURN A(1) = -1237 RETURN 100 A(1) = -1237 GOTO 60 END C*************************************************************** C SUBROUTINE ZPHIN(I,ZR,N1,N2,ZAI,ZPI) C C COMPUTES AMPLITUDE ZAI AND PHASE ZPI OF COULOMB FUNCTION ZPHI C FOR COMPLEX-RADIAL CO-ORDINATE ZR. C USES DATA IN ARRAY D WHICH IS HELD IN COMMON/CJWBK/ C AND SHOULD HAVE BEEN COMPUTED IN SUBROUTINE INJWBK. C THE STRUCTURE OF ZPHI IS SIMILAR TO THAT OF SUBROUTINE JWBK. CNRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (MX15N=15*MZCHF) C COMMON/CJWBK/D(MX15N) COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/NRBZED/TZED,LPRTSW C DIMENSION ZAI(30),ZPI(30),ZR(30) C C NP = 0 C JKB=(I-1)*15 E=D(JKB+1) C=D(JKB+4) C IF(TZED.EQ.0)THEN FK=D(JKB+2) IF(C.EQ.0)THEN DO N=N1,N2 NP=NP+1 ZAI(NP)=1.0/SQRT(FK) ZPI(NP)=FK*ZR(NP) ENDDO ELSE DO N=N1,N2 NP=NP+1 ZX=1./ZR(NP) ZXSQ=ZX*ZX ZW=E-C*ZXSQ ZA1=0.0625*(ZX/ZW)**3 ZCC=ZA1*(D(JKB+14)*ZXSQ+D(JKB+12))*ZX ZWH=SQRT(ZW) Z=ZR(NP)*ZWH ZSQ=Z*Z ZP=(ZSQ-0.125-.2083333*C/ZSQ)/Z+D(JKB+15) ZA1=1./(ZR(NP)*FK) ZS=D(JKB+5)*ZA1 ZG=Z*ZA1 ZP=ZP+D(JKB+6)*(0.,-1.)*LOG(ZG+(0.,1.)*ZS) ZPI(NP)=ZP ZAI(NP)=(1.-ZCC)/SQRT(ZWH) ENDDO ENDIF RETURN ENDIF C IF(E.GT.0) THEN IF(C.GT.0) THEN DO N=N1,N2 NP = NP+1 ZX=1./ZR(NP) ZW=E+ZX*(2.-C*ZX) ZWH=SQRT(ZW) Z=ZR(NP)*ZWH FK=D(JKB+2) ZRK=ZR(NP)*FK ZRMC=ZR(NP)-C ZALP=Z+ZRK CK=D(JKB+10) C COMPUTE PHASE ZP=Z+D(JKB+15) C LOG TERM ZB=FK*ZALP IF(ABS(ZB).GT.ACJWBK) THEN ZP=ZP+D(JKB+3)*LOG(1.+ZB) ELSE ZB=-ZB ZP=ZP+ZALP*((((.2*ZB+.25)*ZB+.33333333)*ZB+.5)*ZB+1.) END IF C ARCTAN TERM ZA1=1./(ZR(NP)*D(JKB+7)) ZS=D(JKB+5)*(Z-FK*ZRMC)*ZA1 ZG=(CK*Z+ZRMC)*ZA1 ZP=ZP+D(JKB+6)*(0.,-1.)*LOG(ZG+(0.,1.)*ZS) C CAP PHI TERM ZP=ZP+((5.*ZRMC/(Z*Z))-(Z*D(JKB+9)+ZRK*D(JKB+8)+CK)/ X (ZALP*D(JKB+7)))/(24.*Z) C COMPLETE CALCULATION OF ZPHI ZA1=.0625*(ZX/ZW)**3 ZCC=ZA1*(((D(JKB+14)*ZX+D(JKB+13))*ZX+D(JKB+12))*ZX+ X D(JKB+11)) ZPI(NP)=ZP ZAI(NP)=(1.-ZCC)/SQRT(ZWH) ENDDO ELSE C CASE OF C.EQ.0 AND E.GT.0 C DO N=N1,N2 NP = NP+1 ZX=1./ZR(NP) ZW=2.*ZX+E ZWH=SQRT(ZW) Z=ZR(NP)*ZWH FK=D(JKB+2) ZRK=ZR(NP)*FK ZALP=Z+ZRK C COMPUTE PHASE ZP=Z+D(JKB+15) ZB=FK*ZALP IF(ABS(ZB).GT.ACJWBK) THEN ZP=ZP+D(JKB+3)*LOG(1.+ZB) ELSE ZB=-ZB ZP=ZP+ZALP*((((.2*ZB+.25)*ZB+.33333333)*ZB+.5)*ZB+1.) END IF ZP=ZP+1/(4.*ZALP)+(5.*ZR(NP)/(Z*Z)-2.*(Z+ZALP)/ZALP)/(24.*Z) C COMPLETE CALCULATION OF ZPHI ZA1=.0625*(ZX/ZW)**3 ZCC=ZA1*(-4.*E-3.*ZX) ZPI(NP)=ZP ZAI(NP)=(1.-ZCC)/SQRT(ZWH) ENDDO ENDIF ELSE IF(C.EQ.0) THEN DO N=N1,N2 NP = NP+1 ZX=1./ZR(NP) ZW=2.*ZX ZWH=SQRT(ZW) Z=ZR(NP)*ZWH ZP=2.*Z*(1.+.046875*ZX)+D(JKB+15) ZWMQ=1./SQRT(ZWH) ZET=(1.+.0234375*ZX)*ZWMQ ZAI(NP)=ZET ZPI(NP)=ZP ENDDO ELSE C C CASE OF E.EQ.0 AND C.GT.0 C DO N=N1,N2 NP = NP+1 ZX=1./ZR(NP) ZW=ZX*(2.-C*ZX) ZWH=SQRT(ZW) Z=ZR(NP)*ZWH ZRMC=ZR(NP)-C C COMPUTE PHASE ZP=2.*Z+D(JKB+15) ZA1=1./ZR(NP) ZS=D(JKB+5)*Z*ZA1 ZG=ZRMC*ZA1 ZP=ZP+D(JKB+6)*(0.,-1.)*LOG(ZG+(0.,1.)*ZS) ZP=ZP-(3.*ZR(NP)+C)/(24.*(ZRMC+ZR(NP))*Z) C COMPLETE CALCULATION OF ZPHI ZA1=.0625*(ZX/ZW)**3 ZCC=((D(JKB+14)*ZX+D(JKB+13))*ZX-3.)*ZX*ZA1 ZAI(NP)=(1.-ZCC)/SQRT(ZWH) ZPI(NP)=ZP ENDDO ENDIF ENDIF RETURN END C*************************************************************** C SUBROUTINE ZTHETAS(I,ZA1,ZA2,ZA3,ZB,ZG,N1,N2,ZTA,ZTDA,ZTP) C C CALCULATES THETA AND THETAD FOR CHANNEL I AND COMPLEX-ZR C THETA = ZTA*CEXP(ZTP) C THETAD = ZTDA**CEXP(ZTP) C ZTP = FNUI*LOG(ZR) - ZR/FNUI CNRB C NEUTRAL CASE ADDED C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C COMMON/CTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF) COMMON/CBLK/XLAG(30),WLAG(30),XLEG(15),WLEG(15) COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/NRBZED/TZED,LPRTSW C DIMENSION ZTP(30),ZTA(30),ZTDA(30) C C X=RTWO MI=MSUM(I) FNUI=BB(I,1) E=BG(I,1) F2=BG(I,2) NP = 0 DO N=N1,N2 NP = NP + 1 U=XLAG(N) ZET=ZA1*(SQRT(ZA2+ZA3*U)-1.) ZMUM=-.5*ZET/(ZB*(1.+ZET*ZG)) ZET=ZET*ZET ZR=ZET*X Z=2.*ZR/FNUI ZY=1./Z ZAS=1. ZS=BB(I,2) ZX=0. DO M=3,MI ZAS=ZAS*ZY ZX=ZX+BG(I,M)*ZAS ZS=ZS+BB(I,M)*ZAS ENDDO C ZDLR=LOG(ZR)*TZED ZTP(NP)=(FNUI*ZDLR-.5*Z) ZTA(NP)=ZS ZTDA(NP)=E*((ZDLR+ZR*F2)*ZS+ZX) ENDDO C RETURN END C C ****************************************************************** C SUBROUTINE ZVERTS(V,LV,N,W,IERR) C C ________________________________________________________ C | | C | INVERT A SYMMETRIC COMPLEX MATRIX WITHOUT PIVOTING | C | | C | INPUT: | C | | C | V --ARRAY CONTAINING MATRIX | C | (ONLY THE LOWER HALF NEED BE DEFINED) | C | | C | LV --LEADING (ROW) DIMENSION OF ARRAY V | C | | C | N --MATRIX DIMENSION | C | | C | W --WORK ARRAY WITH LENGTH AT LEAST N | C | | C | OUTPUT: | C | | C | V --INVERSE (IN LOWER HALF ONLY) | C |________________________________________________________| C COMPLEX*16 V(*),W(*),S,T INTEGER G,H,I,J,K,L,M,N,LV,IERR REAL*8 TZERO,ONE C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) C IERR=0 C C ---------------- CNRB |*** PACK V ***| C ---------------- H=LV-N I=0 M=0 L=N G=(N*(N+1))/2 2 IF(L.EQ.G)GO TO 4 K=L+1 M=M+1 L=L+N-M I=I+H+M DO J=K,L V(J)=V(I+J) ENDDO GO TO 2 C 4 H = N K = 1 10 IF ( H .EQ. 1 ) GOTO 40 C -------------------------- C |*** SAVE PIVOT ENTRY ***| C -------------------------- S = V(K) K = K + H G = K H = H - 1 M = H IF ( ABS(S) .EQ. TZERO ) GOTO 50 J = 0 20 J = J - M M = M - 1 L = G + M T = V(G+J)/S C --------------------------- C |*** ELIMINATE BY ROWS ***| C --------------------------- DO 30 I = G,L 30 V(I) = V(I) - T*V(I+J) G = L + 1 IF ( M .GT. 0 ) GOTO 20 GOTO 10 40 IF ( ABS(V(K)) .NE. TZERO ) GOTO 60 IERR=2 RETURN 50 IERR=1 RETURN C ------------------------------------------ C |*** SOLVE FOR ROWS OF INVERSE MATRIX ***| C ------------------------------------------ 60 G = N + N DO 150 M = 1,N L = ((G-M)*(M-1))/2 H = L K = M DO 70 I = M,N 70 W(I) = TZERO W(M) = ONE 80 IF ( K .EQ. N ) GOTO 100 T = W(K)/V(K+L) J = L L = L + N - K K = K + 1 IF ( ABS(T) .EQ. TZERO ) GOTO 80 DO 90 I = K,N 90 W(I) = W(I) - T*V(I+J) GOTO 80 C ----------------------------------- C |*** BACK SUBSTITUTION BY ROWS ***| C ----------------------------------- 100 W(N) = W(N)/V(K+L) 110 IF ( K .EQ. M ) GOTO 130 J = K K = K - 1 L = L + K - N T = W(K) DO 120 I = J,N 120 T = T - W(I)*V(I+L) W(K) = T/V(K+L) GOTO 110 130 DO 140 I = M,N 140 V(I+H) = W(I) 150 CONTINUE C ------------------ CNRB |*** UNPACK V ***| C ------------------ H=LV-N I=(N-1)*H+(N*(N-1))/2 M=N-1 L=(N*(N+1))/2 K=L 200 IF(I.EQ.0)RETURN DO J=L,K,-1 V(I+J)=V(J) ENDDO I=I-H-M L=K-1 M=M-1 K=K-N+M GO TO 200 C END