c PSTGFDAMP.f :: Parallel version of stgfdamp. 12 JUN 19 c D.M. Mitnik, D.C. Griffin, N.R. Badnell c v2.7/4.7 c C N. R. BADNELL UoS v4.8 29/06/21 C C PROGRAM STGFDAMP C BASED-ON STGF v4.9 C C RADIATION DAMPED 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 AND II DAMPING, FOR DR/RE C CORE AUGER DAMPING C NEUTRAL CASE ADDED C DARC HD.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 (TWO=2.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 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/NRBHYB/FNUHYB,NCHCL,ICHCL(MZCHF),NCHHYB,ICHHYB(MZCHF) 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/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS COMMON/NRBTOP/ITST(MXTST),JTST(MXTST),KTST(MZTAR,MZTAR) X ,OMST(MXTST),ITOP COMMON/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT COMMON/GAUGE/IGAUGE COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN COMMON/WIDSV/FWIDSV1(MZCHF),FWIDSV2(MZCHF),EWIDSV1(MZCHF), 1 EWIDSV2(MZCHF),RWIDSV(MZCHF),NWIDSV(MZCHF) COMMON/AUGER/AAUGER(MZTAR),IAUGER C C ,IRAD COMMON/NRBZED/TZED,LPRTSW NAMELIST/STGF/IPRINT ,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,IGAUGE,NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN,IAUGER,IWARN,FNUMIN 4,ICCINT,INTPQ,ISGPT,ITRMN,ITRMX,FNUHYB,ITOP,PRINT,IMODE,IDIP,IRD0 5,IJBIN,NODAMP C NAMELIST/MESH1/MXE,E0,EINCR,QNMAX,ABVTHR,BELTHR,ncint,nseq,ieq 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 c **** parallel **** common/parainfo/iam,nproc include 'mpif.h' common/blockstop/istop common/buff/buffer1(MZMSH),status(MPI_STATUS_SIZE) character*1 filec,filed,fileu call mpi_init(ierr) call mpi_comm_rank(mpi_comm_world,iam,ierr) call mpi_comm_size(mpi_comm_world,nproc,ierr) istop=0 c **** parallel **** call cpu_time(timei) c write(0,*)' BEGIN proc=:',iam C WARN=.TRUE. WARNE=.TRUE. QJUMP=.FALSE. IWARN=999 C C CALL BLOCK DATA AS SUBROUTINE TO AVOID LINKAGE PROBLEMS C CSUB 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 FOR DIPOLE B-DATA FILES B00, B01, B02 ETC. C 3 FOR DIPOLE D-DATA FILES D00, D01, D02 ETC. C 4 FOR AUGER (CORE) RATES. FILE AUGER. 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 F-DATA INDEPENDENT OF SLPI. FILE F00. C 9 FOR DIPOLE F-DATA DEPENDENT ON SLPI. FILES F01 ETC. C 10 FOR INPUT R-MATRIX DATA. FILE H.DAT. C 11 RESERVED C 14 FOR PARTIAL CROSS SECTIONS. FILE sigpw.dat C 17 FOR TERM INFORMATION FOR INPUT TO stgicf. 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 stgicf. FILE jbinls. C 20 FOR K-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 stgicfdamp. FILE zk/smtls.001,002... C 33 RESERVED C 34 RESERVED C 36 FOR UNPHYSICAL K-MATRIX. FILE kmatls. C 37 RESERVED C 38 RESERVED C 39 RESERVED C C c **** parallel **** ich0 = ichar('0') ic = iam/100 id = (iam - 100*ic)/10 iu = (iam - 100*ic - 10*id) ic = ic + ich0 id = id + ich0 iu = iu + ich0 filec = char(ic) filed = char(id) fileu = char(iu) c **** parallel **** c if (iam.eq.0) then OPEN(6,FILE='routfdamp',STATUS='UNKNOWN') else OPEN(6,FILE='routfdampg',STATUS='UNKNOWN') endif OPEN(5,FILE='dstgfdamp',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,MZDEC,MZREC,MZMEG C C C READ DATA FROM UNIT 5 C ********************* C C DAMPING VARIABLES: C DEFAULTS: EXCITATION DAMPING ON, DR/RR OFF. C C NTYP1 = 1 INCLUDE TYPE 1 (CORE) DECAY (DEFAULT). C = 0 EXCLUDE IT. C NTYP2I = 1 INCLUDE TYPE 2 IN (RMATRIX BOX) DECAY (DEFAULT). C = 0 EXCLUDE IT. C NTYP2OF = 1 INCLUDE TYPE 2 OUT (CONTINUUM-RYDBERG) DECAY. C = 0 EXCLUDE IT. C =-1 NOT SET BECAUSE NDRMET=0 (DEFAULT). C NTYP2OR = 1 INCLUDE TYPE 2 OUT (RYDBERG-RYDBERG) DECAY (DEFAULT). C = 0 EXCLUDE IT. C NMIN = MINIMUM PRINCIPAL QUANTUM NUMBER FOR FINAL DECAY STATES C OF NON-STGB TYPE 2 DECAY (NTYP2OF/R); USUALLY 1 GREATER THAN C THE LARGEST STGB VALUE. BY DEFAULT NMIN=-1 IS UNSET. HOWEVER, C IF NTYP2OR OR NTYP2OF =1 THEN NMIN IS REQUIRED. BUT, C IF NTYP2I=1 THEN THE CODE ATTEMPTS TO READ NMIN FROM THE C STGB B00 FILE (IF IT HAS NOT ALREADY BEEN SET POSITIVE). C NDRMET = NUMBER OF INITIAL METASTABLE STATES FOR DR/RR (DEFAULT=0). C NODAMP > 0 SWITCH OFF ALL DAMPING (OVERRIDES ANY OTHER NTYP SETTING). C = 0 USE GIVEN/DEFAULT DAMPING NTYP SWITCHES (DEFAULT). C IAUGER = 0 (DEFAULT) C = 1 READ CORE RATES FROM FILE AUGER: AAUNITS, THEN ITARG, C AA(AAUNITS) WHERE Z-SCALED AA(RYD)=AA(AAUNITS)/AAUNITS C I.E. AAUNITS/Z^2= 1 RYD, 0.5 AU, 2.06706E16 /SEC (1/HBAR). C IGAUGE = 0 USE LENGTH GAUGE, =1, USE VELOCITY GAUGE (DEFAULT=0). C C END DAMPING SPECIFIC VARIABLES 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 **** parallel **** C NOTE THAT ONLY IMODE<=0 IS IMPLEMENTED IN PARALLEL CODE. c **** parallel **** 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. Serial (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. Parallel takes -|IEQ|. 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 NCUTOFF=MAX PRINCIPAL QUANTUM NUMBER FOR WHICH DR IS CALCULATED, C CASE OF IQDT.GT.0 ONLY. DEFAULT ALL (1000000). 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 STANDARD STGF VARIABLES: 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 IS NOT USED CURRENTLY AS STGBF IS UNDAMPED C IRAD = 0 FOR NO RADIATIVE DATA ON UNIT 9 C = 1 FOR RADIATIVE DATA ON UNIT 9 C (WARNING: not implemented in parallel code) C = 2 FOR RADIATIVE DATA ON UNIT 9 AND NO COLLISION STRENGTHS C (WARNING: not implemented in parallel code) C IPERT = 0 FOR OMISSION OF LONG-RANGE MULTIPOLE POTENTIALS C = 1,2,3,4 FOR THEIR INCLUSION (SEE PERT BELOW AS WELL) 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 PERT = 'YES' SIMPLE OPTION TO SWITCH-ON PERTURBATIONS C = 'NO' OFF - DEFAULT. 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**** parallel c e0=starting energy of grid c eincr=energy step c mxe=number of energies c nseq=number of sequential energies per processor c ncint=number of groups of nseq. c c For *non-interpolation* (default) set only e0,eincr,mxe. c The nproce=mxe/nproc energies per processor are then distributed c linearly across the grid with redefined energy step eincr*nproc. c c For *interpolation* set one or both of nseq, ncint positive, together c with e0,eincr,mxe, where nproce=nseq*ncint. So, now, each processor c has nseq energy points for interpolation to take place on and this c is repeated ncint times across the entire energy range. Boundary c issues are taken account of internally without user intervention. c**** parallel C 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 (WARNING not implemented in parallel code) C = 11 FOR JAJOM, NO OMEGA WRITTEN. c (WARNING not implemented in parallel code) 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) BUT SWITCHED ON BY NTYP1>0. 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, SWITCHED-ON BY NDRMET. 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 (WARNING: in parallel code each processor will write its c own set of k-matrices for its set of energies.) C = 2 WRITE UNPHYSICAL K-MATRIX DATA TO kmatls. (TOM) C (WARNING: not implemented in parallel code.) 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 zk/smtls.dat SO THAT IT CAN BE C READ BY stgicfdamp FOR THE CALCULATION OF INTERMEDIATE-COUPLING C COLLISION STRENGTHS. C = 0 NO WRITES (DEFAULT). C IRD0 >= 100, FOR IPRKM=4, WRITE LS K/S-MATRIX FILES BY SYMMETRY VIZ. C zk/smtls.001, zk/smtls.002 etc. C < 100, FOR IPRKM=4, WRITE A SINGLE LS K/S-MATRIX FILE zk/smtls.dat. C DEFAULT: 99 C IDIP = 1 WRITE DIPOLE LINE STRENGTHS TO strength.dat. C = 0 NO WRITES. (DEFAULT: 0 IPRKM=0-3, 1 IPRKM=4) 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 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 ICCINT = 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 DAMPING SPECIFIC VARIABLES (DEFAULTS: EXCITATION ON, DR/RR OFF) C NTYP1=1 NTYP2I=1 NTYP2OF=-1 !BECAUSE NDRMET=0 NTYP2OR=1 NMIN=-1 !DETERMINE FROM STGB IAUGER=0 NDRMET=0 NCUTOFF=1000000 !SHOULDN'T NEED CHANGING IGAUGE=0 !LENGTH NODAMP=0 C END 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 IPRINT=-2 IPRKM=0 IRAD=0 !FIXED IN STGFDAMP 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='NO' NOMWRT=999999 IBETA=0 IDIP=-1 IBIGE=0 LMX=-1 ISGPT=0 ITRMN=0 ITRMX=0 ABVTHR=-1. BELTHR=-1. ITOP=-1 PRINT='FORM' IRD0=99 !DEFAULT FOR PARALLEL IJBIN=0 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 c **** parallel **** IF(IQDT.NE.0.AND.IMODE.gt.0) THEN STOP 'ONLY IMODE=0 IMPLEMENTED IN MQDT MODE FOR PARALLEL CODE' ENDIF IF(IOPT1.EQ.10.OR.IOPT1.EQ.11) THEN STOP 'JAJOM INPUT NOT IMPLEMENTED IN PARALLEL CODE' ENDIF c **** parallel **** c C BFORM=PRINT.EQ.'FORM'.OR.PRINT.EQ.'form' IF(KFLAG.NE.0)KFLAG=1 C IF(NODAMP.GT.0)THEN !SWITCH OFF DAMPING - EG NEUTRALS NTYP1=0 NTYP2I=0 NTYP2OR=0 NTYP2OF=0 NDRMET=0 ENDIF C IF(NDRMET.GT.0)THEN IF(NTYP2OF.EQ.0)WRITE(6,612) IF(NTYP2OF.LT.0)THEN WRITE(6,611) NTYP2OF=1 ENDIF ENDIF IF(NTYP1.LT.0)NTYP1=0 IF(NTYP2I.LT.0)NTYP2I=0 IF(NTYP2OR.LT.0)NTYP2OR=0 IF(NTYP2OF.LT.0)NTYP2OF=0 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(IQDT.LT.0)THEN !NTYP1 ONLY WHEN SQDT IF(NTYP2I+NTYP2OF+NTYP2OR.GT.0)WRITE(6,*)' ***WARNING: NTYP2' X, ' RADIATION SWITCHED-OFF' NTYP2I=0 NTYP2OF=0 NTYP2OR=0 ENDIF C IF(NMIN.EQ.0.OR.NMIN.GT.1000.AND.(NTYP2OR+NTYP2OF).GT.0)THEN WRITE(6,614)NMIN NMIN=0 NTYP2OF=0 NTYP2OR=0 ENDIF IF(NMIN.LT.0.AND.NTYP2I.EQ.0.AND.(NTYP2OR+NTYP2OF).GT.0)THEN WRITE(6,610) STOP'*** NMIN NOT SET FOR NTYP2O RADIATION (AND NTYP2I.EQ.0)***' ENDIF IF((NTYP2OR+NTYP2OF).EQ.0)NMIN=0 !NMIN NOT NEEDED C IF(IAUGER.GT.0)THEN IF(IQDT.LT.0)THEN WRITE(6,*)' FOR IAUGER > 0, WE NEED MQDT: SET IQDT=1 OR 2' STOP' FOR IAUGER > 0, WE NEED MQDT: SET IQDT=1 OR 2' ENDIF 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(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' ***DIMENSION ERROR, NDRMET>MZMET' 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'//filec//filed//fileu, + STATUS='UNKNOWN') IF(IPRKM.EQ.1)OPEN(20,FILE='KMAT.DAT'//filec//filed//fileu, + STATUS='UNKNOWN') IF(IPRKM.EQ.4)THEN IF(IDIP.LT.0)IDIP=1 OPEN(19,FILE='jbinls'//filec//filed//fileu, + FORM='UNFORMATTED',STATUS='UNKNOWN') IF(IRD0.LT.100)THEN IF(IQDT.EQ.1)THEN OPEN(32,FILE='smtls.dat.'//filec//filed//fileu X ,FORM='UNFORMATTED',STATUS='UNKNOWN') ELSE OPEN(32,FILE='zkmls.dat.'//filec//filed//fileu x ,FORM='UNFORMATTED',STATUS='UNKNOWN') ENDIF ENDIF ENDIF C C SELECT TYPE OF ENERGY MESH C QNMAX=-ONE ncint=1 !parallel if(imode.lt.0.and.imesh.ne.1)then write(6,*)'*** ERROR, IMODE=-1 ONLY IMPLEMENTED FOR IMESH=1' stop '*** ERROR, IMODE=-1 ONLY IMPLEMENTED FOR IMESH=1' endif C IF(IMESH.EQ.1)THEN C C CASE OF IMESH = 1 C c e0=starting energy of grid c eincr=energy step c mxe=number of energies c nseq=number of sequential energies per processor c ncint=number of groups of nseq. c c For *non-interpolation* (default) set only e0,eincr,mxe. c The nproce=mxe/nproc energies per processor are then distributed c linearly across the grid with redefined energy step eincr*nproc. c c For *interpolation* set one or both of nseq, ncint positive, together c with e0,eincr,mxe, where nproce=nseq*ncint. So, now, each processor c has nseq energy points for interpolation to take place on and this c is repeated ncint times across the entire energy range. Boundary c issues are taken account of internally without user intervention. C MXE=1 E0=ONE EINCR=ZERO nseq=-1 ncint=-1 C READ(5,MESH1) C c **** parallel **** ieq=-iabs(ieq) pqrd=pqrd.or.ieq.gt.1 nproce = mxe/nproc if(nproce*nproc.ne.mxe)then write(6,*) x 'WARNING: energy mesh truncated because MXE/NPROC .ne. integer' if(iam.eq.0)write(*,*) x 'WARNING: energy mesh truncated because MXE/NPROC .ne. integer' endif if(nseq.gt.0)ncint=nproce/nseq if(ncint.gt.0)then nseq=nproce/ncint if(ncint*nseq.ne.nproce)then write(6,*) x 'WARNING: energy mesh truncated because NPROCE/NSEQ*NCINT ', x '.ne. integer' if(iam.eq.0)write(*,*) x 'WARNING: energy mesh truncated because NPROCE/NSEQ*NCINT ', x '.ne. integer' endif endif if(ncint.gt.0)then e0=e0+iam*eincr*nseq nseq=nseq+1 mxe=nseq*ncint else e0=e0+iam*eincr eincr=eincr*nproc ncint=1 mxe=nproce nseq=mxe endif c *** parallel **** 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 j=0 eint=nproc*(nseq-1)*eincr do nc=1,ncint DO I=1,nseq e=e0+(i-1)*eincr j=j+1 EMESH(j)=E ENDDO e0=e0+eint enddo c do i=1,mxe c write(*,*)iam,i,emesh(i) c 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 c **** parallel **** nproce = mxe/nproc if(nproce*nproc.ne.mxe)then write(6,*) x 'WARNING: energy mesh truncated because MXE/NPROC .ne. integer' if(iam.eq.0)write(*,*) x 'WARNING: energy mesh truncated because MXE/NPROC .ne. integer' endif mxe=nproce m0=iam+1-nproc do m=1,mxe emesh(m)=emesh(m0+nproc*m) enddo c **** parallel **** 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,NTYP2I X ,NTYP2OF,NTYP2OR,NMIN,IGAUGE,IAUGER 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 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 AUGER WIDTHS; INPUT AS AAUNITS THEN CONVERTED TO A.U. C ************ C IF(IAUGER.GT.0)THEN OPEN(4,FILE='AUGER',STATUS='UNKNOWN') C AAUNITS/Z^2 = 1 RYD, 0.5 AU, 2.06706E16 /SEC I.E. 1/HBAR DO I=1,MZTAR AAUGER(I)=TZERO ENDDO READ(4,*)AAUNITS DO I=1,MZTAR READ(4,*,END=39)II,AAA AAUGER(II)=AAA/(TWO*AAUNITS) ENDDO 39 CONTINUE CLOSE(4) 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(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 ie=0 !parallel do nc=1,ncint do je=1,nseq ie=ie+1 IEE(IE)=0 IF(MOD(je-1,IEQ0).EQ.0)IEE(IE)=IE enddo IEE(ie)=ie ENDDO 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 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 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 READ DIRECTORY FOR B AND D DATAFILES C************************************** C IF(NTYP2I.NE.0)THEN CALL READD0 CALL READB0 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)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 C INITIALIZE JAJOM DATA FOR UNIT 22 (KAB,JAN94) C IF(IOPT1.GE.10) CALL OUTJJ(0,LRGLAM,MXE) C C INITIALIZE TESTS FOR NTYP2O RADIATION C DO I=1,NCHF EWIDSV1(I)=-999 EWIDSV2(I)=EWIDSV1(I) NWIDSV(I)=-99 ENDDO C C C READ B AND D DATAFILES FOR THIS SLP (AND FORM DDEC) C *********************************** C IF(NTYP2I.NE.0)CALL BDORG 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') 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//'.'//filec//filed//fileu, X FORM='UNFORMATTED',STATUS='UNKNOWN') ELSE OPEN(32,FILE='zkmls.'//NAME//'.'//filec//filed//fileu, X FORM='UNFORMATTED',STATUS='UNKNOWN') ENDIF ENDIF ENDIF C C C START ENERGY LOOP C ***************** C ie=0 !parallel do nc=1,ncint EQSAVE=-999999. ETOT=EMESH(ie+1) IF(PQRD)CALL READPQ(-ie,QETEST,ISLP,IOPT1,QJUMP,PQRD) C do 50 je=1,nseq !parallel ie=ie+1 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 enddo 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 if (iam.eq.0) then !par 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 ENDIF C C WRITE COLLISION STRENGTH OMEGA C IF(NOMWRT.NE.0)THEN IF(BFORM)THEN c **** parallel **** OPEN(7,FILE='OMEGA'//filec//filed//fileu, + STATUS='UNKNOWN') c **** parallel **** 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 c **** parallel **** OPEN(7,FILE='OMEGAU'//filec//filed//fileu, + STATUS='UNKNOWN',FORM='UNFORMATTED') c **** parallel **** 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 if (iam.eq.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 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 c **** parallel **** OPEN(18,FILE='OMEGDR'//filec//filed//fileu,STATUS='UNKNOWN') c **** parallel **** 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) IF(NTYP2OF.EQ.0)WRITE(6,612) C ENDIF C C WRITE SUMMARY OF DAMPING TO END OF UNIT6 AS A REMINDER. C WRITE(6,613)NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN 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 C call cpu_time(timef) c time=timef-timei write(6,999) time/60.,nproc 999 format(//1x,'CPU TIME=',f9.3,' MIN -- processors=:',i4) C C call mpi_finalize(ierr) 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 = ',I2/ * 10X,'NCUTOFF= ',I7/ * 10X,'FNUMIN = ',0PF4.1/ * 10X,'FNUHYB = ',F4.1/ * 10X,'NDRMET = ',I2/ 7 10x,'NTYP1 = ',I2/ 8 10X,'NTYP2I = ',I2/ 9 10X,'NTYP2OF= ',I2/ A 10X,'NTYP2OR= ',I2/ B 10X,'NMIN = ',I2/ E 10X,'IGAUGE = ',I2/ F 10X,'IAUGER =',I3//) 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'/) 610 FORMAT(/'*** ERROR: NMIN NOT SET FOR NTYP2OR/F RADIATION (AND' X,' UNABLE TO DETERMINE IT FROM STGB DATA BECAUSE NTYP2I.EQ.0)' X/' EITHER SET NMIN OR SWITCH-OFF NTYP2OR/F RADIATION VIA: ' X,' NTYP2OR=0 NTYP2OF=0') 611 FORMAT(/'*** ATTENTION: DR SWITCHED-ON BUT RR BACKGROUND ' X,'(NTYP2OF) NOT SPECIFIED'/'*** IT HAS BEEN SWITCHED-ON; TO' X,' SWITCH IT OFF SET: NTYP2OF=0') 612 FORMAT('*** ATTENTION: OMEGDR FILE MAY BE INCOMPLETE BECAUSE' X,' THE RR BACKGROUND IS OFF (NTYP2OF.EQ.0)'/) 613 FORMAT(//80('*')/17('*'),3X,'SUMMARY OF DAMPING CHOSEN:',3X, X '1=ON 0=OFF',3X,17('*')// 7 10x,'NTYP1 = ',I2,5X,'INNER-ELECTRON DAMPING'/ 8 10X,'NTYP2I = ',I2,5X,'OUTER-ELECTRON IN-BOX DAMPING'/ 9 10X,'NTYP2OF= ',I2,5X,'OUTER-ELECTRON NON-BOX DAMPING:' X ,' FREE-BOUND (RR)'/ A 10X,'NTYP2OR= ',I2,5X,'OUTER-ELECTRON NON-BOX DAMPING:' X ,' RYDBERG-RYDBERG'/ B 10X,'NMIN = ',I2,5X,'LOWEST N FOR NON-BOX DAMPING'// C 80('*')) 614 FORMAT(/' COMMENT: NTYP2O RADIATION IS BEING SWITCHED-OFF' X,' BECAUSE YOU SPECIFIED NMIN = ',I6) 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('+')//9X,'PSTGFDAMP UoS v2.7'/ + 9X,18('*')//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 & II 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,'RAD DECAY STATES TYPE-II MZDEC =',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 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) 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 SUBROUTINE BDORG C C ORGANIZE THE READING OF THE B AND D FILES C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MNPEXT=MZMNP+MZCHF) C COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB, 1 ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED, 2 ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP), 3 NFBD,NFB(3),NFD(3) 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/GAUGE/IGAUGE COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC C MSLP3=10000*NSPN2+100*LRGL2+NPTY2 C NFBD=0 DO 10 I=1,NFILEB LDIFF=ABS(ILB(I)-LRGL2) IF(NSPN2.EQ.0)LDIFF=LDIFF/2 IF(ISB(I).EQ.NSPN2.AND.LDIFF.LE.1.AND.IPB(I).NE.NPTY2)THEN IF(ILB(I).EQ.0.AND.LRGL2.EQ.0)GO TO 10 NFBD=NFBD+1 IF(NFBD.GT.3)STOP'***BDORG, INPUT ERROR' NFB(NFBD)=I MSLP1=10000*ISB(I)+100*ILB(I)+IPB(I) DO J=1,NFILED MSLP2=10000*ISDL(J)+100*ILDL(J)+IPDL(J) MSLP4=10000*ISDR(J)+100*ILDR(J)+IPDR(J) IF(MSLP1.EQ.MSLP2.AND.MSLP3.EQ.MSLP4) THEN NFD(NFBD)=J GO TO 10 ELSEIF(MSLP1.EQ.MSLP4.AND.MSLP3.EQ.MSLP2) THEN NFD(NFBD)=-J GO TO 10 ENDIF ENDDO WRITE(6,*)' **WARNING**, UNABLE TO FIND D-FILE TO MATCH B-FILE' WRITE(6,*)ISB(I),ILB(I),IPB(I),NSPN2,LRGL2,NPTY2 C STOP ENDIF 10 CONTINUE C IF(NFBD.EQ.0)THEN WRITE(6,*)' *** NO B-FILE FOUND FOR THIS STGF CASE' ELSE WRITE(6,*)' *** B-FILES FOUND FOR THIS STGF CASE' DO N=1,NFBD I=NFB(N) WRITE(6,*)ISB(I),ILB(I),IPB(I) ENDDO ENDIF C NDEC=0 IF(IGAUGE.EQ.0)LV=1 IF(IGAUGE.NE.0)LV=2 DO MF=1,NFBD CALL READB(NFB(MF)) C write(6,*)'NFBD',MF CALL READD(NFD(MF),LV) ENDDO C RETURN END C C*************************************************************** C CSUB SUBROUTINE BLOCK BLOCK DATA 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 CSUB 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 THFACT(I)=PI*FKNU(I)**3/TWO 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 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 ITARGN=0 DO I0=NCHPP1,NCHFF I=I0 IF(IOMSW.LT.0)I=ICHHYB(I0) IF(IOMIT(I).EQ.0)THEN ICHAN=I IF(INTPQ.EQ.0)THFACT(I)=ONE C C ARDEC=2*PI*GAMMA/Z**2, WHERE GAMMA IS IN ATOMIC UNITS C CONVERT TO Z-SCALED RYDBERG UNITS BY DIVIDING BY PI C MODIFY ECORE --> ECORE - I*GAMMA/2. C ABS(E) = ECORE - ETOT --> ABS(E) -I*GAMMA/2. C IF(IRDEC.GT.0.AND.INTPQ.EQ.0)THEN C C RADIATIVE DECAYS; RECALCULATE ARDEC (DEPENDS ON ETOT) IF NECESS. C IF(NEWAR.GT.0.AND.ITARG(I).NE.ITARGN)THEN ITARGN=ITARG(I) KVEC=((ITARG(I)-IONE)*(ITARG(I)-1-IONE))/2 ARDEC(ITARG(I))=TZERO DO JLOOP=1,ITARG(I)-1 KVEC=KVEC+1 IF(ETOT-(ENAT(ITARG(I))-ENAT(JLOOP)).LE.ENAT(1))THEN ARDEC(ITARG(I))=ARDEC(ITARG(I))+ARAD(KVEC) ENDIF ENDDO ARDEC(ITARG(I))=ARDEC(ITARG(I))*CONST IF(IPRINT.GT.2)THEN WRITE(6,612) ITARG(I),ARDEC(ITARG(I)) ENDIF ENDIF GAMMA=ARDEC(ITARG(I))/PI IF(IAUGER.GT.0)GAMMA=GAMMA+AAUGER(ITARG(I))*TWO ELSE GAMMA=TZERO ENDIF C IF(NTYP1.EQ.0)GAMMA=TZERO EEE=ONE/FKNU(I)**2 ZE=-EEE*ZONE+GAMMA*ZI/TWO ZFKNU(I)=ZONE/SQRT(-ZE) 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 IF(KP2T.LT.KP2)THEN DO K=KP2T,KP2 ZFS(K,I)=ZERO ZFC(K,I)=ZERO ENDDO ENDIF C IF(INTPQ.EQ.0)CALL ZTHETA(RTWOT,I,ZFS(KP2T,I),ZFSP(I) X ,ZFC(KP2T,I),ZFCP(I),ICONV,EEE,GAMMA) C ELSE KINF=0 IF(IPERT.NE.0)THEN KINF=(0.6*RINF(I)-RZERO)/H IF(KINF.GE.KP2)THEN RINF(I)=-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 C C AND NOW COMPLEX VERSION C XNUI=DIMAG(ZFKNU(I)) IF(XNUI .LT. 3.)THEN ZSINF=SIN(PI*ZFKNU(I)) ZCOSF=COS(PI*ZFKNU(I)) ZFS(KRA,I)=FCA*ZSINF-FSA*ZCOSF ZFSP(I)=FCPA*ZSINF-FSPA*ZCOSF ZFC(KRA,I)=ZSINF*FSA+ZCOSF*FCA ZFCP(I)=ZSINF*FSPA+ZCOSF*FCPA ELSE C C IMAGINARY PART OF PI*NU IS LARGE, SO REDEFINE SOLUTIONS C FACT=ONE/SQ2 ZFS(KRA,I)=FACT*(ZI*FCA-FSA) ZFSP(I)=FACT*(ZI*FCPA-FSPA) ZFC(KRA,I)=FACT*(FCA-ZI*FSA) ZFCP(I)=FACT*(FCPA-ZI*FSPA) ENDIF 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)THEN CALL NUMT(EPS(I),CCT(I),TKRA,H,KRA,KRB,I) IF(INTPQ.EQ.0)CALL ZNUMT(ZE,CCT(I),TKRA,H,KRA,KRB,I) ENDIF IF(KRA.GT.KRB)INOUT(I)=0 IF(KRA.LE.KRB)INOUT(I)=1 IF(KINF.GT.1)THEN CALL NUMT(EPS(I),CCT(I),TKRA,H,KINF,-1,I) IF(INTPQ.EQ.0)CALL ZNUMT(ZE,CCT(I),TKRA,H,KINF,-1,I) ENDIF 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 XNUI=DIMAG(ZFKNU(I)) IF(XNUI .LT. 3.)THEN ZSINF=SIN(PI*ZFKNU(I)) ZCOSF=COS(PI*ZFKNU(I)) ZFS(1,I)=FCA*ZSINF-FSA*ZCOSF ZFSP(I)=FCPA*ZSINF-FSPA*ZCOSF ELSE FACT=ONE/SQ2 ZFS(1,I)=FACT*(ZI*FCA-FSA) ZFSP(I)=FACT*(ZI*FCPA-FSPA) ENDIF 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/) 610 FORMAT('SR.COUL: INCREASE MZPTS TO ',I6) 612 FORMAT(I15,1PE20.4) 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 C*************************************************************** C 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 DIPOL(JSW,N1,N2,E2,LMAX,CP,CM,JC) IMPLICIT REAL*8 (A-H,O-Z) C C ALAN BURGESS DAMTP CAMBRIDGE C C CALCULATES SQUARES OF HYDROGENIC DIPOLE LENGTH RADIAL MATRIX ELEMENTS C FOR BOUND-BOUND OR BOUND-FREE TRANSITIONS. C C BOUND STATES ARE NORMALISED TO UNITY. C FREE STATES ARE NORMALISED TO ASYMPTOTIC AMPLITUDE K**(-0.5). C C N.B. DIPOLE ACCELERATION MATRIX ELEMENT = (E12**2/4Z) * DIPOLE LENGTH C WHERE E12 = - N1**(-2) + N2**(-2) FOR BOUND-BOUND C = - N1**(-2) + E2 FOR BOUND-FREE C Z = REDUCED CHARGE C INPUT C FOR BOUND-BOUND,SET JSW=NEGATIVE C N1,N2=PRINCIPAL QUANTUM NUMBERS OF STATES C LMAX=RANGE OF ANGULAR MOMENTUM QUANTUM NUMBERS C FOR BOUND-FREE, SET JSW=POSITIVE C N1=BOUND STATE PRINCIPAL QUANTUM NUMBER C E2=FREE STATE ENERGY IN RYDBERGS (=K**2) C C OUTPUT C VECTOR CP(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR C MOMENTUM TRANSITIONS FROM L-1 TO L, C VECTOR CM(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR C MOMENTUM TRANSITIONS FROM L TO L-1, C IN BOTH CASES THE TRANSITION IS FROM LOWER TO HIGHER C ENERGY, INDEPENDANT OF THE SIGN OF N1-N2 FOR BOUND-BOUND C CASES. IF N1=N2 THEN CP(L)=CM(L). C VECTOR JC(L),L=1,LMAX WILL USUALLY BE ZERO AND MAY THEN BE IGNORED, C BUT FOR EXTREME INPUT VALUES THERE IS POSSIBILITY OF C OVER OR UNDERFLOW OF CP(L) OR CM(L),IN WHICH CASE THE C OUTPUT VALUES OF CP(L) AND CM(L) SHOULD BE MULTIPLIED C BY (1.0D10)**JC(L) TO OBTAIN TRUE VALUES. C FOR DOUBLE-PRECISION OPERATION,CHANGES ARE REQUIRED AT LINES NUMBER C 38 40 41 42 43 44 45 46 47 48 49 50 51 124 126 137 140 156 157 160 DIMENSION CP(LMAX),CM(LMAX),JC(LMAX) ZERO=0.0E0 ONE=1.0E0 PI=3.14159265359E0 S1=1.0E10 S2=1.0E-10 TEST1=1.0E-20 TEST2=1.0E20 TEST3=0.044E0 TEST4=0.1E0 TEST5=300.0E0 TEST6=1.0E-30 TEST7=1.0E30 N=N1 E=E2 IF (JSW.GT.0) GO TO 4 EN2=N2 N3=N2 IF(N2-N1)2,59,3 2 N=N2 EN2=N1 N3=N1 3 E=-ONE/(EN2*EN2) 4 EN=N ENN=EN*EN E1=-ONE/ENN JMAX=LMAX IF(N-LMAX)5,7,8 5 L1=N+1 DO 6 L=L1,LMAX CP(L)=ZERO CM(L)=ZERO JC(L)=0 6 CONTINUE 7 CP(N)=ONE CM(N)=ZERO JC(N)=0 JMAX=N-1 8 C1=ONE C2=ZERO JS=0 L=N+1 9 L=L-1 IF (L.LE.1) GO TO 15 EL=L ELL=EL*EL T1=ONE+ELL*E1 T2=ONE+ELL*E T3=L+L-1 T4=ONE/(T3+ONE) T5=(T3*T1*C2+T2*C1)*T4 C1=(T1*C2+T3*T2*C1)*T4 C2=T5 11 IF (C1*C1.LE.TEST2) GO TO 13 C1=S2*C1 C2=S2*C2 JS=JS+1 GO TO 11 13 IF (L.GT.LMAX+1) GOTO 9 CP(L-1)=C1 CM(L-1)=C2 JC(L-1)=JS GO TO 9 15 CONTINUE JS=0 T=4 T=ONE/(T*EN*ENN) IF (JSW.GT.0) GO TO 23 ENN2=EN2*EN2 T1=4 T1=T1*ENN*ENN2/(ENN2-ENN) T1=T1*T1 T=T*T1*T1/(EN2*ENN2) IF (N3.GT.30) GO TO 18 T=T*((EN2-EN)/(EN2+EN))**(N3+N3) GO TO 34 18 E21=E/E1 IF (E21.GT.TEST4) GO TO 21 T2=ZERO DO 20 J=1,11 T3=2*(11-J)+1 T2=ONE/T3+T2*E21 20 CONTINUE T2=T2+T2 GO TO 22 21 T3=EN/EN2 T2=LOG((ONE+T3)/(ONE-T3))/T3 22 T2=T2+T2 T1=T1*EXP(-T2) GO TO 34 23 T1=4 T1=T1*ENN/(ONE+ENN*E) T1=T1*T1 T=T*T1*T1 IF (E.GE.TEST3) GO TO 25 T3=2 T=T*(PI/T3) GO TO 29 25 CONTINUE T4=SQRT(E) IF (T4.GT.TEST5) GO TO 27 T3=(PI+PI)/T4 T3=ONE-EXP(-T3) T3=ONE/T3 GO TO 28 27 T4=PI/T4 T3=3 T3=(ONE+T4+T4*T4/T3)/(T4+T4) 28 T2=2 T=T*(PI*T3/T2) 29 T4=ENN*E IF (T4.GT.TEST4) GO TO 32 T2=ZERO DO 31 J=1,11 T3=2*(11-J)+1 T2=ONE/T3-T2*T4 31 CONTINUE GO TO 33 32 T3=SQRT(T4) T2=ATAN(T3)/T3 33 T2=T2+T2 T2=T2+T2 T1=T1*EXP(-T2) 34 DO 39 J=1,N TJ=J+J T2=TJ*(TJ-ONE) T2=T2*T2 T=T*T1/T2 35 IF (T.GT.TEST1) GO TO 37 T=T*S1 JS=JS-1 GO TO 35 37 IF (T.LT.TEST2) GO TO 39 T=T*S2 JS=JS+1 GO TO 37 39 CONTINUE J=0 40 J=J+1 IF (J.GT.JMAX) GO TO 50 TJ=J TJ=TJ*TJ T1=ONE+TJ*E1 T2=ONE+TJ*E T3=CP(J) T3=T2*T*T3*T3 T4=CM(J) T4=T1*T*T4*T4 L1=JC(J)+JC(J)+JS 42 IF(L1)43,47,45 43 IF (T4.LE.TEST6) GO TO 47 L1=L1+1 T3=T3*S2 T4=T4*S2 GO TO 42 45 IF (T3.GE.TEST7) GO TO 47 L1=L1-1 T3=T3*S1 T4=T4*S1 GO TO 42 47 CP(J)=T3 CM(J)=T4 JC(J)=L1 T=T*T1*T2 48 IF (T.LE.TEST2) GO TO 40 T=T*S2 JS=JS+1 GO TO 48 50 IF (N.GT.LMAX) GO TO 58 T2=ONE+ENN*E T3=CP(N) T3=T2*T*T3*T3 L1=JC(N)+JC(N)+JS 52 IF(L1)53,57,55 53 IF (T3.LE.TEST6) GO TO 57 L1=L1+1 T3=T3*S2 GO TO 52 55 IF (T3.GE.TEST7) GO TO 57 L1=L1-1 T3=T3*S1 GO TO 52 57 CP(N)=T3 JC(N)=L1 58 RETURN 59 JMAX=LMAX IF (N.GT.LMAX) GO TO 62 DO 61 L=N,LMAX CP(L)=ZERO CM(L)=ZERO JC(L)=0 61 CONTINUE JMAX=N-1 62 T1=9 T2=4 T3=(T1/T2) T1=EN2*EN2 T2=T1*T3 DO 63 J=1,JMAX TJ=J JC(J)=0 T=T2*(T1-TJ*TJ) CP(J)=T CM(J)=T 63 CONTINUE RETURN END C*************************************************************** 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/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(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') ICASE=1 ENDIF C DO J=1,NCHOP DO I=1,NCHOP RK2(I,J)=DBLE(ZK(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 REAL*8 FUNCTION FWIDTH(NZA,NMIN,NMAX,ECH,LL) IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (NVINT=50, ICMX=22) PARAMETER (ZERO=0.0, ONE=1.0, TWO=2.0, FOUR=4.0, TWELV=12.0) LOGICAL BJUMP DIMENSION NS(22),TCN(100) COMMON /DIP/ CP(100),CM(100),JDUM(100) C C EVALUATE FREE-BOUND (RR) ************* OF CONTINUUM ELECTRON, C ECH=Z-SCALED CONTINUUM ENERGY (RY) C LL=CONTINUUM ORBITAL ANGULAR MOMENTUM C NMIN=LOWEST N-VALUE ACCESSIBLE C NMAX= HIGHEST N-VALUE INCLUDED C NZA=ION CHARGE. C DATA NS/21,25,30,36,42,50,60,72,85,100,115,135,160,200 X ,250,300,375,450,550,675,825,1000/ C FWIDTH=ZERO COLD IF(NMIN.GT.NZA)RETURN NR1=MAX0(NMIN,LL) IF(NR1.GT.NMAX)RETURN IF(NR1.GT.NS(1))THEN IF(NR1.GT.100)RETURN WRITE(6,*)' **FWIDTH** NMIN=',NMIN,' > NSTART =',NS(1) STOP ENDIF LP=LL+1 IF(LP.GT.100)THEN WRITE(6,*)' **FWIDTH** L =',LP,' > LDIM = 100' STOP ENDIF DZ=NZA*NZA N=NR1 TC=ZERO IC=1 BJUMP=.FALSE. C 10 TN=N*N DE=ONE/TN+ECH CALL DIPOL(1,N,0,ECH,LP,CP,CM,JDUM) TL=LL+LL TLP=LP+LP FSUM=TLP*CM(LP)*1.0D10**JDUM(LP) IF(LL.GT.0)FSUM=FSUM+TL*CP(LL)*1.0D10**JDUM(LL) FSUM=1.13953D-5*FSUM*DE**3*DZ ! pi*a0**2*alpha**3/3 Mb IF(.NOT.BJUMP)THEN TC=TC+FSUM IF(N.EQ.NMAX)GO TO 70 ENDIF TCN(IC)=FSUM N=N+1 IF(N.LE.NS(1))GO TO 10 IF(IC.EQ.ICMX)GO TO 12 BJUMP=.TRUE. IC=IC+1 N=NS(IC) GO TO 10 C C C SUM HIGH N USING INTERPOLATION AND THEN SIMPSONS RULE C 12 DO 15 I=3,ICMX,2 I0=I T1=NS(I-2) T2=NS(I-1) T3=NS(I) V1=T1**3 V2=T2**3 V3=T3**3 20 N1=NS(I0-2) N2=NS(I0-1) TN1=N1*N1 N1=N1+1 DO 30 N=N1,N2 TN=N S1=V1*(T2-TN)*(T3-TN)/((T2-T1)*(T3-T1)) S2=V2*(T1-TN)*(T3-TN)/((T1-T2)*(T3-T2)) S3=V3*(T1-TN)*(T2-TN)/((T1-T3)*(T2-T3)) TN2=N*N TT=S1*TCN(I-2)+S2*TCN(I-1)+S3*TCN(I) TT=TT/(TN*TN2) TC=TC+TT IF(N.EQ.NMAX)GO TO 70 30 CONTINUE I0=I0+1 IF((I0-1).EQ.I)GO TO 20 IC0=I IF((I+1).LT.ICMX.AND.N2.GT.NVINT)GO TO 40 15 CONTINUE GO TO 70 C 40 TC=TC-TCN(IC0)/TWO IC0=IC0+2 C C SIMPSONS RULE C DO 50 I=IC0,ICMX,2 IF(NS(I-1).GT.NMAX)GO TO 70 T1=NS(I-2)*NS(I-2) T3=NS(I)*NS(I) H=(T3-T1)/(T1*T3) H=H/TWELV T=NS(I-2) T1=T1*T T2=NS(I-1)**3 T=NS(I) T3=T3*T TT=ZERO T=T1*TCN(I-2)+FOUR*T2*TCN(I-1)+T3*TCN(I) IF(I.EQ.ICMX)TT=TCN(ICMX)/TWO T=T*H+TT TC=TC+T 50 CONTINUE C CTOM 70 FWIDTH=TC/(ECH*DZ) ! Mb THIS IS ACTUAL FWIDTH, DIVERGES AT E=0 70 FWIDTH=TC ! Mb*E C CONVERT FROM CROSS SECTION IN MB*E(RYD) TO IN Z-SCALED UNITS IF(ECH.GT.0)THEN FWD=FWIDTH/(ECH*DZ) ELSE FWD=FWIDTH*1.E+20 ENDIF c WRITE(28,*)' FWIDTH(MB) = ',FWD PIA0SQ=87.97115 FWIDTH=FWIDTH/PIA0SQ 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 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 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=MZCHF*MZCHF) C 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/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF) 1 ,ZFCP(MZCHF),ZFKNU(MZCHF) COMMON/AUGER/AAUGER(MZTAR),IAUGER 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 xeps=.55 PI=ACOS(-ONE) TPI=TWO*PI CONST=TPI IF(TZED.GT.TZERO)CONST=TPI/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 IF(TZED.EQ.TZERO)THEN !BETTER NOT TO ENTER IN FIRST PLACE ZFDEC=EXP(BIG) ELSE TPINU=FKNU(NNN)*TPI IF(IOMIT(NNN).LT.0)TPINU=-TPINU IF(IRDEC.EQ.0.OR.FKNU(NNN).GT.NCUTOFF x .or. llch(nnn).gt.0.and.fknu(nnn).lt.llch(nnn)+xeps X .OR.(NTYP1.EQ.0.AND.IAUGER.LE.0))THEN C NONE ZFKNU(NNN)=FKNU(NNN) ZFDEC=EXP(DCMPLX(TZERO,-TPINU)) ELSEIF(IRDEC.EQ.1)THEN C BELL & SEATON TR=ONE/FKNU(NNN)**2 TI=TZERO IF(NTYP1.GT.0)TI=-ARDEC(ITARG(NNN))/TPI IF(IAUGER.GT.0)TI=TI-AAUGER(ITARG(NNN)) !A.U. HERE ZFKNU(NNN)=DCMPLX(ONE,TZERO)/SQRT(DCMPLX(TR,TI)) T=-TPI*TI*(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=TZERO IF(NTYP1.GT.0)TI=-ARDEC(ITARG(NNN))/TPI IF(IAUGER.GT.0)TI=TI-AAUGER(ITARG(NNN)) !A.U. HERE ZFKNU(NNN)=DCMPLX(ONE,TZERO)/SQRT(DCMPLX(TR,TI)) C IF(IQDT.EQ.2)THEN CK Z=DCMPLX(PI,TZERO) CK ZFDEC=-TAN(Z*ZFKNU(NNN)) C ELSE Z=DCMPLX(TZERO,-TPI)*ZFKNU(NNN) 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 ENDIF C 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 'ERROR IN BLAS ROUTINE ZSYTRF' ENDIF CALL ZSYTRS('L',NCC,NCHOP,ZKHICC,MZDEG,IPIV,ZKHICO,MZDEG,INFO) IF (INFO.NE.0) THEN WRITE(6,603) INFO STOP 'ERROR IN BLAS ROUTINE ZSYTRS' 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 600 FORMAT(' SR.MQDTS: ZLUS RETURNED WITH INFO =',I6) 601 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 (ZONE=(1.0,0.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 CSTGF 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) COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF) COMMON/NRBZED/TZED,LPRTSW C C C CALCULATE PERTURBED FUNCTIONS (NCHOP=NCHF WHEN IQDT.GT.0) C C OPEN-OPEN C 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) CSTGF CSPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J) CSTGF CCPP(I,J)=SPP(I)*ACC(I,J)-CPP(I)*ASC(I,J) CSTGF DS(I,J)=CS(I,J) CSTGF DC(I,J)=CC(I,J) CSTGF DSP(I,J)=CSP(I,J) CSTGF 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) CSTGF CSPP(I,I)=CSPP(I,I)+SPP(I) CSTGF CCPP(I,I)=CCPP(I,I)+CPP(I) ENDDO C C ENERGY SCALE CASE NEUTRAL MQDT C IF(TZED.EQ.TZERO.AND.IQDT.GT.0)THEN DO J=1,NCHOP DO I=1,NCHOP CS(I,J)=CS(I,J)/FSCL(J) CSP(I,J)=CSP(I,J)/FSCL(J) CC(I,J)=CC(I,J)*FSCL(J) CCP(I,J)=CCP(I,J)*FSCL(J) ENDDO ENDDO ENDIF C IF(NCHOP.EQ.NCHF)GOTO 270 !IQDT=1,2 C C CLOSED-OPEN C 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 C OPEN-CLOSED C 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 C CLOSED-CLOSED C 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 CSTGF IF(NCHHYB.GT.0)THEN !SEE ZPETFSC CSTGF DO N=1,NCHHYB CSTGF I=ICHHYB(N) CSTGF CC(I,I)=S(I) !SINCE ALPHA=0 CSTGF CCP(I,I)=SP(I) CSTGF CS(I,I)=TZERO CSTGF CSP(I,I)=TZERO CSTGF ENDDO CSTGF ENDIF C C CALCULATE MATRICES A AND B C DO J=1,NCHF DO I=1,NCHF ZA(I,J)=CC(I,J) ENDDO CSTRTNBL CNBL DO K=1,NCHF CNBL DO I=1,NCHF CNBL ZA(I,J)=ZA(I,J)-ZR(I,K)*CCP(K,J) CNBL ENDDO CNBL ENDDO CENDNBL ENDDO DO J=1,NCHOP DO I=1,NCHF ZB(I,J)=CS(I,J) ENDDO CSTRTNBL CNBL DO K=1,NCHF CNBL DO I=1,NCHF CNBL ZB(I,J)=ZB(I,J)-ZR(I,K)*CSP(K,J) CNBL ENDDO CNBL ENDDO CENDNBL ENDDO CSTRTBL DO J=1,NCHF DO I=1,NCHF ZK(I,J)=CCP(I,J) ENDDO ENDDO C CALL ZGEMM('N','N',NCHF,NCHF,NCHF,-ZONE,ZR,MZCHF,ZK,MZCHF, X ZONE,ZA,MZCHF) C DO J=1,NCHOP DO I=1,NCHF ZK(I,J)=CSP(I,J) ENDDO ENDDO C CALL ZGEMM('N','N',NCHF,NCHOP,NCHF,-ZONE,ZR,MZCHF,ZK,MZCHF, X ZONE,ZB,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=MZCHF*MZCHF) 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 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=MZCHF*MZCHF) 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) DIMENSION IPIV(MZDEC) 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) CENDBL 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 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.PETTMX' 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=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 CN100 FORMAT(' THE MATRIX: 1 + K^2 HAS NO INVERSE IN SUBROUTINE ' CN 1 ,'PETTMX - MUST STOP') 602 FORMAT(//10X,10('*'),' SR.PETTMX: DSYTRF RETURNED WITH INFO =',I2) 603 FORMAT(//10X,10('*'),' SR.PETTMX: DSYTRI RETURNED WITH INFO =',I2) 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-Y) IMPLICIT COMPLEX*16 (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/NRBOMT/FNUMIN,ICHAN,IOMIT(MZCHF),IOMSW,IFLAG,IFLEG,ICCINT COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF) COMMON/NRBZED/TZED,LPRTSW C C DIMENSION TEMPH(MZCHF) C 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 CHANNEL ENERGIES EPS AND NUMBER OF OPEN CHANNELS NCHOP C NCHOP=0 NCHCL=0 NCHHYB=0 DO I=1,NCHF 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) FSCL(I)=SQRT(FKNU(I))*FKNU(I)**LLCH(I) ZFSCL(I)=ONE ELSE FKNU(I)=SQRT(-E) FSCL(I)=SQRT(FKNU(I))*FKNU(I)**LLCH(I) FKNU(I)=ONE/SQRT(-E) ZFSCL(I)=ONE 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)THEN RINF(I)=1.D-4 !KEEP NON-ZERO, ELSE PERT DROPPED R2ST(I)=RZERO-1.D-4 !OMIT CLOSED-CLOSED PERT 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 C WM=TZERO DO 170 I=1,NCHF 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) c h=h/2. IF(RTWO.LE.RZERO)THEN KP2=1 COLD H=TZERO RTWOO=RTWO RTWOC=RTWO KP2C=1 RETURN ENDIF C C FIND TABULAR POINTS BETWEEN RZERO AND RTWO C 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=NCHF,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 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 C PARAMETER (ONE=1.0) PARAMETER (TZERO=0.0) PARAMETER (TWO=2.0) PARAMETER (FOUR=4.0) PARAMETER (QUART=0.25) PARAMETER (ZERO=(0.0,0.0)) PARAMETER (ZI=(0.0,1.0)) 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/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF) 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/NRBGAM/ZGAM(MZCHF),GAM(MZCHF) COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF) COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF) 1 ,ZCCP(MZCHF,MZCHF) COMMON/THETAF/THFACT(MZCHF) COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN COMMON/WIDSV/FWIDSV1(MZCHF),FWIDSV2(MZCHF),EWIDSV1(MZCHF), 1 EWIDSV2(MZCHF),RWIDSV(MZCHF),NWIDSV(MZCHF) COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF) 1 ,ZFCP(MZCHF),ZFKNU(MZCHF) 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 NZA=MAX(NZED-NELC,1) 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*8 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 GAM(I)=TZERO ZGAM(I)=ZERO 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 ZS(I)=ZERO ZSP(I)=ZERO ZC(I)=ZERO ZCP(I)=ZERO DO J=1,NCHF ZR(I,J)=ZERO ENDDO ENDIF ENDDO C DO I=NCHOP1,NCHF !NCHOP1=NCHF+1 WHEN IQDT=1,2 IF(IOMIT(I).LE.0)THEN ZS(I)=ZFS(1,I) ZSP(I)=ZFSP(I)-BSTO*ZS(I) ZC(I)=ZFC(1,I) ZCP(I)=ZFCP(I)-BSTO*ZC(I) ELSE ZS(I)=ZERO ZSP(I)=ZERO ZC(I)=ZERO ZCP(I)=ZERO ENDIF ENDDO C IF(NCHHYB.GT.0)THEN DO N=1,NCHHYB I=ICHHYB(N) ZS(I)=ZFS(1,I) ZSP(I)=ZFSP(I)-BSTO*ZS(I) ZC(I)=ZFC(1,I) ZCP(I)=ZFCP(I)-BSTO*ZC(I) ENDDO ENDIF C C EVALUATE NTYP2O CONTRIBUTIONS AND LOAD INTO ZGAM NOW C IF IQDT.EQ.0 OR STORE IN GAM AND LOAD LATER IF IQDT.GT.0 C C FOR NTYP2OF, NOW INTERPOLATE, RATHER THAN PERIODIC SCALED EXTRAPOLATION C WHICH CAN LEAD TO SMALL SAWTOOTH FEATURES. C IF(NTYP2OF.GT.0)THEN C GET SIGMA(RR)*E/PIAOSQ IN RYDBERGS, CONVERT TO if(iqdt.gt.0)then !decouple from iqdt.le.0 DO I=1,NCHOPO IF(ITARG(I).EQ.1)THEN !NMAX(I) should really only be determined once NMAX=1000 ELSE NMAX=INT(SQRT(ONE/(ENAT(ITARG(I))-ENAT(1)))) ENDIF NMAX=MIN(NMAX,NCUTOFF) GAM(I)=FWIDTH(NZA,NMIN,NMAX,EPS(I),LLCH(I)) X /(FOUR*L2P(I)+TWO) ENDDO else !now modify original case DO I=1,NCHOPO ETEST=ABS((EPS(I)-EWIDSV1(I))/EWIDSV1(I)) IF(ETEST.GT.0.2)THEN !.OR.IQDT.GT.0 IF(ITARG(I).EQ.1)THEN !NMAX(I) should really only be determined once NMAX=1000 ELSE NMAX=INT(SQRT(ONE/(ENAT(ITARG(I))-ENAT(1)))) ENDIF NMAX=MIN(NMAX,NCUTOFF) If(EWIDSV1(I).GT.0)then EWIDSV1(I) = EWIDSV2(I) FWIDSV1(I) = FWIDSV2(I) else FWIDSV1(I)=FWIDTH(NZA,NMIN,NMAX,EPS(I),LLCH(I)) X /(FOUR*L2P(I)+TWO) IF(EPS(I).GT.1.0E-8)EWIDSV1(I)=EPS(I) endif EWIDSV2(I)=1.2*EPS(i) FWIDSV2(I)=FWIDTH(NZA,NMIN,NMAX,EWIDSV2(I),LLCH(I)) X /(FOUR*L2P(I)+TWO) c ELSE ENDIF !<--- since EPS may not equal ewidsv1 c GAM(I)=EWIDSV(I)*FWIDSV(I)/EPS(I) GAM(I)=FWIDSV1(I)+( FWIDSV2(I)-FWIDSV1(I) )* X (EPS(I)-EWIDSV1(I))/( EWIDSV2(I) - EWIDSV1(I)) IF(IQDT.EQ.0)ZGAM(I)=ZI*GAM(I)/TWO ENDDO endif ENDIF C C FOR NTYP2OR SCALE AS 1/N^3. C IF(NTYP2OR.GT.0)THEN DO I=NCHOPO+1,NCHF XTEST=ABS((FKNU(I)-NWIDSV(I))/NWIDSV(I)) IF(XTEST.GT.0.2.OR.IQDT.GT.0)THEN NWID=NINT(FKNU(I)) IF(NWID.GT.0)THEN NMAX=INT(SQRT(ONE/(ENAT(ITARG(I))-ENAT(1)))) GAM(I)=RWIDTH(NZA,NMIN,NMAX,NWID,LLCH(I)) RWIDSV(I)=GAM(I) NWIDSV(I)=NWID GAM(I)=GAM(I)*NWID**3/(NZA**2*FKNU(I)**3) ENDIF ELSE GAM(I)=RWIDSV(I)*(NWIDSV(I)**3)/(NZA**2*FKNU(I)**3) ENDIF C C THFACT(I)=1.0 IF SR.THETA IS USED C = PI*NU**3/2 IF SR.SC IS USED C GAM(I)=GAM(I)*THFACT(I) IF(IQDT.EQ.0)ZGAM(I)=ZI*GAM(I)/TWO ENDDO IF(NCHHYB.GT.0)THEN DO N=1,NCHHYB I=ICHHYB(N) ZGAM(I)=ZI*GAM(I)/TWO ENDDO ENDIF ENDIF 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 IF(IQDT.NE.0.AND.IOMSW.GE.0)CALL PETFSC IF(IQDT.EQ.0.OR.IOMSW.LT.0)CALL ZPETFSC C ELSE C C..CASE OF IPERT.LE.0 C C ENERGY SCALE CASE NEUTRAL MQDT C IF(TZED.EQ.TZERO.AND.IQDT.GT.0)THEN DO J=1,NCHF S(J)=S(J)/FSCL(J) SP(J)=SP(J)/FSCL(J) C(J)=C(J)*FSCL(J) CP(J)=CP(J)*FSCL(J) ENDDO ENDIF C C CALCULATE MATRICES A AND B DO J=1,NCHOP DO I=1,NCHF ZA(I,J)=-ZR(I,J)*CP(J) ZB(I,J)=-ZR(I,J)*(SP(J)-ZGAM(J)*CP(J)) ENDDO ENDDO DO I=1,NCHOP ZA(I,I)=ZA(I,I)+C(I) ZB(I,I)=ZB(I,I)+S(I)-ZGAM(I)*C(I) ENDDO C NON-MQDT DO J=NCHOP1,NCHF DO I=1,NCHF ZA(I,J)=-ZR(I,J)*(ZSP(J)+ZGAM(J)*ZCP(J)) ENDDO ZA(J,J)=ZA(J,J)+ZS(J)+ZGAM(J)*ZC(J) ENDDO IF(NCHHYB.GT.0)THEN DO N=1,NCHHYB J=ICHHYB(N) DO I=1,NCHF ZA(I,J)=-ZR(I,J)*(ZSP(J)+ZGAM(J)*ZCP(J)) ZB(I,J)=ZERO ENDDO ZA(J,J)=ZA(J,J)+ZS(J)+ZGAM(J)*ZC(J) ENDDO ENDIF C ENDIF C..... C C NOW LOAD ZGAM (CASE IQDT.GT.0) C IF(IQDT.GT.0)THEN DO I=1,NCHF ZGAM(I)=ZI*GAM(I)/TWO ENDDO IF(NCHHYB.GT.0)THEN DO N=1,NCHHYB I=ICHHYB(N) ZGAM(I)=ZERO ENDDO ENDIF ENDIF C C COMPLETE CALCULATION OF (REACTANCE) K-MATRIX C CALL ZAINVB C C PERTURB DIAGONAL OF UNPHYSICAL K-MATRIX BY NTYP2O RADIATION C IF(IQDT.GT.0)THEN DO I=1,NCHF ZK(I,I)=ZK(I,I)+ZGAM(I) ENDDO ENDIF C C TRANSFER REAL PART OF COMPLEX (REACTANCE) K-MATRIX C DO J=1,NCHF DO I=1,NCHF RK(I,J)=DBLE(ZK(I,J)) ENDDO ENDDO 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 (NOT USED BY STGFDAMP). C IF(IRAD.GT.0.AND.IOPT1.LT.10) THEN C CSTGF 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 ZK(I,J)=ZK(I,J)+Y(I,J) ENDDO ENDDO ENDIF C C OPTIONALLY GO VIA K-UNPHYS->K-PHYS C (FIRST PUT ZK 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)=DBLE(ZK(I,J)) Q(I,J)=DIMAG(ZK(I,J)) 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)((ZK(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 ZKMTLS.DAT FOR NSPN2 = ', 1 I3,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 ZMQDTK C ELSE DO J=1,NCHF DO I=1,NCHF ZK(I,J)=DCMPLX(P(I,J),Q(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 ZPQ C C NOW, PERTURB (IN EFFECT) T-MATRIX, ALTHOUGH I CAN'T SEE WHY-NRB. C IF(IPERT.EQ.-1)CALL PETTMX C C WRITE K-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,(DBLE(ZK(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,(DBLE(ZK(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)DBLE(ZK(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) AND MQDTS 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(IQDT.NE.0.AND.TZED.EQ.TZERO)NCHOP=NCHOPO !AS S_PHYS=S_UNPHYS 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, PDR. 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 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 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 WRITE(6,651)PDR(I) 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 CSTGF .AND.NCHOP.LT.NCHF IF(NDRMET.GT.0 )THEN CSTGF 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 CSTGF 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 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) 651 FORMAT(47X,'OMEGA-DR = ',1PE14.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 READB(MF) C C READS BOUND DATA C NOTE: B-DATA IS NOT PERTURBED. C IPERTB IS JUST USED TO SKIP THE CORRECT NUMBER OF RECORDS. C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MNPEXT=MZMNP+MZCHF) C PARAMETER (TZERO=0.0) C COMMON/A1/AVECT1(MNPEXT,MZEST),MXE1 COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB, 1 ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED, 2 ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP), 3 NFBD,NFB(3),NFD(3) 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/CNTRLB/IPERTB COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC C CHARACTER FILE*3,NUM(0:9) DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ C FILE='B'//NUM(MF/10)//NUM(MF-10*(MF/10)) OPEN(2,FILE=FILE,STATUS='OLD',FORM='UNFORMATTED',ERR=90) REWIND(2) C C READ E1-INDEPENDENT DATA C READ(2)IS,IL,IP C *******CHECK SLPI IF(IS.NE.ISB(MF).OR.IL.NE.ILB(MF).OR.IP.NE.IPB(MF))THEN WRITE(6,*)' ***ERROR** IS,IL,IP .NE. ISB,ILB,IPB' WRITE(6,*)IS,IL,IP,ISB(MF),ILB(MF),IPB(MF) STOP ENDIF C READ(2)MNP2B IF(MNP2B.GT.MZMNP) THEN WRITE(6,613)MNP2B STOP ENDIF READ(2) READ(2) IF(IPERTB.EQ.1)READ(2) READ(2)MXE1 C IF(MXE1.GT.MZEST)THEN WRITE(6,612)MXE1 STOP ENDIF C NDEC=NDEC+MXE1 IF(NDEC.GT.MZDEC)THEN WRITE(6,614)NDEC STOP ENDIF N0=NDEC-MXE1+1 NREC=5 IF(IPERTB.EQ.1)NREC=NREC+3 C C READ E1-DEPENDENT DATA C IE=0 DO ND=N0,NDEC IE=IE+1 READ(2) EDEC(ND) READ(2) (AVECT1(K1,IE),K1=1,MNP2B) DO NR=1,NREC READ(2) ENDDO ENDDO C CLOSE(2) RETURN C 90 WRITE(6,696) FILE STOP C 612 FORMAT(//' NO OF BOUND STATE ENERGIES MXE1 = ',I4 X,' WHICH IS LARGER THAN ', 1 'MAXIMUM VALUE OF MZEST ALLOWED BY DIMENSIONS'//) 613 FORMAT(//' READS MNP2B = ',I4,' WHICH IS LARGER THAN ', 1 'MAXIMUM VALUE OF MZMNP ALLOWED BY DIMENSIONS'//) 614 FORMAT(//' NO OF DECAYS NDEC = ',I4,' WHICH IS LARGER THAN ', 1 'MAXIMUM VALUE OF MZDEC ALLOWED BY DIMENSIONS'//) 696 FORMAT(/' *** CANNOT OPEN FILE ',A/) C END C********************************************************************** C SUBROUTINE READB0 C C READ DIRECTORY FILES ON B DATASETS C IMPLICIT REAL*8 (A-H,O-Z) C LOGICAL FEXIST C INCLUDE 'PARAM' C COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB, 1 ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED, 2 ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP), 3 NFBD,NFB(3),NFD(3) 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 COMMON/CNTRLB/IPERTB COMMON/CPOINT/RZERO,RONE,RTWO,H,KP0,KP1,KP2 COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN C C INITIAL BOUND STATE DATA C INQUIRE(FILE='B00',EXIST=FEXIST) IF(FEXIST)THEN OPEN(2,FILE='B00',STATUS='OLD',FORM='UNFORMATTED') ELSE WRITE(6,505) STOP 'STGB DATASET B00 NOT FOUND' ENDIF C REWIND(2) C READ(2)NZEDB,NELCB READ(2) READ(2)RZEROB READ(2) READ(2)IPERTB C IF(NZEDB.NE.NZED.OR.NELCB.NE.NELC)THEN WRITE(6,504)NZEDB,NELCB,NZED,NELC STOP 'STGB - STGF MIS-MATCH' ENDIF IF(ABS(RZERO-RZEROB).GT.1.E-4)THEN WRITE(6,503)RZEROB,RZERO STOP 'STGB - STGF MIS-MATCH' ENDIF IF(IPRINT.GT.0)WRITE(6,501) KSLP1=0 C C AND LIST OF SLPI CASES C 5 READ(2,END=77)IS,IL,IP IF(IL.NE.-1) THEN KSLP1=KSLP1+1 NFILEB=KSLP1 ISB(NFILEB)=IS ILB(NFILEB)=IL IPB(NFILEB)=IP IF(IPRINT.GT.0)WRITE(6,502)KSLP1,IS,IL,IP GOTO 5 ELSE IF(NMIN.NE.0)THEN READ(2,END=77)NMAX IF(NMIN.LT.0)THEN NMIN=NMAX+1 ELSEIF(NMIN.NE.NMAX+1)THEN WRITE(6,507)NMIN,NMAX ENDIF ENDIF ENDIF 77 IF(NMIN.LT.0)THEN WRITE(6,506) STOP'*** UNABLE TO DETERMINE NMIN FROM B00 FOR NTYP2O RADIATION' ENDIF C CLOSE(2) C RETURN C 501 FORMAT(//10X,'FROM STGB DATASET'/10X,'KSLP',3X,'IS',3X,'IL',3X, 1 'IP') 502 FORMAT(10X,I3,4X,I2,3X,I2,3X,I2) 503 FORMAT(//' STGB - STGF MIS-MATCH: RZERO=',2F8.4) 504 FORMAT(//' STGB - STGF MIS-MATCH: NZED, NELC=',4I3) 505 FORMAT(/'*** ERROR: UNABLE TO FIND DIRECTORY FILE B00 ***'// X' EITHER GENERATE SUITABLE BOUND FILES *OR* SET: NTYP2I=0'/ X' WHICH SWITCHES-OFF TYPE-2 (OUTER ELECTRON) RADIATION INTO', X' THE BOX.') 506 FORMAT(/'*** ERROR: UNABLE TO DETERMINE NMIN FROM B00 FOR', X' NTYP2O RADIATION - TRY UPDATING STGB TO UoS 2.17 OR LATER.'/ X' IN THE MEAN TIME, EITHER SET NMIN EXPLICITLY OR TURN OFF', X' TYPE-2 (OUTER ELECTRON) RADIATION TO NON-BOX STATES'/ X' VIA: NTYP2OR=0 NTYP2OF=0') 507 FORMAT(/'*** WARNING: YOUR INPUT VALUE OF NMIN (=',I4,') DOES', X' NOT APPEAR TO BE CONSISTENT WITH NMAX FROM STGB (=',I4,')'/) C END C********************************************************************** C SUBROUTINE READD(LPOS,LV) C C ADAPTED FROM C PROGRAM OF KTT FOR READING DIPOLE MATRIX ELEMENT DATA C AND KB/WE FOR REDUCED MEMORY - ERRORS CORRECTED BY NRB 10/03/99. C IMPLICIT REAL*8(A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MNPEXT=MZMNP+MZCHF) PARAMETER (MXLV=2) C PARAMETER (TZERO=0.0) C COMMON/A1/AVECT1(MNPEXT,MZEST),MXE1 COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC C DIMENSION D(MNPEXT,MZNRG,MXLV) !USE MZNRG - NRB C CHARACTER DKK*3,NUM(0:9) DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ C C************ STGFDAMP/STGBF0DAMP ******************** IBUT=0 C***************************************** C IF(LV.GT.MXLV)THEN WRITE(6,*)' ****INCREASE PARAMETER MXLV TO:',LV STOP ENDIF C MLAST=NDEC M11=MLAST-MXE1+1 C DO M1=M11,MLAST DO K2=1,MNPEXT DDEC(K2,M1)=TZERO ENDDO ENDDO C LTAPE=3 K1 = ABS(LPOS) DKK='D'//NUM(K1/10)//NUM(K1-10*(K1/10)) C write(6,*)'about to open ',DKK OPEN(LTAPE,FILE=DKK,STATUS='OLD',FORM='UNFORMATTED',ERR=99) REWIND LTAPE C READ(LTAPE) NOTERM,MNP2D2,NCHND2,LRGLD2,NPTYD2, & NSPND ,MNP2D1,NCHND1,LRGLD1 C C CHECK DIMENSIONS FOR MNP2,MZCHF N=MAX(NCHND1,NCHND2) M=MAX(MNP2D1,MNP2D2) IF(M.GT.MZMNP.OR.N.GT.MZCHF) THEN WRITE(6,600)MNP2D1,NCHND1,MNP2D2,NCHND2 STOP ENDIF C C CHECK DIMENSION FOR "NR2". C STGFDAMP DOES NOT USE BUTTLE CORRECTION AND SO COULD JUST USE MZNR2 C BUT WILL USE THE RELATED OUTER REGION PARAMETER MZNRG INSTEAD. NRB IF(NOTERM.GT.MZNRG)THEN WRITE(6,601)NOTERM STOP ENDIF C C READ DIPOLE MATRIX - TRANSPOSING IF -VE LPOS C IAIN1 = (MNP2D1 - 1) / NOTERM IBIN1 = (MNP2D2 - 1) / NOTERM MCI = 0 DO IK = 1 , IAIN1 MCH = MCI + 1 MCI = MCI + NOTERM NCI = 0 DO JK = 1 , IBIN1 NCH = NCI + 1 NCI = NCI + NOTERM READ(LTAPE) (((D(J,I,L),J=1,NOTERM),I=1,NOTERM),L=1,LV) IF(LPOS.GT.0) THEN M1P=0 DO M1=M11,MLAST M1P=M1P+1 K1P = 0 DO K1=MCH,MCI K1P=K1P+1 K2P = 0 DO K2=NCH,NCI K2P=K2P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV) ENDDO ENDDO ENDDO ELSE M1P=0 DO M1=M11,MLAST M1P=M1P+1 K2P = 0 DO K2=MCH,MCI K2P=K2P+1 K1P = 0 DO K1=NCH,NCI K1P=K1P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV) ENDDO ENDDO ENDDO ENDIF ENDDO NCH = NCI + 1 NCI = MNP2D2 NCP=NCI-NCH+1 READ(LTAPE) (((D(J,I,L),J=1,NCP),I=1,NOTERM),L=1,LV) IF(LPOS.GT.0) THEN M1P=0 DO M1=M11,MLAST M1P=M1P+1 K1P = 0 DO K1=MCH,MCI K1P=K1P+1 K2P = 0 DO K2=NCH,NCI K2P=K2P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV) ENDDO ENDDO ENDDO ELSE M1P=0 DO M1=M11,MLAST M1P=M1P+1 K2P = 0 DO K2=MCH,MCI K2P=K2P+1 K1P=0 DO K1=NCH,NCI K1P=K1P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV) ENDDO ENDDO ENDDO ENDIF ENDDO C MCH = MCI + 1 MCI = MNP2D1 MCP=MCI-MCH+1 NCI = 0 DO JK = 1 , IBIN1 NCH = NCI + 1 NCI = NCI + NOTERM READ(LTAPE) (((D(J,I,L),J=1,NOTERM),I=1,MCP),L=1,LV) IF(LPOS.GT.0) THEN M1P=0 DO M1=M11,MLAST M1P=M1P+1 K1P = 0 DO K1=MCH,MCI K1P=K1P+1 K2P = 0 DO K2=NCH,NCI K2P=K2P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV) ENDDO ENDDO ENDDO ELSE M1P=0 DO M1=M11,MLAST M1P=M1P+1 K2P = 0 DO K2=MCH,MCI K2P=K2P+1 K1P = 0 DO K1=NCH,NCI K1P=K1P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV) ENDDO ENDDO ENDDO ENDIF ENDDO NCH = NCI + 1 NCI = MNP2D2 NCP=NCI-NCH+1 READ(LTAPE) (((D(J,I,L),J=1,NCP),I=1,MCP),L=1,LV) IF(LPOS.GT.0) THEN M1P=0 DO M1=M11,MLAST M1P=M1P+1 K1P = 0 DO K1=MCH,MCI K1P=K1P+1 K2P = 0 DO K2=NCH,NCI K2P=K2P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K2P,K1P,LV) ENDDO ENDDO ENDDO ELSE M1P=0 DO M1=M11,MLAST M1P=M1P+1 K2P = 0 DO K2=MCH,MCI K2P=K2P+1 K1P = 0 DO K1=NCH,NCI K1P=K1P+1 DDEC(K2,M1)=DDEC(K2,M1)+AVECT1(K1,M1P)*D(K1P,K2P,LV) ENDDO ENDDO ENDDO ENDIF C C READ BUTTLE PART C IF(IBUT.EQ.-1) GOTO 1000 READ(LTAPE) READ(LTAPE) READ(LTAPE) C C-----READ ANGULAR COEFFICIENTS 1000 CONTINUE READ(LTAPE) READ(LTAPE) CLOSE(LTAPE) C RETURN C 99 WRITE(6,*)' *** FATAL ERROR IN READD *** ' WRITE(6,*)' UNABLE TO OPEN DIPOLE FILE: ',DKK STOP C 600 FORMAT(//1X,30(1H*)//' DIMENSION FOR MNP2 OR NCHF TOO' &,' SMALL'// ' MNP2D1, NCHND1 = ',I5,', ',I5/ & ' MNP2D2, NCHND2 = ',I5,', ',I5//1X,30(1H*)//) 601 FORMAT(//1X,30(1H*)//' MZNRG TOO SMALL FOR BUFFER'// & ' NEED AT LEAST ',I4//1X,30(1H*)//) C END C********************************************************************* C SUBROUTINE READD0 C C READ DIRECTORY FILE ON D DATASET C IMPLICIT REAL*8 (A-H,O-Z) C LOGICAL FEXIST C CHARACTER DKK*3,NUM(0:9) DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ C INCLUDE 'PARAM' C COMMON/BDSYM/ISB(MZSLP),ILB(MZSLP),IPB(MZSLP),NFILEB, 1 ISDL(MZSLP),ILDL(MZSLP),IPDL(MZSLP),NFILED, 2 ISDR(MZSLP),ILDR(MZSLP),IPDR(MZSLP), 3 NFBD,NFB(3),NFD(3) COMMON/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW C C INITIAL DIPOLE DATA C INQUIRE(FILE='D00',EXIST=FEXIST) IF(FEXIST)THEN OPEN(3,FILE='D00',STATUS='OLD',FORM='UNFORMATTED') ELSE WRITE(6,503) STOP 'STG3 DATASET D00 NOT FOUND' ENDIF C REWIND(3) ICOUNT=0 C READ(3)KOUNT K1=0 K2=1 C DO I=1,KOUNT DKK='D'//NUM(K1)//NUM(K2) INQUIRE(FILE=DKK,EXIST=FEXIST) IF(FEXIST) THEN ICOUNT=ICOUNT+1 FEXIST=.FALSE. END IF K2=K2+1 IF(MOD(K2,10).EQ.0) THEN K2=0 K1=K1+1 END IF ENDDO IFLAG=0 IF(ICOUNT.LT.KOUNT) THEN IFLAG=1 WRITE(6,502)KOUNT,ICOUNT KOUNT=ICOUNT END IF C NFILED=KOUNT IF(IPRINT.GT.0.OR.IFLAG.GT.0)WRITE(6,500) DO K=1,KOUNT READ(3)IS1,IL1,IP1,IS2,IL2,IP2 ISDL(K)=IS1 ISDR(K)=IS2 ILDL(K)=IL1 ILDR(K)=IL2 IPDL(K)=IP1 IPDR(K)=IP2 IF(IPRINT.GT.0.OR.IFLAG.GT.0) X WRITE(6,501)K,IS1,IL1,IP1,IS2,IL2,IP2 ENDDO CLOSE(3) C RETURN C 500 FORMAT(//10X,'FROM D DATASET'//10X,'K',8X,'IS1',2X,'IL1',2X,'IP1', 1 6X,'IS2',2X,'IL2',2X,'IP2'/) 501 FORMAT(8X,I3,8X,I3,2X,I3,2X,I3,6X,I3,2X,I3,2X,I3) 502 FORMAT (/'***WARNING: ',I3,' POSSIBLE DIPOLES BUT ONLY ' X,I3,' GENERATED' /) 503 FORMAT(/'*** ERROR: UNABLE TO FIND DIRECTORY FILE D00 ***'// X' EITHER GENERATE SUITABLE DIPOLE FILES *OR* SET: NTYP2I=0'/ X' WHICH SWITCHES-OFF TYPE-2 (OUTER ELECTRON) RADIATION INTO', X' THE BOX.') 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 c common/parainfo/iam,nproc 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.le.0)THEN C IF(IMODE.LT.0)THEN C C CALCULATE UNPHYSICAL P,Q C c write(iam+70,*)ie,etot CALL POINTS(IOPT1,.FALSE.) CALL REACT(IOPT1,.FALSE.,.TRUE.) C IF(NCHOP.NE.NCHF)STOP'READPQ: NCHOP.NE.NCHF' E2=ETOT IE2=1-ie !parallel 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 c write(iam+70,*)ie,ie2 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.le.0)THEN !PQ FILE DOES NOT EXIST parallel 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 (MNPEXT=MZMNP+MZCHF) 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) COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC C DATA IDIV/0/ !FOR NON-DGEMM SYMMETRISE C ALLOCATABLE :: TEMP1A(:),TEMP2A(:,:) C C ALLOCATE C ALLOCATE (TEMP1A(MNP2)) 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 TEMP1A(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) 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 NCHF2=0 C ALLOCATE (TEMP2A(MNP2,NCHFI),stat=ierr) if(ierr.ne.0)stop 'Failure to allocate temp2a' C DO ID=1,IDIV C DO I=1,NCHF0 II=NCHF2+I DO K=1,MNP2 TEMP2A(K,I)=TEMP1A(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 ,TEMP2A,MNP2,ONE,RMAT(1,NCHF1),MZCHF) C NCHF0=NCHFI C ENDDO C C NON-DGEMM C C ALLOCATE (TEMP2A(MNP2,1),stat=ierr) c if(ierr.ne.0)stop 'Failure to allocate temp2a' 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 TEMP2A(K,1)=TEMP1A(K)*WMAT(K,I) CBL ENDDO CBL DO J=1,I CBL RMAT(J,I)=RMAT(J,I)+DDOT(MNP2,TEMP2A(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 TEMP2A(K,1)=TEMP1A(K)*WMAT(K,I) CNBL ENDDO CNBL DO J=1,I CNBL DO K=1,MNP2 CNBL RMAT(J,I)=RMAT(J,I)+TEMP2A(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 C DEALLOCATE C DEALLOCATE(TEMP1A,TEMP2A,stat=ierr) if(ierr.ne.0)stop 'Failure to deallocate in rinit' C C ADD-IN RADIATION DAMPING C CALL ZRMAT C RETURN END C*************************************************************** C REAL*8 FUNCTION RWIDTH(NZA,NMIN,NMAX,NV,LV) IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (HBAR=4.837769D-17,ZERO=0.0D0) DIMENSION CP(100),CM(100),JDUM(100) C C EVALUATE RADIATIVE WIDTH (IN RY) OF VALENCE ORBITAL NV,LV C NMIN=LOWEST N-VALUE ACCESSIBLE C NMAX=HIGHEST N-VALUE INCLUDED C NZA=ION CHARGE (AS SEEN BY VALENCE ELECTRON). C RWIDTH=ZERO NR1=MAX0(NMIN,LV) NR2=MIN0(NMAX,NV-1) IF(NR1.GT.NR2)RETURN DZ=NZA*NZA TV=NV*NV LP=LV+1 IF(LP.GT.100)THEN WRITE(6,*)' **ERROR** L =',LP,' > LDIM = 100' STOP ENDIF TL=LV TLP=LP DO 1 N=NR1,NR2 T=N*N DE=DZ*(TV-T)/(TV*T) CALL DIPOL(-1,N,NV,ZERO,LP,CP,CM,JDUM) T1=TLP*CM(LP)*1.0E10**JDUM(LP) T2=ZERO IF(LV.GT.0)T2=TL*CP(LV)*1.0E10**JDUM(LV) T=(T1+T2)/(TL+TLP) T0=DE**3*2.6775E9/DZ T=T*T0 c IF(N.EQ.2)T=T/4. RWIDTH=RWIDTH+T 1 CONTINUE RWIDTH=HBAR*RWIDTH 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/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF) 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.TZERO)THEN FNU=ONE/SQRT(-E) IF(FNU-0.1.LT.L.OR.FNU.LT.FNUMIN)THEN !DROP IERR=-2 IF(IFLAG.LE.0)THEN WRITE(6,*)' WARNING, N.LT.L IN SUBROUTINE SC0', 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 IOMIT(ICHAN)=1 C ALLOW EXECUTION TO PROCEED AND OMIT LATER S=0.5 SP=-0.05 C=100. CP=-10. ZFSCL(ICHAN)=ONE RETURN ENDIF ENDIF C CALL SC0(E,L,R,AC,ZS,S,SP,ZC,C,CP,IERR) C IF(IERR.GT.0)THEN !NOT (SUFFICIENTLY) CONVERGED 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. ZFSCL(ICHAN)=ONE RETURN ENDIF C IF(E.GE.0)THEN ZFSCL(ICHAN)=ONE ELSE ZFSCL(ICHAN)=ZS !ZC=1/ZS ENDIF 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(6,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) 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 DO 50 J=1,NAST K=NCONAT(J) IF(K.EQ.0)GOTO 50 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,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 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=MZCHF*MZCHF) 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 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 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 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 ZAINVB C CNRB: C COMPUTE ZK=-ZA**(-1)*ZB C USE KAB'S PARTITIONING, BUT SOLVE ZA*ZK=-ZB INSTEAD. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZCHF*MZCHF) C PARAMETER (TWO=2.0) PARAMETER (ZERO=(0.0,0.0)) PARAMETER (ZONE=(1.0,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/CNTRL/IPRINT,IPRKM,IWORD,IRAD,IPERT,NPERT,IPRTSW 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/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) C DIMENSION IPIV3(MZCHF),IPIVA(MZCHF) DIMENSION ZTEMP1(MZCHF,MZCHF),ZTEMP2(MZCHF,MZCHF), X ZTEMP3(MZCHF,MZCHF),ZTEMP4(MZCHF,MZCHF) EQUIVALENCE (ZTEMP1,ZR),(ZTEMP2,ZKHICC),(ZTEMP3,ZKHIOC) X ,(ZTEMP4,ZWORK) C IF(MZDEG.LT.MZCHF)THEN WRITE(6,*)'SR.ZAINV: SET MZDEG=MZCHF IN PARAM FILE' STOP 'SR.ZAINV: SET MZDEG=MZCHF IN PARAM FILE' ENDIF 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)ZA(I,I)=ZONE 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 ZTEMP4(J,I)=ZA(I,JJ) !TRANSPOSE ENDDO DO I=1,NCC ZTEMP3(J,I)=ZA(JJ,NCHOP+I) ENDDO ENDDO C CSTRTNBL CNBL CALL ZLU(ZTEMP3,MZCHF,NCC,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,600)IERR CNBL STOP ' ERROR IN ZLU' CNBL END IF CNBL CALL ZLUBT(ZTEMP3,ZTEMP4,MZCHF,NCHOP,IERR) !TRANSPOSE CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN ZLUBT' CNBL END IF CENDNBL C CSTRTBL CALL ZGETRF(NCC,NCC,ZTEMP3,MZCHF,IPIV3,INFO) IF(INFO.NE.0)THEN WRITE(6,602)INFO STOP ' ERROR IN ZGETRF' ENDIF CALL ZGETRS('T',NCC,NCHOP,ZTEMP3,MZCHF,IPIV3,ZTEMP4,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN ZGETRS' ENDIF CENDBL C C TRANSPOSE BACK C DO I=1,NCHOP DO J=1,NCC ZTEMP2(I,J)=ZTEMP4(J,I) ENDDO ENDDO DO I=1,NCHOP DO J=1,NCC ZTEMP4(I,J)=ZTEMP2(I,J) ENDDO ENDDO C DO J=1,NCHOP DO I=1,NCC ZTEMP2(I,J)=ZA(NCHOP+I,J) !ACO ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL ZTEMP1(I,J)=ZERO CNBL ENDDO CNBL DO K=1,NCC CNBL DO I=1,NCHOP CNBL ZTEMP1(I,J)=ZTEMP1(I,J)+ZTEMP4(I,K)*ZTEMP2(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL ZGEMM('N','N',NCHOP,NCHOP,NCC,ZONE, X ZTEMP4,MZCHF,ZTEMP2,MZCHF,ZERO,ZTEMP1,MZCHF) CENDBL C DO J=1,NCHOP DO I=1,NCHOP ZA(I,J)=ZA(I,J)-ZTEMP1(I,J) ENDDO ENDDO DO J=1,NCHOP DO I=1,NCC ZTEMP1(I,J)=ZB(NCHOP+I,J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,NCHOP CNBL ZTEMP2(I,J)=ZERO CNBL ENDDO CNBL DO K=1,NCC CNBL DO I=1,NCHOP CNBL ZTEMP2(I,J)=ZTEMP2(I,J)+ZTEMP4(I,K)*ZTEMP1(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL CALL ZGEMM('N','N',NCHOP,NCHOP,NCC,ZONE, X ZTEMP4,MZCHF,ZTEMP1,MZCHF,ZERO,ZTEMP2,MZCHF) CENDBL C DO J=1,NCHOP DO I=1,NCHOP ZB(I,J)=ZB(I,J)-ZTEMP2(I,J) ENDDO ENDDO DO J=1,NCHOP DO I=1,NCC ZTEMP4(NCHOP+I,J)=ZA(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 ZK(I,J)=-ZB(I,J) ENDDO ENDDO C CSTRTNBL CNBL CALL ZLU(ZA,MZCHF,NCHOP,IERR) !A DESTROYED CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,600)IERR CNBL STOP ' ERROR IN ZLU' CNBL END IF CNBL CALL ZLUB(ZA,ZK,MZCHF,NCHOP,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN ZLUB' CNBL END IF CENDNBL C CSTRTBL CALL ZGETRF(NCHOP,NCHOP,ZA,MZCHF,IPIVA,INFO) IF(INFO.NE.0)THEN WRITE(6,602)INFO STOP ' ERROR IN ZGETRF' ENDIF CALL ZGETRS('N',NCHOP,NCHOP,ZA,MZCHF,IPIVA,ZK,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN ZGETRS' ENDIF CENDBL C C SYMMETRISE OPEN-OPEN PART OF REACTANCE MATRIX C DO I=1,NCHOP-1 DO J=I+1,NCHOP ZK(I,J)=(ZK(I,J)+ZK(J,I))/TWO ZK(J,I)=ZK(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 C C KCO=-ACC**(-1)*[BCO+ACO*KOO] C DO J=1,NCHOP DO I=1,NCC ZTEMP1(I,J)=ZTEMP4(NCHOP+I,J) !ACO ZTEMP2(I,J)=ZB(NCHOP+I,J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO K=1,NCHOP CNBL DO I=1,NCC CNBL ZTEMP2(I,J)=ZTEMP2(I,J)+ZTEMP1(I,K)*ZK(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO C CNBL CALL ZLUB(ZTEMP3,ZTEMP2,MZCHF,NCHOP,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN ZLUB' CNBL END IF CENDNBL C CSTRTBL CALL ZGEMM('N','N',NCC,NCHOP,NCHOP,ZONE, X ZTEMP1,MZCHF,ZK,MZCHF,ZONE,ZTEMP2,MZCHF) CALL ZGETRS('N',NCC,NCHOP,ZTEMP3,MZCHF,IPIV3,ZTEMP2,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN ZGETRS' ENDIF CENDBL C DO J=1,NCHOP DO I=1,NCC ZK(NCHOP+I,J)=-ZTEMP2(I,J) ENDDO ENDDO C C COPY CLOSED-OPEN TO OPEN-CLOSED C DO J=NCHOP+1,NCHF DO I=1,NCHOP ZK(I,J)=ZK(J,I) ENDDO ENDDO C ENDIF C IF(IQDT.GT.0.AND.IPERT.GT.0)THEN !IQDT>0 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 ZTEMP1(I,J)=ZB(NCHOP+I,NCHOP+J) ENDDO ENDDO DO J=1,NCC DO I=1,NCHOP ZTEMP2(I,J)=ZB(I,NCHOP+J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCC CNBL DO K=1,NCC CNBL DO I=1,NCHOP CNBL ZTEMP2(I,J)=ZTEMP2(I,J)-ZTEMP4(I,K)*ZTEMP1(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL CALL ZLUB(ZA,ZTEMP2,MZCHF,NCC,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN ZLUB' CNBL END IF CENDNBL C CSTRTBL CALL ZGEMM('N','N',NCHOP,NCC,NCC,-ZONE, + ZTEMP4,MZCHF,ZTEMP1,MZCHF,ZONE,ZTEMP2,MZCHF) CALL ZGETRS('N',NCHOP,NCC,ZA,MZCHF,IPIVA,ZTEMP2,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN ZGETRS' ENDIF CENDBL C DO J=1,NCC DO I=1,NCHOP ZK(I,NCHOP+J)=-ZTEMP2(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 ZK(I,J)=(ZK(I,J)+ZK(J,I))/TWO ZK(J,I)=ZK(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 ZTEMP1(I,J)=ZTEMP4(NCHOP+I,J) !ACO ENDDO ENDDO DO J=1,NCC DO I=1,NCHOP ZTEMP2(I,J)=ZK(I,NCHOP+J) ENDDO ENDDO DO J=1,NCC DO I=1,NCC ZTEMP4(I,J)=ZB(NCHOP+I,NCHOP+J) ENDDO ENDDO C CSTRTNBL CNBL DO J=1,NCC CNBL DO K=1,NCHOP CNBL DO I=1,NCC CNBL ZTEMP4(I,J)=ZTEMP4(I,J)+ZTEMP1(I,K)*ZTEMP2(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO CNBL CALL ZLUB(ZTEMP3,ZTEMP4,MZCHF,NCC,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601)IERR CNBL STOP ' ERROR IN ZLUB' CNBL END IF CENDNBL C CSTRTBL CALL ZGEMM('N','N',NCC,NCC,NCHOP,ZONE, X ZTEMP1,MZCHF,ZTEMP2,MZCHF,ZONE,ZTEMP4,MZCHF) CALL ZGETRS('N',NCC,NCC,ZTEMP3,MZCHF,IPIV3,ZTEMP4,MZCHF,INFO) IF(INFO.NE.0)THEN WRITE(6,603)INFO STOP ' ERROR IN ZGETRS' ENDIF CENDBL C DO J=1,NCC DO I=1,NCC ZK(NCHOP+I,NCHOP+J)=-ZTEMP4(I,J) ENDDO ENDDO C C SYMMETRISE "CLOSED"-"CLOSED" PART OF REACTANCE MATRIX C DO I=NCHOP+1,NCHF DO J=I+1,NCHF ZK(I,J)=(ZK(I,J)+ZK(J,I))/TWO ZK(J,I)=ZK(I,J) ENDDO ENDDO C ENDIF C NCHOP=NHOLD RETURN C CN600 FORMAT(' SR.ZAINVB: ZLU RETURNED WITH INFO =',I2) CN601 FORMAT(' SR.ZAINVB: ZLUB RETURNED WITH INFO =',I2) 602 FORMAT(//10X,10('*'),' SR.ZAINVB: ZGETRF RETURNED WITH INFO =',I2) 603 FORMAT(//10X,10('*'),' SR.ZAINVB: ZGETRS RETURNED WITH INFO =',I2) 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 ZLU(A,LA,N,IERR) C C ________________________________________________________ C | | C |LU FACTOR A GENERAL COMPLEX MATRIX WITH PARTIAL PIVOTING| C | | C | INPUT: | C | | C | A --COMPLEX 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 COMPLEX*16 A(*),T REAL*8 R,S,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) = 1239 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 ( ABS(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 ( ABS(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) = -1239 GOTO 40 110 IF ( ABS(A(I)) .EQ. TZERO ) A(1) = -1239 RETURN END C****************************************************************** C SUBROUTINE ZLUB(A,B,LB,NB,IERR) C ________________________________________________________ C | | C | SOLVE A GENERAL COMPLEX LU FACTORED SYSTEM | C | | C | INPUT: | C | | C | A --ZLU'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 TZERO,ONE COMPLEX*16 A(*),B(LB,*),T 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(DBLE(A(1))) IF ( ABS(I1) .NE. 1239 ) THEN IERR=1 !ERROR, MUST FACTOR BEFORE SOLVING RETURN ENDIF C ----------------------------- C |*** FORWARD ELIMINATION ***| C ----------------------------- DO 20 IB = 1,NB N = NINT(DBLE(A(2))) M = N + 1 J = 4 - M IF ( I1 .LT. 0 ) GOTO 80 K = 1 30 J = J + M IF ( ABS(A(J+K)) .EQ. TZERO ) GOTO 80 IF ( K .EQ. N ) GOTO 50 L = NINT(DBLE(A(J))) T = B(L,IB) B(L,IB) = B(K,IB) B(K,IB) = T 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 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 ( ABS(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 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 ZLUBT(A,B,LB,NB,IERR) C ________________________________________________________ C | | C | SOLVE THE TRANSPOSE OF A GENERAL COMPLEX | C | LU FACTORED SYSTEM | C | | C | INPUT: | C | | C | A --ZLU'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 TZERO,ONE COMPLEX*16 A(*),B(LB,*),T 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(DBLE(A(1))) IF ( ABS(I1) .NE. 1239 ) THEN IERR=1 !ERROR, MUST FACTOR BEFORE SOLVING RETURN ENDIF C DO 10 IB = 1,NB N = NINT(DBLE(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 ( ABS(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 = NINT(DBLE(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 ( ABS(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 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 ZMQDTK C C NRB: C CALCULATION OF K-PHYS FROM K-UNPHYS IN QDT, ALL CHANNELS OPEN. 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=MZCHF*MZCHF) C PARAMETER (ZERO=(0.0,0.0)) PARAMETER (ZONE=(1.0,0.0)) PARAMETER (ZI=(0.0,1.0)) PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (QUART=0.25) PARAMETER (BIG=170.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/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF) COMMON/NRBSKP/ISKP(MZMSH),ISKP0,LINC,ELAS COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN COMMON/ZCOUL/ZFS(MZPTS,MZCHF),ZFSP(MZCHF),ZFC(MZPTS,MZCHF) 1 ,ZFCP(MZCHF),ZFKNU(MZCHF) COMMON/AUGER/AAUGER(MZTAR),IAUGER COMMON/NRBZED/TZED,LPRTSW C DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF) X ,POLD(MZCHF,MZCHF),QOLD(MZCHF,MZCHF) DIMENSION ZKHICO(MZDEG,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 xeps=.55 PI=ACOS(-ONE) TPI=TWO*PI CONST=TPI IF(TZED.GT.TZERO)CONST=TPI/DBLE((NZED-NELC)**2) IONE=1 IF(ELAS.EQ.'YES')IONE=0 C C INITIALIZE KCC 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 ZKCC-ZFDEC (ZFDEC=-TAN(PI*NU)) 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 IF(TZED.EQ.TZERO)THEN ZFDEC=ZI ZFDEC=ZFDEC/ZFSCL(NNN)**2 !COMPLEX FACTOR ZFDEC=ZFDEC/FSCL(NNN)**2 !ENERGY FACTOR ZFDEC=-ZFDEC ELSE IF(IRDEC.EQ.0.OR.FKNU(NNN).GT.NCUTOFF x .or. llch(nnn).gt.0.and.fknu(nnn).lt.llch(nnn)+xeps X .OR.(NTYP1.EQ.0.AND.IAUGER.LE.0))THEN C NONE ZFKNU(NNN)=FKNU(NNN) PINU=FKNU(NNN)*PI ZFDEC=-DCMPLX(TAN(PINU),TZERO) ELSE TR=ONE/FKNU(NNN)**2 TI=TZERO IF(NTYP1.GT.0)TI=-ARDEC(ITARG(NNN))/TPI IF(IAUGER.GT.0)TI=TI-AAUGER(ITARG(NNN)) !A.U. HERE ZFKNU(NNN)=DCMPLX(ONE,TZERO)/SQRT(DCMPLX(TR,TI)) IF(DIMAG(ZFKNU(NNN)).LT.BIG)THEN ZSIN=SIN(PI*ZFKNU(NNN)) ZCOS=COS(PI*ZFKNU(NNN)) ZTAN=ZSIN/ZCOS ELSE ZTAN=DCMPLX(TZERO,ONE) ENDIF ZFDEC=-ZTAN ENDIF ENDIF C IF(IOMIT(NNN).LT.0)ZFDEC=-ZFDEC 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 KCO C DO N2=1,NCHOP DO N1=1,NCC IF(FKNU(ICHCL(N1)).LE.NCUTOFF)THEN ZKHICO(N1,N2)=DCMPLX(P(ICHCL(N1),N2),Q(ICHCL(N1),N2)) ELSE ZKHICO(N1,N2)=TZERO 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 (SOME) OPEN CHANNELS TO FORM PHYSICAL K-MATRIX C (THERE MAY BE NO SUBSEQUENT CALL TO SQDT) C DO K=1,NCC K1=NCHOP+K KI=ICHCL(K) IF(FKNU(KI).LE.NCUTOFF)THEN DO I=1,NCHOP ZK(I,K1)=-DCMPLX(P(I,KI),Q(I,KI)) !KOC ENDDO ELSE DO I=1,NCHOP ZK(I,K1)=ZERO ENDDO ENDIF ENDDO C CSTRTNBL CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL ZK(I,J)=DCMPLX(P(I,J),Q(I,J)) CNBL ENDDO CNBL DO K=1,NCC CNBL K1=NCHOP+K CNBL DO I=1,J CNBL ZK(I,J)=ZK(I,J)+ZK(I,K1)*ZKHICO(K,J) CNBL ENDDO CNBL ENDDO CNBL ENDDO C C SYMMETRIZE C CNBL DO J=1,NCHOP CNBL DO I=1,J CNBL ZK(J,I)=ZK(I,J) CNBL ENDDO CNBL ENDDO CENDNBL C CSTRTBL DO J=1,NCHOP DO I=1,NCHOP ZK(I,J)=DCMPLX(P(I,J),Q(I,J)) ENDDO ENDDO C CALL ZGEMM('N','N',NCHOP,NCHOP,NCC,ZONE,ZK(1,NCHOP1),MZCHF X ,ZKHICO,MZCHF,ZONE,ZK,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 600 FORMAT(' SR.ZMQDTK: ZLUS RETURNED WITH INFO =',I6) 601 FORMAT(' SR.ZMQDTK: ZLUBS RETURNED WITH INFO =',I6) 602 FORMAT(//10X,10('*'),' SR.ZMQDTK: ZSYTRF RETURNED WITH INFO =',I6) 603 FORMAT(//10X,10('*'),' SR.ZMQDTK: ZSYTRS RETURNED WITH INFO =',I6) 610 FORMAT(//10X,10('*'),' SR.ZMQDTK: NUMBER OF MQDT CLOSED', X ' CHANNELS, NCC = ',I4/20X,' LARGER THAN DIMENSION', X ' VALUE OF DEG = MZDEG'//) END C*************************************************************** C SUBROUTINE ZNUMT(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 FS,FSP C FUNCTIONS THETAD,THETADP STORED IN 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 ASSUMES OUTWARD INTEGRATION OF THETA,THETADOT CORRECTLY NORMALIZED C AND FINAL DERIVATIVE NOT NEEDED. C IMPLICIT COMPLEX*16 (A-H,O-Z) REAL*8 C,R1,HP,ONE,TWO,THREE,FOUR,SIX,TEN,TWELVE X ,P1,P2,P3,P4,P5,P6,P7,P8,TZED 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/ZCOUL/FS(MZPTS,MZCHF),FSP(MZCHF),FC(MZPTS,MZCHF) 1 ,FCP(MZCHF),ZFKNU(MZCHF) COMMON/ZCTHET/BB(MZCHF,MZTET),BG(MZCHF,MZTET),MSUM(MZCHF) 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.EQ.0.0)RETURN W1=ONE/SQRT(W) FS(N1,I)=FS(N1,I)*W1 FC(N1,I)=FC(N1,I)*W1 FSP(I)=FSP(I)*W1 FCP(I)=FCP(I)*W1 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 20 IF(N1.LT.ABS(N2))RETURN C C CALCULATE FINAL DERIVATIVE C 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 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 W1=AMAX/SQRT(W1) FSP(I)=F3P*W1 FCP(I)=G3P*W1 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 ZPETFSC 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 (ZONE=(1.0,0.0)) PARAMETER (ZERO=(0.0,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) COMMON/NRBGAM/ZGAM(MZCHF),GAM(MZCHF) COMMON/NRBPH2/ZS(MZCHF),ZSP(MZCHF),ZC(MZCHF),ZCP(MZCHF) COMMON/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/NRBPH5/ZCS(MZCHF,MZCHF),ZCSP(MZCHF,MZCHF),ZCC(MZCHF,MZCHF) 1 ,ZCCP(MZCHF,MZCHF) C C C CALCULATE PERTURBED FUNCTIONS C C OPEN-OPEN C DO J=1,NCHOP DO I=1,NCHOP ZCS(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J) ZCSP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J) ZCC(I,J)=S(I)*ACC(I,J)-C(I)*ASC(I,J) ZCCP(I,J)=SP(I)*ACC(I,J)-CP(I)*ASC(I,J) CSTGF CSPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J) CSTGF CCPP(I,J)=SPP(I)*ACC(I,J)-CPP(I)*ASC(I,J) CSTGF DS(I,J)=CS(I,J) CSTGF DC(I,J)=CC(I,J) CSTGF DSP(I,J)=CSP(I,J) CSTGF DCP(I,J)=CCP(I,J) ENDDO ENDDO DO I=1,NCHOP ZCS(I,I)=ZCS(I,I)+S(I)-ZGAM(I)*C(I) !ZGAM=0, IQDT=1,2 ZCSP(I,I)=ZCSP(I,I)+SP(I)-ZGAM(I)*CP(I) ZCC(I,I)=ZCC(I,I)+C(I) ZCCP(I,I)=ZCCP(I,I)+CP(I) CSTGF CSPP(I,I)=CSPP(I,I)+SPP(I) CSTGF CCPP(I,I)=CCPP(I,I)+CPP(I) ENDDO C IF(NCHOP.EQ.NCHF)GOTO 270 !IQDT=1,2 C C CLOSED-OPEN C DO J=1,NCHOP DO I=NCHOP1,NCHF ZCS(I,J)=ZC(I)*ASS(I,J)-ZS(I)*ACS(I,J) ZCSP(I,J)=ZCP(I)*ASS(I,J)-ZSP(I)*ACS(I,J) ZCC(I,J)=ZC(I)*ASC(I,J)-ZS(I)*ACC(I,J) ZCCP(I,J)=ZCP(I)*ASC(I,J)-ZSP(I)*ACC(I,J) CSTGF CSPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J) CSTGF CCPP(I,J)=CPP(I)*ASC(I,J)-SPP(I)*ACC(I,J) CSTGF DS(I,J)=CS(I,J) CSTGF DC(I,J)=CC(I,J) CSTGF DSP(I,J)=CSP(I,J) CSTGF DCP(I,J)=CCP(I,J) ENDDO ENDDO C C OPEN-CLOSED C DO J=NCHOP1,NCHF DO I=1,NCHOP ZCC(I,J)=S(I)*ACS(I,J)-C(I)*ASS(I,J) ZCCP(I,J)=SP(I)*ACS(I,J)-CP(I)*ASS(I,J) CSTGF CCPP(I,J)=SPP(I)*ACS(I,J)-CPP(I)*ASS(I,J) CSTGF DC(I,J)=CC(I,J) CSTGF DCP(I,J)=CCP(I,J) ENDDO ENDDO C C CLOSED-CLOSED C DO J=NCHOP1,NCHF DO I=NCHOP1,NCHF ZCC(I,J)=ZC(I)*ASS(I,J)-ZS(I)*ACS(I,J) ZCCP(I,J)=ZCP(I)*ASS(I,J)-ZSP(I)*ACS(I,J) CSTGF CCPP(I,J)=CPP(I)*ASS(I,J)-SPP(I)*ACS(I,J) CSTGF DC(I,J)=CC(I,J) CSTGF DCP(I,J)=CCP(I,J) ENDDO ENDDO DO I=NCHOP1,NCHF ZCC(I,I)=ZCC(I,I)+ZS(I)+ZGAM(I)*ZC(I) ZCCP(I,I)=ZCCP(I,I)+ZSP(I)+ZGAM(I)*ZCP(I) ENDDO C 270 CONTINUE IF(NCHHYB.GT.0)THEN DO N=1,NCHHYB I=ICHHYB(N) ZCC(I,I)=ZS(I)+ZGAM(I)*ZC(I) !SINCE ALPHA=0 ZCCP(I,I)=ZSP(I)+ZGAM(I)*ZCP(I) ZCS(I,I)=ZERO ZCSP(I,I)=ZERO ENDDO ENDIF C C CALCULATE MATRICES A AND B C DO J=1,NCHF DO I=1,NCHF ZA(I,J)=ZCC(I,J) ENDDO CSTRTNBL CNBL DO K=1,NCHF CNBL DO I=1,NCHF CNBL ZA(I,J)=ZA(I,J)-ZR(I,K)*ZCCP(K,J) CNBL ENDDO CNBL ENDDO CENDNBL ENDDO DO J=1,NCHOP DO I=1,NCHF ZB(I,J)=ZCS(I,J) ENDDO CSTRTNBL CNBL DO K=1,NCHF CNBL DO I=1,NCHF CNBL ZB(I,J)=ZB(I,J)-ZR(I,K)*ZCSP(K,J) CNBL ENDDO CNBL ENDDO CENDNBL ENDDO CSTRTBL CALL ZGEMM('N','N',NCHF,NCHF,NCHF,-ZONE,ZR,MZCHF,ZCCP,MZCHF, X ZONE,ZA,MZCHF) CALL ZGEMM('N','N',NCHF,NCHOP,NCHF,-ZONE,ZR,MZCHF,ZCSP,MZCHF, X ZONE,ZB,MZCHF) CENDBL C RETURN 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 ZPQ C C NRB: C CALCULATE MATRICES P AND Q, C TRANSMISSION MATRIX IS -2*I*(P+I*Q), I=SQRT(-1) C NOTE: WITH A COMPLEX ZK IT IS SLIGHTLY FASTER TO SOLVE AX=B. C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZCHF*MZCHF) C PARAMETER (TZERO=0.0) PARAMETER (ZERO=(0.0,0.0)) PARAMETER (ZONE=(1.0,0.0)) PARAMETER (ZI=(0.0,1.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/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/NRBQDT/RTWOC,KP2C,IEE(MZMSH),IQDT,NCUTOFF,IMODE,INTPQ,IJBIN COMMON/NRBSCL/ZFSCL(MZCHF),FSCL(MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) COMMON/NRBZED/TZED,LPRTSW C DIMENSION IPIV(MZCHF) DIMENSION P(MZCHF,MZCHF),Q(MZCHF,MZCHF) C EQUIVALENCE (P,CSP),(Q,CC) C C C FIRST, UNSCALE K-MX IF NECESSARY C IF(TZED.EQ.TZERO.AND.IQDT.GT.0)THEN DO J=1,NCHOP !NCHF IF IOPEN SCALE DO I=1,NCHOP ! DITTO ZK(I,J)=ZFSCL(I)*FSCL(I)*ZK(I,J)*FSCL(J)*ZFSCL(J) ENDDO ENDDO ENDIF C C ZA=(I+ZK)**(-1) C DO J=1,NCHOP DO I=1,NCHOP ZA(I,J)=ZK(I,J) ZB(I,J)=ZK(I,J) !INITIALIZE ENDDO ENDDO DO I=1,NCHOP ZA(I,I)=ZA(I,I)+ZI ENDDO C CSTRTNBL CNBL CALL ZLUS(ZA,MZCHF,NCHOP,WORK,IERR) CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,600) CNBL STOP 'ERROR IN ZLUS' CNBL END IF CNBL CALL ZLUBS(ZA,ZB,MZCHF,-NCHOP,IERR) !COMPUTE HALF ONLY CNBL IF (IERR.NE.0) THEN CNBL WRITE(6,601) CNBL STOP 'ERROR IN ZLUBS' CNBL END IF CENDNBL CSTRTBL CALL ZSYTRF('L',NCHOP,ZA,MZCHF,IPIV,ZWORK,MWORK,INFO) IF (INFO.NE.0) THEN WRITE(6,602) INFO STOP 'FAILURE IN BLAS ROUTINE ZSYTRF' ENDIF CALL ZSYTRS('L',NCHOP,NCHOP,ZA,MZCHF,IPIV,ZB,MZCHF,INFO) IF (INFO.NE.0) THEN WRITE(6,603) INFO STOP 'FAILURE IN BLAS ROUTINE ZSYTRS' ENDIF CENDBL C DO J=1,NCHOP DO I=1,NCHOP P(I,J)=-DIMAG(ZB(I,J)) Q(I,J)=DBLE(ZB(I,J)) ENDDO ENDDO C RETURN C 600 FORMAT(' SR.ZPQ: ZLUS RETURNED WITH INFO =',I6) 601 FORMAT(' SR.ZPQ: ZLUBS RETURNED WITH INFO =',I6) 602 FORMAT(//10X,10('*'),' SR. ZPQ: ZSYTRF RETURNED WITH INFO =',I6) 603 FORMAT(//10X,10('*'),' SR. ZPQ: ZSYTRI RETURNED WITH INFO =',I6) C END C*********************************************************************** C C A FULL BLAS IMPLEMENTATION OF THIS ZRMAT SUBROUTINE IS AVAILABLE, BUT, C IT HAS *NOT* BEEN TESTED, CONTACT NRB IF YOU WANT TO BE THE GUINEA PIG C C*********************************************************************** C SUBROUTINE ZRMAT C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (MNPEXT=MZMNP+MZCHF) PARAMETER (LWORK=MZCHF*MZCHF) PARAMETER (MWORK=MZCHF*MZCHF) C PARAMETER (TZERO=0.0) PARAMETER (ONE=1.0) PARAMETER (TWO=2.0) PARAMETER (THREE=3.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/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/PART/EIGENS(MZNRG,MZLP1),ENDS(MZNRG,MZLP1),SI(MZCHF), X TRACE,NRANG1(MZLP1),NRANG2,IPRCENT 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/NRBPH3/ZR(MZCHF,MZCHF),ZK(MZCHF,MZCHF), X ZA(MZCHF,MZCHF),ZB(MZCHF,MZCHF) COMMON/NRBWRK/WORK(LWORK),ZWORK(MWORK) COMMON/GAUGE/IGAUGE COMMON/TYPE/NTYP1,NTYP2I,NTYP2OF,NTYP2OR,NMIN COMMON/RADDEC/EDEC(MZDEC),DDEC(MNPEXT,MZDEC),NDEC C DIMENSION A1(MZDEC,MZDEC),B1(MZDEC,MZDEC),C1(MZDEC,MZCHF) X,C2(MZDEC,MZDEC) DIMENSION WDEC(MZDEC,MZCHF),TEMP(MZDEC),A2(MZDEC,MZCHF) DIMENSION TEMP1(MZMNP),TEMP2(MZMNP) CBL DIMENSION IPIV(MZDEC) C EQUIVALENCE (A2(1,1),C1(1,1)) !STGFDAMP ONLY, NOT STGFBF0DAMP C IF(NTYP2I.EQ.0.OR.NDEC.EQ.0)THEN DO J=1,NCHF DO I=1,NCHF ZR(I,J)=DCMPLX(RMAT(I,J),TZERO) ENDDO ENDDO RETURN ENDIF C CC3=137.0360 CC3=CC3*CC3*CC3 IF(NSPN2.EQ.0)THEN FACT=SQRT(TWO/(THREE*(LRGL2+1)*CC3)) ELSE FACT=SQRT(TWO/(THREE*(TWO*LRGL2+1)*CC3)) ENDIF AZ=MAX(NZED-NELC,1) FACTL=FACT*AZ**2/TWO FACTV=FACT IF(IGAUGE.EQ.0)THEN DO J=1,NDEC TEMP(J)=FACTL*SQRT((ETOT-EDEC(J))**3) ENDDO ELSE DO J=1,NDEC TEMP(J)=FACTV*SQRT((ETOT-EDEC(J))) ENDDO ENDIF C C NRB:THE FOLLOWING MATRIX OPERATIONS ARE OPTIMIZED FOR A SCALAR MACHINE C DO I=1,NCHF DO J=1,NDEC WDEC(J,I)=TZERO ENDDO ENDDO C DO K=1,MNP2 TEMP1(K)=ONE/(VALUE(K)-ETOT) !-EZERO NO PARTITION HERE ENDDO C DO I=1,NCHF DO K=1,MNP2 TEMP2(K)=TEMP1(K)*WMAT(K,I) ENDDO DO J=1,NDEC !NOT I,NCHF DO K=1,MNP2 WDEC(J,I)=WDEC(J,I)+TEMP2(K)*DDEC(K,J)*TEMP(J) ENDDO ENDDO ENDDO C DO J=1,NDEC DO I=1,NDEC A1(I,J)=TZERO ENDDO ENDDO C DO J=1,NDEC DO K=1,MNP2 TEMP2(K)=TEMP1(K)*DDEC(K,J) ENDDO DO I=1,NDEC VIJ=TEMP(I)*TEMP(J) DO K=1,MNP2 A1(I,J)=A1(I,J)+DDEC(K,I)*TEMP2(K)*VIJ ENDDO ENDDO ENDDO C DO J=1,NDEC DO I=1,NDEC B1(I,J)=TZERO ENDDO B1(J,J)=ONE DO K=1,NDEC DO I=1,J B1(I,J)=B1(I,J)+A1(I,K)*A1(K,J) ENDDO ENDDO ENDDO C DO J=1,NDEC DO I=1,J B1(J,I)=B1(I,J) ENDDO ENDDO C CSTRTNBL CALL VERTS(B1,MZDEC,NDEC,WORK,IERR) IF (IERR.NE.0) THEN WRITE(6,100) STOP 'STOP BECAUSE NO INVERSE FOUND IN SR.ZRMAT' END IF CENDNBL CSTRTBL CBL CALL DSYTRF('L',NDEC,B1,MZDEC,IPIV,WORK,LWORK,INFO) CBL IF (INFO.NE.0) THEN CBL WRITE(6,602) INFO CBL STOP 'FAILURE IN BLAS ROUTINE DSYTRF' CBL ENDIF CBL CALL DSYTRI('L',NDEC,B1,MZDEC,IPIV,WORK,INFO) CBL IF (INFO.NE.0) THEN CBL WRITE(6,603) INFO CBL STOP 'FAILURE IN BLAS ROUTINE DSYTRI' CBL ENDIF CENDBL C DO J=1,NDEC DO I=J,NDEC B1(J,I)=B1(I,J) ENDDO ENDDO C DO J=1,NCHF DO I=1,NDEC C1(I,J)=TZERO ENDDO DO K=1,NDEC DO I=1,NDEC C1(I,J)=C1(I,J)+B1(I,K)*WDEC(K,J) ENDDO ENDDO ENDDO C DO J=1,NCHF DO I=1,J SUM=TZERO DO K=1,NDEC SUM=SUM+WDEC(K,I)*C1(K,J) ENDDO ZR(I,J)=DCMPLX(RMAT(I,J),SUM) ENDDO ENDDO C DO J=1,NDEC DO I=1,NDEC C2(I,J)=TZERO ENDDO DO K=1,NDEC DO I=1,NDEC C2(I,J)=C2(I,J)+A1(I,K)*B1(K,J) ENDDO ENDDO ENDDO C DO J=1,NCHF DO I=1,NDEC A2(I,J)=TZERO ENDDO DO K=1,NDEC DO I=1,NDEC A2(I,J)=A2(I,J)+C2(I,K)*WDEC(K,J) ENDDO ENDDO ENDDO C DO J=1,NCHF DO I=1,J SUM=TZERO DO K=1,NDEC SUM=SUM-WDEC(K,I)*A2(K,J) ENDDO ZR(I,J)=ZR(I,J)+SUM ENDDO ENDDO C DO J=1,NCHF DO I=1,J ZR(J,I)=ZR(I,J) ENDDO ENDDO C RETURN 100 FORMAT(' SR.ZRMAT: MATRIX HAS NO INVERSE IN VERTS') CB602 FORMAT(//10X,10('*'),' SR.ZRMAT: DSYTRF RETURNED WITH INFO =',I2) CB603 FORMAT(//10X,10('*'),' SR.ZRMAT: DSYTRI RETURNED WITH INFO =',I2) END C********************************************************** C SUBROUTINE ZTHETA(R,I,ZT,ZTP,ZTD,ZTDP,ICONV,ENERGY,GAMMA) C IMPLICIT REAL*8 (A-H,O-Y) IMPLICIT COMPLEX*16 (Z) C INCLUDE 'PARAM' C PARAMETER (ZI=(0.0,1.0)) PARAMETER (ZERO=(0.0,0.0)) PARAMETER (ZONE=(1.0,0.0)) PARAMETER (ZTWO=(2.0,0.0)) C COMMON/CHAN/ECH(MZCHF),EPS(MZCHF),FKNU(MZCHF),CC(MZCHF) 1 ,RINF(MZCHF),ITARG(MZCHF),LLCH(MZCHF),NCHF,NCHOP,NCHOP1 COMMON/CPOT/BW(MZCHF,MZCHF),LAMP(MZCHF,MZCHF) COMMON/CEN/ETOT,MXE,NWT,NZ COMMON/CACC/AC,ACNUM,ACJWBK,ACZP,LACC COMMON/ZCTHET/ZBB(MZCHF,MZTET),ZBG(MZCHF,MZTET),MMSUM(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 FNU=FKNU(I) ZFNU=ZONE/SQRT(ENERGY*ZONE-GAMMA*ZI/ZTWO) LL=LLCH(I) M=FNU+LL+12 ZR=R 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 ZF1=ZONE/ZFNU ZF2=ZF1*ZF1 ZX=ZTWO*ZR*ZF1 ZY=ZONE/ZX FL=DBLE(LL) ZFL=FL C ZR1=ZONE/ZR ZA=TZED*ZFNU*ZR1-ZF1 ZB=TZED*LOG(R)+ZR*ZF2 ZC=TZED*ZR1+ZF2 ZD=-ZR1 ZE=ZFNU**3/ZTWO C ZBB(I,1)=ZFNU ZBB(I,2)=ZONE ZBG(I,1)=ZE ZBG(I,2)=ZF2 C ZYN=ZONE ZA1=ZFL-ZFNU*TZED ZA2=ZFL+ZFNU*TZED+ZONE ZBN=-ZTWO*ZFNU-ZONE C ZBET=ZONE ZGAM=ZERO ZW0=ZC C ZS=ZONE ZU=ZERO ZCX=ZERO ZCY=ZERO C C N=0 FLAG=.FALSE. DO 20 MN=3,M N=N+1 ZA1=ZA1+ZONE ZA2=ZA2-ZONE ZBN=ZBN+ZTWO ZCN=ZA1*ZA2 ZDN=ZBN*TZED+ZF1*ZCN ZGAM=ZCN*ZGAM+ZDN*ZBET ZBET=ZCN*ZBET ZYN=ZYN*ZY ZU=ZU+ZBET*ZYN ZCY=ZCY+ZGAM*ZYN AN=DBLE(N) ZAN=ZONE/AN ZGAM=ZGAM*ZAN ZBET=ZBET*ZAN ZS=ZS+ZBET*ZYN ZCX=ZCX+ZGAM*ZYN ZW1=ZC*ZS*ZS+ZD*(ZS*ZCY-ZU*ZCX) ZBB(I,MN)=ZBET ZBG(I,MN)=ZGAM ZAC0=(ZW1-ZW0)/ZW1 AC0=ABS(ZAC0) IF(ABS(ZAC0).LT.ABS(AC))THEN IF(FLAG)THEN GO TO 30 ELSE FLAG=.TRUE. END IF ELSE FLAG=.FALSE. END IF 20 ZW0=ZW1 C-NRB IF(ABS(ZR*ZF1).GT.150.)THEN ZT=ZERO ZTP=ZERO ZTD=ZERO ZTDP=ZERO ICONV=0 RETURN ENDIF C-NRB C C NOT CONVERGED GOTO 100 C C SUMMATIONS CONVERGED C 30 P=EXP(-R*F1)*R**ZFNU C 30 ZP=EXP(-ZR*ZF1/ZTWO) IF(TZED.GT.0)ZP=ZP*ZR**(ZFNU/ZTWO) IF(ABS(ZP).GT.1.D-100)THEN ZCFACT=ZONE/ZP ELSE ZCFACT=ZERO ENDIF ZBB(I,2)=ZBB(I,2)*ZCFACT DO 40 J=3,N+2 ZBB(I,J)=ZBB(I,J)*ZCFACT ZBG(I,J)=ZBG(I,J)*ZCFACT 40 CONTINUE C ZT=ZP*ZS ZTP=ZP*(ZA*ZS+ZD*ZU) ZTD=ZP*ZE*(ZB*ZS+ZCX) ZTDP=ZP*ZE*((ZA*ZB+ZC)*ZS+ZB*ZD*ZU+ZA*ZCX+ZD*ZCY) N2=N+2 MMSUM(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)WRITE(6,650)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 ZTHETA - 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) ZSINF=SIN(3.141592654*ZFNU) ZCOSF=COS(3.141592654*ZFNU) ZT=FCA*ZSINF-FSA*ZCOSF ZTP=FCPA*ZSINF-FSPA*ZCOSF IPERT=0 ICONV=1 RETURN C 700 FORMAT(//10X,30('*')/10X,'SUBROUTINE ZTHETA'/ 1 10X,'FOR I=',I3,' REQUIRE M=',I3/ 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(//'SUBROUTINE ZTHETA EXECUATION HALTED BECAUSE IPERT=' X,I3,' RESET IPERT=',I3,' OR FIX INDICATED PROBLEM') 650 FORMAT(//10X,30('*')//10X,'SUBROUTINE ZTHETA'// X' SUMMATIONS NOT CONVERGED FOR 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 ZTHETA'// 1' SUMMATIONS NOT CONVERGED WITH ',I3,' TERMS'/ 2 /10X,'USING SUBROUTINE SC WITH IPERT = 0'/10X,30('*')) 611 FORMAT(//10X,30('*')//10X,'SUBROUTINE ZTHETA'// 1'FAILURE FOR NEUTRAL CASE - TOO CLOSE TO THRESHOLD?'/ 2 10X,30('*')) 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